semTools/0000755000176200001440000000000014764514742012075 5ustar liggesuserssemTools/MD50000644000176200001440000002003014764514742012400 0ustar liggesusers01e81474807aa45c53f8d85020d70e93 *DESCRIPTION e5312a485ec0f2dac0d9e1cb3fe83b75 *NAMESPACE 17c0795d9e1e9dac7abbbd3f7c52fedd *NEWS.md 35e3b92136a02ce4a8a3b19817054398 *R/EmpKaiser.R deeb23e9dd0dda60ea5ec933c8b93c24 *R/NET.R 528e54b04c168f9818d962f24976ce26 *R/PAVranking.R 1830a4f07e22584dc6fb6d508c232949 *R/TSML.R b493f1e2905a9f6c68e09b577f7bcc39 *R/aa_semTools-deprecated.R 4af8fe4548dc80d75c65bbb033a57299 *R/auxiliary.R 2a42d605da779f85461c0de8f9413545 *R/clipboard.R 414285f701314ef09aa2e61a0f29b5be *R/compareFit.R 9452cfe3870212e48397e951991b27bf *R/data.R bd2d9ec4e394cbfb22d616f0b3006410 *R/dataDiagnosis.R 36efcb04956d27597da57d2edb00e7d4 *R/discriminantValidity.R 1e509ab0163cf575a72a7280f21a6ec4 *R/efa.R 1c7a99c8c46cc8bf2817f8459bec1023 *R/emmeans_lavaan.R f68e7fcf7b1351bac3feb40038d148fb *R/fitIndices.R 7f95ac609c99baf8953fd0145c1da9c0 *R/fmi.R 3d26bbf0d7143f21e1f76db128a9649d *R/gorica.R 5116fa966b876ab74cccca6f18d414dd *R/htmt.R f70a1de02115ad9cef51820ebaa1565e *R/imposeStart.R 317f3300c1e8a0def5f6df9220d7d717 *R/indProd.R ed3337c42eecfba61fc37e863ea61f65 *R/kd.R 664b1dee784db1f51dfc2b82984d21c4 *R/loadingFromAlpha.R fd6fe461a0fc803ab3558ca4c0ab26fe *R/longInvariance.R e9f316b43e1e510d771d13b3b93d0748 *R/measEq.R 6c59696ff6fa81dc9c02b558d65034b0 *R/measurementInvariance.R a9498c16325bbfcd556f786eb36a7e31 *R/measurementInvarianceCat.R 1c671dd436dbecc4b5c20b4012c13fd8 *R/miPowerFit.R 798b84d227427fcbfe3ba9fed332576e *R/missingBootstrap.R bb1bedb72f6e00232c22418479aa41a7 *R/monteCarloCI.R f0f13700b0f7cc300f5c6326c4653acc *R/mvrnonnorm.R 7704490623667921dff2868bd2392dd6 *R/ordMoments.R b3a5236c5120109f909904c212692c87 *R/parcelAllocation.R ab4ae4f4c6a74e028b848588a41d8c5d *R/partialInvariance.R e4dbf1869e8b44e961e142bf36fcfb31 *R/permuteMeasEq.R 373d9869b27631c40cbedbcd7261328e *R/plausibleValues.R 464377d7f7fdabcaeef7806675102e28 *R/poolMAlloc.R bab9b4f4590967574d0955e9bb8621e8 *R/powerAnalysisNested.R 588942616f7a22bf4258f545e0f3b000 *R/powerAnalysisRMSEA.R 35eca65deb80aa5c9a03080b3a5fd09a *R/powerAnalysisSS.R 7918c8b6be077cb98212cafb5f99e05e *R/probeInteraction.R 2fe1e05a38e10ca178678b663baaad24 *R/quark.R a271b15672276a99d2b10d47cbd15d3f *R/reliability.R d740abd5f729b37d44c58007747aeb84 *R/residualCovariate.R 675ddf14e8759ce30fe49ee9333a0222 *R/runMI-LRT.R 608eaa911b92ffce42f5384d97d13101 *R/runMI-Wald.R 4b37f8e362964a96691095c1972ebd6d *R/runMI-methods.R ae25c5a8a4c8b8e888f817541de3be6a *R/runMI-modification.R 116da660f76e16c8d3e1893a0c385810 *R/runMI-score.R ccb836c856259541245fd982f4208850 *R/runMI.R 8c786f138852cab89cf318c66f6e0f94 *R/semTools.R a2d82175ca8f019859f0636de40a81e9 *R/singleParamTest.R db5ec4cf1a5310d50dbb09dc664dc561 *R/splitSample.R a7a44eb40f895592c9c2f5ddc3008e6d *R/tukeySEM.R 540f327d33c85cc090c6fda8c361efde *R/zzz.R ebcb52eff7ecb5000bb00ad17957036b *README.md 4454e632feb75ce4f508807d50b3b12f *build/partial.rdb 59dab2029bfb738e06e036800778c3d4 *build/vignette.rds 4d1090db8b160303f235075ebbda16d7 *data/dat2way.rda c56c2358c6e4d82c4cd7855e4df37282 *data/dat3way.rda d3f489a4fefd07ccfcd3875bc71e0b83 *data/datCat.rda ba21a4b5113fd7515fbf26fccfe0fe17 *data/exLong.rda 35cb60d186fd440645d81b56e22a3fa2 *data/simParcel.rda cf344eafafe90f08e687a259663b0c4d *inst/CITATION 81dc319ba4e3739b20cbcd3196f00e1e *inst/doc/partialInvariance.Rnw 93b949b15e67a95b70b0607eb5f75066 *inst/doc/partialInvariance.pdf fbdb4902cc1df8b273d644fb4d1de132 *inst/examples/lavaan2emmeans.R 4d59b5a289ca1e7b3cf7f487570dd3cd *man/AVE.Rd a28c22979c817fda070bbc8b191a36df *man/BootMiss-class.Rd 156b38edd860913bffdffad8b0dd6e55 *man/EFA-class.Rd 9b843422caf2145783b42860a0ad55ba *man/FitDiff-class.Rd b559b20ac662d06cf943a39472653a57 *man/Net-class.Rd b116b58e4420ba329e7d8e4abbab33fa *man/OLDlavaan.mi-class.Rd 84758fa1b8f55b0af087d11a1da6d0fb *man/PAVranking.Rd 13d9de2a40e21e2fec56b0135fcf719e *man/SSpower.Rd a70ea2c6d04e74909d8a0e0b3dc30beb *man/auxiliary.Rd 168db4d761c2691aa9ce09ae3c8480da *man/bsBootMiss.Rd 3ebeb7407f27d97eeb065aadb4199619 *man/calculate.D2-deprecated.Rd 91d2269797723745356c74b0a16f05bc *man/chisqSmallN.Rd 0358922e0e101d12670e23db2ae468b5 *man/clipboard.Rd 32205b01e78c1e2f7d1ecee7d19d5e9e *man/combinequark.Rd c4b31139833748945955285ba7b69653 *man/compRelSEM.Rd ab6be7f82ae5a019f5cddbca4b91c828 *man/compareFit.Rd e3b7ebbd49ee04307b7c2a9269ccd5c2 *man/dat2way.Rd bc676545cc6f99640bee85f1d124637d *man/dat3way.Rd bb535d599ad9096582dc0256ef785a1f *man/datCat.Rd 928b3be970ee728a5b63bf356c5550bc *man/discriminantValidity.Rd b953186f103230d01c7cf98d5c245e15 *man/efa.ekc.Rd a765ac05a4f82b953ee9c612e8cb7c03 *man/efaUnrotate-deprecated.Rd 91c710004d40191cc92a7b7d4e27139f *man/exLong.Rd 8e886463f55e5edeedddbb77f601a1a2 *man/findRMSEApower.Rd 4388dbbe39c7f66ddc58d3543c742864 *man/findRMSEApowernested.Rd 181b47581b794e42091883a3f2715a4a *man/findRMSEAsamplesize.Rd 3b4214558a5f6b4ad5a7df6e411f2e90 *man/findRMSEAsamplesizenested.Rd 75895615d5f9bb188af3d355a5bce1fa *man/fmi.Rd bfbfda5bca607c81efda738b31d4a7b4 *man/goricaSEM.Rd 4fef726eb173e9ab4aafca30452a5849 *man/htmt.Rd 2865323337743b69f0111bfe8d3763f4 *man/imposeStart.Rd 793499bc1078d3c3a55ffc5e81da467d *man/indProd.Rd 050966fdeb43eeb3c23176c0791d88b4 *man/kd.Rd 8dbf7627bcc9e7d5f23e3f57a0712a23 *man/kurtosis.Rd ea964847025c22e9e87e187e896a6334 *man/lavTestLRT.mi-deprecated.Rd bf779d773d3484933109637ccf75f0b7 *man/lavTestScore.mi-deprecated.Rd 57f44a50bdab4364f229b3cc8f2ab21b *man/lavTestWald.mi-deprecated.Rd 25dc38a53f52a8e4eddf6a169f1e117a *man/lavaan2emmeans.Rd b24d6f6dc617e522f1bdb7d2478e9ec0 *man/loadingFromAlpha.Rd 4d7e1e6b4e4b00d0c333ff5667eb9400 *man/longInvariance-deprecated.Rd a1416c3b9594ff872e601a11f69ebe56 *man/lrv2ord.Rd e62aff85d844043eeb417a94b065a10d *man/mardiaKurtosis.Rd 3e5c5ac5ce4923a87133e02fdd87ca7e *man/mardiaSkew.Rd 7d7f26b6540e5176a7b44c086bb6857b *man/maximalRelia.Rd 97c1b90dab0910110c6363dcbadba2ba *man/measEq.syntax-class.Rd 6b08c7e06ca0bfb0d0143c3416fd2f1c *man/measEq.syntax.Rd 1ef20d2748ed82006ae30cf7bc8bbde8 *man/measurementInvariance-deprecated.Rd f4fadfbb8d4eb0f79ef1d98d93a0669b *man/measurementInvarianceCat-deprecated.Rd 1bbca5c95a676992a09bfe400f65009a *man/miPowerFit.Rd af841691e041cb9309205c6864a9d57b *man/modindices.mi-deprecated.Rd e136c8b6e08a3be1062473389a4cf4b6 *man/monteCarloCI.Rd eee6c0fc8f5ab944e846887571f09a68 *man/moreFitIndices.Rd a46444a8b87a06d19a8446a21f58749c *man/mvrnonnorm.Rd f51137adb8cb4587d0e5eb7a63e4778f *man/net.Rd 6d949b7d106a6774f75b3387ccc62efa *man/nullRMSEA.Rd dad21e0350e2d1b05dd0291b25d8ea07 *man/parcelAllocation.Rd c391317e75520f81a60392e07e616fdb *man/partialInvariance.Rd dbe9310ae109bb5b17b671de55b77196 *man/permuteMeasEq-class.Rd 20a50c52bc7c6fb4b4480c2f65ac77df *man/permuteMeasEq.Rd 2d674defaa2c487063c080a197836afd *man/plausibleValues.Rd bfd140211baf83ac057f7caaf356a66f *man/plotProbe.Rd 981a1c3ef734038ade2d80f6f1c8e1fb *man/plotRMSEAdist.Rd 2a8a4bdc7777b0723cdc3e25e36de04f *man/plotRMSEApower.Rd 1003bb6dba12f7f08a7d0e97b9ca043f *man/plotRMSEApowernested.Rd 86ff2b2c35eea574ed046f6cd8e93bf3 *man/poolMAlloc.Rd 7c19934693578e00fd5a2cd8f30b47f3 *man/probe2WayMC.Rd d2c032bc6a9e4fae589dc25b0fa3bf14 *man/probe2WayRC.Rd ce1daf746eb6cbdd47e2334b0d1fd6ce *man/probe3WayMC.Rd f1d63c788d3faaff8946ea539b6c1c28 *man/probe3WayRC.Rd 9093b87793638e47a6890826d44a4a7a *man/quark.Rd af445dcb2bd7c487bc053fe1f47c6898 *man/reliability-deprecated.Rd ee1fcbc69047bfe60c047ee4d549c198 *man/reliabilityL2-deprecated.Rd 99dbb956123d40f686e2d77d842b0886 *man/residualCovariate.Rd 227d9cc1050e78fcf56de7e8d6fbba68 *man/rotate-deprecated.Rd e05acabb8c05ef66e4448ad2877ca856 *man/runMI-deprecated.Rd 75e345c0ff37d47791ac78e3d09e2184 *man/semTools-deprecated.Rd 23410ceaee95b119e395cc72a537e5b2 *man/semTools.Rd 2d0c2f4e2f10d8c84feb8f1705bef4fb *man/simParcel.Rd 792694fbca04408c36137c258b318c4f *man/singleParamTest.Rd a8935482bf0136620398a0e38cc7e33e *man/skew.Rd 2da1028ad38bb0531d85ef2b95f9273f *man/splitSample.Rd 84b89acd41d31adce3db39a5b89f0009 *man/tukeySEM.Rd 21b218fa85360e1ae22c0d31b1fb8306 *man/twostage-class.Rd b21e87ffc30baacb82e92cea8c87e8e7 *man/twostage.Rd 81dc319ba4e3739b20cbcd3196f00e1e *vignettes/partialInvariance.Rnw 4f5891dc46f7212c1ce6189c4467adba *vignettes/partialInvariance.bib semTools/R/0000755000176200001440000000000014753125033012263 5ustar liggesuserssemTools/R/PAVranking.R0000644000176200001440000017047014764274542014433 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ##' Parcel-Allocation Variability in Model Ranking ##' ##' This function quantifies and assesses the consequences of parcel-allocation ##' variability for model ranking of structural equation models (SEMs) that ##' differ in their structural specification but share the same parcel-level ##' measurement specification (see Sterba & Rights, 2016). This function calls ##' [parcelAllocation()]---which can be used with only one SEM in ##' isolation---to fit two (assumed) nested models to each of a specified number ##' of random item-to-parcel allocations. Output includes summary information ##' about the distribution of model selection results (including plots) and the ##' distribution of results for each model individually, across allocations ##' within-sample. Note that this function can be used when selecting among more ##' than two competing structural models as well (see instructions below ##' involving the `seed=` argument). ##' ##' This is based on a SAS macro `ParcelAlloc` (Sterba & MacCallum, 2010). ##' The `PAVranking()` function produces results discussed in Sterba and ##' Rights (2016) relevant to the assessment of parcel-allocation variability in ##' model selection and model ranking. Specifically, the `PAVranking()` ##' function first calls [parcelAllocation()] to generate a given ##' number (`nAlloc=`) of item-to-parcel allocations, fitting both specified ##' models to each allocation, and providing summaryies of PAV for each model. ##' Additionally, `PAVranking()` provides the following new summaries: ##' ##' \itemize{ ##' \item{PAV in model selection index values and model ranking between ##' Models `model0=` and `model1=`.} ##' \item{The proportion of allocations that converged and the proportion of ##' proper solutions (results are summarized for allocations with both ##' converged and proper allocations only).} ##' } ##' ##' For further details on the benefits of the random allocation of items to ##' parcels, see Sterba (2011) and Sterba and MacCallum (2010). ##' ##' To test whether nested models have equivalent fit, results can be pooled ##' across allocations using the same methods available for pooling results ##' across multiple imputations of missing data (see **Examples**). ##' ##' *Note*: This function requires the `lavaan` package. Missing data ##' must be coded as `NA`. If the function returns `"Error in ##' plot.new() : figure margins too large"`, the user may need to increase ##' size of the plot window (e.g., in RStudio) and rerun the function. ##' ##' ##' @importFrom stats sd ##' @importFrom lavaan parTable lavListInspect lavaanList ##' @importFrom graphics hist ##' ##' @param model0,model1 [lavaan::lavaan()] model syntax specifying ##' nested models (`model0` within `model1`) to be fitted ##' to the same parceled data. Note that there can be a mixture of ##' items and parcels (even within the same factor), in case certain items ##' should never be parceled. Can be a character string or parameter table. ##' Also see [lavaan::lavaanify()] for more details. ##' @param data A `data.frame` containing all observed variables appearing ##' in `model0=` and `model1=`, as well as those in the `item.syntax=` used to ##' create parcels. If the data have missing values, multiple imputation ##' before parceling is recommended: submit a stacked data set (with a variable ##' for the imputation number, so they can be separated later) and set ##' `do.fit=FALSE` to return the list of `data.frame`s (one per ##' allocation), each of which is a stacked, multiply imputed data set with ##' parcels created using the same allocation scheme. ##' @param parcel.names `character` vector containing names of all parcels ##' appearing as indicators in `model0=` or `model1=`. ##' @param item.syntax [lavaan::lavaan()] model syntax specifying the model ##' that would be fit to all of the unparceled items, including items that ##' should be randomly allocated to parcels appearing in `model0=` and `model1=`. ##' @param nAlloc The number of random items-to-parcels allocations to generate. ##' @param fun `character` string indicating the name of the ##' [lavaan::lavaan()] function used to fit `model0=` and `model1=` to `data=`. ##' Can only take the values `"lavaan"`, `"sem"`, `"cfa"`, or `"growth"`. ##' @param alpha Alpha level used as criterion for significance. ##' @param bic.crit Criterion for assessing evidence in favor of one model ##' over another. See Rafferty (1995) for guidelines (default is "very ##' strong evidence" in favor of the model with lower BIC). ##' @param fit.measures `character` vector containing names of fit measures ##' to request from each fitted [lavaan::lavaan-class] model. See the ##' output of [lavaan::fitMeasures()] for a list of available measures. ##' @param \dots Additional arguments to be passed to ##' [lavaan::lavaanList()]. See also [lavaan::lavOptions()] ##' @param show.progress If `TRUE`, show a [utils::txtProgressBar()] ##' indicating how fast each model-fitting iterates over allocations. ##' @param iseed (Optional) Random seed used for parceling items. When the same ##' random seed is specified and the program is re-run, the same allocations ##' will be generated. The seed argument can be used to assess parcel-allocation ##' variability in model ranking when considering more than two models. For each ##' pair of models under comparison, the program should be rerun using the same ##' random seed. Doing so ensures that multiple model comparisons will employ ##' the same set of parcel datasets. *Note*: When using \pkg{parallel} ##' options, you must first type `RNGkind("L'Ecuyer-CMRG")` into the R ##' Console, so that the seed will be controlled across cores. ##' @param warn Whether to print warnings when fitting models to each allocation ##' ##' @return ##' A `list` with 3 elements. The first two (`model0.results` and ##' `model1.results`) are results returned by [parcelAllocation()] ##' for `model0` and `model1`, respectively. ##' The third element (`model0.v.model1`) is a `list` of ##' model-comparison results, including the following: ##' \item{`LRT_Summary:`}{ The average likelihood ratio test across ##' allocations, as well as the *SD*, minimum, maximum, range, and the ##' proportion of allocations for which the test was significant.} ##' \item{`Fit_Index_Differences:`}{ Differences in fit indices, organized ##' by what proportion favored each model and among those, what the average ##' difference was.} ##' \item{`Favored_by_BIC:`}{ The proportion of allocations in which each ##' model met the criterion (`bic.crit`) for a substantial difference ##' in fit.} ##' \item{`Convergence_Summary:`}{ The proportion of allocations in which ##' each model (and both models) converged on a solution.} ##' ##' Histograms are also printed to the current plot-output device. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [parcelAllocation()] for fitting a single model, ##' [poolMAlloc()] for choosing the number of allocations ##' ##' @references ##' Raftery, A. E. (1995). Bayesian model selection in social ##' research. *Sociological Methodology, 25*, 111--163. \doi{10.2307/271063} ##' ##' Sterba, S. K. (2011). Implications of parcel-allocation variability for ##' comparing fit of item-solutions and parcel-solutions. *Structural ##' Equation Modeling, 18*(4), 554--577.\doi{10.1080/10705511.2011.607073} ##' ##' Sterba, S. K., & MacCallum, R. C. (2010). Variability in parameter estimates ##' and model fit across repeated allocations of items to parcels. ##' *Multivariate Behavioral Research, 45*(2), 322--358. ##' \doi{10.1080/00273171003680302} ##' ##' Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation ##' variability in practice: Combining sources of uncertainty and choosing the ##' number of allocations. *Multivariate Behavioral Research, 51*(2--3), ##' 296--313. \doi{10.1080/00273171.2016.1144502} ##' ##' Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model ##' selection: Parcel-allocation variability in model ranking. ##' *Psychological Methods, 22*(1), 47--68. \doi{10.1037/met0000067} ##' ##' @examples ##' ##' ## Specify the item-level model (if NO parcels were created) ##' ## This must apply to BOTH competing models ##' ##' item.syntax <- c(paste0("f1 =~ f1item", 1:9), ##' paste0("f2 =~ f2item", 1:9)) ##' cat(item.syntax, sep = "\n") ##' ## Below, we reduce the size of this same model by ##' ## applying different parceling schemes ##' ##' ## Specify a 2-factor CFA with correlated factors, using 3-indicator parcels ##' mod1 <- ' ##' f1 =~ par1 + par2 + par3 ##' f2 =~ par4 + par5 + par6 ##' ' ##' ## Specify a more restricted model with orthogonal factors ##' mod0 <- ' ##' f1 =~ par1 + par2 + par3 ##' f2 =~ par4 + par5 + par6 ##' f1 ~~ 0*f2 ##' ' ##' ## names of parcels (must apply to BOTH models) ##' (parcel.names <- paste0("par", 1:6)) ##' ##' \donttest{ ##' ## override default random-number generator to use parallel options ##' RNGkind("L'Ecuyer-CMRG") ##' ##' PAVranking(model0 = mod0, model1 = mod1, data = simParcel, nAlloc = 100, ##' parcel.names = parcel.names, item.syntax = item.syntax, ##' # parallel = "multicore", # parallel available on Mac/Linux ##' std.lv = TRUE) # any addition lavaan arguments ##' ##' ##' ##' ## POOL RESULTS by treating parcel allocations as multiple imputations. ##' ## Details provided in Sterba & Rights (2016); see ?poolMAlloc. ##' ##' ## save list of data sets instead of fitting model yet ##' dataList <- parcelAllocation(mod0, # or mod1 (either uses same allocations) ##' data = simParcel, nAlloc = 100, ##' parcel.names = parcel.names, ##' item.syntax = item.syntax, ##' do.fit = FALSE) ##' ## now fit each model to each data set ##' if(requireNamespace("lavaan.mi")){ ##' library(lavaan.mi) ##' fit0 <- cfa.mi(mod0, data = dataList, std.lv = TRUE) ##' fit1 <- cfa.mi(mod1, data = dataList, std.lv = TRUE) ##' anova(fit0, fit1) # Pooled test statistic comparing models. ##' help(package = "lavaan.mi") # Find more methods for pooling results. ##' } ##' ##' } ##' ##' @export PAVranking <- function(model0, model1, data, parcel.names, item.syntax, nAlloc = 100, fun = "sem", alpha = .05, bic.crit = 10, fit.measures = c("chisq","df","cfi","tli","rmsea", "srmr","logl","aic","bic","bic2"), ..., show.progress = FALSE, iseed = 12345, warn = FALSE) { if (alpha >= 1 | alpha <= 0) stop('alpha level must be between 0 and 1') bic.crit <- abs(bic.crit) ## fit each model out0 <- parcelAllocation(model = model0, data = data, nAlloc = nAlloc, parcel.names = parcel.names, item.syntax = item.syntax, fun = fun, alpha = alpha, fit.measures = fit.measures, ..., show.progress = show.progress, iseed = iseed, return.fit = TRUE, warn = warn) out1 <- parcelAllocation(model = model1, data = data, nAlloc = nAlloc, parcel.names = parcel.names, item.syntax = item.syntax, fun = fun, alpha = alpha, fit.measures = fit.measures, ..., show.progress = show.progress, iseed = iseed, return.fit = TRUE, warn = warn) ## convergence summary conv0 <- out0$Model@meta$ok conv1 <- out1$Model@meta$ok conv01 <- conv0 & conv1 conv <- data.frame(Proportion_Converged = sapply(list(conv0, conv1, conv01), mean), row.names = c("model0","model1","Both_Models")) ## add proper solutions? I would advise against ## check df matches assumed nesting DF0 <- out0$Fit["df", "Avg"] DF1 <- out1$Fit["df", "Avg"] if (DF0 == DF1) stop('Models have identical df, so they cannot be compared.') if (DF0 < DF1) warning('model0 should be nested within model1, ', 'but df_0 < df_1. Should models be swapped?') temp <- out0 out0 <- out1 out1 <- temp ## Re-run lavaanList to collect model-comparison results if (show.progress) message('Re-fitting model0 to collect model-comparison ', 'statistics\n') oldCall <- out0$Model@call oldCall$model <- parTable(out0$Model) oldCall$dataList <- out0$Model@external$dataList[conv01] if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L if (warn) warning("Unable to pass lavaan::lavTestLRT() arguments when ", "parallel = 'snow'. Switching to parallel = 'no'. ", "Unless using Windows, parallel = 'multicore' works.") } } PT1 <- parTable(out1$Model) op1 <- lavListInspect(out1$Model, "options") oldCall$FUN <- function(obj) { fit1 <- try(lavaan::lavaan(model = PT1, slotOptions = op1, slotData = obj@Data), silent = TRUE) if (inherits(fit1, "try-error")) return("fit failed") out <- lavaan::lavTestLRT(obj, fit1) if (inherits(out, "try-error")) return("lavTestLRT() failed") out } fit01 <- eval(as.call(oldCall)) ## check if there are any results noLRT <- sapply(fit01@funList, is.character) if (all(noLRT)) stop("No success using lavTestScore() on any allocations.") ## anova() results CHIs <- sapply(fit01@funList[!noLRT], "[", i = 2, j = "Chisq diff") pVals <- sapply(fit01@funList[!noLRT], "[", i = 2, j = "Pr(>Chisq)") LRT <- c(`Avg LRT` = mean(CHIs), df = abs(DF0 - DF1), SD = sd(CHIs), Min = min(CHIs), Max = max(CHIs), Range = max(CHIs) - min(CHIs), `% Sig` = mean(pVals < alpha)) class(LRT) <- c("lavaan.vector","numeric") ## differences in fit indices indices <- fit.measures[!grepl(pattern = "chisq|df|pvalue", fit.measures)] Fit0 <- do.call(cbind, out0$Model@funList[conv01])[indices, ] Fit1 <- do.call(cbind, out1$Model@funList[conv01])[indices, ] ## higher values for model0 Fit01 <- Fit0 - Fit1 higher0 <- Fit0 > Fit1 perc0 <- rowMeans(higher0) avg0 <- rowMeans(Fit01 * higher0) ## higher values for model1 Fit10 <- Fit1 - Fit0 higher1 <- Fit1 > Fit0 perc1 <- rowMeans(higher1) avg1 <- rowMeans(Fit10 * higher1) fitDiff <- data.frame(Prop0 = perc0, Avg0 = avg0, Prop1 = perc1, Avg1 = avg1) class(fitDiff) <- c("lavaan.data.frame","data.frame") attr(fitDiff, "header") <- paste("Note: Higher values of goodness-of-fit", "indices (e.g., CFI) favor that model, but", "higher values of badness-of-fit indices", "(e.g., RMSEA) indicate the competing model", "is favored.\n\n'Prop0' indicates the", "proportion of allocations for which each", "index was higher for model0 (likewise,", "'Prop1' indicates this for model1).\n", "\nAmong those allocations, 'Avg0' or 'Avg1'", "indicates the average amount by which the", "index was higher for that model.") ## favored by BIC favorBIC <- NULL if (any(grepl(pattern = "bic", fit.measures))) { if ("bic" %in% fit.measures) { highBIC <- abs(Fit01["bic",]) >= bic.crit favor0 <- mean(higher1["bic",] & highBIC) favor1 <- mean(higher0["bic",] & highBIC) favorBIC <- data.frame("bic" = c(favor0, favor1), row.names = paste("Evidence Favoring Model", 0:1)) } if ("bic2" %in% fit.measures) { highBIC <- abs(Fit01["bic2",]) >= bic.crit favor0 <- mean(higher1["bic2",] & highBIC) favor1 <- mean(higher0["bic2",] & highBIC) favorBIC2 <- data.frame("bic2" = c(favor0, favor1), row.names = paste("Evidence Favoring Model", 0:1)) if (is.null(favorBIC)) { favorBIC <- favorBIC2 } else favorBIC <- cbind(favorBIC, favorBIC2) } class(favorBIC) <- c("lavaan.data.frame","data.frame") attr(favorBIC, "header") <- paste("Percent of Allocations with |BIC Diff| >", bic.crit) } ## return results list(Model0_Results = out0[c("Estimates","SE","Fit")], Model1_Results = out1[c("Estimates","SE","Fit")], Model0.v.Model1 = list(LRT_Summary = LRT, Fit_Index_Differences = fitDiff, Favored_by_BIC = favorBIC, Convergence_Summary = conv)) } ## ------------ ## old function ## ------------ ## @param nPerPar A list in which each element is a vector, corresponding to ## each factor, indicating sizes of parcels. If variables are left out of ## parceling, they should not be accounted for here (i.e., there should not be ## parcels of size "1"). ## @param facPlc A list of vectors, each corresponding to a factor, specifying ## the item indicators of that factor (whether included in parceling or not). ## Either variable names or column numbers. Variables not listed will not be ## modeled or included in output datasets. ## @param nAlloc The number of random allocations of items to parcels to ## generate. ## @param syntaxA lavaan syntax for Model A. Note that, for likelihood ratio ## test (LRT) results to be interpreted, Model A should be nested within Model ## B (though the function will still provide results when Models A and B are ## nonnested). ## @param syntaxB lavaan syntax for Model B. Note that, for likelihood ratio ## test (LRT) results to be appropriate, Model A should be nested within Model ## B (though the function will still provide results when Models A and B are ## nonnested). ## @param dataset Item-level dataset ## @param parceloutput folder where parceled data sets will be outputted (note ## for Windows users: file path must specified using forward slashes). ## @param names (Optional) A character vector containing the names of parceled ## variables. ## @param leaveout (Optional) A vector of variables to be left out of ## randomized parceling. Either variable names or column numbers are allowed. ## @examples ## ## \dontrun{ ## ## lavaan syntax for Model A: a 2 Uncorrelated ## ## factor CFA model to be fit to parceled data ## ## parmodelA <- ' ## f1 =~ NA*p1f1 + p2f1 + p3f1 ## f2 =~ NA*p1f2 + p2f2 + p3f2 ## p1f1 ~ 1 ## p2f1 ~ 1 ## p3f1 ~ 1 ## p1f2 ~ 1 ## p2f2 ~ 1 ## p3f2 ~ 1 ## p1f1 ~~ p1f1 ## p2f1 ~~ p2f1 ## p3f1 ~~ p3f1 ## p1f2 ~~ p1f2 ## p2f2 ~~ p2f2 ## p3f2 ~~ p3f2 ## f1 ~~ 1*f1 ## f2 ~~ 1*f2 ## f1 ~~ 0*f2 ## ' ## ## ## lavaan syntax for Model B: a 2 Correlated ## ## factor CFA model to be fit to parceled data ## ## parmodelB <- ' ## f1 =~ NA*p1f1 + p2f1 + p3f1 ## f2 =~ NA*p1f2 + p2f2 + p3f2 ## p1f1 ~ 1 ## p2f1 ~ 1 ## p3f1 ~ 1 ## p1f2 ~ 1 ## p2f2 ~ 1 ## p3f2 ~ 1 ## p1f1 ~~ p1f1 ## p2f1 ~~ p2f1 ## p3f1 ~~ p3f1 ## p1f2 ~~ p1f2 ## p2f2 ~~ p2f2 ## p3f2 ~~ p3f2 ## f1 ~~ 1*f1 ## f2 ~~ 1*f2 ## f1 ~~ f2 ## ' ## ## ## specify items for each factor ## f1name <- colnames(simParcel)[1:9] ## f2name <- colnames(simParcel)[10:18] ## ## ## run function ## PAVranking(nPerPar = list(c(3,3,3), c(3,3,3)), facPlc = list(f1name,f2name), ## nAlloc = 100, parceloutput = 0, leaveout = 0, ## syntaxA = parmodelA, syntaxB = parmodelB, dataset = simParcel, ## names = list("p1f1","p2f1","p3f1","p1f2","p2f2","p3f2")) ## } ## # PAVranking <- function(nPerPar, facPlc, nAlloc = 100, parceloutput = 0, syntaxA, syntaxB, # dataset, names = NULL, leaveout = 0, seed = NA, ...) { # if (is.null(names)) # names <- matrix(NA, length(nPerPar), 1) # ## set random seed if specified # if (is.na(seed) == FALSE) # set.seed(seed) # ## allow many tables to be outputted # options(max.print = 1e+06) # # ## Create parceled datasets # if (is.character(dataset)) dataset <- utils::read.csv(dataset) # dataset <- as.matrix(dataset) # # if (nAlloc < 2) # stop("Minimum of two allocations required.") # # if (is.list(facPlc)) { # if (is.numeric(facPlc[[1]][1]) == FALSE) { # facPlcb <- facPlc # Namesv <- colnames(dataset) # # for (i in 1:length(facPlc)) { # for (j in 1:length(facPlc[[i]])) { # facPlcb[[i]][j] <- match(facPlc[[i]][j], Namesv) # } # facPlcb[[i]] <- as.numeric(facPlcb[[i]]) # } # facPlc <- facPlcb # } # # # facPlc2 <- rep(0, sum(sapply(facPlc, length))) # facPlc2 <- rep(0, ncol(dataset)) # # for (i in 1:length(facPlc)) { # for (j in 1:length(facPlc[[i]])) { # facPlc2[facPlc[[i]][j]] <- i # } # } # facPlc <- facPlc2 # } # # if (leaveout != 0) { # if (is.numeric(leaveout) == FALSE) { # leaveoutb <- rep(0, length(leaveout)) # Namesv <- colnames(dataset) # # for (i in 1:length(leaveout)) { # leaveoutb[i] <- match(leaveout[i], Namesv) # } # leaveout <- as.numeric(leaveoutb) # } # k1 <- 0.001 # for (i in 1:length(leaveout)) { # facPlc[leaveout[i]] <- facPlc[leaveout[i]] + k1 # k1 <- k1 + 0.001 # } # } # # if (0 %in% facPlc == TRUE) { # Zfreq <- sum(facPlc == 0) # for (i in 1:Zfreq) { # Zplc <- match(0, facPlc) # dataset <- dataset[, -Zplc] # facPlc <- facPlc[-Zplc] # } # ## this allows for unused variables in dataset, which are specified by zeros, and # ## deleted # } # # if (is.list(nPerPar)) { # nPerPar2 <- c() # for (i in 1:length(nPerPar)) { # Onesp <- sum(facPlc > i & facPlc < i + 1) # nPerPar2 <- c(nPerPar2, nPerPar[i], rep(1, Onesp), recursive = TRUE) # } # nPerPar <- nPerPar2 # } # # Npp <- c() # for (i in 1:length(nPerPar)) { # Npp <- c(Npp, rep(i, nPerPar[i])) # } # # Locate <- sort(round(facPlc)) # Maxv <- max(Locate) - 1 # # if (length(Locate) != length(Npp)) # stop("Parcels incorrectly specified.\", # \" Check input!") # # if (Maxv > 0) { # ## Bug was here. With 1 factor Maxv=0. Skip this with a single factor # for (i in 1:Maxv) { # Mat <- match(i + 1, Locate) # if (Npp[Mat] == Npp[Mat - 1]) # stop("Parcels incorrectly specified.\", # \" Check input!") # } # } # ## warning message if parcel crosses into multiple factors vector, parcel to which # ## each variable belongs vector, factor to which each variables belongs if # ## variables are in the same parcel, but different factors error message given in # ## output # # Onevec <- facPlc - round(facPlc) # NleaveA <- length(Onevec) - sum(Onevec == 0) # NleaveP <- sum(nPerPar == 1) # # if (NleaveA < NleaveP) # warning("Single-variable parcels have been requested.\", # \" Check input!") # # if (NleaveA > NleaveP) # warning("More non-parceled variables have been", " requested than provided for in parcel", # " vector. Check input!") # # if (length(names) > 1) { # if (length(names) != length(nPerPar)) # warning("Number of parcel names provided not equal to number", " of parcels requested") # } # # Data <- c(1:ncol(dataset)) # ## creates a vector of the number of indicators e.g. for three indicators, c(1, 2, # ## 3) # Nfactors <- max(facPlc) # ## scalar, number of factors # Nindicators <- length(Data) # ## scalar, number of indicators # Npar <- length(nPerPar) # ## scalar, number of parcels # Rmize <- runif(Nindicators, 1, Nindicators) # ## create vector of randomly ordered numbers, length of number of indicators # # Data <- rbind(facPlc, Rmize, Data) # ## 'Data' becomes object of three rows, consisting of 1) factor to which each # ## indicator belongs (in order to preserve indicator/factor assignment during # ## randomization) 2) randomly order numbers 3) indicator number # # Results <- matrix(numeric(0), nAlloc, Nindicators) # ## create empty matrix for parcel allocation matrix # # Pin <- nPerPar[1] # for (i in 2:length(nPerPar)) { # Pin <- c(Pin, nPerPar[i] + Pin[i - 1]) # ## creates vector which indicates the range of columns (endpoints) in each parcel # } # # for (i in 1:nAlloc) { # Data[2, ] <- runif(Nindicators, 1, Nindicators) # ## Replace second row with newly randomly ordered numbers # # Data <- Data[, order(Data[2, ])] # ## Order the columns according to the values of the second row # # Data <- Data[, order(Data[1, ])] # ## Order the columns according to the values of the first row in order to preserve # ## factor assignment # # Results[i, ] <- Data[3, ] # ## assign result to allocation matrix # } # # Alpha <- rbind(Results[1, ], dataset) # ## bind first random allocation to dataset 'Alpha' # # Allocations <- list() # ## create empty list for allocation data matrices # # for (i in 1:nAlloc) { # Ineff <- rep(NA, ncol(Results)) # Ineff2 <- c(1:ncol(Results)) # for (inefficient in 1:ncol(Results)) { # Ineff[Results[i, inefficient]] <- Ineff2[inefficient] # } # # Alpha[1, ] <- Ineff # ## replace first row of dataset matrix with row 'i' from allocation matrix # # Beta <- Alpha[, order(Alpha[1, ])] # ## arrangle dataset columns by values of first row assign to temporary matrix # ## 'Beta' # # Temp <- matrix(NA, nrow(dataset), Npar) # ## create empty matrix for averaged parcel variables # # TempAA <- if (length(1:Pin[1]) > 1) # Beta[2:nrow(Beta), 1:Pin[1]] else cbind(Beta[2:nrow(Beta), 1:Pin[1]], Beta[2:nrow(Beta), 1:Pin[1]]) # Temp[, 1] <- rowMeans(TempAA, na.rm = TRUE) # ## fill first column with averages from assigned indicators # for (al in 2:Npar) { # Plc <- Pin[al - 1] + 1 # ## placeholder variable for determining parcel width # TempBB <- if (length(Plc:Pin[al]) > 1) # Beta[2:nrow(Beta), Plc:Pin[al]] else cbind(Beta[2:nrow(Beta), Plc:Pin[al]], Beta[2:nrow(Beta), Plc:Pin[al]]) # Temp[, al] <- rowMeans(TempBB, na.rm = TRUE) # ## fill remaining columns with averages from assigned indicators # } # if (length(names) > 1) # colnames(Temp) <- names # Allocations[[i]] <- Temp # ## assign result to list of parcel datasets # } # # ## Write parceled datasets # if (as.vector(regexpr("/", parceloutput)) != -1) { # replist <- matrix(NA, nAlloc, 1) # for (i in 1:nAlloc) { # ## if (is.na(names)==TRUE) names <- matrix(NA,nrow( # colnames(Allocations[[i]]) <- names # utils::write.table(Allocations[[i]], paste(parceloutput, "/parcelruns", i, # ".dat", sep = ""), # row.names = FALSE, col.names = TRUE) # replist[i, 1] <- paste("parcelruns", i, ".dat", sep = "") # } # utils::write.table(replist, paste(parceloutput, "/parcelrunsreplist.dat", # sep = ""), # quote = FALSE, row.names = FALSE, col.names = FALSE) # } # # # ## Model A estimation # # { # Param_A <- list() # ## list for parameter estimated for each imputation # Fitind_A <- list() # ## list for fit indices estimated for each imputation # Converged_A <- list() # ## list for whether or not each allocation converged # ProperSolution_A <- list() # ## list for whether or not each allocation has proper solutions # ConvergedProper_A <- list() # ## list for whether or not each allocation converged and has proper solutions # # for (i in 1:nAlloc) { # data_A <- as.data.frame(Allocations[[i]], row.names = NULL, optional = FALSE) # ## convert allocation matrix to dataframe for model estimation # fit_A <- lavaan::sem(syntaxA, data = data_A, ...) # ## estimate model in lavaan # if (lavInspect(fit_A, "converged") == TRUE) { # Converged_A[[i]] <- 1 # } else Converged_A[[i]] <- 0 # ## determine whether or not each allocation converged # Param_A[[i]] <- lavaan::parameterEstimates(fit_A)[, c("lhs", "op", "rhs", # "est", "se", "z", "pvalue", "ci.lower", "ci.upper")] # ## assign allocation parameter estimates to list # if (lavInspect(fit_A, "post.check") == TRUE & Converged_A[[i]] == 1) { # ProperSolution_A[[i]] <- 1 # } else ProperSolution_A[[i]] <- 0 # ## determine whether or not each allocation has proper solutions # if (any(is.na(Param_A[[i]][, 5] == TRUE))) # ProperSolution_A[[i]] <- 0 # ## make sure each allocation has existing SE # if (Converged_A[[i]] == 1 & ProperSolution_A[[i]] == 1) { # ConvergedProper_A[[i]] <- 1 # } else ConvergedProper_A[[i]] <- 0 # ## determine whether or not each allocation converged and has proper solutions # # if (ConvergedProper_A[[i]] == 0) # Param_A[[i]][, 4:9] <- matrix(data = NA, nrow(Param_A[[i]]), 6) # ## make parameter estimates null for nonconverged, improper solutions # # if (ConvergedProper_A[[i]] == 1) { # Fitind_A[[i]] <- lavaan::fitMeasures(fit_A, c("chisq", "df", "cfi", # "tli", "rmsea", "srmr", "logl", "bic", "aic")) # } else Fitind_A[[i]] <- c(NA, NA, NA, NA, NA, NA, NA, NA, NA) # ### assign allocation parameter estimates to list # # } # # # nConverged_A <- Reduce("+", Converged_A) # ## count number of converged allocations # # nProperSolution_A <- Reduce("+", ProperSolution_A) # ## count number of allocations with proper solutions # # nConvergedProper_A <- Reduce("+", ConvergedProper_A) # ## count number of allocations with proper solutions # # if (nConvergedProper_A == 0) # stop("All allocations failed to converge and/or yielded improper solutions for Model A and/or B.") # ## stop program if no allocations converge # # Parmn_A <- Param_A[[1]] # ## assign first parameter estimates to mean dataframe # # ParSE_A <- matrix(NA, nrow(Parmn_A), nAlloc) # ParSEmn_A <- Parmn_A[, 5] # # Parsd_A <- matrix(NA, nrow(Parmn_A), nAlloc) # ## assign parameter estimates for S.D. calculation # # Fitmn_A <- Fitind_A[[1]] # ## assign first fit indices to mean dataframe # # Fitsd_A <- matrix(NA, length(Fitmn_A), nAlloc) # ## assign fit indices for S.D. calculation # # Sigp_A <- matrix(NA, nrow(Parmn_A), nAlloc) # ## assign p-values to calculate percentage significant # # Fitind_A <- data.frame(Fitind_A) # ### convert fit index table to data frame # # for (i in 1:nAlloc) { # # Parsd_A[, i] <- Param_A[[i]][, 4] # ## assign parameter estimates for S.D. estimation # # ParSE_A[, i] <- Param_A[[i]][, 5] # # if (i > 1) { # ParSEmn_A <- rowSums(cbind(ParSEmn_A, Param_A[[i]][, 5]), na.rm = TRUE) # } # # Sigp_A[, ncol(Sigp_A) - i + 1] <- Param_A[[i]][, 7] # ## assign p-values to calculate percentage significant # # Fitsd_A[, i] <- Fitind_A[[i]] # ## assign fit indices for S.D. estimation # # if (i > 1) { # Parmn_A[, 4:ncol(Parmn_A)] <- rowSums(cbind(Parmn_A[, 4:ncol(Parmn_A)], # Param_A[[i]][, 4:ncol(Parmn_A)]), na.rm = TRUE) # } # ## add together all parameter estimates # # if (i > 1) # Fitmn_A <- rowSums(cbind(Fitmn_A, Fitind_A[[i]]), na.rm = TRUE) # ## add together all fit indices # # } # # # Sigp_A <- Sigp_A + 0.45 # Sigp_A <- apply(Sigp_A, c(1, 2), round) # Sigp_A <- 1 - as.vector(rowMeans(Sigp_A, na.rm = TRUE)) # ## calculate percentage significant parameters # # Parsum_A <- cbind(apply(Parsd_A, 1, mean, na.rm = TRUE), # apply(Parsd_A, 1, sd, na.rm = TRUE), # apply(Parsd_A, 1, max, na.rm = TRUE), # apply(Parsd_A, 1, min, na.rm = TRUE), # apply(Parsd_A, 1, max, na.rm = TRUE) - apply(Parsd_A, 1, min, na.rm = TRUE), Sigp_A * 100) # colnames(Parsum_A) <- c("Avg Est.", "S.D.", "MAX", "MIN", "Range", "% Sig") # ## calculate parameter S.D., minimum, maximum, range, bind to percentage # ## significant # # ParSEmn_A <- Parmn_A[, 1:3] # ParSEfn_A <- cbind(ParSEmn_A, apply(ParSE_A, 1, mean, na.rm = TRUE), # apply(ParSE_A, 1, sd, na.rm = TRUE), # apply(ParSE_A, 1, max, na.rm = TRUE), # apply(ParSE_A, 1, min, na.rm = TRUE), # apply(ParSE_A, 1, max, na.rm = TRUE) - apply(ParSE_A, 1, min, na.rm = TRUE)) # colnames(ParSEfn_A) <- c("lhs", "op", "rhs", "Avg SE", "S.D.", # "MAX", "MIN", "Range") # # Fitsum_A <- cbind(apply(Fitsd_A, 1, mean, na.rm = TRUE), # apply(Fitsd_A, 1, sd, na.rm = TRUE), # apply(Fitsd_A, 1, max, na.rm = TRUE), # apply(Fitsd_A, 1, min, na.rm = TRUE), # apply(Fitsd_A, 1, max, na.rm = TRUE) - apply(Fitsd_A, 1, min, na.rm = TRUE)) # rownames(Fitsum_A) <- c("chisq", "df", "cfi", "tli", "rmsea", "srmr", "logl", # "bic", "aic") # ## calculate fit S.D., minimum, maximum, range # # Parmn_A[, 4:ncol(Parmn_A)] <- Parmn_A[, 4:ncol(Parmn_A)]/nConvergedProper_A # ## divide totalled parameter estimates by number converged allocations # Parmn_A <- Parmn_A[, 1:3] # ## remove confidence intervals from output # Parmn_A <- cbind(Parmn_A, Parsum_A) # ## bind parameter average estimates to cross-allocation information # Fitmn_A <- Fitmn_A/nConvergedProper_A # ## divide totalled fit indices by number converged allocations # # pChisq_A <- list() # ## create empty list for Chi-square p-values # sigChisq_A <- list() # ## create empty list for Chi-square significance # # for (i in 1:nAlloc) { # pChisq_A[[i]] <- (1 - pchisq(Fitsd_A[1, i], Fitsd_A[2, i])) # ## calculate p-value for each Chi-square # if (is.na(pChisq_A[[i]]) == FALSE & pChisq_A[[i]] < 0.05) { # sigChisq_A[[i]] <- 1 # } else sigChisq_A[[i]] <- 0 # } # ## count number of allocations with significant chi-square # # PerSigChisq_A <- (Reduce("+", sigChisq_A))/nConvergedProper_A * 100 # PerSigChisq_A <- round(PerSigChisq_A, 3) # ## calculate percent of allocations with significant chi-square # # PerSigChisqCol_A <- c(PerSigChisq_A, "n/a", "n/a", "n/a", "n/a", "n/a", "n/a", # "n/a", "n/a") # ## create list of Chi-square Percent Significant and 'n/a' (used for fit summary # ## table) # # options(stringsAsFactors = FALSE) # ## set default option to allow strings into dataframe without converting to factors # # Fitsum_A <- data.frame(Fitsum_A, PerSigChisqCol_A) # colnames(Fitsum_A) <- c("Avg Ind", "S.D.", "MAX", "MIN", "Range", "% Sig") # ### bind to fit averages # # options(stringsAsFactors = TRUE) # ## unset option to allow strings into dataframe without converting to factors # # ParSEfn_A[, 4:8] <- apply(ParSEfn_A[, 4:8], 2, round, digits = 3) # Parmn_A[, 4:9] <- apply(Parmn_A[, 4:9], 2, round, digits = 3) # Fitsum_A[, 1:5] <- apply(Fitsum_A[, 1:5], 2, round, digits = 3) # ## round output to three digits # # Fitsum_A[2, 2:5] <- c("n/a", "n/a", "n/a", "n/a") # ## Change df row to 'n/a' for sd, max, min, and range # # Output_A <- list(Parmn_A, ParSEfn_A, Fitsum_A) # names(Output_A) <- c("Estimates_A", "SE_A", "Fit_A") # ## output summary for model A # # } # # ## Model B estimation # # { # Param <- list() # ## list for parameter estimated for each imputation # Fitind <- list() # ## list for fit indices estimated for each imputation # Converged <- list() # ## list for whether or not each allocation converged # ProperSolution <- list() # ## list for whether or not each allocation has proper solutions # ConvergedProper <- list() # ## list for whether or not each allocation is converged and proper # # for (i in 1:nAlloc) { # data <- as.data.frame(Allocations[[i]], row.names = NULL, optional = FALSE) # ## convert allocation matrix to dataframe for model estimation # fit <- lavaan::sem(syntaxB, data = data, ...) # ## estimate model in lavaan # if (lavInspect(fit, "converged") == TRUE) { # Converged[[i]] <- 1 # } else Converged[[i]] <- 0 # ## determine whether or not each allocation converged # Param[[i]] <- lavaan::parameterEstimates(fit)[, c("lhs", "op", "rhs", # "est", "se", "z", "pvalue", "ci.lower", "ci.upper")] # ## assign allocation parameter estimates to list # if (lavInspect(fit, "post.check") == TRUE & Converged[[i]] == 1) { # ProperSolution[[i]] <- 1 # } else ProperSolution[[i]] <- 0 # ## determine whether or not each allocation has proper solutions # if (any(is.na(Param[[i]][, 5] == TRUE))) # ProperSolution[[i]] <- 0 # ## make sure each allocation has existing SE # if (Converged[[i]] == 1 & ProperSolution[[i]] == 1) { # ConvergedProper[[i]] <- 1 # } else ConvergedProper[[i]] <- 0 # ## determine whether or not each allocation converged and has proper solutions # # if (ConvergedProper[[i]] == 0) # Param[[i]] <- matrix(data = NA, nrow(Param[[i]]), ncol(Param[[i]])) # ## make parameter estimates null for nonconverged, improper solutions # # if (ConvergedProper[[i]] == 1) { # Fitind[[i]] <- lavaan::fitMeasures(fit, c("chisq", "df", "cfi", "tli", # "rmsea", "srmr", "logl", "bic", "aic")) # } else Fitind[[i]] <- c(NA, NA, NA, NA, NA, NA, NA, NA, NA) # ### assign allocation parameter estimates to list # # # } # # # # # nConverged <- Reduce("+", Converged) # ## count number of converged allocations # # nProperSolution <- Reduce("+", ProperSolution) # ## count number of allocations with proper solutions # # nConvergedProper <- Reduce("+", ConvergedProper) # ## count number of allocations with proper solutions # # if (nConvergedProper == 0) # stop("All allocations failed to converge", " and/or yielded improper solutions for", # " Model A and/or B.") # ## stop program if no allocations converge # # Parmn <- Param[[1]] # ## assign first parameter estimates to mean dataframe # # ParSE <- matrix(NA, nrow(Parmn), nAlloc) # ParSEmn <- Parmn[, 5] # # Parsd <- matrix(NA, nrow(Parmn), nAlloc) # ## assign parameter estimates for S.D. calculation # # Fitmn <- Fitind[[1]] # ## assign first fit indices to mean dataframe # # Fitsd <- matrix(NA, length(Fitmn), nAlloc) # ## assign fit indices for S.D. calculation # # Sigp <- matrix(NA, nrow(Parmn), nAlloc) # ## assign p-values to calculate percentage significant # # Fitind <- data.frame(Fitind) # ### convert fit index table to dataframe # # # for (i in 1:nAlloc) { # # Parsd[, i] <- Param[[i]][, 4] # ## assign parameter estimates for S.D. estimation # # ParSE[, i] <- Param[[i]][, 5] # # if (i > 1) # ParSEmn <- rowSums(cbind(ParSEmn, Param[[i]][, 5]), na.rm = TRUE) # # Sigp[, ncol(Sigp) - i + 1] <- Param[[i]][, 7] # ## assign p-values to calculate percentage significant # # # Fitsd[, i] <- Fitind[[i]] # ## assign fit indices for S.D. estimation # # if (i > 1) { # Parmn[, 4:ncol(Parmn)] <- rowSums(cbind(Parmn[, 4:ncol(Parmn)], Param[[i]][, # 4:ncol(Parmn)]), na.rm = TRUE) # } # ## add together all parameter estimates # # if (i > 1) # Fitmn <- rowSums(cbind(Fitmn, Fitind[[i]]), na.rm = TRUE) # ## add together all fit indices # # } # # # Sigp <- Sigp + 0.45 # Sigp <- apply(Sigp, c(1, 2), round) # Sigp <- 1 - as.vector(rowMeans(Sigp, na.rm = TRUE)) # ## calculate percentage significant parameters # # Parsum <- cbind(apply(Parsd, 1, mean, na.rm = TRUE), apply(Parsd, 1, sd, na.rm = TRUE), # apply(Parsd, 1, max, na.rm = TRUE), apply(Parsd, 1, min, na.rm = TRUE), # apply(Parsd, 1, max, na.rm = TRUE) - apply(Parsd, 1, min, na.rm = TRUE), # Sigp * 100) # colnames(Parsum) <- c("Avg Est", "S.D.", "MAX", "MIN", "Range", "% Sig") # ## calculate parameter S.D., minimum, maximum, range, bind to percentage # ## significant # # ParSEmn <- Parmn[, 1:3] # ParSEfn <- cbind(ParSEmn, apply(ParSE, 1, mean, na.rm = TRUE), apply(ParSE, # 1, sd, na.rm = TRUE), apply(ParSE, 1, max, na.rm = TRUE), apply(ParSE, # 1, min, na.rm = TRUE), apply(ParSE, 1, max, na.rm = TRUE) - apply(ParSE, # 1, min, na.rm = TRUE)) # colnames(ParSEfn) <- c("lhs", "op", "rhs", "Avg SE", "S.D.", "MAX", "MIN", # "Range") # # Fitsum <- cbind(apply(Fitsd, 1, mean, na.rm = TRUE), apply(Fitsd, 1, sd, na.rm = TRUE), # apply(Fitsd, 1, max, na.rm = TRUE), apply(Fitsd, 1, min, na.rm = TRUE), # apply(Fitsd, 1, max, na.rm = TRUE) - apply(Fitsd, 1, min, na.rm = TRUE)) # rownames(Fitsum) <- c("chisq", "df", "cfi", "tli", "rmsea", "srmr", "logl", # "bic", "aic") # ## calculate fit S.D., minimum, maximum, range # # Parmn[, 4:ncol(Parmn)] <- Parmn[, 4:ncol(Parmn)]/nConvergedProper # ## divide totalled parameter estimates by number converged allocations # Parmn <- Parmn[, 1:3] # ## remove confidence intervals from output # Parmn <- cbind(Parmn, Parsum) # ## bind parameter average estimates to cross-allocation information # Fitmn <- as.numeric(Fitmn) # ## make fit index values numeric # Fitmn <- Fitmn/nConvergedProper # ## divide totalled fit indices by number converged allocations # # pChisq <- list() # ## create empty list for Chi-square p-values # sigChisq <- list() # ## create empty list for Chi-square significance # # for (i in 1:nAlloc) { # # pChisq[[i]] <- (1 - pchisq(Fitsd[1, i], Fitsd[2, i])) # ## calculate p-value for each Chi-square # # if (is.na(pChisq[[i]]) == FALSE & pChisq[[i]] < 0.05) { # sigChisq[[i]] <- 1 # } else sigChisq[[i]] <- 0 # } # ## count number of allocations with significant chi-square # # PerSigChisq <- (Reduce("+", sigChisq))/nConvergedProper * 100 # PerSigChisq <- round(PerSigChisq, 3) # ## calculate percent of allocations with significant chi-square # # PerSigChisqCol <- c(PerSigChisq, "n/a", "n/a", "n/a", "n/a", "n/a", "n/a", # "n/a", "n/a") # ## create list of Chi-square Percent Significant and 'n/a' (used for fit summary # ## table) # # options(stringsAsFactors = FALSE) # ## set default option to allow strings into dataframe without converting to factors # # Fitsum <- data.frame(Fitsum, PerSigChisqCol) # colnames(Fitsum) <- c("Avg Ind", "S.D.", "MAX", "MIN", "Range", "% Sig") # ### bind to fit averages # # options(stringsAsFactors = TRUE) # ## unset option to allow strings into dataframe without converting to factors # # ParSEfn[, 4:8] <- apply(ParSEfn[, 4:8], 2, round, digits = 3) # Parmn[, 4:9] <- apply(Parmn[, 4:9], 2, round, digits = 3) # Fitsum[, 1:5] <- apply(Fitsum[, 1:5], 2, round, digits = 3) # ## round output to three digits # # Fitsum[2, 2:5] <- c("n/a", "n/a", "n/a", "n/a") # ## Change df row to 'n/a' for sd, max, min, and range # # Output_B <- list(Parmn, ParSEfn, Fitsum) # names(Output_B) <- c("Estimates_B", "SE_B", "Fit_B") # ## output summary for model A # # } # # ## Model Comparison (everything in this section is new) # # { # Converged_AB <- list() # ## create list of convergence comparison for each allocation # ProperSolution_AB <- list() # ## create list of proper solution comparison for each allocation # ConvergedProper_AB <- list() # ## create list of convergence and proper solution comparison for each allocation # lrtest_AB <- list() # ## create list for likelihood ratio test for each allocation # lrchisq_AB <- list() # ## create list for likelihood ratio chi square value # lrchisqp_AB <- list() # ## create list for likelihood ratio test p-value # lrsig_AB <- list() # ## create list for likelihood ratio test significance # # for (i in 1:nAlloc) { # if (Converged_A[[i]] == 1 & Converged[[i]] == 1) { # Converged_AB[[i]] <- 1 # } else Converged_AB[[i]] <- 0 # ## compare convergence # # if (ProperSolution_A[[i]] == 1 & ProperSolution[[i]] == 1) { # ProperSolution_AB[[i]] <- 1 # } else ProperSolution_AB[[i]] <- 0 # ## compare existence of proper solutions # # if (ConvergedProper_A[[i]] == 1 & ConvergedProper[[i]] == 1) { # ConvergedProper_AB[[i]] <- 1 # } else ConvergedProper_AB[[i]] <- 0 # ## compare existence of proper solutions and convergence # # # # if (ConvergedProper_AB[[i]] == 1) { # # data <- as.data.frame(Allocations[[i]], row.names = NULL, optional = FALSE) # ## convert allocation matrix to dataframe for model estimation # fit_A <- lavaan::sem(syntaxA, data = data, ...) # ## estimate model A in lavaan # fit <- lavaan::sem(syntaxB, data = data, ...) # ## estimate model B in lavaan # lrtest_AB[[i]] <- lavaan::lavTestLRT(fit_A, fit) # ## likelihood ratio test comparing A and B # lrtestd_AB <- as.data.frame(lrtest_AB[[i]], row.names = NULL, optional = FALSE) # ## convert lrtest results to dataframe # lrchisq_AB[[i]] <- lrtestd_AB[2, 5] # ## write lrtest chisq as single numeric variable # lrchisqp_AB[[i]] <- lrtestd_AB[2, 7] # ## write lrtest p-value as single numeric variable # if (lrchisqp_AB[[i]] < 0.05) { # lrsig_AB[[i]] <- 1 # } else { # lrsig_AB[[i]] <- 0 # } # ## determine statistical significance of lrtest # # } # } # # lrchisqp_AB <- unlist(lrchisqp_AB, recursive = TRUE, use.names = TRUE) # ## convert lrchisqp_AB from list to vector # lrchisqp_AB <- as.numeric(lrchisqp_AB) # ## make lrchisqp_AB numeric # lrsig_AB <- unlist(lrsig_AB, recursive = TRUE, use.names = TRUE) # ## convert lrsig_AB from list to vector # lrsig_AB <- as.numeric(lrsig_AB) # ### make lrsig_AB numeric # # # nConverged_AB <- Reduce("+", Converged_AB) # ## count number of allocations that converged for both A and B # nProperSolution_AB <- Reduce("+", ProperSolution_AB) # ## count number of allocations with proper solutions for both A and B # nConvergedProper_AB <- Reduce("+", ConvergedProper_AB) # ## count number of allocations that converged and have proper solutions for both A # ## and B # ProConverged_AB <- (nConverged_AB/nAlloc) * 100 # ## calc proportion of allocations that converged for both A and B # nlrsig_AB <- Reduce("+", lrsig_AB) # ## count number of allocations with significant lrtest between A and B # Prolrsig_AB <- (nlrsig_AB/nConvergedProper_AB) * 100 # ## calc proportion of allocations with significant lrtest between A and B # lrchisq_AB <- unlist(lrchisq_AB, recursive = TRUE, use.names = TRUE) # ### convert lrchisq_AB from list to vector # lrchisq_AB <- as.numeric(lrchisq_AB) # ### make lrchisq_AB numeric # AvgLRT_AB <- (Reduce("+", lrchisq_AB))/nConvergedProper_AB # ## calc average LRT # # LRTsum <- cbind(AvgLRT_AB, lrtestd_AB[2, 3], sd(lrchisq_AB, na.rm = TRUE), # max(lrchisq_AB), min(lrchisq_AB), # max(lrchisq_AB) - min(lrchisq_AB), Prolrsig_AB) # colnames(LRTsum) <- c("Avg LRT", "df", "S.D.", "MAX", "MIN", "Range", "% Sig") # ## calculate LRT distribution statistics # # FitDiff_AB <- Fitsd_A - Fitsd # ## compute fit index difference matrix # # for (i in 1:nAlloc) { # if (ConvergedProper_AB[[i]] != 1) # FitDiff_AB[1:9, i] <- 0 # } # ### make fit differences zero for each non-converged allocation # # BICDiff_AB <- list() # AICDiff_AB <- list() # RMSEADiff_AB <- list() # CFIDiff_AB <- list() # TLIDiff_AB <- list() # SRMRDiff_AB <- list() # BICDiffGT10_AB <- list() # ## create list noting each allocation in which A is preferred over B # # BICDiff_BA <- list() # AICDiff_BA <- list() # RMSEADiff_BA <- list() # CFIDiff_BA <- list() # TLIDiff_BA <- list() # SRMRDiff_BA <- list() # BICDiffGT10_BA <- list() # ## create list noting each allocation in which B is preferred over A # # for (i in 1:nAlloc) { # if (FitDiff_AB[8, i] < 0) { # BICDiff_AB[[i]] <- 1 # } else BICDiff_AB[[i]] <- 0 # if (FitDiff_AB[9, i] < 0) { # AICDiff_AB[[i]] <- 1 # } else AICDiff_AB[[i]] <- 0 # if (FitDiff_AB[5, i] < 0) { # RMSEADiff_AB[[i]] <- 1 # } else RMSEADiff_AB[[i]] <- 0 # if (FitDiff_AB[3, i] > 0) { # CFIDiff_AB[[i]] <- 1 # } else CFIDiff_AB[[i]] <- 0 # if (FitDiff_AB[4, i] > 0) { # TLIDiff_AB[[i]] <- 1 # } else TLIDiff_AB[[i]] <- 0 # if (FitDiff_AB[6, i] < 0) { # SRMRDiff_AB[[i]] <- 1 # } else SRMRDiff_AB[[i]] <- 0 # if (FitDiff_AB[8, i] < (-10)) { # BICDiffGT10_AB[[i]] <- 1 # } else BICDiffGT10_AB[[i]] <- 0 # } # nBIC_AoverB <- Reduce("+", BICDiff_AB) # nAIC_AoverB <- Reduce("+", AICDiff_AB) # nRMSEA_AoverB <- Reduce("+", RMSEADiff_AB) # nCFI_AoverB <- Reduce("+", CFIDiff_AB) # nTLI_AoverB <- Reduce("+", TLIDiff_AB) # nSRMR_AoverB <- Reduce("+", SRMRDiff_AB) # nBICDiffGT10_AoverB <- Reduce("+", BICDiffGT10_AB) # ## compute number of 'A preferred over B' for each fit index # # for (i in 1:nAlloc) { # if (FitDiff_AB[8, i] > 0) { # BICDiff_BA[[i]] <- 1 # } else BICDiff_BA[[i]] <- 0 # if (FitDiff_AB[9, i] > 0) { # AICDiff_BA[[i]] <- 1 # } else AICDiff_BA[[i]] <- 0 # if (FitDiff_AB[5, i] > 0) { # RMSEADiff_BA[[i]] <- 1 # } else RMSEADiff_BA[[i]] <- 0 # if (FitDiff_AB[3, i] < 0) { # CFIDiff_BA[[i]] <- 1 # } else CFIDiff_BA[[i]] <- 0 # if (FitDiff_AB[4, i] < 0) { # TLIDiff_BA[[i]] <- 1 # } else TLIDiff_BA[[i]] <- 0 # if (FitDiff_AB[6, i] > 0) { # SRMRDiff_BA[[i]] <- 1 # } else SRMRDiff_BA[[i]] <- 0 # if (FitDiff_AB[8, i] > (10)) { # BICDiffGT10_BA[[i]] <- 1 # } else BICDiffGT10_BA[[i]] <- 0 # } # nBIC_BoverA <- Reduce("+", BICDiff_BA) # nAIC_BoverA <- Reduce("+", AICDiff_BA) # nRMSEA_BoverA <- Reduce("+", RMSEADiff_BA) # nCFI_BoverA <- Reduce("+", CFIDiff_BA) # nTLI_BoverA <- Reduce("+", TLIDiff_BA) # nSRMR_BoverA <- Reduce("+", SRMRDiff_BA) # nBICDiffGT10_BoverA <- Reduce("+", BICDiffGT10_BA) # ## compute number of 'B preferred over A' for each fit index # # BICDiffAvgtemp <- list() # AICDiffAvgtemp <- list() # RMSEADiffAvgtemp <- list() # CFIDiffAvgtemp <- list() # TLIDiffAvgtemp <- list() # SRMRDiffAvgtemp <- list() # BICgt10DiffAvgtemp <- list() # ## create empty list for average fit index differences # # for (i in 1:nAlloc) { # if (BICDiff_AB[[i]] != 1) { # BICDiffAvgtemp[[i]] <- 0 # } else BICDiffAvgtemp[[i]] <- FitDiff_AB[8, i] # if (AICDiff_AB[[i]] != 1) { # AICDiffAvgtemp[[i]] <- 0 # } else AICDiffAvgtemp[[i]] <- FitDiff_AB[9, i] # if (RMSEADiff_AB[[i]] != 1) { # RMSEADiffAvgtemp[[i]] <- 0 # } else RMSEADiffAvgtemp[[i]] <- FitDiff_AB[5, i] # if (CFIDiff_AB[[i]] != 1) { # CFIDiffAvgtemp[[i]] <- 0 # } else CFIDiffAvgtemp[[i]] <- FitDiff_AB[3, i] # if (TLIDiff_AB[[i]] != 1) { # TLIDiffAvgtemp[[i]] <- 0 # } else TLIDiffAvgtemp[[i]] <- FitDiff_AB[4, i] # if (SRMRDiff_AB[[i]] != 1) { # SRMRDiffAvgtemp[[i]] <- 0 # } else SRMRDiffAvgtemp[[i]] <- FitDiff_AB[6, i] # if (BICDiffGT10_AB[[i]] != 1) { # BICgt10DiffAvgtemp[[i]] <- 0 # } else BICgt10DiffAvgtemp[[i]] <- FitDiff_AB[8, i] # } # ## make average fit index difference list composed solely of values where A is # ## preferred over B # # BICDiffAvg_AB <- Reduce("+", BICDiffAvgtemp)/nBIC_AoverB * (-1) # AICDiffAvg_AB <- Reduce("+", AICDiffAvgtemp)/nAIC_AoverB * (-1) # RMSEADiffAvg_AB <- Reduce("+", RMSEADiffAvgtemp)/nRMSEA_AoverB * (-1) # CFIDiffAvg_AB <- Reduce("+", CFIDiffAvgtemp)/nCFI_AoverB # TLIDiffAvg_AB <- Reduce("+", TLIDiffAvgtemp)/nTLI_AoverB # SRMRDiffAvg_AB <- Reduce("+", SRMRDiffAvgtemp)/nSRMR_AoverB * (-1) # BICgt10DiffAvg_AB <- Reduce("+", BICgt10DiffAvgtemp)/nBICDiffGT10_AoverB * # (-1) # ## calc average fit index difference when A is preferred over B # # FitDiffAvg_AoverB <- list(BICDiffAvg_AB, AICDiffAvg_AB, RMSEADiffAvg_AB, CFIDiffAvg_AB, # TLIDiffAvg_AB, SRMRDiffAvg_AB) # ## create list of all fit index differences when A is preferred over B # # FitDiffAvg_AoverB <- unlist(FitDiffAvg_AoverB, recursive = TRUE, use.names = TRUE) # ### convert from list to vector # # for (i in 1:nAlloc) { # if (BICDiff_BA[[i]] != 1) { # BICDiffAvgtemp[[i]] <- 0 # } else BICDiffAvgtemp[[i]] <- FitDiff_AB[8, i] # if (AICDiff_BA[[i]] != 1) { # AICDiffAvgtemp[[i]] <- 0 # } else AICDiffAvgtemp[[i]] <- FitDiff_AB[9, i] # if (RMSEADiff_BA[[i]] != 1) { # RMSEADiffAvgtemp[[i]] <- 0 # } else RMSEADiffAvgtemp[[i]] <- FitDiff_AB[5, i] # if (CFIDiff_BA[[i]] != 1) { # CFIDiffAvgtemp[[i]] <- 0 # } else CFIDiffAvgtemp[[i]] <- FitDiff_AB[3, i] # if (TLIDiff_BA[[i]] != 1) { # TLIDiffAvgtemp[[i]] <- 0 # } else TLIDiffAvgtemp[[i]] <- FitDiff_AB[4, i] # if (SRMRDiff_BA[[i]] != 1) { # SRMRDiffAvgtemp[[i]] <- 0 # } else SRMRDiffAvgtemp[[i]] <- FitDiff_AB[6, i] # if (BICDiffGT10_BA[[i]] != 1) { # BICgt10DiffAvgtemp[[i]] <- 0 # } else BICgt10DiffAvgtemp[[i]] <- FitDiff_AB[8, i] # } # ## make average fit index difference list composed solely of values where B is # ## preferred over A # # BICDiffAvg_BA <- Reduce("+", BICDiffAvgtemp)/nBIC_BoverA # AICDiffAvg_BA <- Reduce("+", AICDiffAvgtemp)/nAIC_BoverA # RMSEADiffAvg_BA <- Reduce("+", RMSEADiffAvgtemp)/nRMSEA_BoverA # CFIDiffAvg_BA <- Reduce("+", CFIDiffAvgtemp)/nCFI_BoverA * (-1) # TLIDiffAvg_BA <- Reduce("+", TLIDiffAvgtemp)/nTLI_BoverA * (-1) # SRMRDiffAvg_BA <- Reduce("+", SRMRDiffAvgtemp)/nSRMR_BoverA # BICgt10DiffAvg_BA <- Reduce("+", BICgt10DiffAvgtemp)/nBICDiffGT10_BoverA # ## calc average fit index difference when B is preferred over A # # FitDiffAvg_BoverA <- list(BICDiffAvg_BA, AICDiffAvg_BA, RMSEADiffAvg_BA, CFIDiffAvg_BA, # TLIDiffAvg_BA, SRMRDiffAvg_BA) # ## create list of all fit index differences when B is preferred over A # # FitDiffAvg_BoverA <- unlist(FitDiffAvg_BoverA, recursive = TRUE, use.names = TRUE) # ### convert from list to vector # # FitDiffBICgt10_AoverB <- nBICDiffGT10_AoverB/nConvergedProper_AB * 100 # ### calculate portion of allocations where A strongly preferred over B # # FitDiffBICgt10_BoverA <- nBICDiffGT10_BoverA/nConvergedProper_AB * 100 # ### calculate portion of allocations where B strongly preferred over A # # FitDiffBICgt10 <- rbind(FitDiffBICgt10_AoverB, FitDiffBICgt10_BoverA) # rownames(FitDiffBICgt10) <- c("Very Strong evidence for A>B", "Very Strong evidence for B>A") # colnames(FitDiffBICgt10) <- "% Allocations" # ### create table of proportions of 'A strongly preferred over B' and 'B strongly # ### preferred over A' # # FitDiff_AoverB <- list(nBIC_AoverB/nConvergedProper_AB * 100, nAIC_AoverB/nConvergedProper_AB * # 100, nRMSEA_AoverB/nConvergedProper_AB * 100, nCFI_AoverB/nConvergedProper_AB * # 100, nTLI_AoverB/nConvergedProper_AB * 100, nSRMR_AoverB/nConvergedProper_AB * # 100) # ### create list of all proportions of 'A preferred over B' # FitDiff_BoverA <- list(nBIC_BoverA/nConvergedProper_AB * 100, nAIC_BoverA/nConvergedProper_AB * # 100, nRMSEA_BoverA/nConvergedProper_AB * 100, nCFI_BoverA/nConvergedProper_AB * # 100, nTLI_BoverA/nConvergedProper_AB * 100, nSRMR_BoverA/nConvergedProper_AB * # 100) # ### create list of all proportions of 'B preferred over A' # # FitDiff_AoverB <- unlist(FitDiff_AoverB, recursive = TRUE, use.names = TRUE) # ### convert from list to vector # # FitDiff_BoverA <- unlist(FitDiff_BoverA, recursive = TRUE, use.names = TRUE) # ### convert from list to vector # # FitDiffSum_AB <- cbind(FitDiff_AoverB, FitDiffAvg_AoverB, FitDiff_BoverA, # FitDiffAvg_BoverA) # colnames(FitDiffSum_AB) <- c("% A>B", "Avg Amount A>B", "% B>A", "Avg Amount B>A") # rownames(FitDiffSum_AB) <- c("bic", "aic", "rmsea", "cfi", "tli", "srmr") # ## create table showing number of allocations in which A>B and B>A as well as # ## average difference values # # for (i in 1:nAlloc) { # is.na(FitDiff_AB[1:9, i]) <- ConvergedProper_AB[[i]] != 1 # } # ### make fit differences missing for each non-converged allocation # # LRThistMax <- max(hist(lrchisqp_AB, plot = FALSE)$counts) # BIChistMax <- max(hist(FitDiff_AB[8, 1:nAlloc], plot = FALSE)$counts) # AIChistMax <- max(hist(FitDiff_AB[9, 1:nAlloc], plot = FALSE)$counts) # RMSEAhistMax <- max(hist(FitDiff_AB[5, 1:nAlloc], plot = FALSE)$counts) # CFIhistMax <- max(hist(FitDiff_AB[3, 1:nAlloc], plot = FALSE)$counts) # TLIhistMax <- max(hist(FitDiff_AB[4, 1:nAlloc], plot = FALSE)$counts) # ### calculate y-axis height for each histogram # # LRThist <- hist(lrchisqp_AB, ylim = c(0, LRThistMax), xlab = "p-value", main = "LRT p-values") # ## plot histogram of LRT p-values # # BIChist <- hist(FitDiff_AB[8, 1:nAlloc], ylim = c(0, BIChistMax), xlab = "BIC_modA - BIC_modB", # main = "BIC Diff") # AIChist <- hist(FitDiff_AB[9, 1:nAlloc], ylim = c(0, AIChistMax), xlab = "AIC_modA - AIC_modB", # main = "AIC Diff") # RMSEAhist <- hist(FitDiff_AB[5, 1:nAlloc], ylim = c(0, RMSEAhistMax), xlab = "RMSEA_modA - RMSEA_modB", # main = "RMSEA Diff") # CFIhist <- hist(FitDiff_AB[3, 1:nAlloc], ylim = c(0, CFIhistMax), xlab = "CFI_modA - CFI_modB", # main = "CFI Diff") # TLIhist <- hist(FitDiff_AB[4, 1:nAlloc], ylim = c(0, TLIhistMax), xlab = "TLI_modA - TLI_modB", # main = "TLI Diff") # ### plot histograms for each index_modA - index_modB # BIChist # AIChist # RMSEAhist # CFIhist # TLIhist # # ConvergedProperSum <- rbind(nConverged_A/nAlloc, nConverged/nAlloc, nConverged_AB/nAlloc, # nConvergedProper_A/nAlloc, nConvergedProper/nAlloc, nConvergedProper_AB/nAlloc) # rownames(ConvergedProperSum) <- c("Converged_A", "Converged_B", "Converged_AB", # "ConvergedProper_A", "ConvergedProper_B", "ConvergedProper_AB") # colnames(ConvergedProperSum) <- "Proportion of Allocations" # ### create table summarizing proportions of converged allocations and allocations # ### with proper solutions # # Output_AB <- list(round(LRTsum, 3), "LRT results are interpretable specifically for nested models", # round(FitDiffSum_AB, 3), round(FitDiffBICgt10, 3), ConvergedProperSum) # names(Output_AB) <- c("LRT Summary, Model A vs. Model B", "Note:", "Fit Index Differences", # "Percent of Allocations with |BIC Diff| > 10", "Converged and Proper Solutions Summary") # ### output for model comparison # # } # # return(list(Output_A, Output_B, Output_AB)) # ## returns output for model A, model B, and the comparison of these # } semTools/R/permuteMeasEq.R0000644000176200001440000021523014764267640015203 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### permutation randomization test for measurement equivalence and DIF ## ----------------- ## Class and Methods ## ----------------- ##' Class for the Results of Permutation Randomization Tests of Measurement ##' Equivalence and DIF ##' ##' This class contains the results of tests of Measurement Equivalence and ##' Differential Item Functioning (DIF). ##' ##' ##' @name permuteMeasEq-class ##' @aliases permuteMeasEq-class show,permuteMeasEq-method ##' summary,permuteMeasEq-method hist,permuteMeasEq-method ##' @docType class ##' ##' @slot PT A `data.frame` returned by a call to ##' [lavaan::parTable()] on the constrained model ##' @slot modelType A character indicating the specified `modelType` in the ##' call to `permuteMeasEq` ##' @slot ANOVA A `numeric` vector indicating the results of the observed ##' (\eqn{\Delta})\eqn{\chi^2} test, based on the central \eqn{\chi^2} ##' distribution ##' @slot AFI.obs A vector of observed (changes in) user-selected fit measures ##' @slot AFI.dist The permutation distribution(s) of user-selected fit measures. ##' A `data.frame` with `n.Permutations` rows and one column for each ##' `AFI.obs`. ##' @slot AFI.pval A vector of *p* values (one for each element in slot ##' `AFI.obs`) calculated using slot `AFI.dist`, indicating the ##' probability of observing a change at least as extreme as `AFI.obs` ##' if the null hypothesis were true ##' @slot MI.obs A `data.frame` of observed Lagrange Multipliers ##' (modification indices) associated with the equality constraints or fixed ##' parameters specified in the `param` argument. This is a subset of the ##' output returned by a call to [lavaan::lavTestScore()] on the ##' constrained model. ##' @slot MI.dist The permutation distribution of the maximum modification index ##' (among those seen in slot `MI.obs$X2`) at each permutation of group ##' assignment or of `covariates` ##' @slot extra.obs If `permuteMeasEq` was called with an `extra` ##' function, the output when applied to the original data is concatenated ##' into this vector ##' @slot extra.dist A `data.frame`, each column of which contains the ##' permutation distribution of the corresponding statistic in slot ##' `extra.obs` ##' @slot n.Permutations An `integer` indicating the number of permutations ##' requested by the user ##' @slot n.Converged An `integer` indicating the number of permuation ##' iterations which yielded a converged solution ##' @slot n.nonConverged An `integer` vector of length ##' `n.Permutations` indicating how many times group assignment was ##' randomly permuted (at each iteration) before converging on a solution ##' @slot n.Sparse Only relevant with `ordered` indicators when ##' `modelType == "mgcfa"`. An `integer` vector of length ##' `n.Permutations` indicating how many times group assignment was ##' randomly permuted (at each iteration) before obtaining a sample with all ##' categories observed in all groups. ##' @slot oldSeed An `integer` vector storing the value of ##' `.Random.seed` before running `permuteMeasEq`. Only relevant ##' when using a parallel/multicore option and the original ##' `RNGkind() != "L'Ecuyer-CMRG"`. This enables users to restore their ##' previous `.Random.seed` state, if desired, by running: ##' `.Random.seed[-1] <- permutedResults@oldSeed[-1]` ##' @section Objects from the Class: Objects can be created via the ##' [semTools::permuteMeasEq()] function. ##' ##' @return ##' \itemize{ ##' \item The `show` method prints a summary of the multiparameter ##' omnibus test results, using the user-specified AFIs. The parametric ##' (\eqn{\Delta})\eqn{\chi^2} test is also displayed. ##' \item The `summary` method prints the same information from the ##' `show` method, but when `extra = FALSE` (the default) it also ##' provides a table summarizing any requested follow-up tests of DIF using ##' modification indices in slot `MI.obs`. The user can also specify an ##' `alpha` level for flagging modification indices as significant, as ##' well as `nd` (the number of digits displayed). For each modification ##' index, the *p* value is displayed using a central \eqn{\chi^2} ##' distribution with the *df* shown in that column. Additionally, a ##' *p* value is displayed using the permutation distribution of the ##' maximum index, which controls the familywise Type I error rate in a manner ##' similar to Tukey's studentized range test. If any indices are flagged as ##' significant using the `tukey.p.value`, then a message is displayed for ##' each flagged index. The invisibly returned `data.frame` is the ##' displayed table of modification indices, unless ##' [semTools::permuteMeasEq()] was called with `param = NULL`, ##' in which case the invisibly returned object is `object`. If ##' `extra = TRUE`, the permutation-based *p* values for each ##' statistic returned by the `extra` function are displayed and returned ##' in a `data.frame` instead of the modification indices requested in the ##' `param` argument. ##' \item The `hist` method returns a list of `length == 2`, ##' containing the arguments for the call to `hist` and the arguments ##' to the call for `legend`, respectively. This list may facilitate ##' creating a customized histogram of `AFI.dist`, `MI.dist`, or ##' `extra.dist` ##' } ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [semTools::permuteMeasEq()] ##' ##' @examples ##' ##' # See the example from the permuteMeasEq function ##' setClass("permuteMeasEq", slots = c(PT = "data.frame", modelType = "character", ANOVA = "vector", AFI.obs = "vector", AFI.dist = "data.frame", AFI.pval = "vector", MI.obs = "data.frame", MI.dist = "vector", extra.obs = "vector", extra.dist = "data.frame", n.Permutations = "integer", n.Converged = "integer", n.nonConverged = "vector", n.Sparse = "vector", oldSeed = "integer")) ##' @rdname permuteMeasEq-class ##' @aliases show,permuteMeasEq-method ##' @export setMethod("show", "permuteMeasEq", function(object) { ## print warning if there are nonConverged permutations if (object@n.Permutations != object@n.Converged) { warning(paste("Only", object@n.Converged, "out of", object@n.Permutations, "models converged within", max(object@n.nonConverged), "attempts per permutation.\n\n")) } ## print ANOVA cat("Omnibus p value based on parametric chi-squared difference test:\n\n") print(round(object@ANOVA, digits = 3)) ## print permutation results cat("\n\nOmnibus p values based on nonparametric permutation method: \n\n") AFI <- data.frame(AFI.Difference = object@AFI.obs, p.value = object@AFI.pval) class(AFI) <- c("lavaan.data.frame","data.frame") print(AFI, nd = 3) invisible(object) }) ##' @rdname permuteMeasEq-class ##' @aliases summary,permuteMeasEq-method ##' @export setMethod("summary", "permuteMeasEq", function(object, alpha = .05, nd = 3, extra = FALSE) { ## print warning if there are nonConverged permutations if (object@n.Permutations != object@n.Converged) { warning(paste("Only", object@n.Converged, "out of", object@n.Permutations, "models converged within", max(object@n.nonConverged), "attempts per permutation.\n\n")) } ## print ANOVA cat("Omnibus p value based on parametric chi-squared difference test:\n\n") print(round(object@ANOVA, digits = nd)) ## print permutation results cat("\n\nOmnibus p values based on nonparametric permutation method: \n\n") AFI <- data.frame(AFI.Difference = object@AFI.obs, p.value = object@AFI.pval) class(AFI) <- c("lavaan.data.frame","data.frame") print(AFI, nd = nd) ## print extras or DIF test results, if any were requested if (extra && length(object@extra.obs)) { cat("\n\nUnadjusted p values of extra statistics,\n", "based on permutation distribution of each statistic: \n\n") MI <- data.frame(Statistic = object@extra.obs) class(MI) <- c("lavaan.data.frame","data.frame") MI$p.value <- sapply(names(object@extra.dist), function(nn) { mean(abs(object@extra.dist[,nn]) >= abs(object@extra.obs[nn]), na.rm = TRUE) }) MI$flag <- ifelse(MI$p.value < alpha, "* ", "") print(MI, nd = nd) } else if (length(object@MI.dist)) { cat("\n\n Modification indices for equality constrained parameter estimates,\n", "with unadjusted 'p.value' based on chi-squared distribution and\n", "adjusted 'tukey.p.value' based on permutation distribution of the\n", "maximum modification index per iteration: \n\n") MI <- do.call(paste("summ", object@modelType, sep = "."), args = list(object = object, alpha = alpha)) print(MI, nd = nd) ## print messages about potential DIF if (all(MI$tukey.p.value > alpha)) { cat("\n\n No equality constraints were flagged as significant.\n\n") return(invisible(MI)) } if (object@modelType == "mgcfa") { cat("\n\nThe following equality constraints were flagged as significant:\n\n") for (i in which(MI$tukey.p.value < alpha)) { cat("Parameter '", MI$parameter[i], "' may differ between Groups '", MI$group.lhs[i], "' and '", MI$group.rhs[i], "'.\n", sep = "") } cat("\nUse lavTestScore(..., epc = TRUE) on your constrained model to", "display expected parameter changes for these equality constraints\n\n") } } else return(invisible(object)) invisible(MI) }) summ.mgcfa <- function(object, alpha) { MI <- object@MI.obs class(MI) <- c("lavaan.data.frame","data.frame") PT <- object@PT eqPar <- rbind(PT[PT$plabel %in% MI$lhs, ], PT[PT$plabel %in% MI$rhs, ]) MI$flag <- "" MI$parameter <- "" MI$group.lhs <- "" MI$group.rhs <- "" for (i in 1:nrow(MI)) { par1 <- eqPar$par[ eqPar$plabel == MI$lhs[i] ] par2 <- eqPar$par[ eqPar$plabel == MI$rhs[i] ] MI$parameter[i] <- par1 MI$group.lhs[i] <- eqPar$group.label[ eqPar$plabel == MI$lhs[i] ] MI$group.rhs[i] <- eqPar$group.label[ eqPar$plabel == MI$rhs[i] ] if (par1 != par2) { myMessage <- paste0("Constraint '", MI$lhs[i], "==", MI$rhs[i], "' refers to different parameters: \n'", MI$lhs[i], "' is '", par1, "' in group '", MI$group.lhs[i], "'\n'", MI$rhs[i], "' is '", par2, "' in group '", MI$group.rhs[i], "'\n") warning(myMessage) } if (MI$tukey.p.value[i] < alpha) MI$flag[i] <- "* -->" } MI } summ.mimic <- function(object, alpha) { MI <- object@MI.obs class(MI) <- c("lavaan.data.frame","data.frame") MI$flag <- ifelse(MI$tukey.p.value < alpha, "* ", "") MI } ##' @rdname permuteMeasEq-class ##' @aliases hist,permuteMeasEq-method ##' @importFrom stats qchisq dchisq quantile ##' @param object,x object of class `permuteMeasEq` ##' @param ... Additional arguments to pass to [graphics::hist()] ##' @param AFI `character` indicating the fit measure whose permutation ##' distribution should be plotted ##' @param alpha alpha level used to draw confidence limits in `hist` and ##' flag significant statistics in `summary` output ##' @param nd number of digits to display ##' @param extra `logical` indicating whether the `summary` output ##' should return permutation-based *p* values for each statistic returned ##' by the `extra` function. If `FALSE` (default), `summary` ##' will return permutation-based *p* values for each modification index. ##' @param printLegend `logical`. If `TRUE` (default), a legend will ##' be printed with the histogram ##' @param legendArgs `list` of arguments passed to the ##' [graphics::legend()] function. The default argument is a list ##' placing the legend at the top-left of the figure. ##' @export setMethod("hist", "permuteMeasEq", function(x, ..., AFI, alpha = .05, nd = 3, printLegend = TRUE, legendArgs = list(x = "topleft")) { histArgs <- list(...) histArgs$x <- x@AFI.dist[[AFI]] if (is.null(histArgs$col)) histArgs$col <- "grey69" histArgs$freq <- !grepl("chi", AFI) histArgs$ylab <- if (histArgs$freq) "Frequency" else "Probability Density" if (printLegend) { if (is.null(legendArgs$box.lty)) legendArgs$box.lty <- 0 if (nd < length(strsplit(as.character(1 / alpha), "")[[1]]) - 1) { warning(paste0("The number of digits argument (nd = ", nd , ") is too low to display your p value at the", " same precision as your requested alpha level (alpha = ", alpha, ")")) } if (x@AFI.pval[[AFI]] < (1 / 10^nd)) { pVal <- paste(c("< .", rep(0, nd - 1),"1"), collapse = "") } else { pVal <- paste("=", round(x@AFI.pval[[AFI]], nd)) } } delta <- length(x@MI.dist) > 0L && x@modelType == "mgcfa" if (grepl("chi", AFI)) { ####################################### Chi-squared ChiSq <- x@AFI.obs[AFI] DF <- x@ANOVA[2] histArgs$xlim <- range(c(ChiSq, x@AFI.dist[[AFI]], qchisq(c(.01, .99), DF))) xVals <- seq(histArgs$xlim[1], histArgs$xlim[2], by = .1) theoDist <- dchisq(xVals, df = DF) TheoCrit <- round(qchisq(p = alpha, df = DF, lower.tail = FALSE), 2) Crit <- quantile(histArgs$x, probs = 1 - alpha) if (ChiSq > histArgs$xlim[2]) histArgs$xlim[2] <- ChiSq if (delta) { histArgs$main <- expression(Permutation~Distribution~of~Delta*chi^2) histArgs$xlab <- expression(Delta*chi^2) if (printLegend) { legendArgs$legend <- c(bquote(Theoretical~Delta*chi[Delta*.(paste("df =", DF))]^2 ~ Distribution), bquote(Critical~chi[alpha~.(paste(" =", alpha))]^2 == .(round(TheoCrit, nd))), bquote(.(paste("Permuted Critical Value =", round(Crit, nd)))), bquote(Observed~Delta*chi^2 == .(round(ChiSq, nd))), expression(paste("")), bquote(Permuted~italic(p)~.(pVal))) } } else { histArgs$main <- expression(Permutation~Distribution~of~chi^2) histArgs$xlab <- expression(chi^2) if (printLegend) { legendArgs$legend <- c(bquote(Theoretical~chi[.(paste("df =", DF))]^2 ~ Distribution), bquote(Critical~chi[alpha~.(paste(" =", alpha))]^2 == .(round(TheoCrit, nd))), bquote(.(paste("Permuted Critical Value =", round(Crit, nd)))), bquote(Observed~chi^2 == .(round(ChiSq, nd))), expression(paste("")), bquote(Permuted~italic(p)~.(pVal))) } } H <- do.call(hist, c(histArgs["x"], plot = FALSE)) histArgs$ylim <- c(0, max(H$density, theoDist)) if (printLegend) { legendArgs <- c(legendArgs, list(lty = c(2, 2, 1, 1, 0, 0), lwd = c(2, 2, 2, 3, 0, 0), col = c("black","black","black","red","",""))) } } else { ################################################### other AFIs badness <- grepl(pattern = "fmin|aic|bic|rmr|rmsea|cn|sic|hqc", x = AFI, ignore.case = TRUE) if (badness) { Crit <- quantile(histArgs$x, probs = 1 - alpha) } else { Crit <- quantile(histArgs$x, probs = alpha) } histArgs$xlim <- range(histArgs$x, x@AFI.obs[AFI]) if (delta) { histArgs$main <- bquote(~Permutation~Distribution~of~Delta*.(toupper(AFI))) histArgs$xlab <- bquote(~Delta*.(toupper(AFI))) if (printLegend) { legendArgs$legend <- c(bquote(Critical~Delta*.(toupper(AFI))[alpha~.(paste(" =", alpha))] == .(round(Crit, nd))), bquote(Observed~Delta*.(toupper(AFI)) == .(round(x@AFI.obs[AFI], nd))), expression(paste("")), bquote(Permuted~italic(p)~.(pVal))) } } else { histArgs$main <- paste("Permutation Distribution of", toupper(AFI)) histArgs$xlab <- toupper(AFI) if (printLegend) { legendArgs$legend <- c(bquote(Critical~.(toupper(AFI))[alpha~.(paste(" =", alpha))] == .(round(Crit, nd))), bquote(Observed~.(toupper(AFI)) == .(round(x@AFI.obs[AFI], nd))), expression(paste("")), bquote(Permuted~italic(p)~.(pVal))) } } if (printLegend) { legendArgs <- c(legendArgs, list(lty = c(1, 1, 0, 0), lwd = c(2, 3, 0, 0), col = c("black","red","",""))) } } ## print histogram (and optionally, print legend) suppressWarnings({ do.call(hist, histArgs) if (grepl("chi", AFI)) { lines(x = xVals, y = theoDist, lwd = 2, lty = 2) abline(v = TheoCrit, col = "black", lwd = 2, lty = 2) } abline(v = Crit, col = "black", lwd = 2) abline(v = x@AFI.obs[AFI], col = "red", lwd = 3) if (printLegend) do.call(legend, legendArgs) }) ## return arguments to create histogram (and optionally, legend) invisible(list(hist = histArgs, legend = legendArgs)) }) ## -------------------- ## Constructor Function ## -------------------- ##' Permutation Randomization Tests of Measurement Equivalence and Differential ##' Item Functioning (DIF) ##' ##' The function `permuteMeasEq` provides tests of hypotheses involving ##' measurement equivalence, in one of two frameworks: multigroup CFA or MIMIC ##' models. ##' ##' ##' The function `permuteMeasEq` provides tests of hypotheses involving ##' measurement equivalence, in one of two frameworks: ##' \enumerate{ ##' \item{1} For multiple-group CFA models, provide a pair of nested lavaan objects, ##' the less constrained of which (`uncon`) freely estimates a set of ##' measurement parameters (e.g., factor loadings, intercepts, or thresholds; ##' specified in `param`) in all groups, and the more constrained of which ##' (`con`) constrains those measurement parameters to equality across ##' groups. Group assignment is repeatedly permuted and the models are fit to ##' each permutation, in order to produce an empirical distribution under the ##' null hypothesis of no group differences, both for (a) changes in ##' user-specified fit measures (see `AFIs` and `moreAFIs`) and for ##' (b) the maximum modification index among the user-specified equality ##' constraints. Configural invariance can also be tested by providing that ##' fitted lavaan object to `con` and leaving `uncon = NULL`, in which ##' case `param` must be `NULL` as well. ##' ##' \item{2} In MIMIC models, one or a set of continuous and/or discrete ##' `covariates` can be permuted, and a constrained model is fit to each ##' permutation in order to provide a distribution of any fit measures (namely, ##' the maximum modification index among fixed parameters in `param`) under ##' the null hypothesis of measurement equivalence across levels of those ##' covariates. ##' } ##' ##' In either framework, modification indices for equality constraints or fixed ##' parameters specified in `param` are calculated from the constrained ##' model (`con`) using the function [lavaan::lavTestScore()]. ##' ##' For multiple-group CFA models, the multiparameter omnibus null hypothesis of ##' measurement equivalence/invariance is that there are no group differences in ##' any measurement parameters (of a particular type). This can be tested using ##' the `anova` method on nested `lavaan` objects, as seen in the ##' output of [semTools::measurementInvariance()], or by inspecting ##' the change in alternative fit indices (AFIs) such as the CFI. The ##' permutation randomization method employed by `permuteMeasEq` generates ##' an empirical distribution of any `AFIs` under the null hypothesis, so ##' the user is not restricted to using fixed cutoffs proposed by Cheung & ##' Rensvold (2002), Chen (2007), or Meade, Johnson, & Braddy (2008). ##' ##' If the multiparameter omnibus null hypothesis is rejected, partial ##' invariance can still be established by freeing invalid equality constraints, ##' as long as equality constraints are valid for at least two indicators per ##' factor. Modification indices can be calculated from the constrained model ##' (`con`), but multiple testing leads to inflation of Type I error rates. ##' The permutation randomization method employed by `permuteMeasEq` ##' creates a distribution of the maximum modification index if the null ##' hypothesis is true, which allows the user to control the familywise Type I ##' error rate in a manner similar to Tukey's *q* (studentized range) ##' distribution for the Honestly Significant Difference (HSD) post hoc test. ##' ##' For MIMIC models, DIF can be tested by comparing modification indices of ##' regression paths to the permutation distribution of the maximum modification ##' index, which controls the familywise Type I error rate. The MIMIC approach ##' could also be applied with multiple-group models, but the grouping variable ##' would not be permuted; rather, the covariates would be permuted separately ##' within each group to preserve between-group differences. So whether ##' parameters are constrained or unconstrained across groups, the MIMIC ##' approach is only for testing null hypotheses about the effects of ##' `covariates` on indicators, controlling for common factors. ##' ##' In either framework, [lavaan::lavaan()]'s `group.label` ##' argument is used to preserve the order of groups seen in `con` when ##' permuting the data. ##' ##' ##' @importFrom lavaan lavInspect parTable ##' ##' @param nPermute An integer indicating the number of random permutations used ##' to form empirical distributions under the null hypothesis. ##' @param modelType A character string indicating type of model employed: ##' multiple-group CFA (`"mgcfa"`) or MIMIC (`"mimic"`). ##' @param con The constrained `lavaan` object, in which the parameters ##' specified in `param` are constrained to equality across all groups when ##' `modelType = "mgcfa"`, or which regression paths are fixed to zero when ##' `modelType = "mimic"`. In the case of testing *configural* ##' invariance when `modelType = "mgcfa"`, `con` is the configural ##' model (implicitly, the unconstrained model is the saturated model, so use ##' the defaults `uncon = NULL` and `param = NULL`). When ##' `modelType = "mimic"`, `con` is the MIMIC model in which the ##' covariate predicts the latent construct(s) but no indicators (unless they ##' have already been identified as DIF items). ##' @param uncon Optional. The unconstrained `lavaan` object, in which the ##' parameters specified in `param` are freely estimated in all groups. ##' When `modelType = "mgcfa"`, only in the case of testing ##' *configural* invariance should `uncon = NULL`. When ##' `modelType = "mimic"`, any non-`NULL uncon` is silently set to ##' `NULL`. ##' @param null Optional. A `lavaan` object, in which an alternative null ##' model is fit (besides the default independence model specified by ##' `lavaan`) for the calculation of incremental fit indices. See Widamin & ##' Thompson (2003) for details. If `NULL`, `lavaan`'s default ##' independence model is used. ##' @param param An optional character vector or list of character vectors ##' indicating which parameters the user would test for DIF following a ##' rejection of the omnibus null hypothesis tested using ##' (`more`)`AFIs`. Note that `param` does not guarantee certain ##' parameters *are* constrained in `con`; that is for the user to ##' specify when fitting the model. If users have any "anchor items" that they ##' would never intend to free across groups (or levels of a covariate), these ##' should be excluded from `param`; exceptions to a type of parameter can ##' be specified in `freeParam`. When `modelType = "mgcfa"`, ##' `param` indicates which parameters of interest are constrained across ##' groups in `con` and are unconstrained in `uncon`. Parameter names ##' must match those returned by `names(coef(con))`, but omitting any ##' group-specific suffixes (e.g., `"f1~1"` rather than `"f1~1.g2"`) ##' or user-specified labels (that is, the parameter names must follow the rules ##' of lavaan's [lavaan::model.syntax()]). Alternatively (or ##' additionally), to test all constraints of a certain type (or multiple types) ##' of parameter in `con`, `param` may take any combination of the ##' following values: `"loadings"`, `"intercepts"`, ##' `"thresholds"`, `"residuals"`, `"residual.covariances"`, ##' `"means"`, `"lv.variances"`, and/or `"lv.covariances"`. When ##' `modelType = "mimic"`, `param` must be a vector of individual ##' parameters or a list of character strings to be passed one-at-a-time to ##' `lavaan::lavTestScore(object = con, add = param[i])`, ##' indicating which (sets of) regression paths fixed to zero in `con` that ##' the user would consider freeing (i.e., exclude anchor items). If ##' `modelType = "mimic"` and `param` is a list of character strings, ##' the multivariate test statistic will be saved for each list element instead ##' of 1-*df* modification indices for each individual parameter, and ##' `names(param)` will name the rows of the `MI.obs` slot (see ##' [permuteMeasEq-class]). Set `param = NULL` (default) to avoid ##' collecting modification indices for any follow-up tests. ##' @param freeParam An optional character vector, silently ignored when ##' `modelType = "mimic"`. If `param` includes a type of parameter ##' (e.g., `"loadings"`), `freeParam` indicates exceptions (i.e., ##' anchor items) that the user would *not* intend to free across groups ##' and should therefore be ignored when calculating *p* values adjusted ##' for the number of follow-up tests. Parameter types that are already ##' unconstrained across groups in the fitted `con` model (i.e., a ##' *partial* invariance model) will automatically be ignored, so they do ##' not need to be specified in `freeParam`. Parameter names must match ##' those returned by `names(coef(con))`, but omitting any group-specific ##' suffixes (e.g., `"f1~1"` rather than `"f1~1.g2"`) or ##' user-specified labels (that is, the parameter names must follow the rules of ##' lavaan [lavaan::model.syntax()]). ##' @param covariates An optional character vector, only applicable when ##' `modelType = "mimic"`. The observed data are partitioned into columns ##' indicated by `covariates`, and the rows are permuted simultaneously for ##' the entire set before being merged with the remaining data. Thus, the ##' covariance structure is preserved among the covariates, which is necessary ##' when (e.g.) multiple dummy codes are used to represent a discrete covariate ##' or when covariates interact. If `covariates = NULL` when ##' `modelType = "mimic"`, the value of `covariates` is inferred by ##' searching `param` for predictors (i.e., variables appearing after the ##' "`~`" operator). ##' @param AFIs A character vector indicating which alternative fit indices (or ##' chi-squared itself) are to be used to test the multiparameter omnibus null ##' hypothesis that the constraints specified in `con` hold in the ##' population. Any fit measures returned by [lavaan::fitMeasures()] ##' may be specified (including constants like `"df"`, which would be ##' nonsensical). If both `AFIs` and `moreAFIs` are `NULL`, only ##' `"chisq"` will be returned. ##' @param moreAFIs Optional. A character vector indicating which (if any) ##' alternative fit indices returned by [semTools::moreFitIndices()] ##' are to be used to test the multiparameter omnibus null hypothesis that the ##' constraints specified in `con` hold in the population. ##' @param maxSparse Only applicable when `modelType = "mgcfa"` and at ##' least one indicator is `ordered`. An integer indicating the maximum ##' number of consecutive times that randomly permuted group assignment can ##' yield a sample in which at least one category (of an `ordered` ##' indicator) is unobserved in at least one group, such that the same set of ##' parameters cannot be estimated in each group. If such a sample occurs, group ##' assignment is randomly permuted again, repeatedly until a sample is obtained ##' with all categories observed in all groups. If `maxSparse` is exceeded, ##' `NA` will be returned for that iteration of the permutation ##' distribution. ##' @param maxNonconv An integer indicating the maximum number of consecutive ##' times that a random permutation can yield a sample for which the model does ##' not converge on a solution. If such a sample occurs, permutation is ##' attempted repeatedly until a sample is obtained for which the model does ##' converge. If `maxNonconv` is exceeded, `NA` will be returned for ##' that iteration of the permutation distribution, and a warning will be ##' printed when using `show` or `summary`. ##' @param showProgress Logical. Indicating whether to display a progress bar ##' while permuting. Silently set to `FALSE` when using parallel options. ##' @param warn Sets the handling of warning messages when fitting model(s) to ##' permuted data sets. See [base::options()]. ##' @param datafun An optional function that can be applied to the data ##' (extracted from `con`) after each permutation, but before fitting the ##' model(s) to each permutation. The `datafun` function must have an ##' argument named `data` that accepts a `data.frame`, and it must ##' return a `data.frame` containing the same column names. The column ##' order may differ, the values of those columns may differ (so be careful!), ##' and any additional columns will be ignored when fitting the model, but an ##' error will result if any column names required by the model syntax do not ##' appear in the transformed data set. Although available for any ##' `modelType`, `datafun` may be useful when using the MIMIC method ##' to test for nonuniform DIF (metric/weak invariance) by using product ##' indicators for a latent factor representing the interaction between a factor ##' and one of the `covariates`, in which case the product indicators would ##' need to be recalculated after each permutation of the `covariates`. To ##' access other R objects used within `permuteMeasEq`, the arguments to ##' `datafun` may also contain any subset of the following: `"con"`, ##' `"uncon"`, `"null"`, `"param"`, `"freeParam"`, ##' `"covariates"`, `"AFIs"`, `"moreAFIs"`, `"maxSparse"`, ##' `"maxNonconv"`, and/or `"iseed"`. The values for those arguments ##' will be the same as the values supplied to `permuteMeasEq`. ##' @param extra An optional function that can be applied to any (or all) of the ##' fitted lavaan objects (`con`, `uncon`, and/or `null`). This ##' function will also be applied after fitting the model(s) to each permuted ##' data set. To access the R objects used within `permuteMeasEq`, the ##' arguments to `extra` must be any subset of the following: `"con"`, ##' `"uncon"`, `"null"`, `"param"`, `"freeParam"`, ##' `"covariates"`, `"AFIs"`, `"moreAFIs"`, `"maxSparse"`, ##' `"maxNonconv"`, and/or `"iseed"`. The values for those arguments ##' will be the same as the values supplied to `permuteMeasEq`. The ##' `extra` function must return a named `numeric` vector or a named ##' `list` of scalars (i.e., a `list` of `numeric` vectors of ##' `length == 1`). Any unnamed elements (e.g., `""` or `NULL`) ##' of the returned object will result in an error. ##' @param parallelType The type of parallel operation to be used (if any). The ##' default is `"none"`. Forking is not possible on Windows, so if ##' `"multicore"` is requested on a Windows machine, the request will be ##' changed to `"snow"` with a message. ##' @param ncpus Integer: number of processes to be used in parallel operation. ##' If `NULL` (the default) and `parallelType %in% ##' c("multicore","snow")`, the default is one less than the maximum number of ##' processors detected by [parallel::detectCores()]. This default is ##' also silently set if the user specifies more than the number of processors ##' detected. ##' @param cl An optional \pkg{parallel} or \pkg{snow} cluster for use when ##' `parallelType = "snow"`. If `NULL`, a `"PSOCK"` cluster on ##' the local machine is created for the duration of the `permuteMeasEq` ##' call. If a valid [parallel::makeCluster()] object is supplied, ##' `parallelType` is silently set to `"snow"`, and `ncpus` is ##' silently set to `length(cl)`. ##' @param iseed Integer: Only used to set the states of the RNG when using ##' parallel options, in which case [base::RNGkind()] is set to ##' `"L'Ecuyer-CMRG"` with a message. See ##' [parallel::clusterSetRNGStream()] and Section 6 of ##' `vignette("parallel", "parallel")` for more details. If user supplies ##' an invalid value, `iseed` is silently set to the default (12345). To ##' set the state of the RNG when not using parallel options, call ##' [base::set.seed()] before calling `permuteMeasEq`. ##' ##' @return The [permuteMeasEq-class] object representing the results of ##' testing measurement equivalence (the multiparameter omnibus test) and DIF ##' (modification indices), as well as diagnostics and any `extra` output. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [stats::TukeyHSD()], [lavaan::lavTestScore()], ##' [semTools::measurementInvariance()], ##' [semTools::measurementInvarianceCat()] ##' ##' @references ##' ##' **Papers about permutation tests of measurement equivalence:** ##' ##' Jorgensen, T. D., Kite, B. A., Chen, P.-Y., & Short, S. D. (2018). ##' Permutation randomization methods for testing measurement equivalence and ##' detecting differential item functioning in multiple-group confirmatory ##' factor analysis. *Psychological Methods, 23*(4), 708--728. ##' \doi{10.1037/met0000152} ##' ##' Kite, B. A., Jorgensen, T. D., & Chen, P.-Y. (2018). Random permutation ##' testing applied to measurement invariance testing with ordered-categorical ##' indicators. *Structural Equation Modeling 25*(4), 573--587. ##' \doi{10.1080/10705511.2017.1421467} ##' ##' Jorgensen, T. D. (2017). Applying permutation tests and multivariate ##' modification indices to configurally invariant models that need ##' respecification. *Frontiers in Psychology, 8*(1455). ##' \doi{10.3389/fpsyg.2017.01455} ##' ##' **Additional reading:** ##' ##' Chen, F. F. (2007). Sensitivity of goodness of fit indexes to ##' lack of measurement invariance. *Structural Equation Modeling, 14*(3), ##' 464--504. \doi{10.1080/10705510701301834} ##' ##' Cheung, G. W., & Rensvold, R. B. (2002). Evaluating goodness-of-fit indexes ##' for testing measurement invariance. *Structural Equation Modeling, ##' 9*(2), 233--255. \doi{10.1207/S15328007SEM0902_5} ##' ##' Meade, A. W., Johnson, E. C., & Braddy, P. W. (2008). Power and sensitivity ##' of alternative fit indices in tests of measurement invariance. *Journal ##' of Applied Psychology, 93*(3), 568--592. \doi{10.1037/0021-9010.93.3.568} ##' ##' Widamin, K. F., & Thompson, J. S. (2003). On specifying the null model for ##' incremental fit indices in structural equation modeling. *Psychological ##' Methods, 8*(1), 16--37. \doi{10.1037/1082-989X.8.1.16} ##' ##' @examples ##' ##' \donttest{ ##' ##' ######################## ##' ## Multiple-Group CFA ## ##' ######################## ##' ##' ## create 3-group data in lavaan example(cfa) data ##' HS <- lavaan::HolzingerSwineford1939 ##' HS$ageGroup <- ifelse(HS$ageyr < 13, "preteen", ##' ifelse(HS$ageyr > 13, "teen", "thirteen")) ##' ##' ## specify and fit an appropriate null model for incremental fit indices ##' mod.null <- c(paste0("x", 1:9, " ~ c(T", 1:9, ", T", 1:9, ", T", 1:9, ")*1"), ##' paste0("x", 1:9, " ~~ c(L", 1:9, ", L", 1:9, ", L", 1:9, ")*x", 1:9)) ##' fit.null <- cfa(mod.null, data = HS, group = "ageGroup") ##' ##' ## fit target model with varying levels of measurement equivalence ##' mod.config <- ' ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' ' ##' fit.config <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup") ##' fit.metric <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup", ##' group.equal = "loadings") ##' fit.scalar <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup", ##' group.equal = c("loadings","intercepts")) ##' ##' ##' ####################### Permutation Method ##' ##' ## fit indices of interest for multiparameter omnibus test ##' myAFIs <- c("chisq","cfi","rmsea","mfi","aic") ##' moreAFIs <- c("gammaHat","adjGammaHat") ##' ##' ## Use only 20 permutations for a demo. In practice, ##' ## use > 1000 to reduce sampling variability of estimated p values ##' ##' ## test configural invariance ##' set.seed(12345) ##' out.config <- permuteMeasEq(nPermute = 20, con = fit.config) ##' out.config ##' ##' ## test metric equivalence ##' set.seed(12345) # same permutations ##' out.metric <- permuteMeasEq(nPermute = 20, uncon = fit.config, con = fit.metric, ##' param = "loadings", AFIs = myAFIs, ##' moreAFIs = moreAFIs, null = fit.null) ##' summary(out.metric, nd = 4) ##' ##' ## test scalar equivalence ##' set.seed(12345) # same permutations ##' out.scalar <- permuteMeasEq(nPermute = 20, uncon = fit.metric, con = fit.scalar, ##' param = "intercepts", AFIs = myAFIs, ##' moreAFIs = moreAFIs, null = fit.null) ##' summary(out.scalar) ##' ##' ## Not much to see without significant DIF. ##' ## Try using an absurdly high alpha level for illustration. ##' outsum <- summary(out.scalar, alpha = .50) ##' ##' ## notice that the returned object is the table of DIF tests ##' outsum ##' ##' ## visualize permutation distribution ##' hist(out.config, AFI = "chisq") ##' hist(out.metric, AFI = "chisq", nd = 2, alpha = .01, ##' legendArgs = list(x = "topright")) ##' hist(out.scalar, AFI = "cfi", printLegend = FALSE) ##' ##' ##' ####################### Extra Output ##' ##' ## function to calculate expected change of Group-2 and -3 latent means if ##' ## each intercept constraint were released ##' extra <- function(con) { ##' output <- list() ##' output["x1.vis2"] <- lavTestScore(con, release = 19:20, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[70] ##' output["x1.vis3"] <- lavTestScore(con, release = 19:20, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[106] ##' output["x2.vis2"] <- lavTestScore(con, release = 21:22, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[70] ##' output["x2.vis3"] <- lavTestScore(con, release = 21:22, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[106] ##' output["x3.vis2"] <- lavTestScore(con, release = 23:24, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[70] ##' output["x3.vis3"] <- lavTestScore(con, release = 23:24, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[106] ##' output["x4.txt2"] <- lavTestScore(con, release = 25:26, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[71] ##' output["x4.txt3"] <- lavTestScore(con, release = 25:26, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[107] ##' output["x5.txt2"] <- lavTestScore(con, release = 27:28, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[71] ##' output["x5.txt3"] <- lavTestScore(con, release = 27:28, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[107] ##' output["x6.txt2"] <- lavTestScore(con, release = 29:30, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[71] ##' output["x6.txt3"] <- lavTestScore(con, release = 29:30, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[107] ##' output["x7.spd2"] <- lavTestScore(con, release = 31:32, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[72] ##' output["x7.spd3"] <- lavTestScore(con, release = 31:32, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[108] ##' output["x8.spd2"] <- lavTestScore(con, release = 33:34, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[72] ##' output["x8.spd3"] <- lavTestScore(con, release = 33:34, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[108] ##' output["x9.spd2"] <- lavTestScore(con, release = 35:36, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[72] ##' output["x9.spd3"] <- lavTestScore(con, release = 35:36, univariate = FALSE, ##' epc = TRUE, warn = FALSE)$epc$epc[108] ##' output ##' } ##' ##' ## observed EPC ##' extra(fit.scalar) ##' ##' ## permutation results, including extra output ##' set.seed(12345) # same permutations ##' out.scalar <- permuteMeasEq(nPermute = 20, uncon = fit.metric, con = fit.scalar, ##' param = "intercepts", AFIs = myAFIs, ##' moreAFIs = moreAFIs, null = fit.null, extra = extra) ##' ## summarize extra output ##' summary(out.scalar, extra = TRUE) ##' ##' ##' ########### ##' ## MIMIC ## ##' ########### ##' ##' ## Specify Restricted Factor Analysis (RFA) model, equivalent to MIMIC, but ##' ## the factor covaries with the covariate instead of being regressed on it. ##' ## The covariate defines a single-indicator construct, and the ##' ## double-mean-centered products of the indicators define a latent ##' ## interaction between the factor and the covariate. ##' mod.mimic <- ' ##' visual =~ x1 + x2 + x3 ##' age =~ ageyr ##' age.by.vis =~ x1.ageyr + x2.ageyr + x3.ageyr ##' ##' x1 ~~ x1.ageyr ##' x2 ~~ x2.ageyr ##' x3 ~~ x3.ageyr ##' ' ##' ##' HS.orth <- indProd(var1 = paste0("x", 1:3), var2 = "ageyr", match = FALSE, ##' data = HS[ , c("ageyr", paste0("x", 1:3))] ) ##' fit.mimic <- cfa(mod.mimic, data = HS.orth, meanstructure = TRUE) ##' summary(fit.mimic, stand = TRUE) ##' ##' ## Whereas MIMIC models specify direct effects of the covariate on an indicator, ##' ## DIF can be tested in RFA models by specifying free loadings of an indicator ##' ## on the covariate's construct (uniform DIF, scalar invariance) and the ##' ## interaction construct (nonuniform DIF, metric invariance). ##' param <- as.list(paste0("age + age.by.vis =~ x", 1:3)) ##' names(param) <- paste0("x", 1:3) ##' # param <- as.list(paste0("x", 1:3, " ~ age + age.by.vis")) # equivalent ##' ##' ## test both parameters simultaneously for each indicator ##' do.call(rbind, lapply(param, function(x) lavTestScore(fit.mimic, add = x)$test)) ##' ## or test each parameter individually ##' lavTestScore(fit.mimic, add = as.character(param)) ##' ##' ##' ####################### Permutation Method ##' ##' ## function to recalculate interaction terms after permuting the covariate ##' datafun <- function(data) { ##' d <- data[, c(paste0("x", 1:3), "ageyr")] ##' indProd(var1 = paste0("x", 1:3), var2 = "ageyr", match = FALSE, data = d) ##' } ##' ##' set.seed(12345) ##' perm.mimic <- permuteMeasEq(nPermute = 20, modelType = "mimic", ##' con = fit.mimic, param = param, ##' covariates = "ageyr", datafun = datafun) ##' summary(perm.mimic) ##' ##' } ##' ##' @export permuteMeasEq <- function(nPermute, modelType = c("mgcfa","mimic"), con, uncon = NULL, null = NULL, param = NULL, freeParam = NULL, covariates = NULL, AFIs = NULL, moreAFIs = NULL, maxSparse = 10, maxNonconv = 10, showProgress = TRUE, warn = -1, datafun, extra, parallelType = c("none","multicore","snow"), ncpus = NULL, cl = NULL, iseed = 12345) { ## save arguments from call availableArgs <- as.list(formals(permuteMeasEq)) argNames <- names(availableArgs) if (missing(datafun)) argNames <- setdiff(argNames, "datafun") if (missing(extra)) argNames <- setdiff(argNames, "extra") for (aa in argNames) { if (!is.null(eval(as.name(aa)))) suppressWarnings(availableArgs[[aa]] <- eval(as.name(aa))) } ## check and return them fullCall <- do.call(checkPermArgs, availableArgs) ## assign them to workspace (also adds old_RNG & oldSeed to workspace) for (aa in names(fullCall)) assign(aa, fullCall[[aa]]) ###################### SAVE OBSERVED RESULTS ########################## AFI.obs <- do.call(getAFIs, fullCall) ## save modification indices if !is.null(param) if (is.null(param)) { MI.obs <- data.frame(NULL) } else MI.obs <- do.call(getMIs, fullCall) ## anything extra? if (!missing(extra)) { extraArgs <- formals(extra) neededArgs <- intersect(names(extraArgs), names(fullCall)) extraArgs <- do.call(c, lapply(neededArgs, function(nn) fullCall[nn])) extraOut <- do.call(extra, extraArgs) ## check that extra() returns a named list of scalars if (!is.list(extraOut)) extraOut <- as.list(extraOut) wrongFormat <- paste('Function "extra" must return a numeric vector or a', 'list of scalars, with each element named.') if (!all(sapply(extraOut, is.numeric))) stop(wrongFormat) if (!all(sapply(extraOut, length) == 1L)) stop(wrongFormat) if (is.null(names(extraOut)) | any(names(extraOut) == "")) stop(wrongFormat) extra.obs <- do.call(c, extraOut) } else extra.obs <- numeric(length = 0L) ######################### PREP DATA ############################## argList <- fullCall[c("con","uncon","null","param","freeParam","covariates", "AFIs","moreAFIs","maxSparse","maxNonconv","warn","iseed")] argList$G <- lavInspect(con, "group") ## check for categorical variables # catVars <- lavaan::lavNames(con, type = "ov.ord") # numVars <- lavaan::lavNames(con, type = "ov.num") # latentVars <- lavaan::lavNames(con, type = "lv.regular") ## assemble data to which the models were fit if (length(argList$G)) { dataList <- mapply(FUN = function(x, g, n) { y <- data.frame(as.data.frame(x), g, stringsAsFactors = FALSE) names(y) <- c(n, argList$G) y }, SIMPLIFY = FALSE, x = lavInspect(con, "data"), g = lavInspect(con, "group.label"), n = lavaan::lavNames(con, type = "ov", group = seq_along(lavInspect(con, "group.label")))) argList$d <- do.call(rbind, dataList) } else { argList$d <- as.data.frame(lavInspect(con, "data")) names(argList$d) <- lavaan::lavNames(con, type = "ov") } ## check that covariates are actual variables if (modelType == "mimic") { if (length(covariates) && !all(covariates %in% names(argList$d))) stop('These specified covariates are not columns in the data.frame:\n', paste(setdiff(covariates, names(argList$d)), collapse = ", ")) } ## anything extra? if (!missing(extra)) argList$extra <- extra if (!missing(datafun)) argList$datafun <- datafun ###################### PERMUTED RESULTS ########################### ## permute and return distributions of (delta)AFIs, largest MI, and extras if (showProgress) { mypb <- utils::txtProgressBar(min = 1, max = nPermute, initial = 1, char = "=", width = 50, style = 3, file = "") permuDist <- list() for (j in 1:nPermute) { permuDist[[j]] <- do.call(paste("permuteOnce", modelType, sep = "."), args = c(argList, i = j)) utils::setTxtProgressBar(mypb, j) } close(mypb) } else if (parallelType == "multicore") { if (length(iseed)) set.seed(iseed) argList$FUN <- as.name(paste("permuteOnce", modelType, sep = ".")) argList$X <- 1:nPermute argList$mc.cores <- ncpus argList$mc.set.seed <- TRUE pmcl <- function(...) { parallel::mclapply(...) } permuDist <- do.call(pmcl, args = argList) ## restore old RNG type if (fullCall$old_RNG[1] != "L'Ecuyer-CMRG") RNGkind(fullCall$old_RNG[1]) } else if (parallelType == "snow") { stopTheCluster <- FALSE if (is.null(cl)) { stopTheCluster <- TRUE cl <- parallel::makePSOCKcluster(rep("localhost", ncpus)) } parallel::clusterSetRNGStream(cl, iseed = iseed) argList$cl <- cl argList$X <- 1:nPermute argList$fun <- paste("permuteOnce", modelType, sep = ".") parallel::clusterExport(cl, varlist = c(argList$fun, "getAFIs","getMIs")) #FIXME: need update? tempppl <- function(...) { parallel::parLapply(...) } permuDist <- do.call(tempppl, args = argList) if (stopTheCluster) parallel::stopCluster(cl) ## restore old RNG type if (fullCall$old_RNG[1] != "L'Ecuyer-CMRG") RNGkind(fullCall$old_RNG[1]) } else { argList$X <- 1:nPermute argList$FUN <- paste("permuteOnce", modelType, sep = ".") permuDist <- do.call(lapply, args = argList) } ## extract AFI distribution if (length(AFI.obs) > 1) { AFI.dist <- as.data.frame(t(sapply(permuDist, function(x) x$AFI))) } if (length(AFI.obs) == 1L) { AFI.dist <- data.frame(sapply(permuDist, function(x) x$AFI)) colnames(AFI.dist) <- names(AFI.obs) } ## identify badness-of-fit measures badness <- grepl(pattern = "fmin|chi|aic|bic|rmr|rmsea|cn|sic|hqc", x = names(AFI.obs), ignore.case = TRUE) ## calculate all one-directional p-values AFI.pval <- mapply(FUN = function(x, y, b) { if (b) return(mean(x >= y, na.rm = TRUE)) mean(x <= y, na.rm = TRUE) }, x = unclass(AFI.dist), y = AFI.obs, b = badness) ## extract distribution of maximum modification indices MI.dist <- as.numeric(unlist(lapply(permuDist, function(x) x$MI))) ## calculate Tukey-adjusted p values for modification indices if (!is.null(param)) { MI.obs$tukey.p.value <- sapply(MI.obs$X2, function(i) mean(i <= MI.dist, na.rm = TRUE)) MI.obs <- as.data.frame(unclass(MI.obs)) rownames(MI.obs) <- names(param) } ## anything extra? if (!missing(extra)) { extra.dist <- do.call(rbind, lapply(permuDist, function(x) x$extra)) } else extra.dist <- data.frame(NULL) ## save parameter table for show/summary methods PT <- as.data.frame(parTable(con)) PT$par <- paste0(PT$lhs, PT$op, PT$rhs) if (length(lavInspect(con, "group"))) PT$group.label[PT$group > 0] <- lavInspect(con, "group.label")[PT$group[PT$group > 0] ] ## return observed results, permutation p values, and ANOVA results if (is.null(uncon)) { delta <- lavaan::anova(con) } else { delta <- lavaan::anova(uncon, con) } ANOVA <- sapply(delta[,c("Chisq diff","Df diff","Pr(>Chisq)")], function(x) x[2]) out <- new("permuteMeasEq", PT = PT, modelType = modelType, ANOVA = ANOVA, AFI.obs = AFI.obs, AFI.dist = AFI.dist, AFI.pval = AFI.pval, MI.obs = MI.obs, MI.dist = MI.dist, extra.obs = extra.obs, extra.dist = extra.dist, n.Permutations = nPermute, n.Converged = sum(!is.na(AFI.dist[,1])), n.nonConverged = sapply(permuDist, function(x) x$n.nonConverged), n.Sparse = sapply(permuDist, function(x) x$n.Sparse), oldSeed = fullCall$oldSeed) out } ## ---------------- ## Hidden Functions ## ---------------- ## function to check validity of arguments to permuteMeasEq() #' @importFrom lavaan lavInspect parTable checkPermArgs <- function(nPermute, modelType, con, uncon, null, param, freeParam, covariates, AFIs, moreAFIs, maxSparse, maxNonconv, showProgress, warn, datafun, extra, parallelType, ncpus, cl, iseed) { fixedCall <- as.list(match.call())[-1] fixedCall$nPermute <- as.integer(nPermute[1]) fixedCall$modelType <- modelType[1] if (!fixedCall$modelType %in% c("mgcfa","mimic","long")) stop('modelType must be one of c("mgcfa","mimic","long")') if (fixedCall$modelType == "long") stop('modelType "long" is not yet available.') if (fixedCall$modelType == "mgcfa" && lavInspect(con, "ngroups") == 1L) stop('modelType = "mgcfa" applies only to multigroup models.') if (fixedCall$modelType == "mimic") { uncon <- NULL fixedCall$uncon <- NULL fixedCall <- c(fixedCall, list(uncon = NULL)) } ## strip white space if (is.list(param)) { fixedCall$param <- lapply(param, function(cc) gsub("[[:space:]]+", "", cc)) } else if (!is.null(param)) fixedCall$param <- gsub("[[:space:]]+", "", param) if (!is.null(freeParam)) fixedCall$freeParam <- gsub("[[:space:]]+", "", freeParam) if (fixedCall$modelType == "mimic") { # PT <- lavaan::lavaanify(fixedCall$param) # checkCovs <- unique(PT$rhs[PT$op == "~"]) # if (is.null(covariates)) covariates <- checkCovs # if (length(setdiff(covariates, checkCovs))) # warning('Argument "covariates" includes predictors not in argument "param"') ##### ordVars <- lavaan::lavNames(con, type = "ov.ord") fixedCall$covariates <- as.character(covariates) } fixedCall$maxSparse <- as.integer(maxSparse[1]) fixedCall$maxNonconv <- as.integer(maxNonconv[1]) fixedCall$showProgress <- as.logical(showProgress[1]) fixedCall$warn <- as.integer(warn[1]) fixedCall$oldSeed <- as.integer(NULL) parallelType <- as.character(parallelType[1]) if (!parallelType %in% c("none","multicore","snow")) parallelType <- "none" if (!is.null(cl)) { if (!is(cl, "cluster")) stop("Invalid cluster object. Check class(cl)") parallelType <- "snow" ncpus <- length(cl) } if (parallelType == "multicore" && .Platform$OS.type == "windows") { parallelType <- "snow" message("'multicore' option unavailable on Windows. Using 'snow' instead.") } ## parallel settings, adapted from boot::boot() if (parallelType != "none") { if (is.null(ncpus) || ncpus > parallel::detectCores()) { ncpus <- parallel::detectCores() - 1 } if (ncpus <= 1L) { parallelType <- "none" } else { fixedCall$showProgress <- FALSE fixedCall$old_RNG <- RNGkind() fixedCall$oldSeed <- .Random.seed if (fixedCall$old_RNG[1] != "L'Ecuyer-CMRG") { RNGkind("L'Ecuyer-CMRG") message("Your RNGkind() was changed from ", fixedCall$old_RNG[1], " to L'Ecuyer-CMRG, which is required for reproducibility ", " in parallel jobs. Your RNGkind() has been returned to ", fixedCall$old_RNG[1], " but the seed has not been set. ", " The state of your previous RNG is saved in the slot ", " named 'oldSeed', if you want to restore it using ", " the syntax:\n", ".Random.seed[-1] <- permuteMeasEqObject@oldSeed[-1]") } fixedCall$iseed <- as.integer(iseed[1]) if (is.na(fixedCall$iseed)) fixedCall$iseed <- 12345 } } fixedCall$parallelType <- parallelType if (is.null(ncpus)) { fixedCall$ncpus <- NULL fixedCall <- c(fixedCall, list(ncpus = NULL)) } else fixedCall$ncpus <- ncpus ## Check that "param" is NULL if uncon is NULL, and check for lavaan class. ## Also check that models are fitted to raw data, not summary stats. notLavaan <- "Non-NULL 'con', 'uncon', or 'null' must be fitted lavaan object." notRawData <- "lavaan models ('con', 'uncon', or 'null') must be fitted to raw data=, not summary statistics (e.g., sample.cov=)" if (is.null(uncon)) { if (!is.null(fixedCall$param) && fixedCall$modelType == "mgcfa") { message(c(" When 'uncon = NULL', only configural invariance is tested.", "\n So the 'param' argument was changed to NULL.")) fixedCall$param <- NULL fixedCall <- c(fixedCall, list(param = NULL)) } if (!inherits(con, "lavaan")) stop(notLavaan) stopifnot(con@Data@data.type == "full") } else { if (!inherits(con, "lavaan")) stop(notLavaan) if (!inherits(uncon, "lavaan")) stop(notLavaan) stopifnot( con@Data@data.type == "full") stopifnot(uncon@Data@data.type == "full") } if (!is.null(null)) { if (!inherits(null, "lavaan")) stop(notLavaan) stopifnot(null@Data@data.type == "full") } ############ FIXME: check that lavInspect(con, "options")$conditional.x = FALSE (find defaults for continuous/ordered indicators) if (!is.null(fixedCall$param)) { ## Temporarily warn about testing thresholds without necessary constraints. FIXME: check for binary indicators if ("thresholds" %in% fixedCall$param | any(grepl("\\|", fixedCall$param))) { warning(c("This function is not yet optimized for testing thresholds.\n", "Necessary identification contraints might not be specified.")) } ## collect parameter types for "mgcfa" if (fixedCall$modelType != "mimic") { ## save all estimates from constrained model PT <- parTable(con)[ , c("lhs","op","rhs","group","plabel")] ## extract parameters of interest paramTypes <- c("loadings","intercepts","thresholds","residuals","means", "residual.covariances","lv.variances","lv.covariances") params <- PT[paste0(PT$lhs, PT$op, PT$rhs) %in% setdiff(fixedCall$param, paramTypes), ] ## add parameters by type, if any are specified types <- intersect(fixedCall$param, paramTypes) ov.names <- lavaan::lavNames(con, "ov") isOV <- PT$lhs %in% ov.names lv.names <- con@pta$vnames$lv[[1]] isLV <- PT$lhs %in% lv.names & PT$rhs %in% lv.names if ("loadings" %in% types) params <- rbind(params, PT[PT$op == "=~", ]) if ("intercepts" %in% types) { params <- rbind(params, PT[isOV & PT$op == "~1", ]) } if ("thresholds" %in% types) params <- rbind(params, PT[PT$op == "|", ]) if ("residuals" %in% types) { params <- rbind(params, PT[isOV & PT$lhs == PT$rhs & PT$op == "~~", ]) } if ("residual.covariances" %in% types) { params <- rbind(params, PT[isOV & PT$lhs != PT$rhs & PT$op == "~~", ]) } if ("means" %in% types) { params <- rbind(params, PT[PT$lhs %in% lv.names & PT$op == "~1", ]) } if ("lv.variances" %in% types) { params <- rbind(params, PT[isLV & PT$lhs == PT$rhs & PT$op == "~~", ]) } if ("lv.covariances" %in% types) { params <- rbind(params, PT[isLV & PT$lhs != PT$rhs & PT$op == "~~", ]) } ## remove parameters specified by "freeParam" argument params <- params[!paste0(params$lhs, params$op, params$rhs) %in% fixedCall$freeParam, ] fixedCall$param <- paste0(params$lhs, params$op, params$rhs) } } if (is.null(AFIs) & is.null(moreAFIs)) { message("No AFIs were selected, so only chi-squared will be permuted.\n") fixedCall$AFIs <- "chisq" AFIs <- "chisq" } if ("ecvi" %in% AFIs & lavInspect(con, "ngroups") > 1L) stop("ECVI is not available for multigroup models.") ## check estimators leastSq <- grepl("LS", lavInspect(con, "options")$estimator) if (!is.null(uncon)) { if (uncon@Options$estimator != lavInspect(con, "options")$estimator) stop("Models must be fit using same estimator.") } if (!is.null(null)) { if (lavInspect(null, "options")$estimator != lavInspect(con, "options")$estimator) stop("Models must be fit using same estimator.") } ## check extra functions, if any restrictedArgs <- c("con","uncon","null","param","freeParam","covariates", "AFIs","moreAFIs","maxSparse","maxNonconv","iseed") if (!missing(datafun)) { if (!is.function(datafun)) stop('Argument "datafun" must be a function.') extraArgs <- formals(datafun) if (!all(names(extraArgs) %in% c(restrictedArgs, "data"))) stop('The user-supplied function "datafun" can only have any among the ', 'following arguments:\n', paste(restrictedArgs, collapse = ", ")) } if (!missing(extra)) { if (!is.function(extra)) stop('Argument "extra" must be a function.') extraArgs <- formals(extra) if (!all(names(extraArgs) %in% restrictedArgs)) stop('The user-supplied function "extra" can only have any among the ', 'following arguments:\n', paste(restrictedArgs, collapse = ", ")) } ## return evaluated list of other arguments lapply(fixedCall, eval) } ## function to extract fit measures #' @importFrom lavaan lavInspect getAFIs <- function(...) { dots <- list(...) AFI1 <- list() AFI0 <- list() leastSq <- grepl("LS", lavInspect(dots$con, "options")$estimator) ## check validity of user-specified AFIs, save output if (!is.null(dots$AFIs)) { IC <- grep("ic|logl", dots$AFIs, value = TRUE) if (leastSq & length(IC)) { stop(paste("Argument 'AFIs' includes invalid options:", paste(IC, collapse = ", "), "Information criteria unavailable for least-squares estimators.", sep = "\n")) } if (!is.null(dots$uncon)) AFI1[[1]] <- lavaan::fitMeasures(dots$uncon, fit.measures = dots$AFIs, baseline.model = dots$null) AFI0[[1]] <- lavaan::fitMeasures(dots$con, fit.measures = dots$AFIs, baseline.model = dots$null) } ## check validity of user-specified moreAFIs if (!is.null(dots$moreAFIs)) { IC <- grep("ic|hqc", dots$moreAFIs, value = TRUE) if (leastSq & length(IC)) { stop(paste("Argument 'moreAFIs' includes invalid options:", paste(IC, collapse = ", "), "Information criteria unavailable for least-squares estimators.", sep = "\n")) } if (!is.null(dots$uncon)) AFI1[[2]] <- moreFitIndices(dots$uncon, fit.measures = dots$moreAFIs) AFI0[[2]] <- moreFitIndices(dots$con, fit.measures = dots$moreAFIs) } ## save observed AFIs or delta-AFIs if (is.null(dots$uncon)) { AFI.obs <- unlist(AFI0) } else { AFI.obs <- unlist(AFI0) - unlist(AFI1) } AFI.obs } ## Function to extract modification indices for equality constraints #' @importFrom lavaan parTable getMIs <- function(...) { dots <- list(...) if (dots$modelType == "mgcfa") { ## save all estimates from constrained model PT <- parTable(dots$con)[ , c("lhs","op","rhs","group","plabel")] ## extract parameters of interest params <- PT[paste0(PT$lhs, PT$op, PT$rhs) %in% dots$param, ] ## return modification indices for specified constraints (param) MIs <- lavaan::lavTestScore(dots$con)$uni MI.obs <- MIs[MIs$lhs %in% params$plabel, ] } else if (dots$modelType == "mimic") { if (is.list(dots$param)) { MI <- lapply(dots$param, function(x) lavaan::lavTestScore(dots$con, add = x)$test) MI.obs <- do.call(rbind, MI) } else MI.obs <- lavaan::lavTestScore(dots$con, add = dots$param)$uni } else if (dots$modelType == "long") { ## coming soon } MI.obs } ## Functions to find delta-AFIs & maximum modification index in one permutation permuteOnce.mgcfa <- function(i, d, G, con, uncon, null, param, freeParam, covariates, AFIs, moreAFIs, maxSparse, maxNonconv, iseed, warn, extra = NULL, datafun = NULL) { old_warn <- options()$warn options(warn = warn) ## save arguments from call argNames <- names(formals(permuteOnce.mgcfa)) availableArgs <- lapply(argNames, function(x) eval(as.name(x))) names(availableArgs) <- argNames group.label <- lavaan::lavInspect(con, "group.label") nSparse <- 0L nTries <- 1L while ( (nSparse <= maxSparse) & (nTries <= maxNonconv) ) { ## permute grouping variable d[ , G] <- sample(d[ , G]) ## transform data? if (!is.null(datafun)) { extraArgs <- formals(datafun) neededArgs <- intersect(names(extraArgs), names(availableArgs)) extraArgs <- do.call(c, lapply(neededArgs, function(nn) availableArgs[nn])) extraArgs$data <- d originalNames <- colnames(d) d <- do.call(datafun, extraArgs) ## coerce extraOut to data.frame if (!is.data.frame(d)) stop('Argument "datafun" did not return a data.frame') if (!all(originalNames %in% colnames(d))) stop('The data.frame returned by argument "datafun" did not contain ', 'column names required by the model:\n', paste(setdiff(originalNames, colnames(d)), collapse = ", ")) } ## for ordered indicators, check that groups have same observed categories ordVars <- lavaan::lavNames(con, type = "ov.ord") if (length(ordVars) > 0) { try(onewayTables <- lavaan::lavTables(d, dimension = 1L, categorical = ordVars, group = G), silent = TRUE) if (exists("onewayTables")) { if (any(onewayTables$obs.prop == 1)) { nSparse <- nSparse + 1L next } } else { ## no "onewayTables" probably indicates empty categories in 1+ groups nSparse <- nSparse + 1L next } } ## fit null model, if it exists if (!is.null(null)) { out.null <- lavaan::update(null, data = d, group.label = group.label) } ## fit constrained model, check for convergence try(out0 <- lavaan::update(con, data = d, group.label = group.label)) if (!exists("out0")) { nTries <- nTries + 1L next } if (!lavaan::lavInspect(out0, "converged")) { nTries <- nTries + 1L next } ## fit unconstrained model (unless NULL), check for convergence if (!is.null(uncon)) { try(out1 <- lavaan::update(uncon, data = d, group.label = group.label)) if (!exists("out1")) { nTries <- nTries + 1L next } if (!lavaan::lavInspect(out1, "converged")) { nTries <- nTries + 1L next } } ## If you get this far, everything converged, so break WHILE loop break } ## if WHILE loop ended before getting results, return NA if ( (nSparse == maxSparse) | (nTries == maxNonconv) ) { allAFIs <- c(AFIs, moreAFIs) AFI <- rep(NA, sum(!is.na(allAFIs))) names(AFI) <- allAFIs[!is.na(allAFIs)] MI <- if (is.null(param)) NULL else NA extra.obs <- NA nTries <- nTries + 1L } else { availableArgs$con <- out0 if (exists("out1")) availableArgs$uncon <- out1 if (exists("out.null")) availableArgs$null <- out.null AFI <- do.call(getAFIs, availableArgs) ## save max(MI) if !is.null(param) if (is.null(param)) { MI <- NULL } else { MI <- max(do.call(getMIs, c(availableArgs, modelType = "mgcfa"))$X2) } ## anything extra? if (!is.null(extra)) { extraArgs <- formals(extra) neededArgs <- intersect(names(extraArgs), names(availableArgs)) extraArgs <- do.call(c, lapply(neededArgs, function(nn) availableArgs[nn])) extraOut <- do.call(extra, extraArgs) ## coerce extraOut to data.frame if (!is.list(extraOut)) extraOut <- as.list(extraOut) extra.obs <- data.frame(extraOut) } else extra.obs <- data.frame(NULL) } options(warn = old_warn) list(AFI = AFI, MI = MI, extra = extra.obs, n.nonConverged = nTries - 1L, n.Sparse = nSparse) } permuteOnce.mimic <- function(i, d, G, con, uncon, null, param, freeParam, covariates, AFIs, moreAFIs, maxSparse, maxNonconv, iseed, warn, extra = NULL, datafun = NULL) { old_warn <- options()$warn options(warn = warn) ## save arguments from call argNames <- names(formals(permuteOnce.mimic)) availableArgs <- lapply(argNames, function(x) eval(as.name(x))) names(availableArgs) <- argNames group.label <- lavaan::lavInspect(con, "group.label") nTries <- 1L while (nTries <= maxNonconv) { ## permute covariate(s) within each group if (length(G)) { for (gg in group.label) { dG <- d[ d[[G]] == gg, ] N <- nrow(dG) newd <- dG[sample(1:N, N), covariates, drop = FALSE] for (COV in covariates) d[d[[G]] == gg, COV] <- newd[ , COV] } } else { N <- nrow(d) newd <- d[sample(1:N, N), covariates, drop = FALSE] for (COV in covariates) d[ , COV] <- newd[ , COV] } ## transform data? if (!is.null(datafun)) { extraArgs <- formals(datafun) neededArgs <- intersect(names(extraArgs), names(availableArgs)) extraArgs <- do.call(c, lapply(neededArgs, function(nn) availableArgs[nn])) extraArgs$data <- d originalNames <- colnames(d) d <- do.call(datafun, extraArgs) ## coerce extraOut to data.frame if (!is.data.frame(d)) stop('Argument "datafun" did not return a data.frame') if (!all(originalNames %in% colnames(d))) stop('The data.frame returned by argument "datafun" did not contain ', 'column names required by the model:\n', paste(setdiff(originalNames, colnames(d)), collapse = ", ")) } ## fit null model, if it exists if (!is.null(null)) { out.null <- lavaan::update(null, data = d, group.label = group.label) } ## fit constrained model try(out0 <- lavaan::update(con, data = d, group.label = group.label)) ## check for convergence if (!exists("out0")) { nTries <- nTries + 1L next } if (!lavaan::lavInspect(out0, "converged")) { nTries <- nTries + 1L next } ## If you get this far, everything converged, so break WHILE loop break } ## if WHILE loop ended before getting results, return NA if (nTries == maxNonconv) { allAFIs <- c(AFIs, moreAFIs) AFI <- rep(NA, sum(!is.na(allAFIs))) names(AFI) <- allAFIs[!is.na(allAFIs)] MI <- if (is.null(param)) NULL else NA extra.obs <- NA nTries <- nTries + 1L } else { availableArgs$con <- out0 if (exists("out.null")) availableArgs$null <- out.null AFI <- do.call(getAFIs, availableArgs) if (is.null(param)) { MI <- NULL } else { MI <- max(do.call(getMIs, c(availableArgs, modelType = "mimic"))$X2) } ## anything extra? if (!is.null(extra)) { extraArgs <- formals(extra) neededArgs <- intersect(names(extraArgs), names(availableArgs)) extraArgs <- do.call(c, lapply(neededArgs, function(nn) availableArgs[nn])) extraOut <- do.call(extra, extraArgs) ## coerce extraOut to data.frame if (!is.list(extraOut)) extraOut <- as.list(extraOut) extra.obs <- data.frame(extraOut) } else extra.obs <- data.frame(NULL) } options(warn = old_warn) list(AFI = AFI, MI = MI, extra = extra.obs, n.nonConverged = nTries - 1L, n.Sparse = integer(length = 0)) } semTools/R/residualCovariate.R0000644000176200001440000000357614632143377016076 0ustar liggesusers### Sunthud Pornprasertmanit ### Last updated: 10 January 2021 ##' Residual-center all target indicators by covariates ##' ##' This function will regress target variables on the covariate and replace the ##' target variables by the residual of the regression analysis. This procedure ##' is useful to control the covariate from the analysis model (Geldhof, ##' Pornprasertmanit, Schoemann, & Little, 2013). ##' ##' ##' @importFrom stats lm ##' ##' @param data The desired data to be transformed. ##' @param targetVar Varible names or the position of indicators that users wish ##' to be residual centered (as dependent variables) ##' @param covVar Covariate names or the position of the covariates using for ##' residual centering (as independent variables) onto target variables ##' ##' @return The data that the target variables replaced by the residuals ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' ##' @references Geldhof, G. J., Pornprasertmanit, S., Schoemann, A. M., & ##' Little, T. D. (2013). Orthogonalizing through residual centering: ##' Extended applications and caveats. *Educational and Psychological ##' Measurement, 73*(1), 27--46. \doi{10.1177/0013164412445473} ##' ##' @examples ##' ##' dat <- residualCovariate(attitude, 2:7, 1) ##' ##' @export residualCovariate <- function(data, targetVar, covVar) { x <- as.list(match.call()) cov <- eval(x$covVar) target <- eval(x$targetVar) if (all(is.numeric(cov))) cov <- colnames(data)[cov] if (all(is.numeric(target))) target <- colnames(data)[target] express <- paste("cbind(", paste(target, collapse = ", "), ") ~ ", paste(cov, collapse = " + "), sep = "") data[, target] <- lm(express, data = data)$residuals return(data) } semTools/R/powerAnalysisSS.R0000644000176200001440000002001414632143377015520 0ustar liggesusers### Alexander M. Schoemann & Terrence D. Jorgensen ### Last updated: 2 June 2022 ### Function to apply Satorra & Saris method for chi-squared power analysis ## Steps: ## 1. Specify model (use lavaan syntax based on simulateData) ## 2. get model implied covariance matrix ## 3. Fit model with parameter constrained to 0 (or take a model specification for multiparameter tests?) ## 4. Use chi square from step 3 as non-centrality parameter to get power. ## Alternatively, combine steps 1 and 2 by providing population moments directly ##' Power for model parameters ##' ##' Apply Satorra & Saris (1985) method for chi-squared power analysis. ##' ##' Specify all non-zero parameters in a population model, either by using ##' lavaan syntax (`popModel`) or by submitting a population covariance ##' matrix (`Sigma`) and optional mean vector (`mu`) implied by the ##' population model. Then specify an analysis model that places at least ##' one invalid constraint (note the number in the `nparam` argument). ##' ##' There is also a Shiny app called "power4SEM" that provides a graphical user ##' interface for this functionality (Jak et al., in press). It can be accessed ##' at . ##' ##' ##' @importFrom stats qchisq pchisq ##' ##' @param powerModel lavaan [lavaan::model.syntax()] for the model to ##' be analyzed. This syntax should constrain at least one nonzero parameter ##' to 0 (or another number). ##' @param n `integer`. Sample size used in power calculation, or a vector ##' of sample sizes if analyzing a multigroup model. If ##' `length(n) < length(Sigma)` when `Sigma` is a list, `n` will ##' be recycled. If `popModel` is used instead of `Sigma`, `n` ##' must specify a sample size for each group, because that is used to infer ##' the number of groups. ##' @param nparam `integer`. Number of invalid constraints in `powerModel`. ##' @param popModel lavaan [lavaan::model.syntax()] specifying the ##' data-generating model. This syntax should specify values for all nonzero ##' parameters in the model. If `length(n) > 1`, the same population ##' values will be used for each group, unless different population values are ##' specified per group, either in the lavaan [lavaan::model.syntax()] ##' or by utilizing a list of `Sigma` (and optionally `mu`). ##' @param mu `numeric` or `list`. For a single-group model, a vector ##' of population means. For a multigroup model, a list of vectors (one per ##' group). If `mu` and `popModel` are missing, mean structure will ##' be excluded from the analysis. ##' @param Sigma `matrix` or `list`. For a single-group model, ##' a population covariance matrix. For a multigroup model, a list of matrices ##' (one per group). If missing, `popModel` will be used to generate a ##' model-implied Sigma. ##' @param fun character. Name of `lavaan` function used to fit ##' `powerModel` (i.e., `"cfa"`, `"sem"`, `"growth"`, or ##' `"lavaan"`). ##' @param alpha Type I error rate used to set a criterion for rejecting H0. ##' @param ... additional arguments to pass to [lavaan::lavaan()]. ##' See also [lavaan::lavOptions()]. ##' ##' @author ##' Alexander M. Schoemann (East Carolina University; \email{schoemanna@@ecu.edu}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Satorra, A., & Saris, W. E. (1985). Power of the likelihood ratio ##' test in covariance structure analysis. *Psychometrika, 50*(1), 83--90. ##' \doi{10.1007/BF02294150} ##' ##' Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. ##' (2021). Analytical power calculations for structural equation modeling: ##' A tutorial and Shiny app. *Behavior Research Methods, 53*, 1385--1406. ##' \doi{10.3758/s13428-020-01479-0} ##' ##' @examples ##' ## Specify population values. Note every parameter has a fixed value. ##' modelP <- ' ##' f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 ##' f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 ##' f1 ~~ .3*f2 ##' f1 ~~ 1*f1 ##' f2 ~~ 1*f2 ##' V1 ~~ .51*V1 ##' V2 ~~ .51*V2 ##' V3 ~~ .51*V3 ##' V4 ~~ .51*V4 ##' V5 ~~ .51*V5 ##' V6 ~~ .51*V6 ##' V7 ~~ .51*V7 ##' V8 ~~ .51*V8 ##' ' ##' ## Specify analysis model. Note parameter of interest f1~~f2 is fixed to 0. ##' modelA <- ' ##' f1 =~ V1 + V2 + V3 + V4 ##' f2 =~ V5 + V6 + V7 + V8 ##' f1 ~~ 0*f2 ##' ' ##' ## Calculate power ##' SSpower(powerModel = modelA, popModel = modelP, n = 150, nparam = 1, ##' std.lv = TRUE) ##' ##' ## Get power for a range of sample sizes ##' Ns <- seq(100, 500, 40) ##' Power <- rep(NA, length(Ns)) ##' for(i in 1:length(Ns)) { ##' Power[i] <- SSpower(powerModel = modelA, popModel = modelP, ##' n = Ns[i], nparam = 1, std.lv = TRUE) ##' } ##' plot(x = Ns, y = Power, type = "l", xlab = "Sample Size") ##' ##' ##' ## Optionally specify different values for multiple populations ##' ##' modelP2 <- ' ##' f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 ##' f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 ##' f1 ~~ c(-.3, .3)*f2 # DIFFERENT ACROSS GROUPS ##' f1 ~~ 1*f1 ##' f2 ~~ 1*f2 ##' V1 ~~ .51*V1 ##' V2 ~~ .51*V2 ##' V3 ~~ .51*V3 ##' V4 ~~ .51*V4 ##' V5 ~~ .51*V5 ##' V6 ~~ .51*V6 ##' V7 ~~ .51*V7 ##' V8 ~~ .51*V8 ##' ' ##' modelA2 <- ' ##' f1 =~ V1 + V2 + V3 + V4 ##' f2 =~ V5 + V6 + V7 + V8 ##' f1 ~~ c(psi21, psi21)*f2 # EQUALITY CONSTRAINT ACROSS GROUPS ##' ' ##' ## Calculate power ##' SSpower(powerModel = modelA2, popModel = modelP2, n = c(100, 100), nparam = 1, ##' std.lv = TRUE) ##' ## Get power for a range of sample sizes ##' Ns2 <- cbind(Group1 = seq(10, 100, 10), Group2 = seq(10, 100, 10)) ##' Power2 <- apply(Ns2, MARGIN = 1, FUN = function(nn) { ##' SSpower(powerModel = modelA2, popModel = modelP2, n = nn, ##' nparam = 1, std.lv = TRUE) ##' }) ##' plot(x = rowSums(Ns2), y = Power2, type = "l", xlab = "Total Sample Size", ##' ylim = 0:1) ##' abline(h = c(.8, .9), lty = c("dotted","dashed")) ##' legend("bottomright", c("80% Power","90% Power"), lty = c("dotted","dashed")) ##' ##' @export SSpower <- function(powerModel, n, nparam, popModel, mu, Sigma, fun = "sem", alpha = .05, ...) { if (missing(Sigma)) { ## specify (vector of) sample size(s) for optional multigroup syntax to work popMoments <- lavaan::fitted(do.call(fun, list(model = popModel, sample.nobs = n), envir = getNamespace("lavaan"))) ## without data, can't apply fitted() to multigroup model syntax, so ## save the same fitted moments for each group if (length(n) > 1L) { Sigma <- lapply(popMoments, "[[", i = "cov") mu <- if (!is.null(popMoments[[1]]$mean)) { lapply(popMoments, "[[", i = "mean") } else NULL } else { ## single group Sigma <- popMoments$cov mu <- popMoments$mean } } else { ## otherwise, user-supplied moments if (is.list(Sigma)) { nG <- length(Sigma) if (length(n) < nG) n <- rep(n, length.out = nG) if (length(n) > nG) n <- n[1:nG] no.mu <- missing(mu) if (!no.mu) null.mu <- any(sapply(mu, is.null)) if (no.mu || null.mu) { mu <- NULL } } else if (is.matrix(Sigma)) { n <- n[[1]] if (missing(mu)) { mu <- NULL } else if (!is.numeric(mu) || !!is.null(mu)) { stop('mu must be a numeric vector, or a list (one vector per group)') } } else stop('Sigma must be a covariance matrix, or a list (one matrix per group)') } ## Fit (probably constrained) analysis model dots <- list(...) funArgs <- list(model = powerModel, sample.cov = Sigma, sample.mean = mu, sample.nobs = n) useArgs <- c(funArgs, dots[setdiff(names(dots), names(funArgs))]) fit <- do.call(fun, useArgs, envir = getNamespace("lavaan")) ## get NCP from chi square ncp <- lavaan::fitmeasures(fit)["chisq"] ## critical value under H0 critVal <- qchisq(alpha, df = nparam, lower.tail = FALSE) ## return power pchisq(critVal, df = nparam, ncp = ncp, lower.tail = FALSE) } semTools/R/parcelAllocation.R0000644000176200001440000004273014764334616015703 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ##' Random Allocation of Items to Parcels in a Structural Equation Model ##' ##' @description ##' This function generates a given number of randomly generated item-to-parcel ##' allocations, fits a model to each allocation, and provides averaged results ##' over all allocations. ##' ##' @details ##' This function implements the random item-to-parcel allocation procedure ##' described in Sterba (2011) and Sterba and MacCallum (2010). The function ##' takes a single data set with item-level data, randomly assigns items to ##' parcels, fits a structural equation model to the parceled data using ##' [lavaan::lavaanList()], and repeats this process for a user-specified ##' number of random allocations. Results from all fitted models are summarized ##' in the output. For further details on the benefits of randomly allocating ##' items to parcels, see Sterba (2011) and Sterba and MacCallum (2010). ##' ##' @importFrom stats sd qnorm ##' @importFrom lavaan parTable lavInspect lavaanList lavaanify lavNames ##' ##' @param model [lavaan::lavaan()] model syntax specifying the model ##' fit to (at least some) parceled data. Note that there can be a mixture of ##' items and parcels (even within the same factor), in case certain items ##' should never be parceled. Can be a character string or parameter table. ##' Also see [lavaan::lavaanify()] for more details. ##' @param data A `data.frame` containing all observed variables appearing ##' in the `model`, as well as those in the `item.syntax` used to ##' create parcels. If the data have missing values, multiple imputation ##' before parceling is recommended: submit a stacked data set (with a variable ##' for the imputation number, so they can be separateed later) and set ##' `do.fit = FALSE` to return the list of `data.frame`s (one per ##' allocation), each of which is a stacked, imputed data set with parcels. ##' @param parcel.names `character` vector containing names of all parcels ##' appearing as indicators in `model`. ##' @param item.syntax [lavaan::model.syntax()] specifying the model ##' that would be fit to all of the unparceled items, including items that ##' should be randomly allocated to parcels appearing in `model`. ##' @param nAlloc The number of random items-to-parcels allocations to generate. ##' @param fun `character` string indicating the name of the ##' [lavaan::lavaan()] function used to fit `model` to ##' `data`. Can only take the values `"lavaan"`, `"sem"`, ##' `"cfa"`, or `"growth"`. ##' @param alpha Alpha level used as criterion for significance. ##' @param fit.measures `character` vector containing names of fit measures ##' to request from each fitted [lavaan::lavaan()] model. See the ##' output of [lavaan::fitMeasures()] for a list of available measures. ##' @param \dots Additional arguments to be passed to ##' [lavaan::lavaanList()]. See also [lavaan::lavOptions()] ##' @param show.progress If `TRUE`, show a [utils::txtProgressBar()] ##' indicating how fast the model-fitting iterates over allocations. ##' @param iseed (Optional) Random seed used for parceling items. When the same ##' random seed is specified and the program is re-run, the same allocations ##' will be generated. Using the same `iseed` argument will ensure the ##' any model is fit to the same parcel allocations. *Note*: When using ##' \pkg{parallel} options, you must first type `RNGkind("L'Ecuyer-CMRG")` ##' into the R Console, so that the seed will be controlled across cores. ##' @param do.fit If `TRUE` (default), the `model` is fitted to each ##' parceled data set, and the summary of results is returned (see the Value ##' section below). If `FALSE`, the items are randomly parceled, but the ##' model is not fit; instead, the `list` of `data.frame`s is ##' returned (so assign it to an object). ##' @param return.fit If `TRUE`, a [lavaan::lavaanList-class] object ##' is returned with the `list` of results across allocations ##' @param warn Whether to print warnings when fitting `model` to each allocation ##' ##' @return ##' \item{Estimates}{A `data.frame` containing results related to ##' parameter estimates with columns corresponding to their names; average ##' and standard deviation across allocations; minimum, maximum, and range ##' across allocations; and the proportion of allocations in which each ##' parameter estimate was significant.} ##' \item{SE}{A `data.frame` containing results similar to ##' `Estimates`, but related to the standard errors of parameter ##' estimates.} ##' \item{Fit}{A `data.frame` containing results related to model fit, ##' with columns corresponding to fit index names; their average and ##' standard deviation across allocations; the minimum, maximum, and range ##' across allocations; and (if the test statistic or RMSEA is included in ##' `fit.measures`) the proportion of allocations in which each ##' test of (exact or close) fit was significant.} ##' \item{Model}{A [lavaan::lavaanList-class] object containing results ##' of the `model` fitted to each parcel allocation. Only returned if ##' `return.fit = TRUE`.} ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [PAVranking()] for comparing 2 models, ##' [poolMAlloc()] for choosing the number of allocations ##' ##' @references ##' ##' Sterba, S. K. (2011). Implications of parcel-allocation ##' variability for comparing fit of item-solutions and parcel-solutions. ##' *Structural Equation Modeling, 18*(4), 554--577. ##' \doi{10.1080/10705511.2011.607073} ##' ##' Sterba, S. K. & MacCallum, R. C. (2010). Variability in parameter estimates ##' and model fit across random allocations of items to parcels. ##' *Multivariate Behavioral Research, 45*(2), 322--358. ##' \doi{10.1080/00273171003680302} ##' ##' Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation ##' variability in practice: Combining sources of uncertainty and choosing the ##' number of allocations. *Multivariate Behavioral Research, 51*(2--3), ##' 296--313. \doi{10.1080/00273171.2016.1144502} ##' ##' Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model ##' selection: Parcel-allocation variability in model ranking. ##' *Psychological Methods, 22*(1), 47--68. \doi{10.1037/met0000067} ##' ##' @examples ##' ##' ## Fit 2-factor CFA to simulated data. Each factor has 9 indicators. ##' ##' ## Specify the item-level model (if NO parcels were created) ##' item.syntax <- c(paste0("f1 =~ f1item", 1:9), ##' paste0("f2 =~ f2item", 1:9)) ##' cat(item.syntax, sep = "\n") ##' ## Below, we reduce the size of this same model by ##' ## applying different parceling schemes ##' ##' ##' ## 3-indicator parcels ##' mod.parcels <- ' ##' f1 =~ par1 + par2 + par3 ##' f2 =~ par4 + par5 + par6 ##' ' ##' ## names of parcels ##' (parcel.names <- paste0("par", 1:6)) ##' ##' \donttest{ ##' ## override default random-number generator to use parallel options ##' RNGkind("L'Ecuyer-CMRG") ##' ##' parcelAllocation(mod.parcels, data = simParcel, nAlloc = 100, ##' parcel.names = parcel.names, item.syntax = item.syntax, ##' # parallel = "multicore", # parallel available in Mac/Linux ##' std.lv = TRUE) # any addition lavaan arguments ##' ##' ##' ##' ## POOL RESULTS by treating parcel allocations as multiple imputations ##' ## Details provided in Sterba & Rights (2016); see ?poolMAlloc. ##' ##' ## save list of data sets instead of fitting model yet ##' dataList <- parcelAllocation(mod.parcels, data = simParcel, nAlloc = 100, ##' parcel.names = parcel.names, ##' item.syntax = item.syntax, ##' do.fit = FALSE) ##' ## now fit the model to each data set ##' library(lavaan.mi) ##' fit.parcels <- cfa.mi(mod.parcels, data = dataList, std.lv = TRUE) ##' summary(fit.parcels) # pooled using Rubin's rules ##' anova(fit.parcels) # pooled test statistic ##' help(package = "lavaan.mi") # find more methods for pooling results ##' } ##' ##' ##' ## multigroup example ##' simParcel$group <- 0:1 # arbitrary groups for example ##' mod.mg <- ' ##' f1 =~ par1 + c(L2, L2)*par2 + par3 ##' f2 =~ par4 + par5 + par6 ##' ' ##' ## names of parcels ##' (parcel.names <- paste0("par", 1:6)) ##' ##' parcelAllocation(mod.mg, data = simParcel, parcel.names, item.syntax, ##' std.lv = TRUE, group = "group", group.equal = "loadings", ##' nAlloc = 20, show.progress = TRUE) ##' ##' ##' ##' ## parcels for first factor, items for second factor ##' mod.items <- ' ##' f1 =~ par1 + par2 + par3 ##' f2 =~ f2item2 + f2item7 + f2item8 ##' ' ##' ## names of parcels ##' (parcel.names <- paste0("par", 1:3)) ##' ##' parcelAllocation(mod.items, data = simParcel, parcel.names, item.syntax, ##' nAlloc = 20, std.lv = TRUE) ##' ##' ##' ##' ## mixture of 1- and 3-indicator parcels for second factor ##' mod.mix <- ' ##' f1 =~ par1 + par2 + par3 ##' f2 =~ f2item2 + f2item7 + f2item8 + par4 + par5 + par6 ##' ' ##' ## names of parcels ##' (parcel.names <- paste0("par", 1:6)) ##' ##' parcelAllocation(mod.mix, data = simParcel, parcel.names, item.syntax, ##' nAlloc = 20, std.lv = TRUE) ##' ##' @export parcelAllocation <- function(model, data, parcel.names, item.syntax, nAlloc = 100, fun = "sem", alpha = .05, fit.measures = c("chisq","df","cfi", "tli","rmsea","srmr"), ..., show.progress = FALSE, iseed = 12345, do.fit = TRUE, return.fit = FALSE, warn = FALSE) { if (nAlloc < 2) stop("Minimum of two allocations required.") if (!fun %in% c("sem","cfa","growth","lavaan")) stop("'fun' argument must be either 'lavaan', 'cfa', 'sem', or 'growth'") lavArgs <- list(...) lavArgs$model <- item.syntax lavArgs$data <- data lavArgs$do.fit <- FALSE ## fit item-level model to data item.fit <- do.call(fun, lavArgs) item.PT <- parTable(item.fit) ## construct parameter table for parcel-level model if (is.character(model)) { ## default lavaanify arguments ptArgs <- formals(lavaanify) ## arguments passed to lavaan by user fitArgs <- lavInspect(item.fit, "call")[-1] ## overwrite defaults with user's values sameArgs <- intersect(names(ptArgs), names(fitArgs)) ptArgs[sameArgs] <- fitArgs[sameArgs] ptArgs$model <- model if (is.null(ptArgs$model.type)) ptArgs$model.type <- "sem" if (ptArgs$model.type != "growth") ptArgs$model.type <- "sem" ptArgs$ngroups <- lavInspect(item.fit, "ngroups") PT <- do.call("lavaanify", ptArgs) } else if (is.data.frame(model)) { PT <- model } else stop("'model' argument must be a character string of lavaan model", " syntax or a lavaan parameter table. See ?lavaanify help page.") ## check that both models specify the same factors ## NOTE: lv.names remains unaltered, to omit latent indicators from $items factorNames <- lv.names <- lavNames(PT, type = "lv") if (!all(sort(lavNames(item.PT, type = "lv")) == sort(factorNames))) { stop("'model' and 'item.syntax' arguments specify different factors.\n", "'model' specifies: ", paste(sort(factorNames), collapse = ", "), "\n", "'item.syntax' specifies: ", paste(sort(lavNames(item.PT, type = "lv")), collapse = ", ")) } ## for each factor, assign item sets to parcel sets assignments <- list() for (i in factorNames) { ## all indicators from parcel-level model parcels <- PT$rhs[PT$lhs == i & PT$op == "=~"] ## all indicators from item-level model items <- item.PT$rhs[item.PT$lhs == i & item.PT$op == "=~"] ## exclude observed indicators from parceling scheme if specified ## in parcel-level model assignments[[i]]$parcels <- setdiff(parcels, c(names(data), lv.names)) assignments[[i]]$items <- setdiff(items , c( parcels , lv.names)) ## Does this factor have parcels? If not, omit this factor from next loop if (length(assignments[[i]]$parcels) == 0L) { factorNames <- factorNames[-which(factorNames == i)] next } ## how many items per parcel? nItems <- length(assignments[[i]]$items) nParcels <- length(assignments[[i]]$parcels) assignments[[i]]$nPerParcel <- rep(nItems %/% nParcels, nParcels) if (nItems %% nParcels > 0) for (j in 1:(nItems %% nParcels)) { assignments[[i]]$nPerParcel[j] <- assignments[[i]]$nPerParcel[j] + 1 } names(assignments[[i]]$nPerParcel) <- assignments[[i]]$parcels } ## for each allocation, create parcels from items dataList <- list() for (i in 1:nAlloc) { dataList[[i]] <- data for (j in factorNames) { ## create a random assignment pattern ranAss <- sample(rep(names(assignments[[j]]$nPerParcel), times = assignments[[j]]$nPerParcel)) ## add each parcel to a copy of the original data set for (k in assignments[[j]]$parcels) { ## which items were selected for this parcel? ranVars <- assignments[[j]]$items[ranAss == k] ## calculate row means of those items, save as parcel dataList[[i]][ , k] <- rowMeans(data[ , ranVars]) } } } if (!do.fit) return(dataList) ## fit parcel-level model to list of data sets set.seed(iseed) # in case not using parallel fitList <- lavaanList(model, dataList, cmd = fun, ..., warn = warn, iseed = iseed, FUN = lavaan::fitMeasures, show.progress = show.progress) ## for which data sets did the model converge? conv <- fitList@meta$ok if (!any(conv)) stop("The model did not converge for any allocations.") if (!all(conv)) message("The model did not converge for the following ", "allocations: ", paste(which(!conv), collapse = ", ")) ## tools to extract output getOutput <- function(x, sig = FALSE) { c(Avg = mean(x, na.rm = TRUE), SD = sd(x, na.rm = TRUE), Min = min(x, na.rm = TRUE), Max = max(x, na.rm = TRUE), Range = max(x, na.rm = TRUE) - min(x, na.rm = TRUE)) } out <- list() myCols <- c("lhs","op","rhs","group", "block","label") template <- data.frame(fitList@ParTableList[[which(conv)[1]]][myCols]) ## parameter estimates Est <- sapply(fitList@ParTableList[conv], function(x) x$est) out$Estimates <- cbind(template, t(apply(Est, 1, getOutput))) ## standard errors SE <- sapply(fitList@ParTableList[conv], function(x) x$se) ## Any for which SE could not be calculated? missingSE <- apply(SE, 2, function(x) any(is.na(x))) if (!all(missingSE)) { if (any(missingSE)) message("Standard errors could not be computed for ", "the following allocations: ", paste(which(missingSE), collapse = ", ")) out$SE <- cbind(template, t(apply(SE[ , !missingSE], 1, getOutput))) ## add significance test results to $Estimates Sig <- abs(Est[, !missingSE] / SE[, !missingSE]) > qnorm(alpha / 2, lower.tail = FALSE) out$Estimates$Percent_Sig <- rowMeans(Sig) out$Estimates$Percent_Sig[fitList@ParTableList[[which(conv)[1]]]$free == 0L] <- NA } else { message("Standard errors could not be calculated for any converged", " data sets, so no significance tests could be conducted.") out$SE <- NULL } ## fit measures Fit <- do.call(cbind, fitList@funList[conv])[fit.measures, ] out$Fit <- data.frame(t(apply(Fit, 1, getOutput))) if (any(grepl(pattern = "chisq", fit.measures))) { out$Fit$Percent_Sig <- NA if ("chisq" %in% fit.measures) { pvalues <- sapply(fitList@funList[conv], "[", i = "pvalue") out$Fit["chisq", "Percent_Sig"] <- mean(pvalues < alpha, na.rm = TRUE) } if ("chisq.scaled" %in% fit.measures) { pvalues <- sapply(fitList@funList[conv], "[", i = "pvalue.scaled") out$Fit["chisq.scaled", "Percent_Sig"] <- mean(pvalues < alpha, na.rm = TRUE) } } if (any(grepl(pattern = "rmsea", fit.measures))) { if (is.null(out$Fit$Percent_Sig)) out$Fit$Percent_Sig <- NA if ("rmsea" %in% fit.measures) { pvalues <- sapply(fitList@funList[conv], "[", i = "rmsea.pvalue") out$Fit["rmsea", "Percent_Sig"] <- mean(pvalues < alpha, na.rm = TRUE) } if ("rmsea.scaled" %in% fit.measures) { pvalues <- sapply(fitList@funList[conv], "[", i = "rmsea.pvalue.scaled") out$Fit["rmsea.scaled", "Percent_Sig"] <- mean(pvalues < alpha, na.rm = TRUE) } } ## check for robust test if (any(grepl(pattern = "scaled", names(fitList@funList[conv][[1]]))) & !any(grepl(pattern = "scaled", fit.measures))) { warning('Robust test requested, but "fit.measures" argument does not', ' include any scaled measures (e.g., "chisq.scaled", ', '"rmsea.scaled", or "rmsea.robust").') } ## remove rows that do not correspond to estimates out$Estimates <- out$Estimates[fitList@ParTableList[[which(conv)[1]]]$group > 0L, ] if (!is.null(out$SE)) out$SE <- out$SE[fitList@ParTableList[[which(conv)[1]]]$group > 0L, ] ## assign class for lavaan's print method class(out$Estimates) <- c("lavaan.data.frame","data.frame") if (!is.null(out$SE)) class(out$SE) <- c("lavaan.data.frame","data.frame") class(out$Fit) <- c("lavaan.data.frame","data.frame") ## return output if (return.fit) { out$Model <- fitList out$Model@external$dataList <- dataList } out } semTools/R/compareFit.R0000644000176200001440000005202114764323566014514 0ustar liggesusers### Terrence D. Jorgensen & Sunthud Pornprasertmanit ### Last updated: 12 March 2025 ### source code for compareFit() function and FitDiff class ## ----------------- ## Class and Methods ## ----------------- ##' Class For Representing A Template of Model Fit Comparisons ##' ##' This class contains model fit measures and model fit comparisons among ##' multiple models ##' ##' ##' @name FitDiff-class ##' @aliases FitDiff-class show,FitDiff-method summary,FitDiff-method ##' @docType class ##' ##' @slot name `character`. The name of each model ##' @slot model.class `character`. One class to which each model belongs ##' @slot nested `data.frame`. Model fit comparisons between adjacently ##' nested models that are ordered by their degrees of freedom (*df*) ##' @slot fit `data.frame`. Fit measures of all models specified in the ##' `name` slot, ordered by their *df* ##' @slot fit.diff `data.frame`. Sequential differences in fit measures in ##' the `fit` slot ##' ##' @section Objects from the Class: Objects can be created via the ##' [compareFit()] function. ##' ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso [compareFit()]; [clipboard()] ##' ##' @examples ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' fit.config <- cfa(HS.model, data = HolzingerSwineford1939, group = "school") ##' ## invariance constraints ##' fit.metric <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = "loadings") ##' fit.scalar <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = c("loadings","intercepts")) ##' fit.strict <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = c("loadings","intercepts","residuals")) ##' measEqOut <- compareFit(fit.config, fit.metric, fit.scalar, fit.strict) ##' summary(measEqOut) ##' summary(measEqOut, fit.measures = "all") ##' summary(measEqOut, fit.measures = c("aic", "bic")) ##' ##' if(interactive()){ ##' ## Save results to a file ##' saveFile(measEqOut, file = "measEq.txt") ##' ##' ## Copy to a clipboard ##' clipboard(measEqOut) ##' } ##' setClass("FitDiff", slots = c(name = "character", # list of model names model.class = "character", # lavaan or lavaan.mi nested = "data.frame", # anova() table fit = "data.frame", # fitMeasures() output fit.diff = "data.frame")) # index differences ##' @rdname FitDiff-class ##' @aliases show,FitDiff-method ##' @importFrom methods getMethod ##' @export setMethod("show", signature(object = "FitDiff"), function(object) { cat("The following", object@model.class, "models were compared:\n ") cat(object@name, sep = "\n ") cat("To view results, assign the compareFit() output to an object and ", "use the summary() method; see the class?FitDiff help page.\n") invisible(object) }) ##' @rdname FitDiff-class ##' @aliases summary,FitDiff-method ##' ##' @param object object of class `FitDiff` ##' @param fit.measures `character` vector naming fit indices the user can ##' request from [lavaan::fitMeasures()]. If `"default"`, the ##' fit measures will be `c("chisq", "df", "pvalue", "cfi", "tli", ##' "rmsea", "srmr", "aic", "bic")`. If `"all"`, all available fit ##' measures will be returned. ##' @param nd number of digits printed ##' @param tag single `character` used to flag the model preferred by each ##' fit index. To omit tags, set to `NULL` or `NA`. ##' ##' @export setMethod("summary", signature(object = "FitDiff"), function(object, fit.measures = "default", nd = 3, tag = "\u2020") { if (nrow(object@nested) > 0L) { cat("################### Nested Model Comparison #########################\n") test.statistics <- object@nested if (object@model.class == "lavaan") { print(test.statistics, nd = nd) } else { class(test.statistics) <- c("lavaan.data.frame","data.frame") stats::printCoefmat(test.statistics, P.values = TRUE, has.Pvalue = TRUE) } cat("\n") } noFit <- ncol(object@fit) == 1L && names(object@fit)[1] == "df" if (!noFit) { if (is.null(fit.measures)) fit.measures <- colnames(object@fit) if ("all" %in% fit.measures) fit.measures <- colnames(object@fit) if (length(fit.measures) == 1 && fit.measures == "default") { ## robust or scaled test statistics? if (is.null(object@fit$cfi.scaled)) { fit.measures <- c("chisq","df","pvalue","rmsea","cfi","tli","srmr") } else if (all(!is.na(object@fit$cfi.robust)) && !is.null(object@fit$cfi.robust)) { fit.measures <- c("chisq.scaled","df.scaled","pvalue.scaled", "rmsea.robust","cfi.robust","tli.robust","srmr") } else { fit.measures <- c("chisq.scaled","df.scaled","pvalue.scaled", "rmsea.scaled","cfi.scaled","tli.scaled","srmr") } if ("aic" %in% colnames(object@fit)) { fit.measures <- c(fit.measures, "aic", "bic") } } cat("####################### Model Fit Indices ###########################\n") ## this is the object to return (numeric, no printed daggers) fit.indices <- object@fit[ , fit.measures , drop = FALSE] ## print with daggers marking each fit index's preferred model ## (turns "numeric" vectors into "character") badness <- grepl(pattern = c("chisq|rmsea|ic|rmr|ecvi|fmin|hqc"), x = colnames(fit.indices)) goodness <- grepl(pattern = c("cfi|tli|rfi|nfi|ifi|rni|cn|gfi|mfi|Hat"), x = colnames(fit.indices)) minvalue <- badness & !goodness minvalue[!badness & !goodness] <- NA fit.integer <- grepl(pattern = c("df|npar|ntotal"), x = colnames(fit.indices)) suppressWarnings(fitTab <- as.data.frame(mapply(tagCharacter, nd = nd, char = tag, vec = fit.indices, minvalue = minvalue, print_integer = fit.integer), stringsAsFactors = FALSE)) rownames(fitTab) <- object@name colnames(fitTab) <- colnames(fit.indices) class(fitTab) <- c("lavaan.data.frame","data.frame") print(fitTab, nd = nd) cat("\n") if (nrow(object@nested) > 0L) { fit.diff.measures <- fit.measures[!grepl(pattern = "chisq|pvalue|ntotal", x = fit.measures)] cat("################## Differences in Fit Indices #######################\n") fit.diff <- object@fit.diff[ , fit.diff.measures, drop = FALSE] class(fit.diff) <- c("lavaan.data.frame","data.frame") print(fit.diff, nd = nd) cat("\n") } } invisible(object) }) ## "method" for saveFile() function (see "clipboard.R") saveFileFitDiff <- function(object, file, what = "summary", tableFormat = FALSE, fit.measures = "default", writeArgs = list()) { if (tableFormat) { writeArgs$file <- file writeArgs$append <- TRUE if (is.null(writeArgs$sep)) writeArgs$sep <- "\t" if (is.null(writeArgs$quote)) writeArgs$quote <- FALSE if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (nrow(object@nested) > 0L) { cat("Nested Model Comparison\n\n", file = file, append = TRUE) out <- object@nested #out <- data.frame(model.diff = rownames(out), out) writeArgs$x <- out do.call("write.table", writeArgs) cat("\n\n", file = file, append = TRUE) } out2 <- getFitSummary(object, fit.measures) out2 <- data.frame(model = object@name, out2) cat("Fit Indices Summaries\n\n", file = file, append = TRUE) writeArgs$x <- out2 do.call("write.table", writeArgs) } else { write(paste(utils::capture.output(getMethod("summary", signature = "FitDiff")(object)), collapse = "\n"), file = file) } } ## -------------------- ## Constructor Function ## -------------------- ##' Build an object summarizing fit indices across multiple models ##' ##' This function will create the template to compare fit indices across ##' multiple fitted lavaan objects. The results can be exported to a clipboard ##' or a file later. ##' ##' @importFrom lavaan lavTestLRT ##' @importMethodsFrom lavaan fitMeasures ##' ##' @param ... fitted `lavaan` models or list(s) of `lavaan` objects. ##' [lavaan.mi::lavaan.mi-class] objects are also accepted, but all models ##' must belong to the same class. ##' @param nested `logical` indicating whether the models in `...` are ##' nested. See [net()] for an empirical test of nesting. ##' @param argsLRT `list` of arguments to pass to ##' [lavaan::lavTestLRT()], as well as to ##' [lavaan.mi::lavTestLRT.mi()] and [lavaan::fitMeasures()] when ##' comparing [lavaan.mi::lavaan.mi-class] models. ##' @param indices `logical` indicating whether to return fit indices from ##' the [lavaan::fitMeasures()] function. Selecting particular ##' indices is controlled in the `summary` method; see ##' [FitDiff-class]. ##' @param moreIndices `logical` indicating whether to return fit indices ##' from the [moreFitIndices()] function. Selecting particular ##' indices is controlled in the `summary` method; see ##' [FitDiff-class]. ##' @param baseline.model optional fitted [lavaan::lavaan-class] model passed to ##' [lavaan::fitMeasures()] to calculate incremental fit indices. ##' @param nPrior passed to [moreFitIndices()], if relevant ##' ##' @return A [FitDiff-class] object that saves model fit ##' comparisons across multiple models. If the models are not nested, only ##' fit indices for each model are returned. If the models are nested, the ##' differences in fit indices are additionally returned, as well as test ##' statistics comparing each sequential pair of models (ordered by their ##' degrees of freedom). ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso [FitDiff-class], [clipboard()] ##' ##' @examples ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' ## non-nested models ##' fit1 <- cfa(HS.model, data = HolzingerSwineford1939) ##' ##' m2 <- ' f1 =~ x1 + x2 + x3 + x4 ##' f2 =~ x5 + x6 + x7 + x8 + x9 ' ##' fit2 <- cfa(m2, data = HolzingerSwineford1939) ##' ##' (out1 <- compareFit(fit1, fit2, nested = FALSE)) ##' summary(out1) ##' ##' ##' ## nested model comparisons: measurement equivalence/invariance ##' fit.config <- cfa(HS.model, data = HolzingerSwineford1939, group = "school") ##' fit.metric <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = "loadings") ##' fit.scalar <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = c("loadings","intercepts")) ##' fit.strict <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = c("loadings","intercepts","residuals")) ##' ##' measEqOut <- compareFit(fit.config, fit.metric, fit.scalar, fit.strict, ##' moreIndices = TRUE) # include moreFitIndices() ##' summary(measEqOut) ##' summary(measEqOut, fit.measures = "all") ##' summary(measEqOut, fit.measures = c("aic", "bic", "sic", "ibic")) ##' ##' #FIXME: why doesn't this example work? ## \donttest{ ## ## also applies to lavaan.mi objects (fit model to multiple imputations) ## library(lavaan.mi) ## data("HS20imps", package = "lavaan.mi") # example data: 20 imputations ## ## ## request robust test statistics ## mgfit2 <- cfa.mi(HS.model, data = HS20imps, group = "school", estimator = "mlm") ## mgfit1 <- cfa.mi(HS.model, data = HS20imps, group = "school", estimator = "mlm", ## group.equal = "loadings") ## mgfit0 <- cfa.mi(HS.model, data = HS20imps, group = "school", estimator = "mlm", ## group.equal = c("loadings","intercepts")) ## ## ## request the strictly-positive robust test statistics ## out2 <- compareFit(scalar = mgfit0, metric = mgfit1, config = mgfit2, ## argsLRT = list(asymptotic = TRUE, ## method = "satorra.bentler.2010")) ## ## note that moreFitIndices() does not work for lavaan.mi objects ## summary(out2, fit.measures = c("crmr","srmr", "cfi.robust","tli.robust", ## "rmsea.robust", ## "rmsea.ci.lower.robust", ## "rmsea.ci.upper.robust")) ## } ##' ##' @export compareFit <- function(..., nested = TRUE, argsLRT = list(), indices = TRUE, moreIndices = FALSE, baseline.model = NULL, nPrior = 1) { ## make sure there is something to do if (!(nested || indices || moreIndices)) { message('User requested neither indices nor tests of nested models.') return(NULL) } ## separate models from lists of models dots <- list(...) idx.list <- sapply(dots, is.list) modLists <- dots[ idx.list] mods <- dots[!idx.list] ## capture names of any arguments passed via dots allnames <- sapply(substitute(list(...))[-1], deparse) listnames <- allnames[ idx.list] modnames <- allnames[!idx.list] ## make sure models are named if (length(mods) && is.null(names(mods))) { names(mods) <- modnames } else for (nn in seq_along(mods)) { if (names(mods)[nn] == "") names(mods)[nn] <- modnames[nn] } ## make sure lists are named if (length(modLists) && is.null(names(modLists))) { names(modLists) <- listnames } else for (nn in seq_along(modLists)) { if (names(modLists)[nn] == "") names(modLists)[nn] <- listnames[nn] } ## within each list, make sure models are named for (i in seq_along(modLists)) { if (length(modLists[[i]]) && is.null(names(modLists[[i]]))) { names(modLists[[i]]) <- seq_along(modLists[[i]]) } else for (nn in seq_along(modLists[[i]])) { if (names(modLists[[i]])[nn] == "") names(modLists[[i]])[nn] <- nn } } ## collapse into a single list of models if (length(modLists)) mods <- c(mods, unlist(modLists)) ## check for lavaan models not.lavaan <- !sapply(mods, inherits, what = c("lavaan","lavaan.mi")) if (any(not.lavaan)) stop("The following are not fitted lavaan(.mi) models:\n", paste0(names(which(not.lavaan)), collapse = ", ")) modClass <- unique(sapply(mods, class)) if (length(modClass) > 1L) stop('All models must be of the same class (e.g.,', ' cannot compare lavaan objects to lavaan.mi)') if (inherits(mods[[1]], "lavaan")) { nonConv <- !sapply(mods, lavInspect, what = "converged") } else if (inherits(mods[[1]], "lavaan.mi")) { ## attach lavaan.mi to access LRT + fitMeasures if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") nonConv <- !sapply(mods, function(fit) { any(sapply(fit@convergence, "[", i = "converged")) }) } if (all(nonConv)) { stop('No models converged') } else if (any(nonConv)) { message('The following models did not converge, so they are ignored:\n', paste(names(nonConv)[nonConv], collapse = ",\t")) mods <- mods[which(!nonConv)] } ## grab lavaan.mi options, if relevant if (is.null(argsLRT$pool.robust)) { pool.robust <- formals(lavaan.mi::lavTestLRT.mi)$pool.robust # default value } else { pool.robust <- argsLRT$pool.robust # user-specified value } if (is.null(argsLRT$pool.method)) { pool.method <- eval(formals(lavaan.mi::lavTestLRT.mi)$pool.method) # default value } else { pool.method <- argsLRT$pool.method # user-specified value } ## FIT INDICES if (indices || moreIndices) { fitList <- lapply(mods, fitMeasures, baseline.model = baseline.model, pool.robust = pool.robust, pool.method = pool.method) if (moreIndices && modClass == "lavaan") { moreFitList <- lapply(mods, moreFitIndices, nPrior = nPrior) fitList <- mapply(c, fitList, moreFitList, SIMPLIFY = FALSE) } if (length(unique(sapply(fitList, length))) > 1L) { warning('fitMeasures() returned vectors of different lengths for different', ' models, probably because certain options are not the same. Check', ' lavInspect(fit, "options")[c("estimator","test","meanstructure")]', ' for each model, or run fitMeasures() on each model to investigate.') indexList <- lapply(fitList, names) useNames <- names(which(table(unlist(indexList)) == length(fitList))) fitList <- lapply(fitList, "[", i = useNames) } fit <- as.data.frame(do.call(rbind, fitList)) } else { fitList <- lapply(mods, fitMeasures, fit.measures = "df", pool.robust = pool.robust, pool.method = pool.method) ## check for scaled tests nDF <- sapply(fitList, length) if (any(nDF != nDF[1])) stop('Some (but not all) models have robust tests,', ' so they cannot be compared as nested models.') fit <- data.frame(df = sapply(fitList, "[", i = if (any(nDF > 1L)) 2L else 1L)) } ## order models by increasing df (least-to-most constrained) ord <- order(fit$df) #FIXME: what if test == "mean.var.adjusted"? fit <- fit[ord, , drop = FALSE] mods <- mods[ord] ## TEST STATISTICS if (nested) { argsLRT$model.names <- names(mods) argsLRT$object <- mods[[1]] if (inherits(mods[[1]], "lavaan")) { nestedout <- do.call(lavTestLRT, c(mods[-1], argsLRT)) } else if (inherits(mods[[1]], "lavaan.mi")) { nestedout <- do.call(lavaan.mi::lavTestLRT.mi, c(mods[-1], argsLRT)) } ## not nested } else nestedout <- data.frame() ## DIFFERENCES IN FIT INDICES if (indices && length(names(mods)) > 1L) { fitSubset <- colnames(fit)[!grepl(pattern = "chisq|pvalue|ntotal", x = colnames(fit))] fitTab <- fit[ , fitSubset, drop = FALSE] diffTab <- as.data.frame(do.call(cbind, lapply(fitTab, diff))) rownames(diffTab) <- paste(names(mods)[-1], "-", names(mods)[-length(names(mods))]) } else diffTab <- data.frame(df = diff(fit)) new("FitDiff", name = names(mods), model.class = modClass, nested = nestedout, fit = fit, fit.diff = diffTab) } ## ---------------- ## Hidden Functions ## ---------------- noLeadingZero <- function(vec, fmt, nd = 3L) { out <- sprintf(fmt, vec) upper.limit <- paste0(".", paste(rep(9, nd - 1L), collapse = ""), "5") used <- vec < as.numeric(upper.limit) & vec >= 0 used[is.na(used)] <- FALSE out[used] <- substring(out[used], 2) out } tagCharacter <- function(vec, char = "\u2020", minvalue = NA, print_integer = FALSE, nd = 3L) { char <- if (is.null(char)) as.character(NA) else as.character(char)[1] if (nchar(char) != 1L) { message('Only a single character can be used to tag= preferred models, so ', 'no tags were added. To omit tags, specify tag=NULL or tag=NA.') char <- as.character(NA) } if (print_integer) { vec <- noLeadingZero(vec, fmt = "%.0f", nd = nd) } else if (is.na(minvalue)) { vec <- noLeadingZero(vec, fmt = paste0("%.", nd, "f"), nd = nd) } else { target <- if (minvalue) min(vec, na.rm = TRUE) else max(vec, na.rm = TRUE) tag <- rep(" ", length(vec)) if (!is.na(char)) tag[vec == target] <- char vec <- noLeadingZero(vec, fmt = paste0("%.", nd, "f"), nd = nd) vec <- paste0(vec, tag) } vec } getFitSummary <- function(object, fit.measures = "default", return.diff = FALSE) { if (is.null(fit.measures)) fit.measures <- colnames(object@fit) if ("all" %in% fit.measures) fit.measures <- colnames(object@fit) if (length(fit.measures) == 1 && fit.measures == "default") { ## robust or scaled test statistics? if (is.null(object@fit$cfi.scaled)) { fit.measures <- c("chisq","df","pvalue","rmsea","cfi","tli","srmr") } else if (all(!is.na(object@fit$cfi.robust)) && !is.null(object@fit$cfi.robust)) { fit.measures <- c("chisq.scaled","df.scaled","pvalue.scaled", "rmsea.robust","cfi.robust","tli.robust","srmr") } else { fit.measures <- c("chisq.scaled","df.scaled","pvalue.scaled", "rmsea.scaled","cfi.scaled","tli.scaled","srmr") } if ("aic" %in% colnames(object@fit)) { fit.measures <- c(fit.measures, "aic", "bic") } } ## chi-squared difference test already reported, so remove (diff in p-value) if (return.diff) { fit.measures <- fit.measures[!grepl(pattern = "chisq|pvalue|ntotal", x = fit.measures)] } ## return numeric values fitTab <- object@fit[ , colnames(object@fit) %in% fit.measures, drop = FALSE] if (!return.diff) return(fitTab) ## or return differences in fit indices diffTab <- as.data.frame(do.call(cbind, lapply(fitTab, diff))) rownames(diffTab) <- paste(object@name[-1], "-", object@name[-length(object@name)]) diffTab } semTools/R/discriminantValidity.R0000644000176200001440000002245314753073506016615 0ustar liggesusers### Mikko Rönkkö (Roxygen edits by TDJ) ### Last updated: 12 February 2025 ##' Calculate discriminant validity statistics ##' ##' Calculate discriminant validity statistics based on a fitted lavaan object ##' ##' Evaluated on the measurement scale level, discriminant validity is commonly ##' evaluated by checking if each pair of latent correlations is sufficiently ##' below one (in absolute value) that the latent variables can be thought of ##' representing two distinct constructs. ##' ##' `discriminantValidity` function calculates two sets of statistics that ##' are commonly used in discriminant validity evaluation. The first set are ##' factor correlation estimates and their confidence intervals. The second set ##' is a series of nested model tests, where the baseline model is compared ##' against a set of constrained models that are constructed by constraining ##' each factor correlation to the specified cutoff one at a time. ##' ##' The function assume that the `object` is set of confirmatory ##' factor analysis results where the latent variables are scaled by fixing their ##' variances to 1s. If the model is not a CFA model, the function will calculate ##' the statistics for the correlations among exogenous latent variables, but ##' for the *residual* variances with endogenous variables. If the ##' latent variables are scaled in some other way (e.g. fixing the first loadings), ##' the function issues a warning and re-estimates the model by fixing latent ##' variances to 1 (and estimating all loadings) so that factor covariances are ##' already estimated as correlations. ##' ##' The likelihood ratio tests are done by comparing the original baseline model ##' against more constrained alternatives. By default, these alternatives are ##' constructed by fixing each correlation at a time to a cutoff value. The ##' typical purpose of this test is to demonstrate that the estimated factor ##' correlation is well below the cutoff and a significant \eqn{chi^2} statistic ##' thus indicates support for discriminant validity. In some cases, the original ##' correlation estimate may already be greater than the cutoff, making it ##' redundant to fit a "restricted" model. When this happens, the likelihood ##' ratio test will be replaced by comparing the baseline model against itself. ##' For correlations that are estimated to be negative, a negation of the cutoff ##' is used in the constrained model. ##' ##' Another alternative is to do a nested model comparison against a model where ##' two factors are merged as one by setting the `merge` argument to ##' `TRUE`. In this comparison, the constrained model is constructed by ##' removing one of the correlated factors from the model and assigning its ##' indicators to the factor that remains in the model. ##' ##' ##' @importFrom lavaan lavInspect lavNames parTable ##' ##' @param object The [lavaan::lavaan-class] model object returned by ##' the [lavaan::cfa()] function. ##' @param cutoff A cutoff to be used in the constrained models in likelihood ##' ratio tests. ##' @param merge Whether the constrained models should be constructed by merging ##' two factors as one. Implies `cutoff` = 1. ##' ##' @inheritParams lavaan::parameterEstimates ##' ##' @return A `data.frame` of latent variable correlation estimates, their ##' confidence intervals, and a likelihood ratio tests against constrained models. ##' with the following attributes: ##' \describe{ ##' \item{baseline}{The baseline model after possible rescaling.} ##' \item{constrained}{A `list` of the fitted constrained models ##' used in the likelihood ratio test.} ##' } ##' ##' @author ##' Mikko Rönkkö (University of Jyväskylä; \email{mikko.ronkko@jyu.fi}): ##' @references ##' ##' Rönkkö, M., & Cho, E. (2022). An updated guideline for assessing ##' discriminant validity. *Organizational Research Methods*, 25(1), 6–14. ##' \doi{10.1177/1094428120968614} ##' ##' @examples ##' ##' library(lavaan) ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit <- cfa(HS.model, data = HolzingerSwineford1939) ##' discriminantValidity(fit) ##' discriminantValidity(fit, merge = TRUE) ##' ##' @export discriminantValidity <- function(object, cutoff = .9, merge = FALSE, level = .95, boot.ci.type = "perc") { free <- lavInspect(object, "free", add.class = FALSE) #FIXME: adapt for multiple blocks by looping over groups/levels if (lavInspect(object, "ngroups") > 1L | lavInspect(object, "nlevels") > 1L) stop("Only implemented for single-group, single-level models so far.") # Identify the latent variables that we will use lvs <- lavNames(object,"lv") if (cutoff <= 0 | cutoff > 1) stop("The cutoff must be between (0,1]") if (merge & !missing(cutoff) & cutoff != 1) message("Merging factors imply constraining factor correlation to 1. ", "Cutoff will be ignored.") if (length(lvs) == 0) stop("The model does not have any exogenous latent variables.") if (length(lvs) == 1) stop("The model has only one exogenous latent variable. ", "At least two are required for assessing discriminant validity.") if (length(lavNames(object, "lv.y")) > 0) warning("The model has at least one endogenous latent variable (", paste(lavNames(object, "lv.y"), collapse = ", "), "). The correlations of these variables will be estimated after ", "conditioning on their predictors.") # Extract the part of psi that contains latent variables psi <- free$psi[lvs,lvs] # Identify exogenous variances and covariances pt <- parTable(object) varIndices <- which(pt$lhs == pt$rhs & pt$lhs %in% lvs & pt$op == "~~") covIndices <- which(pt$lhs != pt$rhs & pt$lhs %in% lvs & pt$rhs %in% lvs & pt$op == "~~") # Check that the diagonal of psi is all zeros if (any(diag(psi) != 0)) { message("Some of the latent variable variances are estimated instead of ", "fixed to 1. The model is re-estimated by scaling the latent ", "variables by fixing their variances and freeing all factor loadings.") # Identify free exogenous variances i <- intersect(varIndices,which(pt$free != 0)) pt$free[i] <- 0 pt$ustart[i] <- 1 pt$user[i] <- 1 # Free all factor loadings corresponding of lvs where the covariances were # just freed i <- which(pt$lhs %in% pt$lhs[i] & pt$op == "=~") pt$free[i] <- -1 pt$ustart[i] <- NA # Update parameter numbers i <- which(pt$free != 0) pt$free[i] <- seq_along(i) object <- lavaan::update(object, model = pt[,1:12]) # Leave out starting # values, estimates, and # ses from pt # Update pt based on the new model pt <- parTable(object) } # At this point we can be sure that all exogenous variances are fixed instead # of being estimated. We need to still check that they are fixed to 1s est <- lavInspect(object,"est")$psi[lvs,lvs] if (any(diag(est) != 1)) { message("Some of the latent variable variances are fixed to values other ", "than 1. The model is re-estimated by scaling the latent variables", " based on the first factor loading.") # constrain the exogenous variances to 1 pt$ustart[varIndices] <- 1 object <- lavaan::update(object, model = pt[,1:12]) # Leave out starting # values, estimates, and # ses from pt # Update pt based on the new estimates pt <- parTable(object) } # At this point we can be sure that all exogenous LVs have their variances # fixed to ones and can start constructing the matrix to be returned ret <- lavaan::parameterEstimates(object, ci = TRUE, level = level, boot.ci.type = boot.ci.type)[covIndices, c("lhs","op","rhs","est", "ci.lower","ci.upper")] rownames(ret) <- seq_len(nrow(ret)) # Add the chi^2 test to all correlation pairs constrainedModels <- lapply(covIndices, function(i) { thisPt <- pt if (merge) { lhs <- pt$lhs[i] rhs <- pt$rhs[i] # Merge the factors by assigning indicator of lhs to rhs thisPt$lhs[thisPt$lhs == lhs & thisPt$op == "=~"] <- rhs # Then remove all other parameters concering lhs thisPt <- thisPt[!(thisPt$lhs == lhs | thisPt$rhs == lhs), ] thisPt$id <- seq_len(nrow(thisPt)) } else { # If the correlation is estimated to be greater than the cuttof, constrain # it to the estimated alue if (abs(pt$est[i]) > cutoff) { thisCutoff <- pt$est[i] } else { thisCutoff <- ifelse(pt$est[i] < 0, - cutoff, cutoff) } thisPt$free[i] <- 0 thisPt$ustart[i] <- thisCutoff } # Update parameter numbers j <- which(thisPt$free != 0) thisPt$free[j] <- seq_along(j) lavaan::update(object, model = thisPt[,1:12], se = "none") # Disable SEs to save computational time }) lrTests <- lapply(constrainedModels, function(constrained) { lavaan::lavTestLRT(object,constrained)[2,] # Return the second row of the # test }) ret <- cbind(ret,do.call(rbind,lrTests)) # Store the baseline model attr(ret,"baseline") <- object attr(ret,"constrained") <- constrainedModels ret } semTools/R/NET.R0000644000176200001440000003121314764263766013056 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### semTools functions for Nesting and Equivalence Testing ## ----------------- ## Class and Methods ## ----------------- ##' Class For the Result of Nesting and Equivalence Testing ##' ##' This class contains the results of nesting and equivalence testing among ##' multiple models ##' ##' ##' @name Net-class ##' @aliases Net-class show,Net-method summary,Net-method ##' @docType class ##' ##' @slot test Logical `matrix` indicating nesting/equivalence among models ##' @slot df The degrees of freedom of tested models ##' ##' @section Objects from the Class: Objects can be created via the ##' [net()] function. ##' ##' @param object An object of class `Net`. ##' ##' @return ##' \item{show}{`signature(object = "Net")`: prints the logical matrix of ##' test results. `NA` indicates a model did not converge.} ##' \item{summary}{`signature(object = "Net")`: prints a narrative ##' description of results. The original `object` is invisibly returned.} ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [net()] ##' ##' @examples ##' ##' # See the example in the net function. ##' setClass("Net", representation(test = "matrix", df = "vector")) ##' @rdname Net-class ##' @aliases show,Net-method ##' @export setMethod("show", "Net", function(object) { if (length(object@test)) { m <- as.matrix(unclass(object@test)) m[upper.tri(m, diag = TRUE)] <- "" cat(" If cell [R, C] is TRUE, the model in row R is nested within column C. If the models also have the same degrees of freedom, they are equivalent. NA indicates the model in column C did not converge when fit to the implied means and covariance matrix from the model in row R. The hidden diagonal is TRUE because any model is equivalent to itself. The upper triangle is hidden because for models with the same degrees of freedom, cell [C, R] == cell [R, C]. For all models with different degrees of freedom, the upper diagonal is all FALSE because models with fewer degrees of freedom (i.e., more parameters) cannot be nested within models with more degrees of freedom (i.e., fewer parameters). \n") print(m, quote = FALSE) } else { cat(data.class(object@test), "(0)\n", sep = "") } invisible(object) }) ##' @rdname Net-class ##' @aliases summary,Net-method ##' @export setMethod("summary", "Net", function(object) { DFs <- object@df x <- object@test mods <- colnames(x) ## keep track of how many are printed nPrinted <- 0L for (R in 2:nrow(x)) { for (C in (R - 1):1) { ## if model didn't converge (logical value is missing), go to next iteration if (is.na(x[R, C])) next ## if the models are not nested, go to next iteration if (!x[R, C]) next ## choose message based on whether models are equivalent or nested if (identical(DFs[R], DFs[C])) { rel <- "equivalent to" nPrinted <- nPrinted + 1L } else { rel <- "nested within" nPrinted <- nPrinted + 1L } cat("Model \"", mods[R], "\" is ", rel, " model \"", mods[C], "\"\n", sep = "") } } if (nPrinted == 0L) cat('No models were determined as nested/equivalent.\n') invisible(object) }) ## -------------------- ## Constructor Function ## -------------------- ##' Nesting and Equivalence Testing ##' ##' This test examines whether pairs of SEMs are nested or equivalent. ##' ##' The concept of nesting/equivalence should be the same regardless of ##' estimation method. However, the particular method of testing ##' nesting/equivalence (as described in Bentler & Satorra, 2010) employed by ##' the `net` function analyzes summary statistics (model-implied means and ##' covariance matrices, not raw data). In the case of robust methods like MLR, ##' the raw data is only utilized for the robust adjustment to SE and chi-sq, ##' and the net function only checks the unadjusted chi-sq for the purposes of ##' testing nesting/equivalence. This method also applies to models for ##' categorical data, following the procedure described by Asparouhov & Muthen ##' (2019). ##' ##' ##' @importFrom lavaan lavInspect ##' ##' @param \dots The `lavaan` objects used for test of nesting and ##' equivalence ##' @param crit The upper-bound criterion for testing the equivalence of models. ##' Models are considered nested (or equivalent) if the difference between ##' their \eqn{\chi^2} fit statistics is less than this criterion. ##' ##' @return The [Net-class] object representing the outputs for nesting ##' and equivalent testing, including a logical matrix of test results and a ##' vector of degrees of freedom for each model. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' ##' Bentler, P. M., & Satorra, A. (2010). Testing model nesting and equivalence. ##' *Psychological Methods, 15*(2), 111--123. \doi{10.1037/a0019625} ##' ##' Asparouhov, T., & Muthen, B. (2019). Nesting and equivalence testing for ##' structural equation models. *Structural Equation Modeling, 26*(2), ##' 302--309. \doi{10.1080/10705511.2018.1513795} ##' ##' @examples ##' ##' m1 <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' ##' m2 <- ' f1 =~ x1 + x2 + x3 + x4 ##' f2 =~ x5 + x6 + x7 + x8 + x9 ' ##' ##' m3 <- ' visual =~ x1 + x2 + x3 ##' textual =~ eq*x4 + eq*x5 + eq*x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit1 <- cfa(m1, data = HolzingerSwineford1939) ##' fit1a <- cfa(m1, data = HolzingerSwineford1939, std.lv = TRUE) # Equivalent to fit1 ##' fit2 <- cfa(m2, data = HolzingerSwineford1939) # Not equivalent to or nested in fit1 ##' fit3 <- cfa(m3, data = HolzingerSwineford1939) # Nested in fit1 and fit1a ##' ##' \donttest{ ##' tests <- net(fit1, fit1a, fit2, fit3) ##' tests ##' summary(tests) ##' } ##' ##' @export net <- function(..., crit = .0001) { ## put fitted objects in a list fitList <- list(...) ## check that they are all lavaan objects notLavaan <- !sapply(fitList, inherits, what = "lavaan") if (any(notLavaan)) { fitNames <- sapply(as.list(substitute(list(...)))[-1], deparse) stop(paste("The following arguments are not fitted lavaan objects:\n", paste(fitNames[notLavaan], collapse = "\t"))) } ## remove any that did not converge nonConv <- !sapply(fitList, lavInspect, what = "converged") if (all(nonConv)) { stop('No models converged') } else if (any(nonConv)) { fitNames <- sapply(as.list(substitute(list(...)))[-1], deparse) message('The following models did not converge, so they are ignored:\n', paste(fitNames[nonConv], collapse = ",\t")) fitList <- fitList[which(!nonConv)] } ## check for meanstructure meanstructure <- sapply(fitList, function(x) lavInspect(x, "options")$meanstructure) if (!(all(meanstructure) || !any(meanstructure))) stop('Some (but not all) fitted lavaan objects include a mean structure. ', 'Please re-fit all models with the argument meanstructure=TRUE.') ## get degrees of freedom for each model DFs <- sapply(fitList, function(x) lavInspect(x, "fit")["df"]) ## name according to named objects, with DF in parentheses fitNames <- names(fitList) dotNames <- sapply(as.list(substitute(list(...)))[-1], deparse) if (any(nonConv)) dotNames <- dotNames[which(!nonConv)] if (is.null(names(fitList))) { fitNames <- dotNames } else { noName <- which(fitNames == "") fitNames[noName] <- dotNames[noName] } names(fitList) <- paste(fitNames, " (df = ", DFs, ")", sep = "") ## sort list according to DFs fitList <- fitList[order(DFs)] fitNames <- fitNames[order(DFs)] orderedDFs <- DFs[order(DFs)] ## create structure for sequence of tests (logical matrix), FALSE by default nestMat <- matrix(FALSE, length(fitList), length(fitList), dimnames = list(names(fitList), fitNames)) diag(nestMat) <- TRUE # every model is equivalent with itself ## Loop through sorted models in sequence of most to least restricted model for (R in 2:nrow(nestMat)) { for (C in (R - 1):1) { ## test for nesting/equivalence nestMat[R, C] <- x.within.y(x = fitList[[R]], y = fitList[[C]], crit = crit) ## if models are equivalent, set above-diagonal value to TRUE if (identical(orderedDFs[R], orderedDFs[C])) nestMat[C, R] <- nestMat[R, C] if (C == 1) next # to prevent the next 2 tests from returning an error ## if model didn't converge (logical value is missing), go to next iteration if (is.na(nestMat[R, C]) | is.na(nestMat[R - 1, C - 1])) next ## check whether nesting is implied, to skip unnecessary tests if (nestMat[R, C] & nestMat[R - 1, C - 1]) { nestMat[R, C - 1] <- TRUE next } } } out <- new("Net", test = nestMat, df = orderedDFs) out } ## -------------------------------------------------------------------- ## Hidden Function to test whether model "x" is nested within model "y" ## -------------------------------------------------------------------- #' @importFrom lavaan lavInspect lavNames parTable x.within.y <- function(x, y, crit = .0001) { if (!lavInspect(x, "converged")) return(NA) if (!lavInspect(y, "converged")) return(NA) ## not possible for clustered data if (length(lavInspect(x, "cluster")) || length(lavInspect(y, "cluster"))) stop('The net() function does not work with models for clustered data.') ## not currently implemented unless all variables are considered random exoX <- lavInspect(x, "options")$fixed.x & length(lavNames(x, "ov.x")) exoY <- lavInspect(y, "options")$fixed.x & length(lavNames(y, "ov.x")) if (exoX | exoY) { stop(c("The net() function does not work with exogenous variables.\n", "Fit the model again with 'fixed.x = FALSE'")) } ## variable names Xnames <- sort(lavNames(x)) Ynames <- sort(lavNames(y)) if (!identical(Xnames, Ynames)) stop("Models do not contain the same variables") ## check that the analyzed data matches xData <- sort(unlist(lavInspect(x, "sampstat"))) yData <- sort(unlist(lavInspect(y, "sampstat"))) names(xData) <- NULL names(yData) <- NULL if (!isTRUE(all.equal(xData, yData, tolerance = crit))) stop("Sample statistics differ. Models must apply to the same data") #FIXME: this method requires raw data # xData <- lavInspect(x, "data") # if (is.list(xData)) xData <- do.call(rbind, xData) # xData <- xData[ , order(Xnames)] # yData <- lavInspect(y, "data") # if (is.list(yData)) yData <- do.call(rbind, yData) # yData <- yData[ , order(Ynames)] # if (!identical(xData, yData)) stop("Models must apply to the same data") ## check degrees of freedom support nesting structure if (lavInspect(x, "fit")["df"] < lavInspect(y, "fit")["df"]) stop("x cannot be nested within y because y is more restricted than x") ## check sample sizes N <- lavInspect(x, "nobs") if (!all(N == lavInspect(y, "nobs"))) { stop("Sample sizes differ. Models must apply to the same data") } ## model-implied moments Sigma <- lavInspect(x, "cov.ov") nBlocks <- if (is.list(Sigma)) length(Sigma) else 1L ## mean structure? Mu <- lavInspect(x, "mean.ov") if (nBlocks == 1L) { if (!length(Mu)) Mu <- NULL } else { if (all(sapply(Mu, length) == 0)) Mu <- NULL } ## thresholds? Thr <- lavInspect(x, "thresholds") if (nBlocks == 1L) { if (!length(Thr)) Thr <- NULL } else { if (all(sapply(Thr, length) == 0)) Thr <- NULL } if (!is.null(Thr)) attr(Thr, "th.idx") <- lavInspect(x, "th.idx") ## If DWLS, extract WLS.V and NACOV estimator <- lavInspect(x, "options")$estimator if (estimator == "DWLS") { WLS.V <- lavInspect(x, "WLS.V") NACOV <- lavInspect(x, "gamma") #TODO: check against same output from y } else { WLS.V <- NULL NACOV <- NULL } ## fit model and check that chi-squared < crit PT <- parTable(y) PT$start <- PT$est PT$est <- PT$se <- NULL CALL <- lavInspect(y, "call") CALL$model <- PT CALL$data <- NULL CALL$sample.cov <- Sigma CALL$sample.mean <- Mu CALL$sample.nobs <- N CALL$sample.th <- Thr CALL$estimator <- estimator CALL$WLS.V <- WLS.V CALL$NACOV <- NACOV CALL$se <- "none" # to save time CALL$test <- "standard" CALL$group.label <- NULL # unnecessary, and causes an error when is.integer() suppressWarnings(try( newFit <- eval(as.call(CALL)) )) if (!lavInspect(newFit, "converged")) return(NA) else { result <- lavInspect(newFit, "fit")[["chisq"]] < crit if (lavInspect(x, "fit")["df"] == lavInspect(y, "fit")["df"]) return(c(Equivalent = result)) } c(Nested = result) } semTools/R/splitSample.R0000644000176200001440000001330414632016456014710 0ustar liggesusers### Corbin Quick ### Last updated: 4 April 2017 #' Randomly Split a Data Set into Halves #' #' This function randomly splits a data set into two halves, and saves the #' resulting data sets to the same folder as the original. #' #' This function randomly orders the rows of a data set, divides the data set #' into two halves, and saves the halves to the same folder as the original #' data set, preserving the original formatting. Data set type (*.csv or *.dat) #' and formatting (headers) are automatically detected, and output data sets #' will preserve input type and formatting unless specified otherwise. Input #' can be in the form of a file path (*.dat or *.csv), or an R object (matrix or #' dataframe). If input is an R object and path is default, output data sets #' will be returned as a list object. #' #' #' @importFrom stats runif #' #' @param dataset The original data set to be divided. Can be a file path to a #' *.csv or *.dat file (headers will automatically be detected) or an R object #' (matrix or dataframe). (Windows users: file path must be specified using #' FORWARD SLASHES (`/`) ONLY.) #' @param path File path to folder for output data sets. NOT REQUIRED if #' dataset is a filename. Specify ONLY if dataset is an R object, or desired #' output folder is not that of original data set. If path is specified as #' "object", output data sets will be returned as a list, and not saved to hard #' drive. #' @param div Number of output data sets. NOT REQUIRED if default, 2 halves. #' @param type Output file format ("dat" or "csv"). NOT REQUIRED unless desired #' output formatting differs from that of input, or dataset is an R object and #' csv formatting is desired. #' @param name Output file name. NOT REQUIRED unless desired output name #' differs from that of input, or input dataset is an R object. (If input is an #' R object and name is not specified, name will be "splitSample".) #' @return If `path = "object"`, `list` of output data sets. #' Otherwise, output will saved to hard drive in the same format as input. #' @author Corbin Quick (University of Michigan; \email{corbinq@@umich.edu}) #' @examples #' #' #### Input is .dat file #' #splitSample("C:/Users/Default/Desktop/MYDATA.dat") #' #### Output saved to "C:/Users/Default/Desktop/" in .dat format #' #### Names are "MYDATA_s1.dat" and "MYDATA_s2.dat" #' #' #### Input is R object #' ## Split C02 dataset from the datasets package #' library(datasets) #' splitMyData <- splitSample(CO2, path = "object") #' summary(splitMyData[[1]]) #' summary(splitMyData[[2]]) #' #### Output object splitMyData becomes list of output data sets #' #' #### Input is .dat file in "C:/" folder #' #splitSample("C:/testdata.dat", path = "C:/Users/Default/Desktop/", type = "csv") #' #### Output saved to "C:/Users/Default/Desktop/" in *.csv format #' #### Names are "testdata_s1.csv" and "testdata_s2.csv" #' #' #### Input is R object #' #splitSample(myData, path = "C:/Users/Default/Desktop/", name = "splitdata") #' #### Output saved to "C:/Users/Default/Desktop/" in *.dat format #' #### Names are "splitdata_s1.dat" and "splitdata_s2.dat" #' #' @export splitSample <- function(dataset, path = "default", div = 2, type = "default", name = "splitSample") { type1 <- type hea = FALSE file <- dataset if (is.character(file)) { temp <- strsplit(file, "/", fixed = TRUE) if (path == "default") { path <- paste(temp[[1]][1:(length(temp[[1]]) - 1)], "/", sep = "", collapse = "") } fileN <- temp[[1]][length(temp[[1]])] temp <- strsplit(fileN, ".", fixed = TRUE) type <- temp[[1]][2] name <- temp[[1]][1] if (type == "dat") { if (is.numeric(as.matrix(utils::read.table(file, nrows = 1))) == FALSE) { data <- as.matrix(utils::read.table(file, header = TRUE)) hea = TRUE } else { data <- as.matrix(utils::read.table(file)) } } if (type == "csv") { if (is.numeric(as.matrix(utils::read.table(file, nrows = 1))) == FALSE) { data <- as.matrix(utils::read.csv(file, header = TRUE)) hea = TRUE } else { data <- as.matrix(utils::read.csv(file)) } } } else { if (is.matrix(file) | is.data.frame(file)) { data <- as.matrix(file) } else { stop("Provide data in *.dat or *.csv format") } } if (type1 != "default") { type <- type1 } if (is.character(colnames(data))) { hea = TRUE } random <- runif(nrow(data), 1, nrow(data)) data <- cbind(random, data) data <- data[order(random), ] data <- data[, 2:ncol(data)] size <- split((1:nrow(data)), cut((1:nrow(data)), div, labels = FALSE)) size <- as.matrix(as.data.frame(lapply(size, length))) dataL <- list() dataL[[1]] <- data[1:size[1, 1], ] for (i in 2:div) { size[1, i] <- size[1, (i - 1)] + size[1, i] dataL[[i]] <- data[(size[1, (i - 1)] + 1):size[1, i], ] } if (path == "default") { return(dataL) } else { if (path == "object") { return(dataL) } else { for (i in 1:div) { if (type == "dat") { utils::write.table(dataL[[i]], paste(path, name, "_s", i, ".dat", sep = ""), sep = " ", row.names = FALSE, col.names = hea) } if (type == "csv") { utils::write.table(dataL[[i]], paste(path, name, "_s", i, ".csv", sep = ""), sep = ",", row.names = FALSE, col.names = hea) } if (type == "default") { utils::write.table(dataL[[i]], paste(path, name, "_s", i, ".dat", sep = ""), sep = " ", row.names = FALSE, col.names = hea) } } } } } semTools/R/aa_semTools-deprecated.R0000644000176200001440000000101114632016456016747 0ustar liggesusers### Terrence D. Jorgensen ### Last updated 25 August 2018 ### automatically create documentation for "deprecated" help page #' @title Deprecated functions in package \pkg{semTools}. #' @description The functions listed below are deprecated and will be defunct #' in the near future. When possible, alternative functions with similar #' functionality are also mentioned. Help pages for deprecated functions are #' available at `help("semTools-deprecated")`. #' @name semTools-deprecated #' @keywords internal NULL semTools/R/longInvariance.R0000644000176200001440000006162514753124664015370 0ustar liggesusers### Sunthud Pornprasertmanit & Yves Rosseel ### Last updated: 10 January 2021 ##' Measurement Invariance Tests Within Person ##' ##' Testing measurement invariance across timepoints (longitudinal) or any ##' context involving the use of the same scale in one case (e.g., a dyad case ##' with husband and wife answering the same scale). The measurement invariance ##' uses a typical sequence of model comparison tests. This function currently ##' works with only one scale, and only with continuous indicators. ##' ##' If `strict = FALSE`, the following four models are tested in order: ##' \enumerate{ ##' \item Model 1: configural invariance. The same factor structure is ##' imposed on all units. ##' \item Model 2: weak invariance. The factor loadings are constrained to be ##' equal across units. ##' \item Model 3: strong invariance. The factor loadings and intercepts are ##' constrained to be equal across units. ##' \item Model 4: The factor loadings, intercepts and means are constrained to ##' be equal across units. ##' } ##' ##' Each time a more restricted model is fitted, a \eqn{\Delta\chi^2} test is ##' reported, comparing the current model with the previous one, and comparing ##' the current model to the baseline model (Model 1). In addition, the ##' difference in CFA is also reported (\eqn{\Delta}CFI). ##' ##' If `strict = TRUE`, the following five models are tested in order: ##' ##' \enumerate{ ##' \item Model 1: configural invariance. The same factor structure is imposed ##' on all units. ##' \item Model 2: weak invariance. The factor loadings are constrained to be ##' equal across units. ##' \item Model 3: strong invariance. The factor loadings and intercepts are ##' constrained to be equal across units. ##' \item Model 4: strict invariance. The factor loadings, intercepts and ##' residual variances are constrained to be equal across units. ##' \item Model 5: The factor loadings, intercepts, residual variances and ##' means are constrained to be equal across units. ##' } ##' ##' Note that if the \eqn{\chi^2} test statistic is scaled (eg. a Satorra-Bentler ##' or Yuan-Bentler test statistic), a special version of the \eqn{\Delta\chi^2} ##' test is used as described in ##' ##' ##' @param model lavaan syntax or parameter table ##' @param varList A list containing indicator names of factors used in the ##' invariance testing, such as the list that the first element is the vector ##' of indicator names in the first timepoint and the second element is the ##' vector of indicator names in the second timepoint. The order of indicator ##' names should be the same (but measured in different times or different ##' units). ##' @param auto The order of autocorrelation on the measurement errors on the ##' similar items across factor (e.g., Item 1 in Time 1 and Time 2). If 0 is ##' specified, the autocorrelation will be not imposed. If 1 is specified, ##' the autocorrelation will imposed for the adjacent factor listed in ##' `varList`. The maximum number can be specified is the number of ##' factors specified minus 1. If `"all"` is specified, the maximum ##' number of order will be used. ##' @param constrainAuto If `TRUE`, the function will equate the ##' auto-*covariance* to be equal within the same item across factors. ##' For example, the covariance of item 1 in time 1 and time 2 is equal to ##' the covariance of item 1 in time 2 and time 3. ##' @param fixed.x See [lavaan::lavOptions()]. ##' @param std.lv See [lavaan::lavOptions()]. ##' @param group See [lavaan::lavaan()]. ##' @param group.equal See [lavaan::lavOptions()]. ##' @param group.partial See [lavaan::lavOptions()]. ##' @param strict If `TRUE`, the sequence requires strict invariance. See ##' @param warn See See [lavaan::lavOptions()]. ##' @param debug See See [lavaan::lavOptions()]. details for more information. ##' @param quiet If `FALSE` (default), a summary is printed out containing ##' an overview of the different models that are fitted, together with some ##' model comparison tests. If `TRUE`, no summary is printed. ##' @param fit.measures Fit measures used to calculate the differences between ##' nested models. ##' @param baseline.model custom baseline model passed to ##' [lavaan::fitMeasures()] ##' @param method The method used to calculate likelihood ratio test. See ##' [lavaan::lavTestLRT()] for available options ##' @param ... Additional arguments in the [lavaan::lavaan()] ##' function. See also [lavaan::lavOptions()] ##' ##' @return Invisibly, all model fits in the sequence are returned as a list. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references Vandenberg, R. J., and Lance, C. E. (2000). A review and ##' synthesis of the measurement invariance literature: Suggestions, ##' practices, and recommendations for organizational research. ##' *Organizational Research Methods, 3*(1), 4--70. ##' \doi{10.1177/109442810031002} ##' ##' @examples ##' ##' model <- ' f1t1 =~ y1t1 + y2t1 + y3t1 ##' f1t2 =~ y1t2 + y2t2 + y3t2 ##' f1t3 =~ y1t3 + y2t3 + y3t3 ' ##' ##' ## Create list of variables ##' var1 <- c("y1t1", "y2t1", "y3t1") ##' var2 <- c("y1t2", "y2t2", "y3t2") ##' var3 <- c("y1t3", "y2t3", "y3t3") ##' constrainedVar <- list(var1, var2, var3) ##' ##' ## Invariance of the same factor across timepoints ##' longInvariance(model, auto = 1, constrainAuto = TRUE, ##' varList = constrainedVar, data = exLong) ##' ##' ## Invariance of the same factor across timepoints and groups ##' longInvariance(model, auto = 1, constrainAuto = TRUE, ##' varList = constrainedVar, data = exLong, group = "sex", ##' group.equal = c("loadings", "intercepts")) ##' ##' @name longInvariance-deprecated ##' @usage ##' longInvariance(model, varList, auto = "all", constrainAuto = FALSE, ##' fixed.x = TRUE, std.lv = FALSE, group = NULL, ##' group.equal = "", group.partial = "", strict = FALSE, ##' warn = TRUE, debug = FALSE, quiet = FALSE, ##' fit.measures = "default", baseline.model = NULL, ##' method = "satorra.bentler.2001", ...) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' ##' @export longInvariance <- function(model, varList, auto = "all", constrainAuto = FALSE, fixed.x = TRUE, std.lv = FALSE, group = NULL, group.equal = "", group.partial = "", strict = FALSE, warn = TRUE, debug = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001", ...) { .Deprecated(msg = c("The longInvariance function is deprecated, and ", "it will cease to be included in future versions of ", "semTools. See help('semTools-deprecated) for details.")) List <- list(...) # Find the number of groups ngroups <- 1 if (!is.null(group)) { if (!is.null(List$data)) { ngroups <- length(unique(List$data[,group])) } else if (!is.null(List$sample.cov)) { ngroups <- length(List$sample.cov) } else { stop("Cannot find the specifying variable name in the 'group' argument.") } } # Get the lavaan parameter table if (is.character(model)) { lavaanParTable <- lavaan::lavaanify(model = model, meanstructure = TRUE, int.ov.free = TRUE, int.lv.free = FALSE, orthogonal = FALSE, fixed.x = fixed.x, std.lv = std.lv, auto.fix.first = ifelse(std.lv, FALSE, TRUE), auto.fix.single = TRUE, auto.var = TRUE, auto.cov.lv.x = TRUE, auto.cov.y = TRUE, ngroups = ngroups, group.equal = group.equal, group.partial = group.partial, debug = debug, warn = warn, as.data.frame. = TRUE) } else if (is.list(model)) { if (!is.null(model$lhs) && !is.null(model$op) && !is.null(model$rhs) && !is.null(model$free)) { lavaanParTable <- model } else if (is.character(model[[1]])) { stop("lavaan ERROR: model is a list, but not a parameterTable?") } } else { cat("model type: ", class(model), "\n") stop("lavaan ERROR: model is not of type character or list") } # Error checking on the varList argument and get the factor name corresponding to each elements of the list facName <- lapply(varList, function(vec, pt) pt$lhs[(pt$op == "=~") & (pt$rhs %in% vec)], pt = lavaanParTable) if (any(sapply(facName, function(x) length(unique(x)) > 1))) stop("The factor names of the same element of the 'varList' are not the same.") if (length(unique(sapply(facName, function(x) length(x)))) > 1) stop("The numbers of variables in each element are not equal.") facName <- unlist(lapply(facName, unique)) # Impose the autocorrelation in the parameter table if (auto != 0) { if (is.numeric(auto) && auto >= length(varList)) stop("The number of lag in auto-correlation is not possible in the current number of timepoints.") if (auto == "all") auto <- length(varList) - 1 for (k in 1:ngroups) { for (i in 1:length(varList[[1]])) { name <- sapply(varList, function(x, element) x[element], element = i) for (j in 1:auto) { vec <- 1:(length(varList) - j) lavaanParTable <- freeParTable(lavaanParTable, name[vec], "~~", name[vec + j], k, ustart = NA) if (constrainAuto & (length(vec) > 1)) lavaanParTable <- constrainParTable(lavaanParTable, name[vec], "~~", name[vec + j], k) } } } } # Fit configural invariance fitConfigural <- try(lavaan::lavaan(lavaanParTable, ..., group = group, group.equal = group.equal, group.partial = group.partial, warn = TRUE, debug = FALSE), silent = TRUE) # Create the parameter table for metric invariance ptMetric <- lavaanParTable if (std.lv) { for (k in 1:ngroups) { # Free variances of factor 2, 3, ... ptMetric <- freeParTable(ptMetric, facName[-1], "~~", facName[-1], k, ustart = NA) # Constrain factor loadings for (i in 1:length(varList[[1]])) { ptMetric <- constrainParTable(ptMetric, facName, "=~", sapply(varList, function(x, element) x[element], element = i), k) } } ptMetric$ustart[(ptMetric$op == "=~") & (ptMetric$rhs %in% sapply(varList, function(x, element) x[element], element = 1))] <- 1 } else { for (k in 1:ngroups) { # Constrain factor loadings but keep marker variables for (i in 2:length(varList[[1]])) { ptMetric <- constrainParTable(ptMetric, facName, "=~", sapply(varList, function(x, element) x[element], element = i), k) } } } fitMetric <- try(lavaan::lavaan(ptMetric, ..., group = group, group.equal = group.equal, group.partial = group.partial, warn = TRUE, debug = FALSE), silent = TRUE) # Create the parameter table for scalar invariance ptScalar <- ptMetric for (k in 1:ngroups) { # Free means of factors 2, 3, ... ptScalar <- freeParTable(ptScalar, facName[-1], "~1", "", k, ustart = NA) # Constrain measurement intercepts for (i in 1:length(varList[[1]])) { ptScalar <- constrainParTable(ptScalar, sapply(varList, function(x, element) x[element], element = i), "~1", "", k) } } ptScalar$ustart[(ptMetric$op == "~1") & (ptMetric$rhs %in% facName)] <- 0 fitScalar <- try(lavaan::lavaan(ptScalar, ..., group = group, group.equal = group.equal, group.partial = group.partial, warn = TRUE, debug = FALSE), silent = TRUE) ptMeans <- ptScalar # Create the parameter table for strict invariance if specified ptStrict <- ptScalar fitStrict <- NULL if (strict) { ptStrict <- ptScalar for (k in 1:ngroups) { # Constrain measurement error variances for (i in 1:length(varList[[1]])) { name <- sapply(varList, function(x, element) x[element], element = i) ptStrict <- constrainParTable(ptStrict, name, "~~", name, k) } } fitStrict <- try(lavaan::lavaan(ptStrict, ..., group = group, group.equal = group.equal, group.partial = group.partial, warn = TRUE, debug = FALSE), silent = TRUE) ptMeans <- ptStrict } # Create the parameter table for mean equality # Constrain factor means to be equal for (k in 1:ngroups) { ptMeans <- fixParTable(ptMeans, facName[-1], "~1", "", k, ustart = 0) } fitMeans <- try(lavaan::lavaan(ptMeans, ..., group = group, group.equal = group.equal, group.partial = group.partial, warn = TRUE, debug = FALSE), silent = TRUE) FIT <- invisible(list(fit.configural = fitConfigural, fit.loadings = fitMetric, fit.intercepts = fitScalar, fit.residuals = fitStrict, fit.means = fitMeans)) FIT <- FIT[!sapply(FIT, is.null)] if (!quiet) printInvarianceResult(FIT, fit.measures, baseline.model, method) # Modify these functions from measurementInvariance function # if(!quiet) { # cat("\n#################### Measurement invariance tests ####################\n") # cat("\nThe order of autocorrelation: ", auto, "\n") # cat("\n#################### Model 1: configural invariance:\n") # printFitLine(fitConfigural) # cat("\n#################### Model 2: weak invariance (equal loadings):\n") # printFitLine(fitMetric) # cat("\n[Model 1 versus model 2]\n") # difftest(fitConfigural, fitMetric) # cat("\n#################### Model 3: strong invariance (equal loadings + intercepts):\n") # printFitLine(fitScalar) # cat("\n[Model 1 versus model 3]\n") # difftest(fitConfigural, fitScalar) # cat("\n[Model 2 versus model 3]\n") # difftest(fitMetric, fitScalar) # if(strict) { # cat("\n#################### Model 4: strict invariance (equal loadings + intercepts + residuals):\n") # printFitLine(fitStrict) # cat("\n[Model 1 versus model 4]\n") # difftest(fitConfigural, fitStrict) # cat("\n[Model 2 versus model 4]\n") # difftest(fitMetric, fitStrict) # cat("\n[Model 3 versus model 4]\n") # difftest(fitScalar, fitStrict) # cat("\n#################### Model 5: equal loadings + intercepts + residuals + means:\n") # printFitLine(fitMeans, horizontal=TRUE) # cat("\n[Model 1 versus model 5]\n") # difftest(fitConfigural, fitMeans) # cat("\n[Model 2 versus model 5]\n") # difftest(fitMetric, fitMeans) # cat("\n[Model 3 versus model 5]\n") # difftest(fitScalar, fitMeans) # cat("\n[Model 4 versus model 5]\n") # difftest(fitStrict, fitMeans) # } else { # cat("\n#################### Model 4: equal loadings + intercepts + means:\n") # printFitLine(fitMeans) # cat("\n[Model 1 versus model 4]\n") # difftest(fitConfigural, fitMeans) # cat("\n[Model 2 versus model 4]\n") # difftest(fitMetric, fitMeans) # cat("\n[Model 3 versus model 4]\n") # difftest(fitScalar, fitMeans) # } # } # return(invisible(list(fit.configural = fitConfigural, fit.loadings = fitMetric, fit.intercepts = fitScalar, fit.residuals = fitStrict, fit.means = fitMeans))) invisible(FIT) } ## ---------------- ## Hidden Functions ## ---------------- # rearrangeFreeElement: Rearrange the number listed in 'free' in parameter tables rearrangeFreeElement <- function(vec) { vec2 <- vec vec <- vec[vec != 0] uvec <- unique(vec) newvec <- 1:length(unique(vec)) vec2[vec2 != 0] <- newvec[match(vec, uvec)] class(vec2) <- "integer" vec2 } # rearrangept: Rearrange parameter table and plabel rearrangept <- function(pt) { createplabel <- function(num) { result <- paste0(".p", num, ".") result[num == 0] <- "" result } oldfree <- pt$free newfree <- rearrangeFreeElement(oldfree) oldplabel <- pt$plabel newplabel <- createplabel(seq_along(pt$op)) eqpos <- which(pt$op == "==") newplabel[eqpos] <- "" if (length(eqpos) > 0) { eqlhs <- pt$lhs[eqpos] eqrhs <- pt$rhs[eqpos] matchlhs <- match(eqlhs, oldplabel) matchrhs <- match(eqrhs, oldplabel) neweqlhs <- newplabel[matchlhs] neweqrhs <- newplabel[matchrhs] neweqlhs[is.na(matchlhs)] <- eqlhs[is.na(matchlhs)] neweqrhs[is.na(matchrhs)] <- eqrhs[is.na(matchrhs)] pt$lhs[eqpos] <- neweqlhs pt$rhs[eqpos] <- neweqrhs } pt$free <- newfree pt$plabel <- newplabel pt } # freeParTable: Free elements in parameter table #FIXME: used in singleParamTest and partialInvariance freeParTable <- function(parTable, lhs, op, rhs, group, ustart = NA) { parTable$start <- parTable$est <- parTable$se <- NULL target <- cbind(lhs, op, rhs, group) for (i in 1:nrow(target)) { targetElem <- matchElement(parTable = parTable, vec = target[i,]) ptargetElem <- parTable$plabel[targetElem] if ((length(targetElem) == 0) || is.na(targetElem)) { newline <- list(lhs = as.character(target[i, 1]), op = as.character(target[i, 2]), rhs = as.character(target[i, 3]), group = as.integer(target[i, 4]), free = as.integer(max(parTable$free) + 1), ustart = as.numeric(NA)) parTable <- patMerge(pt1 = parTable, pt2 = newline) } else { if (parTable$free[targetElem] == 0) { parTable$ustart[targetElem] <- ustart parTable$user[targetElem] <- 1 parTable$free[targetElem] <- max(parTable$free) + 1 } equalelement <- which(parTable$op == "==") rmelem <- intersect(union(match(ptargetElem, parTable$lhs), match(ptargetElem, parTable$rhs)), equalelement) if (length(rmelem) > 0) parTable <- removeEqCon(parTable, rmelem) } } parTable <- rearrangept(parTable) parTable } # fixParTable: Fix elements in parameter table #FIXME: used in singleParamTest and partialInvariance fixParTable <- function(parTable, lhs, op, rhs, group, ustart = NA) { parTable$start <- parTable$est <- parTable$se <- NULL target <- cbind(lhs, op, rhs, group) element <- apply(target, 1, matchElement, parTable=parTable) for (i in 1:nrow(target)) { ## Why was Sunthud printing warnings? (originally used warnings(), not warning()...) # if (parTable$free[element[i]] == 0) warning('The parameter ', lhs, op, rhs, # ' in group ', group, # ' is already fixed.') # equalelement <- which(parTable$op == "==") # targetElem <- matchElement(parTable = parTable, vec = target[i,]) # ptargetElem <- parTable$plabel[targetElem] # rmelem <- intersect(union(match(ptargetElem, parTable$lhs), match(ptargetElem, parTable$rhs)), equalelement) # if(length(rmelem) > 0) parTable <- removeEqCon(parTable, rmelem) parTable$ustart[element[i]] <- ustart parTable$user[element[i]] <- 1 parTable$free[element[i]] <- 0 } parTable <- rearrangept(parTable) # rearrangePlabel with change all equality constraints parTable } # constrainParTable: Impose equality constraints in any set of elements in the parameter table #FIXME: used in partialInvariance constrainParTable <- function(parTable, lhs, op, rhs, group) { parTable$start <- parTable$est <- parTable$se <- NULL target <- cbind(lhs, op, rhs, group) element <- apply(target, 1, matchElement, parTable=parTable) # id lhs op rhs user group free ustart exo label plabel start for (i in 2:length(element)) { len <- length(parTable$id) newline <- list(lhs = parTable$plabel[element[1]], op = "==", rhs = parTable$plabel[element[i]]) if (!any(parTable$lhs == newline$lhs & parTable$op == newline$op & parTable$rhs == newline$rhs)) parTable <- patMerge(pt1 = parTable, pt2 = newline) } parTable } # matchElement: Find the number of row that have the specification in vec (lhs, op, rhs, group) #FIXME: used in partialInvariance matchElement <- function(parTable, vec) { if (is.null(parTable$group)) { return(which((parTable$lhs == vec[1]) & (parTable$op == vec[2]) & (parTable$rhs == vec[3]))) } else { return(which((parTable$lhs == vec[1]) & (parTable$op == vec[2]) & (parTable$rhs == vec[3]) & (parTable$group == vec[4]))) } } #FIXME: used in partialInvariance getValue <- function(parTable, est, lhs, op, rhs, group) { target <- cbind(lhs, op, rhs, group) element <- apply(target, 1, matchElement, parTable = parTable) free <- parTable$free[element] out <- parTable$ustart[element] out[free != 0] <- est[free[free != 0]] out } # removeEqCon: Remove equality constraints #FIXME: used in singleParamTest removeEqCon <- function(pt, element) { pt <- lapply(pt, "[", -element) pt$id <- seq_along(pt$id) pt } #FIXME: used in singleParamTest patMerge <- function (pt1 = NULL, pt2 = NULL, remove.duplicated = FALSE, fromLast = FALSE, warn = TRUE) { pt1 <- as.data.frame(pt1, stringsAsFactors = FALSE) pt2 <- as.data.frame(pt2, stringsAsFactors = FALSE) stopifnot(!is.null(pt1$lhs), !is.null(pt1$op), !is.null(pt1$rhs), !is.null(pt2$lhs), !is.null(pt2$op), !is.null(pt2$rhs)) if (is.null(pt1$group) && is.null(pt2$group)) { TMP <- rbind(pt1[, c("lhs", "op", "rhs", "group")], pt2[, c("lhs", "op", "rhs", "group")]) } else { if (is.null(pt1$group) && !is.null(pt2$group)) { pt1$group <- rep(1L, length(pt1$lhs)) } else if (is.null(pt2$group) && !is.null(pt1$group)) { pt2$group <- rep(1L, length(pt2$lhs)) } TMP <- rbind(pt1[, c("lhs", "op", "rhs", "group")], pt2[, c("lhs", "op", "rhs", "group")]) } if (is.null(pt1$user) && !is.null(pt2$user)) { pt1$user <- rep(0L, length(pt1$lhs)) } else if (is.null(pt2$user) && !is.null(pt1$user)) { pt2$user <- rep(0L, length(pt2$lhs)) } if (is.null(pt1$free) && !is.null(pt2$free)) { pt1$free <- rep(0L, length(pt1$lhs)) } else if (is.null(pt2$free) && !is.null(pt1$free)) { pt2$free <- rep(0L, length(pt2$lhs)) } if (is.null(pt1$ustart) && !is.null(pt2$ustart)) { pt1$ustart <- rep(0, length(pt1$lhs)) } else if (is.null(pt2$ustart) && !is.null(pt1$ustart)) { pt2$ustart <- rep(0, length(pt2$lhs)) } if (is.null(pt1$exo) && !is.null(pt2$exo)) { pt1$exo <- rep(0L, length(pt1$lhs)) } else if (is.null(pt2$exo) && !is.null(pt1$exo)) { pt2$exo <- rep(0L, length(pt2$lhs)) } if (is.null(pt1$label) && !is.null(pt2$label)) { pt1$label <- rep("", length(pt1$lhs)) } else if (is.null(pt2$label) && !is.null(pt1$label)) { pt2$label <- rep("", length(pt2$lhs)) } if (is.null(pt1$plabel) && !is.null(pt2$plabel)) { pt1$plabel <- rep("", length(pt1$lhs)) } else if (is.null(pt2$plabel) && !is.null(pt1$plabel)) { pt2$plabel <- rep("", length(pt2$lhs)) } if (is.null(pt1$start) && !is.null(pt2$start)) { pt1$start <- rep(as.numeric(NA), length(pt1$lhs)) } else if (is.null(pt2$start) && !is.null(pt1$start)) { pt2$start <- rep(as.numeric(NA), length(pt2$lhs)) } if (!is.null(pt1$est)) pt1$est <- NULL if (!is.null(pt2$est)) pt2$est <- NULL if (!is.null(pt1$se)) pt1$se <- NULL if (!is.null(pt2$se)) pt2$se <- NULL if (remove.duplicated) { idx <- which(duplicated(TMP, fromLast = fromLast)) if (length(idx)) { if (warn) { warning("lavaan WARNING: duplicated parameters are ignored:\n", paste(apply(pt1[idx, c("lhs", "op", "rhs")], 1, paste, collapse = " "), collapse = "\n")) } if (fromLast) { pt1 <- pt1[-idx, ] } else { idx <- idx - nrow(pt1) pt2 <- pt2[-idx, ] } } } else if (!is.null(pt1$start) && !is.null(pt2$start)) { for (i in 1:length(pt1$lhs)) { idx <- which(pt2$lhs == pt1$lhs[i] & pt2$op == pt1$op[i] & pt2$rhs == pt1$rhs[i] & pt2$group == pt1$group[i]) pt2$start[idx] <- pt1$start[i] } } if (is.null(pt1$id) && !is.null(pt2$id)) { nid <- max(pt2$id) pt1$id <- (nid + 1L):(nid + nrow(pt1)) } else if (is.null(pt2$id) && !is.null(pt1$id)) { nid <- max(pt1$id) pt2$id <- (nid + 1L):(nid + nrow(pt2)) } NEW <- base::merge(pt1, pt2, all = TRUE, sort = FALSE) NEW } semTools/R/reliability.R0000644000176200001440000037242314753073401014733 0ustar liggesusers### Sunthud Pornprasertmanit, Terrence D. Jorgensen, Yves Rosseel ### Last updated: 12 February 2025 ## ----------------------------- ## AVE() ## average variance extracted ## (not a reliability index) ## ----------------------------- ##' Calculate average variance extracted ##' ##' Calculate average variance extracted (AVE) per factor from `lavaan` object ##' ##' The average variance extracted (AVE) can be calculated by ##' ##' \deqn{ AVE = \frac{\bold{1}^\prime ##' \textrm{diag}\left(\Lambda\Psi\Lambda^\prime\right)\bold{1}}{\bold{1}^\prime ##' \textrm{diag}\left(\hat{\Sigma}\right) \bold{1}}, } ##' ##' Note that this formula is modified from Fornell & Larcker (1981) in the case ##' that factor variances are not 1. The proposed formula from Fornell & Larcker ##' (1981) assumes that the factor variances are 1. Note that AVE will not be ##' provided for factors consisting of items with dual loadings. AVE is the ##' property of items but not the property of factors. AVE is calculated with ##' polychoric correlations when ordinal indicators are used. ##' ##' @importFrom lavaan lavInspect ##' @importFrom methods getMethod ##' ##' @param object A [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object, ##' expected to contain only exogenous common factors (i.e., a CFA model). ##' Cross-loadings are not allowed and will result in `NA` for any factor with ##' indicator(s) that cross-load. ##' @param obs.var `logical` indicating whether to compute AVE using ##' observed variances in the denominator. Setting `FALSE` triggers ##' using model-implied variances in the denominator. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' @param omit.factors `character` vector naming any common factors ##' modeled in `object` whose indicators' AVE is not of interest. ##' @param dropSingle `logical` indicating whether to exclude factors ##' defined by a single indicator from the returned results. If `TRUE` ##' (default), single indicators will still be included in the `total` ##' column when `return.total = TRUE`. ##' @param return.df `logical` indicating whether to return reliability ##' coefficients in a `data.frame` (one row per group/level), which is ##' possible when every model block includes the same factors (after excluding ##' those in `omit.factors` and applying `dropSingle`). ##' ##' @return `numeric` vector of average variance extracted from indicators ##' per factor. For models with multiple "blocks" (any combination of groups ##' and levels), vectors may be returned as columns in a `data.frame` ##' with additional columns indicating the group/level (see `return.df=` ##' argument description for caveat). ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Fornell, C., & Larcker, D. F. (1981). Evaluating structural equation models ##' with unobservable variables and measurement errors. *Journal of ##' Marketing Research, 18*(1), 39--50. \doi{10.2307/3151312} ##' ##' @seealso [compRelSEM()] for composite reliability estimates ##' ##' @examples ##' data(HolzingerSwineford1939) ##' HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] ##' HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) ##' names(HSbinary) <- c("y7","y8","y9") ##' HS <- cbind(HolzingerSwineford1939, HSbinary) ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ y7 + y8 + y9 ' ##' ##' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ##' ##' ## works for factors with exclusively continuous OR categorical indicators ##' AVE(fit) # uses observed (or unconstrained polychoric/polyserial) by default ##' AVE(fit, obs.var = FALSE) ##' ##' ##' ## works for multigroup models and for multilevel models (and both) ##' data(Demo.twolevel) ##' ## assign clusters to arbitrary groups ##' Demo.twolevel$g <- ifelse(Demo.twolevel$cluster %% 2L, "type1", "type2") ##' model2 <- ' group: type1 ##' level: within ##' fac =~ y1 + L2*y2 + L3*y3 ##' level: between ##' fac =~ y1 + L2*y2 + L3*y3 ##' ##' group: type2 ##' level: within ##' fac =~ y1 + L2*y2 + L3*y3 ##' level: between ##' fac =~ y1 + L2*y2 + L3*y3 ##' ' ##' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") ##' AVE(fit2) ##' ##'@export AVE <- function(object, obs.var = TRUE, omit.imps = c("no.conv","no.se"), omit.factors = character(0), dropSingle = TRUE, return.df = TRUE) { ## numbers of blocks ngroups <- lavInspect(object, "ngroups") nLevels <- lavInspect(object, "nlevels") nblocks <- ngroups*nLevels #FIXME: always true? ## labels for groups if (ngroups > 1L) { group.label <- lavInspect(object, "group.label") blk.g.lab <- if (!length(group.label)) paste0("g", 1:ngroups) else group.label } else { group.label <- blk.g.lab <- NULL } ## labels for clusters if (nLevels > 1L) { #FIXME? lavInspect(object, "level.label") is always == # c("within", lavInspect(object, "cluster")) PT <- parTable(object) clus.label <- unique(PT$level) clus.label <- clus.label[which(clus.label != "")] clus.label <- clus.label[which(clus.label != 0)] blk.clus.lab <- if (is.numeric(clus.label)) { c("within", lavInspect(object, "cluster")) } else clus.label } else clus.label <- blk.clus.lab <- NULL ## labels for blocks if (nblocks > 1L) { block.label <- paste(rep(blk.g.lab, each = nLevels), blk.clus.lab, sep = if (ngroups > 1L && nLevels > 1L) "_" else "") } else block.label <- NULL ## check for categorical anyCategorical <- lavInspect(object, "categorical") if (inherits(object, "lavaan")) { PHI <- lavInspect(object, "cov.lv") # common-factor variance EST <- lavInspect(object, "est") # to extract loadings SIGMA <- lavInspect(object, # total variance ifelse(obs.var, "sampstat", "fitted")) if (nblocks == 1L) { PHI <- list(PHI) LAMBDA <- list(EST$lambda) SIGMA <- list(SIGMA$cov) } else { LAMBDA <- sapply(EST, "[[", i = "lambda", simplify = FALSE) SIGMA <- sapply(SIGMA, "[[", i = "cov", simplify = FALSE) } } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) ## common-factor variance phiList <- object@phiList[useImps] if (nblocks == 1L) for (i in 1:m) phiList[[i]] <- list(phiList[[i]]) PHI <- list() for (b in 1:nblocks) { PHI[[b]] <- Reduce("+", lapply(phiList, "[[", i = b) ) / m } ## loadings LAMBDA <- vector("list", nblocks) if (nblocks == 1L) { lamList <- lapply(object@coefList[useImps], "[[", i = "lambda") LAMBDA[[1]] <- Reduce("+", lamList) / length(lamList) } else { for (b in 1:nblocks) { lamList <- lapply(object@coefList[useImps], function(i) i[[b]]$lambda) LAMBDA[[b]] <- Reduce("+", lamList) / length(lamList) } } ## total variance if (obs.var) { SIGMA <- vector("list", nblocks) ## loop over blocks to pool saturated-model (observed) matrices for (b in 1:nblocks) { covList <- lapply(object@h1List[useImps], function(i) i$implied$cov[[b]]) SIGMA[[b]] <- Reduce("+", covList) / m rownames(SIGMA[[b]]) <- colnames(SIGMA[[b]]) <- lavNames(object, block = b) } } else { ## pooled model-implied matrices if (nblocks == 1L) { SIGMA <- getMethod("fitted", class(object))(object)["cov"] # retain list format } else { SIGMA <- sapply(getMethod("fitted", class(object))(object), "[[", "cov", simplify = FALSE) } } } # end lavaan vs. lavaan.mi conditional ## scale polychoric/polyserial to modeled LRV scale if (anyCategorical) { SDs <- sapply(getScales(object, omit.imps = omit.imps), FUN = function(x) diag(1 / as.numeric(x)), simplify = FALSE) for (b in 1:nblocks) { dimnames(SDs[[b]]) <- dimnames(SIGMA[[b]]) SIGMA[[b]] <- SDs[[b]] %*% SIGMA[[b]] %*% SDs[[b]] } } avevar <- list() for (b in 1:nblocks) { ## extract factor and indicator names LY <- LAMBDA[[b]] allIndNames <- rownames(LY) allFacNames <- colnames(LY) myFacNames <- setdiff(allFacNames, omit.factors) if (dropSingle) { multInd <- sapply(myFacNames, function(fn) sum(LY[,fn] != 0) > 1L) myFacNames <- myFacNames[multInd] } subLY <- LY[ , myFacNames, drop = FALSE] myIndNames <- rownames(subLY)[apply(subLY, 1L, function(x) any(x != 0))] ## check for cross-loadings Xload <- apply(subLY, 1L, function(x) sum(round(x, 5) != 0) > 1L) avevar[[b]] <- setNames(rep(NA, length(myFacNames)), nm = myFacNames) ## loop over factors for (fn in myFacNames) { idx <- which(subLY[,fn] != 0) if (any(Xload[idx])) next # cross-loading violates AVE definition commonVar <- sum(subLY[idx, fn]^2) * PHI[[b]][fn, fn] avevar[[b]][fn] <- commonVar / sum(diag(SIGMA[[b]])[ myIndNames[idx] ]) } } ## drop list structure? if (nblocks == 1L) { avevar <- avevar[[1]] class(avevar) <- c("lavaan.vector","numeric") return(avevar) } else { facList <- lapply(avevar, names) sameNames <- all(sapply(2:nblocks, function(i) { isTRUE(all.equal(facList[[1]], facList[[i]])) } )) if (!(sameNames && return.df)) { ## can't simplify, return as a list for (i in seq_along(avevar)) class(avevar[[i]]) <- c("lavaan.vector","numeric") names(avevar) <- block.label return(avevar) } } ## concatenate each factor's AVE across blocks facRel <- sapply(facList[[1]], simplify = FALSE, FUN = function(nn) { sapply(avevar, "[[", i = nn, USE.NAMES = FALSE) # extract AVE for factor i }) if (ngroups > 1L && nLevels > 1L) { out <- data.frame(group = rep(blk.g.lab, each = nLevels), level = rep(blk.clus.lab, times = ngroups), facRel) } else if (ngroups > 1L) { out <- data.frame(group = blk.g.lab, facRel) } else if (nLevels > 1L) { out <- data.frame(level = blk.clus.lab, facRel) } class(out) <- c("lavaan.data.frame","data.frame") out } ## ------------ ## compRelSEM() ## ------------ ##' Composite Reliability using SEM ##' ##' Calculate composite reliability from estimated factor-model parameters ##' ##' Several coefficients for factor-analysis reliability have been termed ##' "omega", which Cho (2021) argues is a misleading misnomer and argues for ##' using \eqn{\rho} to represent them all, differentiated by descriptive ##' subscripts. In our package, we strive to provide unlabeled coefficients, ##' leaving it to the user to decide on a label in their report. But we do ##' use the symbols \eqn{\alpha} and \eqn{\omega} in the formulas below in order ##' to distinguish coefficients that do (not) assume essential tau-equivalence. ##' For higher-order constructs with latent indicators, only \eqn{\omega} is ##' available. Lai's (2021) multilevel coefficients are labeled in accordance ##' with the symbols used in that article (more details below). ##' ##' Bentler (1968) first introduced factor-analysis reliability for a ##' unidimensional factor model with congeneric indicators, labeling the ##' coeficients \eqn{\alpha}. McDonald (1999) later referred to this ##' *and other reliability coefficients*, first as \eqn{\theta} (in 1970), ##' then as \eqn{\omega}, which is a source of confusion when reporting ##' coefficients (Cho, 2021). Coefficients based on factor models were later ##' generalized to account for multidimenisionality (possibly with ##' cross-loadings) and correlated errors. The general \eqn{\omega} formula ##' implemented in this function is: ##' ##' \deqn{ \omega = \frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} ##' Var\left( \psi \right)}{\bold{1}^\prime \hat{\Sigma} \bold{1}}, } ##' ##' where \eqn{\hat{\Sigma}} can be the model-implied covariance matrix from ##' either the saturated model (i.e., the "observed" covariance matrix, used by ##' default) or from the hypothesized CFA model, controlled by the ##' `obs.var` argument. A \eqn{k}-dimensional vector \eqn{\bold{1}} is used ##' to sum elements in the matrix. Note that if the model includes any directed ##' effects (latent regression slopes), all coefficients are calculated ##' from **total** factor variances: `lavInspect(object, "cov.lv")`. ##' ##' Assuming (essential) tau-equivalence (`tau.eq=TRUE`) makes \eqn{\omega} ##' equivalent to coefficient \eqn{\alpha} from classical test theory ##' (Cronbach, 1951): ##' ##' \deqn{ \alpha = \frac{k}{k - 1}\left[ 1 - \frac{\sum^{k}_{i = 1} ##' \sigma_{ii}}{\sum^{k}_{i = 1} \sigma_{ii} + 2\sum_{i < j} \sigma_{ij}} ##' \right],} ##' ##' where \eqn{k} is the number of items in a factor's composite, ##' \eqn{\sigma_{ii}} signifies item *i*'s variance, and \eqn{\sigma_{ij}} ##' signifies the covariance between items *i* and *j*. Again, the ##' `obs.var` argument controls whether \eqn{\alpha} is calculated using ##' the observed or model-implied covariance matrix. ##' ##' By setting `return.total=TRUE`, one can estimate reliability for a ##' single composite calculated using all indicators in a multidimensional ##' CFA (Bentler, 1972, 2009). Setting `return.total = -1` will return ##' **only** the total-composite reliability (not per factor). ##' ##' **Higher-Order Factors**: ##' The reliability of a composite that represents a higher-order construct ##' requires partitioning the model-implied factor covariance matrix \eqn{\Phi} ##' in order to isolate the common-factor variance associated only with the ##' higher-order factor. Using a second-order factor model, the model-implied ##' covariance matrix of observed indicators \eqn{\hat{\Sigma}} can be ##' partitioned into 3 sources: ##' \enumerate{ ##' \item the second-order common-factor (co)variance: ##' \eqn{\Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime}} ##' \item the residual variance of the first-order common factors (i.e., not ##' accounted for by the second-order factor): ##' \eqn{\Lambda \Psi_{u} \Lambda^{\prime}} ##' \item the measurement error of observed indicators: \eqn{\Theta} ##' } ##' ##' where \eqn{\Lambda} contains first-order factor loadings, \eqn{\bold{B}} ##' contains second-order factor loadings, \eqn{\Phi_2} is the model-implied ##' covariance matrix of the second-order factor(s), and \eqn{\Psi_{u}} is the ##' covariance matrix of first-order factor disturbances. In practice, we can ##' use the full \eqn{\bold{B}} matrix and full model-implied \eqn{\Phi} matrix ##' (i.e., including all latent factors) because the zeros in \eqn{\bold{B}} ##' will cancel out unwanted components of \eqn{\Phi}. Thus, we can calculate ##' the proportion of variance of a composite score calculated from the observed ##' indicators (e.g., a total score or scale mean) that is attributable to the ##' second-order factor (i.e., coefficient \eqn{\omega}): ##' ##' \deqn{\omega=\frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi \bold{B}^{\prime} ##' \Lambda^{\prime} \bold{1} }{ \bold{1}^{\prime} \hat{\Sigma} \bold{1}}, } ##' ##' where \eqn{\bold{1}} is the *k*-dimensional vector of 1s and *k* ##' is the number of observed indicators in the composite. Note that if a ##' higher-order factor also has observed indicators, it is necessary to model ##' the observed indicators as single-indicator constructs, so that all of the ##' higher-order factor indicators are latent (with loadings in the Beta matrix, ##' not Lambda). ##' ##' **Categorical Indicators**: ##' When all indicators (per composite) are ordinal, the `ord.scale` ##' argument controls whether the coefficient is calculated on the ##' latent-response scale (`FALSE`) or on the observed ordinal scale ##' (`TRUE`, the default). For \eqn{\omega}-type coefficients ##' (`tau.eq=FALSE`), Green and Yang's (2009, formula 21) approach is used ##' to transform factor-model results back to the ordinal response scale. When ##' `ord.scale=TRUE` and `tau.eq=TRUE`, coefficient \eqn{\alpha} is ##' calculated using the covariance matrix calculated from the integer-valued ##' numeric weights for ordinal categories, consistent with its definition ##' (Chalmers, 2018) and the `alpha` function in the `psych` package; ##' this implies `obs.var=TRUE`, so `obs.var=FALSE` will be ignored ##' When `ord.scale=FALSE`, the standard \eqn{\alpha} formula is applied to ##' the polychoric correlation matrix ("ordinal \eqn{\alpha}"; Zumbo et al., 2007), ##' estimated from the saturated or hypothesized model (see `obs.var`), ##' and \eqn{\omega} is calculated from CFA results without applying Green and ##' Yang's (2009) correction (see Zumbo & Kroc, 2019, for a rationalization). ##' No method analogous to Green and Yang (2009) has been proposed for ##' calculating reliability with a mixture of categorical and continuous ##' indicators, so an error is returned if `object` includes factors with a ##' mixture of indicator types (unless omitted using `omit.factors`). If ##' categorical indicators load on a different factor(s) than continuous ##' indicators, then reliability will still be calculated separately for those ##' factors, but `return.total` must be `FALSE` (unless ##' `omit.factors` is used to isolate factors with indicators of the same ##' type). ##' ##' **Multilevel Measurement Models**: ##' Under the default settings, `compRelSEM()` will apply the same formula ##' in each "block" (group and/or level of analysis). In the case of multilevel ##' (ML-)SEMs, this yields "reliability" for latent within- and between-level ##' components, as proposed by Geldhof et al. (2014). Although this works fine ##' to calculate reliability per group, this is not recommended for ML-SEMs ##' because the coefficients do not correspond to actual composites that would ##' be calculated from the observed data. Lai (2021) proposed coefficients for ##' reliability of actual composites, depending on the type of construct, which ##' requires specifying the names of constructs for which reliability is desired ##' (or multiple constructs whose indicators would compose a multidimensional ##' composite). Configural (`config=`) and/or `shared=` constructs ##' can be specified; the same construct can be specified in both arguments, so ##' that overall scale-reliability can be estimated for a shared construct by ##' including it in `config`. Instead of organizing the output by block ##' (the default), specifying `config=` and/or `shared=` will prompt ##' organizing the list of output by `$config` and/or `$shared`. ##' ##' \itemize{ ##' \item The overall (`_2L`) scale reliability for `config`ural ##' constructs is returned, along with the reliability of a purely ##' individual-level composite (`_W`, calculated by cluster-mean ##' centering). ##' \item The reliability for a `shared` construct quantifies ##' generalizability across both indicators and raters (i.e., subjects rating ##' their cluster's construct). Lüdtke et al. (2011) refer to these as ##' measurement error and sampling error, respectively. An interrater ##' reliability (IRR) coefficient is also returned, quantifying ##' generalizability across rater/sampling-error only. To obtain a ##' scale-reliability coefficient (quantifying a shared construct's ##' generalizability across indicator/measurement-error only), include the ##' same factor name in `config=`. Jak et al. (2021) recommended ##' modeling components of the same construct at both levels, but users may ##' also saturate the within-level model (Lai, 2021). ##' } ##' ##' Be careful about including Level-2 variables in the model, especially ##' whether it makes sense to include them in a total composite for a Level-2 ##' construct. `dropSingle=TRUE` only prevents estimating reliability for ##' a single-indicator construct, not from including such an indicator in a ##' total composite. It is permissible for `shared=` constructs to have ##' additional indicators at Level-2 only. If it is necessary to model other ##' Level-2 variables (e.g., to justify the missing-at-random assumption when ##' using `missing="FIML" estimation`), they should be placed in the ##' `omit.indicators=` argument to exclude them from total composites. ##' ##' ##' @importFrom lavaan lavInspect lavNames parTable ##' @importFrom methods getMethod ##' ##' @param object A [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object, ##' expected to contain only exogenous common factors (i.e., a CFA model). ##' @param obs.var `logical` indicating whether to compute reliability ##' using observed variances in the denominator. Setting `FALSE` triggers ##' using model-implied variances in the denominator. ##' @param tau.eq `logical` indicating whether to assume (essential) ##' tau-equivalence, yielding a coefficient analogous to \eqn{\alpha}. ##' Setting `FALSE` yields an \eqn{\omega}-type coefficient. ##' @param ord.scale `logical` indicating whether to apply Green and Yang's ##' (2009, formula 21) correction, so that reliability is calculated for the ##' actual ordinal response scale (ignored for factors with continuous ##' indicators). Setting `FALSE` yields coefficients that are ##' only applicable to the continuous latent-response scale. ##' @param config `character` vector naming any configural constructs in ##' a multilevel CFA. For these constructs (and optional total composite), ##' Lai's (2021) coefficients \eqn{\omega^\textrm{W}} and \eqn{\omega^\textrm{2L}} ##' are returned (or corresponding \eqn{\alpha} coefficients when ##' `tau.eq=TRUE`), rather than Geldhof et al.'s (2014) coefficients for ##' hypothetical composites of latent components (although the same formula ##' is used for \eqn{\omega^\textrm{W}} in either case). Note that the same name ##' must be used for the factor component represented at each level of the ##' model. ##' @param shared `character` vector naming any shared constructs in ##' a multilevel CFA. For these constructs (and optional total composite), ##' Lai's (2021) coefficient \eqn{\omega^\textrm{B}} or \eqn{\alpha^\textrm{B}} is ##' returned, rather than Geldhof et al.'s (2014) between-level coefficient ##' for hypothetical composites of latent cluster means. Lai's (2021) ##' coefficient quantifies reliability relative to error associated with both ##' indicators (measurement error) and subjects (sampling error), like a ##' generalizability coefficient. Given that subjects can be considered as ##' raters of their cluster's shared construct, an interrater reliability ##' (IRR) coefficient is also returned, quantifying reliability relative to ##' rater/sampling error alone. To quantify reliability relative to ##' indicator/measurement error alone (i.e., \eqn{\omega^\textrm{2L}}), the ##' `shared=` construct name(s) can additionally be included in ##' `config=` argument. ##' @param higher `character` vector naming any higher-order constructs in ##' `object` for which composite reliability should be calculated. ##' Ignored when `tau.eq=TRUE` because alpha is not based on a CFA model; ##' instead, users must fit a CFA with tau-equivalence constraints. ##' To obtain Lai's (2021) multilevel composite-reliability indices for a ##' higher-order factor, do not use this argument; instead, specify the ##' higher-order factor(s) using the `shared=` or `config=` argument ##' (`compRelSEM` will automatically check whether it includes latent ##' indicators and apply the appropriate formula). ##' @param return.total `logical` indicating whether to return a final ##' column containing the reliability of a composite of all indicators (not ##' listed in `omit.indicators`) of first-order factors not listed in ##' `omit.factors`. Ignored in 1-factor models, and should only be set ##' `TRUE` if all factors represent scale dimensions that could be ##' meaningfully collapsed to a single composite (scale sum or scale mean). ##' Setting a negative value (e.g., `-1` returns **only** the ##' total-composite reliability (excluding coefficients per factor), except ##' when requesting Lai's (2021) coefficients for multilevel `config`ural ##' or `shared=` constructs. ##' @param dropSingle `logical` indicating whether to exclude factors ##' defined by a single indicator from the returned results. If `TRUE` ##' (default), single indicators will still be included in the `total` ##' column when `return.total = TRUE`. ##' @param omit.factors `character` vector naming any common factors ##' modeled in `object` whose composite reliability is not of ##' interest. For example, higher-order or method factors. Note that ##' [reliabilityL2()] should be used to calculate composite ##' reliability of a higher-order factor. ##' @param omit.indicators `character` vector naming any observed variables ##' that should be omitted from the composite whose reliability is calculated. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' @param return.df `logical` indicating whether to return reliability ##' coefficients in a `data.frame` (one row per group/level), which is ##' possible when every model block includes the same factors (after excluding ##' those in `omit.factors` and applying `dropSingle`). ##' ##' @return A `numeric` vector of composite reliability coefficients per ##' factor, or a `list` of vectors per "block" (group and/or level of ##' analysis), optionally returned as a `data.frame` when possible (see ##' `return.df=` argument description for caveat). If there are multiple ##' factors, whose multidimensional indicators combine into a single ##' composite, users can request `return.total=TRUE` to add a column ##' including a reliability coefficient for the total composite, or ##' `return.total = -1` to return **only** the total-composite ##' reliability (ignored when `config=` or `shared=` is specified ##' because each factor's specification must be checked across levels). ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' Uses hidden functions written by Sunthud Pornprasertmanit ##' (\email{psunthud@@gmail.com}) for the old `reliability()` function. ##' ##' @seealso ##' [maximalRelia()] for the maximal reliability of weighted composite ##' ##' @references ##' Bentler, P. M. (1968). Alpha-maximized factor analysis (alphamax): Its ##' relation to alpha and canonical factor analysis. *Psychometrika, 33*(3), ##' 335--345. \doi{10.1007/BF02289328} ##' ##' Bentler, P. M. (1972). A lower-bound method for the dimension-free ##' measurement of internal consistency. *Social Science Research, 1*(4), ##' 343--357. \doi{10.1016/0049-089X(72)90082-8} ##' ##' Bentler, P. M. (2009). Alpha, dimension-free, and model-based internal ##' consistency reliability. *Psychometrika, 74*(1), 137--143. ##' \doi{10.1007/s11336-008-9100-1} ##' ##' Chalmers, R. P. (2018). On misconceptions and the limited usefulness of ##' ordinal alpha. *Educational and Psychological Measurement, 78*(6), ##' 1056--1071. \doi{10.1177/0013164417727036} ##' ##' Cho, E. (2021) Neither Cronbach’s alpha nor McDonald’s omega: A commentary ##' on Sijtsma and Pfadt. *Psychometrika, 86*(4), 877--886. ##' \doi{10.1007/s11336-021-09801-1} ##' ##' Cronbach, L. J. (1951). Coefficient alpha and the internal structure of ##' tests. *Psychometrika, 16*(3), 297--334. \doi{10.1007/BF02310555} ##' ##' Geldhof, G. J., Preacher, K. J., & Zyphur, M. J. (2014). Reliability ##' estimation in a multilevel confirmatory factor analysis framework. ##' *Psychological Methods, 19*(1), 72--91. \doi{10.1037/a0032138} ##' ##' Green, S. B., & Yang, Y. (2009). Reliability of summed item scores using ##' structural equation modeling: An alternative to coefficient alpha. ##' *Psychometrika, 74*(1), 155--167. \doi{10.1007/s11336-008-9099-3} ##' ##' Jak, S., Jorgensen, T. D., & Rosseel, Y. (2021). Evaluating cluster-level ##' factor models with `lavaan` and M*plus*. *Psych, 3*(2), ##' 134--152. \doi{10.3390/psych3020012} ##' ##' Lai, M. H. C. (2021). Composite reliability of multilevel data: It’s about ##' observed scores and construct meanings. *Psychological Methods, 26*(1), ##' 90--102. \doi{10.1037/met0000287} ##' ##' Lüdtke, O., Marsh, H. W., Robitzsch, A., & Trautwein, U. (2011). ##' A 2 \eqn{\times} 2 taxonomy of multilevel latent contextual models: ##' Accuracy--bias trade-offs in full and partial error correction models. ##' *Psychological Methods, 16*(4), 444--467. \doi{10.1037/a0024376} ##' ##' McDonald, R. P. (1999). *Test theory: A unified treatment*. Mahwah, NJ: ##' Erlbaum. ##' ##' Zumbo, B. D., Gadermann, A. M., & Zeisser, C. (2007). Ordinal versions of ##' coefficients alpha and theta for Likert rating scales. ##' *Journal of Modern Applied Statistical Methods, 6*(1), 21--29. ##' \doi{10.22237/jmasm/1177992180} ##' ##' Zumbo, B. D., & Kroc, E. (2019). A measurement is a choice and Stevens’ ##' scales of measurement do not help make it: A response to Chalmers. ##' *Educational and Psychological Measurement, 79*(6), 1184--1197. ##' \doi{10.1177/0013164419844305} ##' ##' ##' @examples ##' ##' data(HolzingerSwineford1939) ##' HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] ##' HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) ##' names(HSbinary) <- c("y7","y8","y9") ##' HS <- cbind(HolzingerSwineford1939, HSbinary) ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ y7 + y8 + y9 ' ##' ##' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ##' ##' ## works for factors with exclusively continuous OR categorical indicators ##' compRelSEM(fit) ##' ##' ## reliability for ALL indicators only available when they are ##' ## all continuous or all categorical ##' compRelSEM(fit, omit.factors = "speed", return.total = TRUE) ##' ##' ##' ## loop over visual indicators to calculate alpha if one indicator is removed ##' for (i in paste0("x", 1:3)) { ##' cat("Drop ", i, ":\n", sep = "") ##' print(compRelSEM(fit, omit.factors = c("textual","speed"), ##' omit.indicators = i, tau.eq = TRUE)) ##' } ##' ## item-total correlations obtainable by adding a composite to the data ##' HS$Visual <- HS$x1 + HS$x2 + HS$x3 ##' cor(HS$Visual, y = HS[paste0("x", 1:3)]) ##' ## comparable to psych::alpha(HS[paste0("x", 1:3)]) ##' ##' ## Reliability of a composite that represents a higher-order factor ##' mod.hi <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' general =~ visual + textual + speed ' ##' ##' fit.hi <- cfa(mod.hi, data = HolzingerSwineford1939) ##' compRelSEM(fit.hi, higher = "general") ##' ## reliabilities for lower-order composites also returned ##' ##' ##' ## works for multigroup models and for multilevel models (and both) ##' data(Demo.twolevel) ##' ## assign clusters to arbitrary groups ##' Demo.twolevel$g <- ifelse(Demo.twolevel$cluster %% 2L, "type1", "type2") ##' model2 <- ' group: type1 ##' level: 1 ##' f1 =~ y1 + L2*y2 + L3*y3 ##' f2 =~ y4 + L5*y5 + L6*y6 ##' level: 2 ##' f1 =~ y1 + L2*y2 + L3*y3 ##' f2 =~ y4 + L5*y5 + L6*y6 ##' ##' group: type2 ##' level: 1 ##' f1 =~ y1 + L2*y2 + L3*y3 ##' f2 =~ y4 + L5*y5 + L6*y6 ##' level: 2 ##' f1 =~ y1 + L2*y2 + L3*y3 ##' f2 =~ y4 + L5*y5 + L6*y6 ##' ' ##' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") ##' compRelSEM(fit2) # Geldhof's indices (hypothetical, for latent components) ##' ##' ## Lai's (2021) indices for Level-1 and configural constructs ##' compRelSEM(fit2, config = c("f1","f2")) ##' ## Lai's (2021) indices for shared (Level-2) constructs ##' ## (also an interrater reliability coefficient) ##' compRelSEM(fit2, shared = c("f1","f2")) ##' ##' ##' ## Shared construct using saturated within-level model ##' mod.sat1 <- ' level: 1 ##' y1 ~~ y1 + y2 + y3 + y4 + y5 + y6 ##' y2 ~~ y2 + y3 + y4 + y5 + y6 ##' y3 ~~ y3 + y4 + y5 + y6 ##' y4 ~~ y4 + y5 + y6 ##' y5 ~~ y5 + y6 ##' y6 ~~ y6 ##' ##' level: 2 ##' f1 =~ y1 + L2*y2 + L3*y3 ##' f2 =~ y4 + L5*y5 + L6*y6 ##' ' ##' fit.sat1 <- sem(mod.sat1, data = Demo.twolevel, cluster = "cluster") ##' compRelSEM(fit.sat1, shared = c("f1","f2")) ##' ##' ##' ## Simultaneous shared-and-configural model (Stapleton et al, 2016, 2019), ##' ## not recommended, but possible by omitting shared or configural factor. ##' mod.both <- ' level: 1 ##' fc =~ y1 + L2*y2 + L3*y3 + L4*y4 + L5*y5 + L6*y6 ##' level: 2 ##' ## configural construct ##' fc =~ y1 + L2*y2 + L3*y3 + L4*y4 + L5*y5 + L6*y6 ##' ## orthogonal shared construct ##' fs =~ NA*y1 + y2 + y3 + y4 + y5 + y6 ##' fs ~~ 1*fs + 0*fc ##' ' ##' fit.both <- sem(mod.both, data = Demo.twolevel, cluster = "cluster") ##' compRelSEM(fit.both, shared = "fs", config = "fc") ##' ##' @export compRelSEM <- function(object, obs.var = TRUE, tau.eq = FALSE, ord.scale = TRUE, config = character(0), shared = character(0), higher = character(0), return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), omit.indicators = character(0), omit.imps = c("no.conv","no.se"), return.df = TRUE) { ## numbers of blocks ngroups <- lavInspect(object, "ngroups") nLevels <- lavInspect(object, "nlevels") nblocks <- ngroups*nLevels #FIXME: always true? return.total <- rep(return.total, nblocks) ## labels for groups if (ngroups > 1L) { group.label <- lavInspect(object, "group.label") blk.g.lab <- if (!length(group.label)) paste0("g", 1:ngroups) else group.label } else { group.label <- blk.g.lab <- NULL } ## labels for clusters if (nLevels > 1L) { #FIXME? lavInspect(object, "level.label") is always == # c("within", lavInspect(object, "cluster")) PT <- parTable(object) clus.label <- unique(PT$level) clus.label <- clus.label[which(clus.label != "")] clus.label <- clus.label[which(clus.label != 0)] blk.clus.lab <- if (is.numeric(clus.label)) { c("within", lavInspect(object, "cluster")) } else clus.label } else clus.label <- blk.clus.lab <- NULL ## labels for blocks if (nblocks > 1L) { block.label <- paste(rep(blk.g.lab, each = nLevels), blk.clus.lab, sep = if (ngroups > 1L && nLevels > 1L) "_" else "") } else block.label <- NULL ## check for categorical anyCategorical <- lavInspect(object, "categorical") threshold <- if (anyCategorical) getThreshold(object, omit.imps = omit.imps) else NULL latScales <- if (anyCategorical) getScales(object, omit.imps = omit.imps) else NULL if (inherits(object, "lavaan")) { ## common-factor variance PHI <- lavInspect(object, "cov.lv") # ignored if tau.eq if (nblocks == 1L) PHI <- list(PHI) names(PHI) <- block.label ## factor loadings EST <- lavInspect(object, "est", drop.list.single.group = FALSE) LAMBDA <- sapply(EST, "[[", i = "lambda", simplify = FALSE) names(LAMBDA) <- block.label ## possibly higher-order loadings? BETA <- sapply(EST, "[[", i = "beta", simplify = FALSE) names(BETA) <- block.label ## total variance if (anyCategorical && tau.eq && ord.scale) { ## calculate SIGMA from data for alpha #FIXME when MLSEM available for ordinal indicators # (Level 2 components available? Extend conditional?) rawData <- try(lavInspect(object, "data", drop.list.single.group = FALSE), silent = TRUE) if (inherits(rawData, "try-error")) stop('Error in lavInspect(fit, "data"); tau.eq= and ord.scale= cannot ', 'both be TRUE for models fitted to summary statistics of ', 'categorial data.') SIGMA <- lapply(rawData, cov) names(SIGMA) <- block.label } else { SIGMA <- sapply(lavInspect(object, drop.list.single.group = FALSE, what = ifelse(obs.var, "sampstat", "fitted")), "[[", i = "cov", simplify = FALSE) names(SIGMA) <- block.label } } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) ## common-factor variance phiList <- object@phiList[useImps] if (nblocks == 1L) for (i in 1:m) phiList[[i]] <- list(phiList[[i]]) PHI <- vector("list", nblocks) names(PHI) <- block.label for (b in 1:nblocks) { PHI[[b]] <- Reduce("+", lapply(phiList, "[[", i = b) ) / m } ## loadings (including higher-order in Beta) if (nblocks == 1L) { lamList <- lapply(object@coefList[useImps], "[[", i = "lambda") LAMBDA <- list(Reduce("+", lamList) / length(lamList)) betList <- lapply(object@coefList[useImps], "[[", i = "beta") if (length(betList)) { BETA <- list(Reduce("+", betList) / length(betList)) } else BETA <- list(NULL) } else { LAMBDA <- BETA <- vector("list", nblocks) names(LAMBDA) <- names(BETA) <- block.label for (b in 1:nblocks) { lamList <- lapply(object@coefList[useImps], function(i) i[[b]]$lambda) LAMBDA[[b]] <- Reduce("+", lamList) / length(lamList) betList <- lapply(object@coefList[useImps], function(i) i[[b]]$beta ) BETA[[b]] <- Reduce("+", betList) / length(betList) } } ## total variance if (anyCategorical && tau.eq && ord.scale) { ## calculate SIGMA from data for alpha #FIXME when MLSEM available for ordinal indicators # (Level 2 components available? Extend conditional?) dataList <- object@DataList[useImps] SIGMA <- vector("list", nblocks) names(SIGMA) <- group.label #FIXME when MLSEMs can have ordinal indicators if (nblocks == 1L) { VV <- lavNames(object, type = "ov") impCovList <- lapply(dataList, function(DD) { dat <- do.call(cbind, sapply(DD[VV], as.numeric, simplify = FALSE)) cov(dat) }) SIGMA[[1]] <- Reduce("+", impCovList) / length(impCovList) } else { ## multigroup models need separate data matrices per group G <- lavInspect(object, "group") for (g in seq_along(group.label)) { VV <- lavNames(object, type = "ov", group = ifelse(length(group.label), yes = group.label[g], no = g)) impCovList <- lapply(dataList, function(DD) { RR <- DD[,G] == ifelse(length(group.label), yes = group.label[g], no = g) dat <- do.call(cbind, sapply(DD[RR, VV], as.numeric, simplify = FALSE)) cov(dat) }) SIGMA[[g]] <- Reduce("+", impCovList) / length(impCovList) } # g } } else { ## use model-implied SIGMA from h0 or h1 model if (obs.var) { SIGMA <- vector("list", nblocks) names(SIGMA) <- block.label ## loop over blocks to pool saturated-model (observed) matrices for (b in 1:nblocks) { covList <- lapply(object@h1List[useImps], function(i) i$implied$cov[[b]]) SIGMA[[b]] <- Reduce("+", covList) / m ## The slot does not contain dimnames, so add them rownames(SIGMA[[b]]) <- colnames(SIGMA[[b]]) <- lavNames(object, block = b) } } else { ## pooled model-implied matrices if (nblocks == 1L) { SIGMA <- getMethod("fitted", class(object))(object)["cov"] # retain list format } else { SIGMA <- sapply(getMethod("fitted", class(object))(object), "[[", "cov", simplify = FALSE) names(SIGMA) <- block.label } } } } # end lavaan vs. lavaan.mi conditional ## scale polychoric/polyserial to modeled LRV scale if (anyCategorical) { SDs <- sapply(latScales, function(x) diag(1 / x), simplify = FALSE) for (b in 1:nblocks) { dimnames(SDs[[b]]) <- dimnames(SIGMA[[b]]) SIGMA[[b]] <- SDs[[b]] %*% SIGMA[[b]] %*% SDs[[b]] } } warnTotal <- warnAlpha <- warnOmega <- FALSE if (!length(c(config, shared))) { rel <- vector("list", length = nblocks) for (b in 1:nblocks) { LY <- LAMBDA[[b]] allIndNames <- rownames(LY) allFacNames <- colnames(LY) myFacNames <- setdiff(allFacNames, omit.factors) if (dropSingle) { multInd <- sapply(myFacNames, function(fn) sum(LY[,fn] != 0) > 1L) myFacNames <- myFacNames[multInd] } subLY <- LY[ , myFacNames, drop = FALSE] myIndNames <- rownames(subLY)[apply(subLY, 1L, function(x) any(x != 0))] ## remove unwanted indicators myIndNames <- setdiff(myIndNames, omit.indicators) subLY <- subLY[myIndNames, , drop = FALSE] ## distinguish between categorical, continuous, and latent indicators nameArgs <- list(object = object) if (nblocks > 1L) nameArgs$block <- b ordNames <- do.call(lavNames, c(nameArgs, list(type = "ov.ord"))) numNames <- do.call(lavNames, c(nameArgs, list(type = "ov.num"))) if (anyCategorical) { ## identify when the (sub)set of factors are all categorical blockCat <- all(myIndNames %in% ordNames) ## identify when the (sub)set of factors have mixed indicators, so no total mix <- any(myIndNames %in% ordNames) && any(myIndNames %in% numNames) } else { blockCat <- FALSE mix <- FALSE } if (mix && return.total[b]) { return.total[b] <- FALSE if (!(tau.eq && ord.scale)) warnTotal <- TRUE } ## compute reliability per factor? if (return.total[b] >= 0) { ## set result missing by default rel[[b]] <- setNames(rep(NA, length(myFacNames)), nm = myFacNames) for (fn in myFacNames) { ## names of indicators with nonzero loadings fIndNames <- myIndNames[which(subLY[,fn] != 0)] ## check for ANY indicators if (length(fIndNames) == 0L) next ## check for single indicators if (dropSingle && length(fIndNames) == 1L) next ## check for categorical (or mixed) indicators fCat <- any(fIndNames %in% ordNames) ## identify when this factor has mixed indicators, so no omegas fMix <- fCat && any(fIndNames %in% numNames) ## ALPHA totalCov <- SIGMA[[b]][fIndNames, fIndNames, drop = FALSE] if (tau.eq) { if (fMix && !ord.scale) { ## can't mix observed and latent scales warnAlpha <- TRUE #TODO next } rel[[b]][fn] <- computeAlpha(totalCov) next } # else compute omega ## OMEGA if (fMix) { warnOmega <- TRUE # can't (yet) mix observed and latent scales next } Lf <- subLY[fIndNames, fn, drop = FALSE] commonCov <- Lf %*% PHI[[b]][fn, fn] %*% t(Lf) if (fCat && ord.scale) { ## Green & Yang (2009) rel[[b]][fn] <- omegaCat(truevar = commonCov, denom = totalCov, threshold = threshold[[b]][fIndNames], scales = latScales[[b]][fIndNames]) next } # else, all continuous or all LRV-scale rel[[b]][fn] <- sum(commonCov) / sum(totalCov) } # end loop over factors } else rel[[b]] <- c(total = as.numeric(NA)) ## compute for total composite? if (return.total[b] && length(myFacNames) > 1L) { ## ALPHA totalCov <- SIGMA[[b]][myIndNames, myIndNames, drop = FALSE] if (tau.eq) { rel[[b]]["total"] <- computeAlpha(totalCov) next } # else compute omega ## OMEGA commonCov <- subLY %*% PHI[[b]][myFacNames, myFacNames] %*% t(subLY) if (blockCat && ord.scale) { ## Green & Yang (2009) rel[[b]]["total"] <- omegaCat(truevar = commonCov, denom = totalCov, threshold = threshold[[b]][myIndNames], scales = latScales[[b]][myIndNames]) next } # else, all continuous or all LRV-scale rel[[b]]["total"] <- sum(commonCov) / sum(totalCov) } ## composite(s) representing higher-order factor(s)? for (hf in higher) { ## find latent indicators L2 <- BETA[[b]][,hf] latInds <- setdiff(names(L2)[L2 != 0], omit.factors) ## find observed indicators indList <- lapply(c(hf, latInds), function(i) names(LY[,i])[ LY[,i] != 0]) myIndNames <- setdiff(unique(do.call(c, indList)), omit.indicators) totalCov <- SIGMA[[b]][myIndNames, myIndNames] # no need for drop = FALSE L <- LY[myIndNames, c(hf, latInds)] B <- BETA[[b]][c(hf, latInds), c(hf, latInds)] Phi <- PHI[[b]][c(hf, latInds), c(hf, latInds)] commonCov <- L %*% B %*% Phi %*% t(B) %*% t(L) if (blockCat && ord.scale) { ## Green & Yang (2009) rel[[b]][hf] <- omegaCat(truevar = commonCov, denom = totalCov, threshold = threshold[[b]][myIndNames], scales = latScales[[b]][myIndNames]) next } # else, all continuous or all LRV-scale rel[[b]][hf] <- sum(commonCov) / sum(totalCov) } } ## drop list structure if (nblocks == 1L) { rel <- rel[[1]] class(rel) <- c("lavaan.vector","numeric") return(rel) } else { facList <- lapply(rel, names) sameNames <- all(sapply(2:nblocks, function(i) { isTRUE(all.equal(facList[[1]], facList[[i]])) } )) if (!(sameNames && return.df)) { ## can't simplify, return as a list for (i in seq_along(rel)) class(rel[[i]]) <- c("lavaan.vector","numeric") names(rel) <- block.label return(rel) } } ## concatenate each factor's reliability across blocks facRel <- sapply(facList[[1]], simplify = FALSE, FUN = function(nn) { sapply(rel, "[[", i = nn, USE.NAMES = FALSE) # extract reliability for factor i }) if (ngroups > 1L && nLevels > 1L) { out <- data.frame(group = rep(blk.g.lab, each = nLevels), level = rep(blk.clus.lab, times = ngroups), facRel) } else if (ngroups > 1L) { out <- data.frame(group = blk.g.lab, facRel) } else if (nLevels > 1L) { out <- data.frame(level = blk.clus.lab, facRel) } class(out) <- c("lavaan.data.frame","data.frame") return(out) } if (warnTotal) { message('Cannot return.total when model contains both continuous and ', 'binary/ordinal observed indicators. Use the ', 'omit.factors= argument to choose factors with only categorical ', 'or continuous indicators, if that is a composite of interest.\n') } if (warnAlpha) { message('Coefficient alpha cannot be computed for factors as though a ', 'composite would be calculated using both observed-response scales', ' (for continuous indicators) and latent-response scales (for ', 'categorical indicators). If you want to assume tau-equivalence, ', 'either set ord.scale=FALSE or fit a model that treats ordinal ', 'indicators as continuous.') } if (warnOmega) { message('Composite reliability (omega) cannot be computed for factors ', 'with mixed categorical and continuous indicators, unless a model ', 'is fitted by treating ordinal indicators as continuous.') } ## otherwise, only use Lai's MULTILEVEL coefficients if (nLevels > 1L && length(c(config, shared))) { ## group-level list, each containing 2 coefs per factor/total in data.frame rel <- vector("list", length = ngroups) for (g in 1:ngroups) { gLab <- ifelse(length(group.label), yes = group.label[g], no = g) nameArgs <- list(object = object, type = "lv") if (ngroups > 1L) nameArgs$group <- gLab lv.names1 <- do.call(lavNames, c(nameArgs, list(level = clus.label[1L]))) lv.names2 <- do.call(lavNames, c(nameArgs, list(level = clus.label[2L]))) nameArgs$type <- "ov" ov.names1 <- do.call(lavNames, c(nameArgs, list(level = clus.label[1L]))) ov.names2 <- do.call(lavNames, c(nameArgs, list(level = clus.label[2L]))) nameArgs$type <- "lv.ind" allLatInds <- do.call(lavNames, c(nameArgs, list(level = clus.label[1L]))) ## erase higher= argument, use it to collect factor names for later checks higher <- character(0) PT <- parTable(object) PT <- PT[PT$op == "=~", ] if (ngroups > 1L) PT <- PT[PT$group == gLab, ] ## block indices for 2 levels in this group #FIXME: eventually possible to model partial clustering? idx1 <- 1 + (g-1)*2 # within idx2 <- 2 + (g-1)*2 # cluster ## configural construct(s) defined at both levels this group? for (fn in config) { if (fn %in% omit.factors) { ## why would they do this? config <- setdiff(config, omit.factors) next } if (fn %in% lv.names1 && fn %in% lv.names2) { ## same indicators for this construct at both levels? indNames1 <- setdiff(PT$rhs[PT$lhs == fn & PT$level == clus.label[1L]], omit.indicators) indNames2 <- setdiff(PT$rhs[PT$lhs == fn & PT$level == clus.label[2L]], omit.indicators) if (!all.equal(indNames1, indNames2)) { stop('After removing omit.indicators=, the indicators of factor ', fn, ' do not match across levels', ifelse(ngroups > 1L, paste(' in group', gLab), "")) } if (dropSingle && length(indNames1) == 1L) next ## is it a higher-order factor? latInds1 <- intersect(indNames1, allLatInds) if (length(latInds1)) { lowList <- lapply(latInds1, function(fn1) { indNames1 <- setdiff(PT$rhs[PT$lhs == fn1 & PT$level == clus.label[1L]], omit.indicators) indNames2 <- setdiff(PT$rhs[PT$lhs == fn1 & PT$level == clus.label[2L]], omit.indicators) ## check indicators also match for lower-order factors if (!all.equal(indNames1, indNames2)) { stop('After removing omit.indicators=, the indicators of factor ', fn1, ' do not match across levels', ifelse(ngroups > 1L, paste(' in group', gLab), "")) } ## check indicators of lower-order factors are not also latent lowerLatent <- intersect(indNames1, allLatInds) if (length(lowerLatent)) stop('Indicators of lower-order factor ', fn1, ifelse(ngroups > 1L, paste(' in group', gLab), ""), ' cannot also be latent') indNames1 }) ## update indicator list to only include relevant observed variables indNames1 <- intersect(c(indNames1, do.call(c, lowList)), ov.names1) ## update list of higher-order factors higher <- c(higher, fn) } Sigma1 <- SIGMA[[idx1]][indNames1, indNames1, drop = FALSE] Sigma2 <- SIGMA[[idx2]][indNames1, indNames1, drop = FALSE] if (tau.eq) { if (fn %in% higher) { warning('Cannot apply alpha (tau.eq=TRUE) to higher-order factor ', fn, '. Instead, fit a higher-order CFA that imposes ', 'tau-equivalence constraints.') } else { ## ALPHA rel[[g]]$config[[fn]] <- c(`alpha_W` = computeAlpha(Sigma1), `alpha_2L` = computeAlpha(Sigma1 + Sigma2)) } } else { ## OMEGA lam1 <- LAMBDA[[idx1]][indNames1, c(fn, latInds1), drop = FALSE] lam2 <- LAMBDA[[idx2]][indNames1, c(fn, latInds1), drop = FALSE] if (!isTRUE(all.equal(lam1, lam2))) warning('Unequal observed-indicator loadings across levels ', 'detected among factors (', paste(c(fn, latInds1), collapse = ","), ifelse(ngroups > 1L, paste(') in group', gLab), ")"), '. omega_2L for configural constructs assumes invariance.') phi1 <- PHI[[idx1]][c(fn, latInds1), c(fn, latInds1), drop = FALSE] phi2 <- PHI[[idx2]][c(fn, latInds1), c(fn, latInds1), drop = FALSE] if (length(latInds1)) { bet1 <- BETA[[idx1]][c(fn, latInds1), c(fn, latInds1), drop = FALSE] bet2 <- BETA[[idx2]][c(fn, latInds1), c(fn, latInds1), drop = FALSE] if (!isTRUE(all.equal(bet1, bet2))) warning('Unequal higher-order loadings detected across levels ', 'detected for factor ', fn, ifelse(ngroups > 1L, paste(' in group', gLab), ""), '. omega_2L for configural constructs assumes invariance.') commonCov1 <- lam1 %*% bet1 %*% phi1 %*% t(bet1) %*% t(lam1) commonCov2 <- lam2 %*% bet2 %*% phi2 %*% t(bet2) %*% t(lam2) } else { commonCov1 <- lam1 %*% phi1 %*% t(lam1) commonCov2 <- lam2 %*% phi2 %*% t(lam2) } rel[[g]]$config[[fn]] <- c(`omega_W` = sum(commonCov1) / sum(Sigma1), `omega_2L` = sum(commonCov1 + commonCov2) / sum(Sigma1 + Sigma2)) } } else { warning('Configural factor ', fn, 'not detected at both levels of ', 'analysis, so removed from config= list. Please use the ', 'same name for the within- and between-level component of a ', 'configural construct in your syntax.') config <- setdiff(config, fn) # rm non-configural construct } } ## after removing ineligible config, still multiple for total? if (length(config) > 1L) { ## only possible if NONE of config= are higher-order factors, or if ## the first-order factors in config= are not latent indicators of any ## higher-order factors in config= if (return.total[idx1] && !(length(higher) && any(config %in% allLatInds))) { indNames1 <- setdiff(PT$rhs[PT$lhs %in% config & PT$level == clus.label[1]], omit.indicators) ## include observed indicators of any latent indicators latInds1 <- intersect(indNames1, allLatInds) indNames1 <- setdiff(PT$rhs[PT$lhs %in% c(config, latInds1) & PT$level == clus.label[1]], omit.indicators) Sigma1 <- SIGMA[[idx1]][indNames1, indNames1, drop = FALSE] Sigma2 <- SIGMA[[idx2]][indNames1, indNames1, drop = FALSE] if (tau.eq) { if (any(config %in% higher)) { warning('Cannot apply alpha (tau.eq=TRUE) to total composite ', 'that includes higher-order configural factor(s):\n', paste(intersect(shared, higher), collapse = ", "), '\nInstead, impose tau-equiv. in a higher-order CFA') } else { ## ALPHA rel[[g]]$config$total <- c(`alpha_W` = computeAlpha(Sigma1), `alpha_2L` = computeAlpha(Sigma1 + Sigma2)) } } else { ## OMEGA lam1 <- LAMBDA[[idx1]][indNames1, c(config, latInds1), drop = FALSE] lam2 <- LAMBDA[[idx2]][indNames1, c(config, latInds1), drop = FALSE] phi1 <- PHI[[idx1]][c(config, latInds1), c(config, latInds1), drop = FALSE] phi2 <- PHI[[idx2]][c(config, latInds1), c(config, latInds1), drop = FALSE] if (length(latInds1)) { bet1 <- BETA[[idx1]][c(config, latInds1), c(config, latInds1), drop = FALSE] bet2 <- BETA[[idx2]][c(config, latInds1), c(config, latInds1), drop = FALSE] commonCov1 <- lam1 %*% bet1 %*% phi1 %*% t(bet1) %*% t(lam1) commonCov2 <- lam2 %*% bet2 %*% phi2 %*% t(bet2) %*% t(lam2) } else { commonCov1 <- lam1 %*% phi1 %*% t(lam1) commonCov2 <- lam2 %*% phi2 %*% t(lam2) } rel[[g]]$config$total <- c(`omega_W` = sum(commonCov1) / sum(Sigma1), `omega_2L` = sum(commonCov1 + commonCov2) / sum(Sigma1 + Sigma2)) } } ## collect 2 coefs for multiple composites into a matrix rel[[g]]$config <- do.call(cbind, rel[[g]]$config) } ## (reciprocal of) harmonic-mean cluster size Ns <- mean(1 / lavInspect(object, "cluster.size", drop.list.single.group = FALSE)[[g]]) ## reset higher= argument for later checks higher <- character(0) ## shared construct(s) defined at between level in this group? for (fn in shared) { if (fn %in% omit.factors) { ## why would they do this? shared <- setdiff(shared, omit.factors) next } if (fn %in% lv.names2) { indNames2 <- setdiff(PT$rhs[PT$lhs == fn & PT$level == clus.label[2L]], omit.indicators) ## only Level-2 single-indicator factors are relevant to drop if (dropSingle && length(indNames2) == 1L) next ## is it a higher-order factor? latInds2 <- intersect(indNames2, allLatInds) if (length(latInds2)) { lowList <- lapply(latInds2, function(fn2) { indNames2 <- setdiff(PT$rhs[PT$lhs == fn2 & PT$level == clus.label[2L]], omit.indicators) ## check indicators of lower-order factors are not also latent lowerLatent <- intersect(indNames2, allLatInds) if (length(lowerLatent)) stop('Indicators of lower-order factor ', fn2, ifelse(ngroups > 1L, paste(' in group', gLab), ""), ' cannot also be latent') indNames2 }) ## update indicator list to only include relevant observed variables indNames2 <- intersect(c(indNames2, do.call(c, lowList)), ov.names2) ## update list of higher-order factors higher <- c(higher, fn) } ## capture within-level variance components of same indicators ## (make sure none are Level-2 only) indNames1 <- intersect(indNames2, ov.names1) Sigma1 <- SIGMA[[idx1]][indNames1, indNames1, drop = FALSE] Sigma2 <- SIGMA[[idx2]][indNames2, indNames2, drop = FALSE] if (tau.eq) { if (fn %in% higher) { warning('Cannot apply alpha (tau.eq=TRUE) to higher-order factor ', fn, '. Instead, fit a higher-order CFA that imposes ', 'tau-equivalence constraints.') } else { nI <- length(indNames2) if (nI == 1L) { stop('Coefficient alpha is undefined for a single indicator. ', 'Set tau.eq=FALSE or dropSingle=TRUE') } kw <- nI / (nI-1) # weight for alpha based on number of items ## ALPHA onlyCov2 <- Sigma2 diag(onlyCov2) <- 0 rel[[g]]$shared[[fn]] <- c(`alpha_B` = kw*sum(onlyCov2) / sum(Sigma1*Ns, Sigma2), `IRR` = sum( Sigma2 ) / sum(Sigma1*Ns, Sigma2)) } } else { ## OMEGA lam2 <- LAMBDA[[idx2]][indNames2, c(fn, latInds2), drop = FALSE] phi2 <- PHI[[idx2]][c(fn, latInds2), c(fn, latInds2), drop = FALSE] if (length(latInds2)) { bet2 <- BETA[[idx2]][c(fn, latInds2), c(fn, latInds2), drop = FALSE] commonCov2 <- lam2 %*% bet2 %*% phi2 %*% t(bet2) %*% t(lam2) } else commonCov2 <- lam2 %*% phi2 %*% t(lam2) rel[[g]]$shared[[fn]] <- c(`omega_B` = sum(commonCov2) / sum(Sigma1*Ns, Sigma2), `IRR` = sum( Sigma2 ) / sum(Sigma1*Ns, Sigma2)) } } else shared <- setdiff(shared, fn) # rm non-shared construct } ## after removing ineligible shared, still multiple for total? if (length(shared) > 1L) { ## only possible if NONE of shared= are higher-order factors, or if ## the first-order factors in shared= are not latent indicators of any ## higher-order factors in shared= if (return.total[idx2] && !(length(higher) && any(shared %in% allLatInds))) { indNames2 <- setdiff(PT$rhs[PT$lhs %in% shared & PT$level == clus.label[2]], omit.indicators) ## include observed indicators of any latent indicators latInds2 <- intersect(indNames2, allLatInds) indNames2 <- setdiff(PT$rhs[PT$lhs %in% c(shared, latInds2) & PT$level == clus.label[2]], omit.indicators) ## capture within-level variance components of same indicators ## (make sure none are Level-2 only) indNames1 <- intersect(indNames2, ov.names1) Sigma1 <- SIGMA[[idx1]][indNames1, indNames1, drop = FALSE] Sigma2 <- SIGMA[[idx2]][indNames2, indNames2, drop = FALSE] if (tau.eq) { if (any(shared %in% higher)) { warning('Cannot apply alpha (tau.eq=TRUE) to total composite ', 'that includes higher-order shared factor(s):\n', paste(intersect(shared, higher), collapse = ", "), '\nInstead, impose tau-equiv. in a higher-order CFA') } else { ## ALPHA nI <- length(indNames2) #TODO: justify when > length(indNames1) # (Level-1 component exists with SD=0) kw <- nI / (nI-1) # weight for alpha based on number of items onlyCov2 <- Sigma2 diag(onlyCov2) <- 0 rel[[g]]$shared$total <- c(`alpha_B` = kw*sum(onlyCov2) / sum(Sigma1*Ns, Sigma2), `IRR` = sum( Sigma2 ) / sum(Sigma1*Ns, Sigma2)) } } else { ## OMEGA lam2 <- LAMBDA[[idx2]][indNames2, c(shared, latInds2), drop = FALSE] phi2 <- PHI[[idx2]][c(shared, latInds2), c(shared, latInds2), drop = FALSE] if (length(latInds1)) { bet2 <- BETA[[idx2]][c(shared, latInds2), c(shared, latInds2), drop = FALSE] commonCov2 <- lam2 %*% bet2 %*% phi2 %*% t(bet2) %*% t(lam2) } else commonCov2 <- lam2 %*% phi2 %*% t(lam2) rel[[g]]$shared$total <- c(`omega_B` = sum(commonCov2) / sum(Sigma1*Ns, Sigma2), `IRR` = sum( Sigma2 ) / sum(Sigma1*Ns, Sigma2)) } } ## collect 2 coefs for multiple composites into a matrix rel[[g]]$shared <- do.call(cbind, rel[[g]]$shared) } } # end loop over groups ## drop list structure? if (ngroups == 1L) { rel <- rel[[1]] } else names(rel) <- group.label } rel } ## ------------- ## reliability() ## (deprecated 10 May 2022) ## ------------- ##' Composite Reliability using SEM ##' ##' Calculate composite reliability from estimated factor-model parameters ##' ##' The coefficient alpha (Cronbach, 1951) can be calculated by ##' ##' \deqn{ \alpha = \frac{k}{k - 1}\left[ 1 - \frac{\sum^{k}_{i = 1} ##' \sigma_{ii}}{\sum^{k}_{i = 1} \sigma_{ii} + 2\sum_{i < j} \sigma_{ij}} ##' \right],} ##' ##' where \eqn{k} is the number of items in a factor, \eqn{\sigma_{ii}} is the ##' item *i* observed variances, \eqn{\sigma_{ij}} is the observed ##' covariance of items *i* and *j*. ##' ##' Several coefficients for factor-analysis reliability have been termed ##' "omega", which Cho (2021) argues is a misleading misnomer and argues for ##' using \eqn{\rho} to represent them all, differentiated by descriptive ##' subscripts. In our package, we number \eqn{\omega} based on commonly ##' applied calculations. Bentler (1968) first introduced factor-analysis ##' reliability for a unidimensional factor model with congeneric indicators. ##' However, assuming there are no cross-loadings in a multidimensional CFA, ##' this reliability coefficient can be calculated for each factor in the model. ##' ##' \deqn{ \omega_1 =\frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} ##' Var\left( \psi \right)}{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} ##' Var\left( \psi \right) + \sum^{k}_{i = 1} \theta_{ii} + 2\sum_{i < j} ##' \theta_{ij} }, } ##' ##' where \eqn{\lambda_i} is the factor loading of item *i*, \eqn{\psi} is ##' the factor variance, \eqn{\theta_{ii}} is the variance of measurement errors ##' of item *i*, and \eqn{\theta_{ij}} is the covariance of measurement ##' errors from item *i* and *j*. McDonald (1999) later referred to ##' this *and other reliability coefficients* as "omega", which is a source ##' of confusion when reporting coefficients (Cho, 2021). ##' ##' The additional coefficients generalize the first formula by accounting for ##' multidimenisionality (possibly with cross-loadings) and correlated errors. ##' By setting `return.total=TRUE`, one can estimate reliability for a ##' single composite calculated using all indicators in the multidimensional ##' CFA (Bentler, 1972, 2009). `"omega2"` is calculated by ##' ##' \deqn{ \omega_2 = \frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} ##' Var\left( \psi \right)}{\bold{1}^\prime \hat{\Sigma} \bold{1}}, } ##' ##' where \eqn{\hat{\Sigma}} is the model-implied covariance matrix, and ##' \eqn{\bold{1}} is the \eqn{k}-dimensional vector of 1. The first and the ##' second coefficients omega will have the same value per factor in models with ##' simple structure, but they differ when there are (e.g.) cross-loadings ##' or method factors. The first coefficient omega can be viewed as the ##' reliability controlling for the other factors (like \eqn{\eta^2_{partial}} in ##' ANOVA). The second coefficient omega can be viewed as the unconditional ##' reliability (like \eqn{\eta^2} in ANOVA). ##' ##' The `"omega3"` coefficient (McDonald, 1999), sometimes referred to as ##' hierarchical omega, can be calculated by ##' ##' \deqn{ \omega_3 =\frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} ##' Var\left( \psi \right)}{\bold{1}^\prime \Sigma \bold{1}}, } ##' ##' where \eqn{\Sigma} is the observed covariance matrix. If the model fits the ##' data well, \eqn{\omega_3} will be similar to \eqn{\omega_2}. Note that if ##' there is a directional effect in the model, all coefficients are calculated ##' from total factor variances: `lavInspect(object, "cov.lv")`. ##' ##' In conclusion, \eqn{\omega_1}, \eqn{\omega_2}, and \eqn{\omega_3} are ##' different in the denominator. The denominator of the first formula assumes ##' that a model is congeneric factor model where measurement errors are not ##' correlated. The second formula accounts for correlated measurement errors. ##' However, these two formulas assume that the model-implied covariance matrix ##' explains item relationships perfectly. The residuals are subject to sampling ##' error. The third formula use observed covariance matrix instead of ##' model-implied covariance matrix to calculate the observed total variance. ##' This formula is the most conservative method in calculating coefficient ##' omega. ##' ##' The average variance extracted (AVE) can be calculated by ##' ##' \deqn{ AVE = \frac{\bold{1}^\prime ##' \textrm{diag}\left(\Lambda\Psi\Lambda^\prime\right)\bold{1}}{\bold{1}^\prime ##' \textrm{diag}\left(\hat{\Sigma}\right) \bold{1}}, } ##' ##' Note that this formula is modified from Fornell & Larcker (1981) in the case ##' that factor variances are not 1. The proposed formula from Fornell & Larcker ##' (1981) assumes that the factor variances are 1. Note that AVE will not be ##' provided for factors consisting of items with dual loadings. AVE is the ##' property of items but not the property of factors. AVE is calculated with ##' polychoric correlations when ordinal indicators are used. ##' ##' Coefficient alpha is by definition applied by treating indicators as numeric ##' (see Chalmers, 2018), which is consistent with the `alpha` function in ##' the `psych` package. When indicators are ordinal, `reliability` ##' additionally applies the standard alpha calculation to the polychoric ##' correlation matrix to return Zumbo et al.'s (2007) "ordinal alpha". ##' ##' Coefficient omega for categorical items is calculated using Green and Yang's ##' (2009, formula 21) approach. Three types of coefficient omega indicate ##' different methods to calculate item total variances. The original formula ##' from Green and Yang is equivalent to \eqn{\omega_3} in this function. ##' Green and Yang did not propose a method for ##' calculating reliability with a mixture of categorical and continuous ##' indicators, and we are currently unaware of an appropriate method. ##' Therefore, when `reliability` detects both categorical and continuous ##' indicators of a factor, an error is returned. If the categorical indicators ##' load on a different factor(s) than continuous indicators, then reliability ##' will still be calculated separately for those factors, but ##' `return.total` must be `FALSE` (unless `omit.factors` is used ##' to isolate factors with indicators of the same type). ##' ##' ##' @importFrom lavaan lavInspect lavNames ##' @importFrom methods getMethod ##' ##' @param object A [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object, ##' expected to contain only exogenous common factors (i.e., a CFA model). ##' @param what `character` vector naming any reliability indices to ##' calculate. All are returned by default. When indicators are ordinal, ##' both traditional `"alpha"` and Zumbo et al.'s (2007) so-called ##' "ordinal alpha" (`"alpha.ord"`) are returned, though the latter is ##' arguably of dubious value (Chalmers, 2018). ##' @param return.total `logical` indicating whether to return a final ##' column containing the reliability of a composite of all indicators (not ##' listed in `omit.indicators`) of factors not listed in ##' `omit.factors`. Ignored in 1-factor models, and should only be set ##' `TRUE` if all factors represent scale dimensions that could be ##' meaningfully collapsed to a single composite (scale sum or scale mean). ##' @param dropSingle `logical` indicating whether to exclude factors ##' defined by a single indicator from the returned results. If `TRUE` ##' (default), single indicators will still be included in the `total` ##' column when `return.total = TRUE`. ##' @param omit.factors `character` vector naming any common factors ##' modeled in `object` whose composite reliability is not of ##' interest. For example, higher-order or method factors. Note that ##' [reliabilityL2()] should be used to calculate composite ##' reliability of a higher-order factor. ##' @param omit.indicators `character` vector naming any observed variables ##' that should be ignored when calculating composite reliability. This can ##' be useful, for example, to estimate reliability when an indicator is ##' removed. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return Reliability values (coefficient alpha, coefficients omega, average ##' variance extracted) of each factor in each group. If there are multiple ##' factors, a `total` column can optionally be included. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Bentler, P. M. (1972). A lower-bound method for the dimension-free ##' measurement of internal consistency. *Social Science Research, 1*(4), ##' 343--357. \doi{10.1016/0049-089X(72)90082-8} ##' ##' Bentler, P. M. (2009). Alpha, dimension-free, and model-based internal ##' consistency reliability. *Psychometrika, 74*(1), 137--143. ##' \doi{10.1007/s11336-008-9100-1} ##' ##' Chalmers, R. P. (2018). On misconceptions and the limited usefulness of ##' ordinal alpha. *Educational and Psychological Measurement, 78*(6), ##' 1056--1071. \doi{10.1177/0013164417727036} ##' ##' Cho, E. (2021) Neither Cronbach’s alpha nor McDonald’s omega: A commentary ##' on Sijtsma and Pfadt. *Psychometrika, 86*(4), 877--886. ##' \doi{10.1007/s11336-021-09801-1} ##' ##' Cronbach, L. J. (1951). Coefficient alpha and the internal structure of ##' tests. *Psychometrika, 16*(3), 297--334. \doi{10.1007/BF02310555} ##' ##' Fornell, C., & Larcker, D. F. (1981). Evaluating structural equation models ##' with unobservable variables and measurement errors. *Journal of ##' Marketing Research, 18*(1), 39--50. \doi{10.2307/3151312} ##' ##' Green, S. B., & Yang, Y. (2009). Reliability of summed item scores using ##' structural equation modeling: An alternative to coefficient alpha. ##' *Psychometrika, 74*(1), 155--167. \doi{10.1007/s11336-008-9099-3} ##' ##' McDonald, R. P. (1999). *Test theory: A unified treatment*. Mahwah, NJ: ##' Erlbaum. ##' ##' Raykov, T. (2001). Estimation of congeneric scale reliability using ##' covariance structure analysis with nonlinear constraints *British ##' Journal of Mathematical and Statistical Psychology, 54*(2), 315--323. ##' \doi{10.1348/000711001159582} ##' ##' Zumbo, B. D., Gadermann, A. M., & Zeisser, C. (2007). Ordinal versions of ##' coefficients alpha and theta for Likert rating scales. ##' *Journal of Modern Applied Statistical Methods, 6*(1), 21--29. ##' \doi{10.22237/jmasm/1177992180} ##' ##' Zumbo, B. D., & Kroc, E. (2019). A measurement is a choice and Stevens’ ##' scales of measurement do not help make it: A response to Chalmers. ##' *Educational and Psychological Measurement, 79*(6), 1184--1197. ##' \doi{10.1177/0013164419844305} ##' ##' ##' @examples ##' ##' data(HolzingerSwineford1939) ##' HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] ##' HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) ##' names(HSbinary) <- c("y7","y8","y9") ##' HS <- cbind(HolzingerSwineford1939, HSbinary) ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ y7 + y8 + y9 ' ##' ##' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ##' ##' ## works for factors with exclusively continuous OR categorical indicators ##' reliability(fit) ##' ##' ## reliability for ALL indicators only available when they are ##' ## all continuous or all categorical ##' reliability(fit, omit.factors = "speed", return.total = TRUE) ##' ##' ##' ## loop over visual indicators to calculate alpha if one indicator is removed ##' for (i in paste0("x", 1:3)) { ##' cat("Drop x", i, ":\n") ##' print(reliability(fit, omit.factors = c("textual","speed"), ##' omit.indicators = i, what = "alpha")) ##' } ##' ##' ##' ## works for multigroup models and for multilevel models (and both) ##' data(Demo.twolevel) ##' ## assign clusters to arbitrary groups ##' Demo.twolevel$g <- ifelse(Demo.twolevel$cluster %% 2L, "type1", "type2") ##' model2 <- ' group: type1 ##' level: within ##' fac =~ y1 + L2*y2 + L3*y3 ##' level: between ##' fac =~ y1 + L2*y2 + L3*y3 ##' ##' group: type2 ##' level: within ##' fac =~ y1 + L2*y2 + L3*y3 ##' level: between ##' fac =~ y1 + L2*y2 + L3*y3 ##' ' ##' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") ##' reliability(fit2, what = c("alpha","omega3")) ##' ##' @name reliability-deprecated ##' @usage ##' reliability(object, what = c("alpha", "omega", "omega2", "omega3", "ave"), ##' return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), ##' omit.indicators = character(0), omit.imps = c("no.conv", "no.se")) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @section Reliability: ##' The original `reliability` function was suboptimally designed. ##' For example, AVE was returned, which is not a reliability index. Also, ##' alpha and several omega-type coefficients were returned, including the ##' original formula that was in appropriate for models with complex structure. ##' Some features could be controlled by the user for one but not both types of ##' index For example, alpha for categorical indicators was returned on both ##' the observed and latent-response scales, but this was not an option for any ##' omega-type indices. The omegas differed in terms of whether the observed or ##' model-implied covariance matrix was used in the denominator, but alpha was ##' only computed using the observed matrix. These inconsistencies have been ##' resolved in the new [compRelSEM()] function, which returns only ##' one reliability index (per factor, optionally total score) according to the ##' user's requested features, for which there is much more flexibility. ##' Average variance extracted is now available in a dedicated [AVE()] ##' function. ##' ##' @export reliability <- function(object, what = c("alpha","omega","omega2","omega3","ave"), return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), omit.indicators = character(0), omit.imps = c("no.conv","no.se")) { .Deprecated(msg = c("\nThe reliability() function was deprecated in 2022 and ", "will cease to be included in future versions of semTools", ". See help('semTools-deprecated) for details.", "\n\nIt is replaced by the compRelSEM() function, which ", "can estimate alpha and model-based reliability in an ", "even wider variety of models and data types, with ", "greater control in specifying the desired type of ", "reliability coefficient (i.e., more explicitly choosing ", "assumptions). \n\nThe average variance extracted should ", "never have been included because it is not a reliability ", "coefficient. It is now available from the AVE() function.")) ngroups <- lavInspect(object, "ngroups") #TODO: adapt to multiple levels nLevels <- lavInspect(object, "nlevels") nblocks <- ngroups*nLevels #FIXME: always true? return.total <- rep(return.total, nblocks) group.label <- if (ngroups > 1L) lavInspect(object, "group.label") else NULL #FIXME? lavInspect(object, "level.labels") clus.label <- if (nLevels > 1L) c("within", lavInspect(object, "cluster")) else NULL if (nblocks > 1L) { block.label <- paste(rep(group.label, each = nLevels), clus.label, sep = if (ngroups > 1L && nLevels > 1L) "_" else "") } ## check for categorical (determines what S will be) anyCategorical <- lavInspect(object, "categorical") if (anyCategorical && "alpha" %in% what) { what <- c(what, "alpha.ord") what <- unique(what) # in case it was already explicitly requested } ## categorical-model parameters threshold <- if (anyCategorical) getThreshold(object, omit.imps = omit.imps) else NULL latScales <- if (anyCategorical) getScales(object, omit.imps = omit.imps) else NULL ## all other relevant parameters in GLIST format (not flat, need block-level list) if (inherits(object, "lavaan")) { param <- lavInspect(object, "est") ve <- lavInspect(object, "cov.lv") # model-implied latent covariance matrix S <- object@h1$implied$cov # observed sample covariance matrix (already a list) if (anyCategorical && any(c("alpha","alpha.ord") %in% what)) { rawData <- try(lavInspect(object, "data"), silent = TRUE) if (inherits(rawData, "try-error")) stop('Error in lavInspect(fit, "data"); what="alpha" unavailable for ', 'models fitted to summary statistics of categorial data.') if (nblocks == 1L) rawData <- list(rawData) S.as.con <- lapply(rawData, cov) # for actual "alpha", not "alpha.ord" } if (nblocks == 1L) { param <- list(param) ve <- list(ve) } } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) param <- object@coefList[[ useImps[1] ]] # first admissible as template coefList <- object@coefList[useImps] phiList <- object@phiList[useImps] if (anyCategorical) { dataList <- object@DataList[useImps] S.as.con <- vector("list", nblocks) # for group-list of pooled S } ## add block-level list per imputation? if (nblocks == 1L) { param <- list(param) for (i in 1:m) { coefList[[i]] <- list(coefList[[i]]) phiList[[i]] <- list(phiList[[i]]) } if (anyCategorical) { #FIXME: currently no categorical ML-SEMs #dataList[[i]] <- list(dataList[[i]]) VV <- lavNames(object, type = "ov") impCovList <- lapply(dataList, function(DD) { dat <- do.call(cbind, sapply(DD[VV], as.numeric, simplify = FALSE)) cov(dat) }) S.as.con[[1]] <- Reduce("+", impCovList) / length(impCovList) } } else if (anyCategorical) { #FIXME: currently no categorical ML-SEMs ## multigroup models need separate data matrices per group G <- lavInspect(object, "group") for (g in seq_along(group.label)) { VV <- try(lavNames(object, type = "ov", group = group.label[g]), silent = TRUE) if (inherits(VV, "try-error")) { VV <- lavNames(object, type = "ov", group = g) } impCovList <- lapply(dataList, function(DD) { RR <- DD[,G] == group.label[g] dat <- do.call(cbind, sapply(DD[RR, VV], as.numeric, simplify = FALSE)) cov(dat) }) S.as.con[[g]] <- Reduce("+", impCovList) / length(impCovList) } } S <- vector("list", nblocks) # pooled observed OR polychoric covariance matrix ve <- vector("list", nblocks) ## loop over blocks for (b in 1:nblocks) { ## param: loop over GLIST elements for (mat in names(param[[b]])) { matList <- lapply(coefList, function(i) i[[b]][[mat]]) param[[b]][[mat]] <- Reduce("+", matList) / length(matList) } # mat ## pooled observed OR polychoric covariance matrix covList <- lapply(object@h1List[useImps], function(i) i$implied$cov[[b]]) S[[b]] <- Reduce("+", covList) / m ## pooled model-implied latent covariance matrix ve[[b]] <- Reduce("+", lapply(phiList, "[[", i = b) ) / m } # b } if (nblocks == 1L) { SigmaHat <- getMethod("fitted", class(object))(object)["cov"] # retain list format } else { SigmaHat <- sapply(getMethod("fitted", class(object))(object), "[[", "cov", simplify = FALSE) } ly <- lapply(param, "[[", "lambda") te <- lapply(param, "[[", "theta") beta <- if ("beta" %in% names(param[[1]])) { lapply(param, "[[", "beta") } else NULL result <- list() warnTotal <- FALSE warnHigher <- character(0) # collect list of potential higher-order factors ## loop over i blocks (groups/levels) for (i in 1:nblocks) { ## extract factor and indicator names allIndNames <- rownames(ly[[i]]) allFacNames <- colnames(ly[[i]]) myFacNames <- setdiff(allFacNames, omit.factors) subLY <- ly[[i]][ , myFacNames, drop = FALSE] != 0 myIndNames <- rownames(subLY)[apply(subLY, MARGIN = 1L, FUN = any)] ## distinguish between categorical, continuous, and latent indicators nameArgs <- list(object = object) if (nblocks > 1L) nameArgs$block <- i ordNames <- do.call(lavNames, c(nameArgs, list(type = "ov.ord"))) numNames <- do.call(lavNames, c(nameArgs, list(type = "ov.num"))) if (anyCategorical) { ## identify when the (sub)set of factors are all categorical blockCat <- all(myIndNames %in% ordNames) ## identify when the (sub)set of factors have mixed indicators, so no total mix <- any(myIndNames %in% ordNames) && any(myIndNames %in% numNames) } else { blockCat <- FALSE mix <- FALSE } if (mix && return.total[i]) { return.total[i] <- FALSE warnTotal <- TRUE } ## identify POSSIBLE higher-order factors (that affect other latent vars) latInds <- do.call(lavNames, c(nameArgs, list(type = "lv.ind"))) higher <- if (length(latInds) == 0L) character(0) else { allFacNames[apply(beta[[i]], MARGIN = 2, function(x) any(x != 0))] } ## keep track of factor indices to skip idx.drop <- numeric(0) ## relevant quantities common <- (apply(ly[[i]], 2, sum)^2) * diag(ve[[i]]) truevar <- ly[[i]] %*% ve[[i]] %*% t(ly[[i]]) ## vectors to store results for each factor error <- rep(NA, length(common)) alpha <- rep(NA, length(common)) alpha.ord <- rep(NA, length(common)) total <- rep(NA, length(common)) omega1 <- omega2 <- omega3 <- rep(NA, length(common)) impliedTotal <- rep(NA, length(common)) avevar <- rep(NA, length(common)) warnOmega <- FALSE ## loop over j factors for (j in 1:length(common)) { ## skip this factor? if (allFacNames[j] %in% omit.factors) { idx.drop <- c(idx.drop, j) next } index <- setdiff(which(ly[[i]][,j] != 0), # nonzero loadings which(allIndNames %in% omit.indicators)) jIndNames <- allIndNames[index] ## identify when this factor has mixed indicators, so no omegas jMix <- any(jIndNames %in% ordNames) && any(jIndNames %in% numNames) ## check for ANY indicators (possibly skip purely higher-order factors) if (length(index) == 0L) { idx.drop <- c(idx.drop, j) next } ## check for single indicators if (dropSingle && length(index) == 1L) { idx.drop <- c(idx.drop, j) next } ## check for categorical (or mixed) indicators jCat <- any(jIndNames %in% ordNames) warnOmega <- jCat && !all(jIndNames %in% ordNames) ## check for latent indicators if (allFacNames[j] %in% higher && !(allFacNames[j] %in% omit.factors)) { warnHigher <- c(warnHigher, allFacNames[j]) } sigma <- S[[i]][index, index, drop = FALSE] faccontrib <- ly[[i]][,j, drop = FALSE] %*% ve[[i]][j,j, drop = FALSE] %*% t(ly[[i]][,j, drop = FALSE]) truefac <- diag(faccontrib[index, index, drop = FALSE]) trueitem <- diag(truevar[index, index, drop = FALSE]) erritem <- diag(te[[i]][index, index, drop = FALSE]) if (sum(abs(trueitem - truefac)) < 0.00001 & "ave" %in% what) { avevar[j] <- sum(trueitem) / sum(trueitem + erritem) } if (jCat) { if ("alpha" %in% what) { alpha[j] <- computeAlpha(S.as.con[[i]][index, index, drop = FALSE]) } if ("alpha.ord" %in% what) { alpha.ord[j] <- computeAlpha(sigma) } if ("omega" %in% what) { omega1[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], threshold = threshold[[i]][jIndNames], scales = latScales[[i]][index], denom = faccontrib[index, index, drop = FALSE] + te[[i]][index, index, drop = FALSE]) } if ("omega2" %in% what) { omega2[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], threshold = threshold[[i]][jIndNames], scales = latScales[[i]][index], denom = SigmaHat[[i]][index, index, drop = FALSE]) } if ("omega3" %in% what) { omega3[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], threshold = threshold[[i]][jIndNames], scales = latScales[[i]][index], denom = sigma) } } else { alpha[j] <- computeAlpha(sigma) commonfac <- sum(faccontrib[index, index, drop = FALSE]) error[j] <- sum(te[[i]][index, index, drop = FALSE]) impliedTotal[j] <- sum(SigmaHat[[i]][index, index, drop = FALSE]) total[j] <- sum(sigma) omega1[j] <- commonfac / (commonfac + error[j]) omega2[j] <- commonfac / impliedTotal[j] omega3[j] <- commonfac / total[j] } ## end loop over j factors } if (return.total[i] & length(myFacNames) > 1L) { if (blockCat) { if ("alpha" %in% what) { alpha <- c(alpha, computeAlpha(S.as.con[[i]])) } if ("alpha.ord" %in% what) { alpha.ord <- c(alpha.ord, total = computeAlpha(S[[i]])) } if ("omega" %in% what) { omega1 <- c(omega1, total = omegaCat(truevar = truevar, threshold = threshold[[i]], scales = latScales[[i]], denom = truevar + te[[i]])) } if ("omega2" %in% what) { omega2 <- c(omega2, total = omegaCat(truevar = truevar, threshold = threshold[[i]], scales = latScales[[i]], denom = SigmaHat[[i]])) } if ("omega2" %in% what) { omega3 <- c(omega3, total = omegaCat(truevar = truevar, threshold = threshold[[i]], scales = latScales[[i]], denom = S[[i]])) } } else { alpha <- c(alpha, total = computeAlpha(S[[i]])) omega1 <- c(omega1, total = sum(truevar) / (sum(truevar) + sum(te[[i]]))) omega2 <- c(omega2, total = sum(truevar) / (sum(SigmaHat[[i]]))) omega3 <- c(omega3, total = sum(truevar) / (sum(S[[i]]))) } avevar <- c(avevar, total = sum(diag(truevar)) / sum((diag(truevar) + diag(te[[i]])))) } if (all(is.na(alpha.ord))) alpha.ord <- NULL result[[i]] <- rbind(alpha = if ("alpha" %in% what) alpha else NULL, alpha.ord = if ("alpha.ord" %in% what) alpha.ord else NULL, omega = if ("omega" %in% what) omega1 else NULL, omega2 = if ("omega2" %in% what) omega2 else NULL, omega3 = if ("omega3" %in% what) omega3 else NULL, avevar = if ("ave" %in% what) avevar else NULL) colnames(result[[i]])[1:length(allFacNames)] <- allFacNames if (return.total[i] & length(myFacNames) > 1L) { colnames(result[[i]])[ ncol(result[[i]]) ] <- "total" } if (length(idx.drop)) { result[[i]] <- result[[i]][ , -idx.drop, drop = FALSE] ## reset indices for next block (could have different model/variables) idx.drop <- numeric(0) } ## end loop over blocks } warnCat <- sapply(result, function(x) any(c("alpha.ord","ave") %in% rownames(x))) if (any(warnCat)) { alphaMessage <- paste0('Zumbo et al.`s (2007) "ordinal alpha" is calculated', ' in addition to the standard alpha, which treats ', 'ordinal variables as numeric. See Chalmers (2018) ', 'for a critique of "alpha.ord" and the response by ', 'Zumbo & Kroc (2019).') AVEmessage <- paste0('average variance extracted is calculated from ', 'polychoric (polyserial) not Pearson correlations.') both <- "alpha.ord" %in% what & "ave" %in% what connectMessage <- if (both) ' Likewise, ' else ' the ' catMessage <- paste0("For constructs with categorical indicators, ", if ("alpha.ord" %in% what) alphaMessage else NULL, if (both) ' Likewise, ' else NULL, if ("ave" %in% what) AVEmessage else NULL) if ("alpha.ord" %in% what || "ave" %in% what) message(catMessage, "\n") } if (length(warnHigher)) warning('Possible higher-order factors detected:\n', paste(unique(warnHigher), sep = ", ")) if (warnTotal) { message('Cannot return.total when model contains both continuous and ', 'binary/ordinal observed indicators. Use the ', 'omit.factors= argument to choose factors with only categorical ', 'indicators, if that is a composite of interest.\n') } if (warnOmega) { message('Composite reliability (omega) cannot be computed for factors ', 'with mixed categorical and continuous indicators.') } ## drop list structure? if (nblocks == 1L) { result <- result[[1]] } else names(result) <- block.label result } ## --------------- ## reliabilityL2() ## (deprecated 10 May 2022) ## --------------- ##' Calculate the reliability values of a second-order factor ##' ##' Calculate the reliability values (coefficient omega) of a second-order ##' factor ##' ##' The first formula of the coefficient omega (in the ##' [reliability()]) will be mainly used in the calculation. The ##' model-implied covariance matrix of a second-order factor model can be ##' separated into three sources: the second-order common-factor variance, ##' the residual variance of the first-order common factors (i.e., not ##' accounted for by the second-order factor), and the measurement error of ##' observed indicators: ##' ##' \deqn{ \hat{\Sigma} = \Lambda \bold{B} \Phi_2 \bold{B}^{\prime} ##' \Lambda^{\prime} + \Lambda \Psi_{u} \Lambda^{\prime} + \Theta, } ##' ##' where \eqn{\hat{\Sigma}} is the model-implied covariance matrix, ##' \eqn{\Lambda} contains first-order factor loadings, \eqn{\bold{B}} contains ##' second-order factor loadings, \eqn{\Phi_2} is the covariance matrix of the ##' second-order factor(s), \eqn{\Psi_{u}} is the covariance matrix of residuals ##' from first-order factors, and \eqn{\Theta} is the covariance matrix of the ##' measurement errors from observed indicators. Thus, we can calculate the ##' proportion of variance of a composite score calculated from the observed ##' indicators (e.g., a total score or scale mean) that is attributable to the ##' second-order factor, i.e. coefficient omega at Level 1: ##' ##' \deqn{ \omega_{L1} = \frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 ##' \bold{B}^{\prime} \Lambda^{\prime} \bold{1}}{\bold{1}^{\prime} \Lambda ##' \bold{B} \Phi_2 \bold{B} ^{\prime} \Lambda^{\prime} \bold{1} + ##' \bold{1}^{\prime} \Lambda \Psi_{u} \Lambda^{\prime} \bold{1} + ##' \bold{1}^{\prime} \Theta \bold{1}}, } ##' ##' where \eqn{\bold{1}} is the *k*-dimensional vector of 1 and *k* is ##' the number of observed variables. ##' ##' The model-implied covariance matrix among first-order factors (\eqn{\Phi_1}) ##' can be calculated as: ##' ##' \deqn{ \Phi_1 = \bold{B} \Phi_2 \bold{B}^{\prime} + \Psi_{u}, } ##' ##' Thus, the proportion of variance among first-order common factors that is ##' attributable to the second-order factor (i.e., coefficient omega at Level 2) ##' can be calculated as: ##' ##' \deqn{ \omega_{L2} = \frac{\bold{1}_F^{\prime} \bold{B} \Phi_2 ##' \bold{B}^{\prime} \bold{1}_F}{\bold{1}_F^{\prime} \bold{B} \Phi_2 ##' \bold{B}^{\prime} \bold{1}_F + \bold{1}_F^{\prime} \Psi_{u} \bold{1}_F}, } ##' ##' where \eqn{\bold{1}_F} is the *F*-dimensional vector of 1 and *F* ##' is the number of first-order factors. This Level-2 omega can be interpreted ##' as an estimate of the reliability of a hypothetical composite calculated ##' from error-free observable variables representing the first-order common ##' factors. This might only be meaningful as a thought experiment. ##' ##' An additional thought experiment is possible: If the observed indicators ##' contained only the second-order common-factor variance and unsystematic ##' measurement error, then there would be no first-order common factors because ##' their unique variances would be excluded from the observed measures. An ##' estimate of this hypothetical composite reliability can be calculated as the ##' partial coefficient omega at Level 1, or the proportion of observed ##' variance explained by the second-order factor after partialling out the ##' uniqueness from the first-order factors: ##' ##' \deqn{ \omega_{L1} = \frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 ##' \bold{B}^{\prime} \Lambda^{\prime} \bold{1}}{\bold{1}^{\prime} \Lambda ##' \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime} \bold{1} + ##' \bold{1}^{\prime} \Theta \bold{1}}, } ##' ##' Note that if the second-order factor has a direct factor loading on some ##' observed variables, the observed variables will be counted as first-order ##' factors, which might not be desirable. ##' ##' ##' @importFrom lavaan lavInspect ##' ##' @param object A [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object, ##' expected to contain a least one exogenous higher-order common factor. ##' @param secondFactor The name of a single second-order factor in the ##' model fitted in `object`. The function must be called multiple ##' times to estimate reliability for each higher-order factor. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return Reliability values at Levels 1 and 2 of the second-order factor, as ##' well as the partial reliability value at Level 1 ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @examples ##' ##' HS.model3 <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' higher =~ visual + textual + speed' ##' ##' fit6 <- cfa(HS.model3, data = HolzingerSwineford1939) ##' reliability(fit6) # Should provide a warning for the endogenous variables ##' reliabilityL2(fit6, "higher") ##' ##' @name reliabilityL2-deprecated ##' @usage ##' reliabilityL2(object, secondFactor, omit.imps = c("no.conv", "no.se")) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @section Higher-Order Reliability: ##' Originally, composite reliability of a single higher-order factor was ##' estimated in a separate function: `reliabilityL2`. It is now available ##' for multiple higher-order factors in the same model, and from the same ##' [compRelSEM()] function that estimates reliability for first-order ##' factors, using the `higher=` argument to name higher-order factors in ##' the fitted model. ##' ##' @export reliabilityL2 <- function(object, secondFactor, omit.imps = c("no.conv","no.se")) { .Deprecated(msg = c("\nThe reliabilityL2() function was deprecated in 2022 and ", "will cease to be included in future versions of semTools", ". See help('semTools-deprecated) for details.", "\n\nIt is replaced by the compRelSEM() function, which ", "can estimate alpha and model-based reliability in an ", "even wider variety of models and data types, with ", "greater control in specifying the desired type of ", "reliability coefficient (i.e., more explicitly choosing ", "assumptions).")) secondFactor <- as.character(secondFactor)[1] # only one at a time ngroups <- lavInspect(object, "ngroups") #TODO: adapt to multiple levels nLevels <- lavInspect(object, "nlevels") nblocks <- ngroups*nLevels #FIXME: always true? group.label <- if (ngroups > 1L) lavInspect(object, "group.label") else NULL #FIXME? lavInspect(object, "level.labels") clus.label <- if (nLevels > 1L) c("within", lavInspect(object, "cluster")) else NULL if (nblocks > 1L) { block.label <- paste(rep(group.label, each = nLevels), clus.label, sep = if (ngroups > 1L && nLevels > 1L) "_" else "") } ## parameters in GLIST format (not flat, need block-level list) if (inherits(object, "lavaan")) { param <- lavInspect(object, "est") ve <- lavInspect(object, "cov.lv") # model-implied latent covariance matrix S <- object@h1$implied$cov # observed sample covariance matrix (already a list) if (nblocks == 1L) { param <- list(param) ve <- list(ve) } } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) param <- object@coefList[[ useImps[1] ]] # first admissible as template coefList <- object@coefList[useImps] phiList <- object@phiList[useImps] ## add block-level list per imputation? if (nblocks == 1L) { param <- list(param) for (i in 1:m) { coefList[[i]] <- list(coefList[[i]]) phiList[[i]] <- list(phiList[[i]]) } } S <- vector("list", nblocks) # pooled observed covariance matrix ve <- vector("list", nblocks) ## loop over blocks for (b in 1:nblocks) { ## param: loop over GLIST elements for (mat in names(param[[b]])) { matList <- lapply(coefList, function(i) i[[b]][[mat]]) param[[b]][[mat]] <- Reduce("+", matList) / length(matList) } # mat ## pooled observed covariance matrix covList <- lapply(object@h1List[useImps], function(i) i$implied$cov[[b]]) S[[b]] <- Reduce("+", covList) / m ## pooled model-implied latent covariance matrix ve[[b]] <- Reduce("+", lapply(phiList, "[[", i = b) ) / m } # b } if (nblocks == 1L) { SigmaHat <- getMethod("fitted", class(object))(object)["cov"] # retain list format } else { SigmaHat <- sapply(getMethod("fitted", class(object))(object), "[[", "cov", simplify = FALSE) } ly <- lapply(param, "[[", "lambda") te <- lapply(param, "[[", "theta") ps <- lapply(param, "[[", "psi") be <- lapply(param, "[[", "beta") result <- list() for (i in 1:nblocks) { # Prepare for higher-order reliability l2var <- ve[[i]][secondFactor, secondFactor, drop = FALSE] l2load <- be[[1]][,secondFactor] indexl2 <- which(l2load != 0) commonl2 <- (sum(l2load)^2) * l2var errorl2 <- sum(ps[[i]][indexl2, indexl2, drop = FALSE]) # Prepare for lower-order reliability indexl1 <- which(apply(ly[[i]][,indexl2, drop = FALSE], 1, function(x) sum(x != 0)) > 0) l1load <- ly[[i]][,indexl2] %*% as.matrix(be[[1]][indexl2, secondFactor, drop = FALSE]) commonl1 <- (sum(l1load)^2) * l2var errorl1 <- sum(te[[i]][indexl1, indexl1, drop = FALSE]) uniquel1 <- 0 for (j in seq_along(indexl2)) { uniquel1 <- uniquel1 + (sum(ly[[i]][,indexl2[j]])^2) * ps[[i]][indexl2[j], indexl2[j], drop = FALSE] } # Adjustment for direct loading from L2 to observed variables if (any(ly[[i]][,secondFactor] != 0)) { indexind <- which(ly[[i]][,secondFactor] != 0) if (length(intersect(indexind, indexl1)) > 0) stop("Direct and indirect loadings of higher-order factor to observed", " variables are specified at the same time.") commonl2 <- sum(c(ly[[i]][,secondFactor], l2load))^2 * l2var errorl2 <- errorl2 + sum(te[[i]][indexind, indexind, drop = FALSE]) commonl1 <- sum(c(ly[[i]][,secondFactor], l1load))^2 * l2var errorl1 <- errorl1 + sum(te[[i]][indexind, indexind, drop = FALSE]) } # Calculate Reliability omegaL1 <- commonl1 / (commonl1 + uniquel1 + errorl1) omegaL2 <- commonl2 / (commonl2 + errorl2) partialOmegaL1 <- commonl1 / (commonl1 + errorl1) result[[i]] <- c(omegaL1 = omegaL1, omegaL2 = omegaL2, partialOmegaL1 = partialOmegaL1) } if (nblocks == 1L) { result <- result[[1]] } else names(result) <- block.label result } ## -------------- ## maximalRelia() ## -------------- ##' Calculate maximal reliability ##' ##' Calculate maximal reliability of a scale ##' ##' Given that a composite score (\eqn{W}) is a weighted sum of item scores: ##' ##' \deqn{ W = \bold{w}^\prime \bold{x} ,} ##' ##' where \eqn{\bold{x}} is a \eqn{k \times 1} vector of the scores of each ##' item, \eqn{\bold{w}} is a \eqn{k \times 1} weight vector of each item, and ##' \eqn{k} represents the number of items. Then, maximal reliability is ##' obtained by finding \eqn{\bold{w}} such that reliability attains its maximum ##' (Li, 1997; Raykov, 2012). Note that the reliability can be obtained by ##' ##' \deqn{ \rho = \frac{\bold{w}^\prime \bold{S}_T \bold{w}}{\bold{w}^\prime ##' \bold{S}_X \bold{w}}} ##' ##' where \eqn{\bold{S}_T} is the covariance matrix explained by true scores and ##' \eqn{\bold{S}_X} is the observed covariance matrix. Numerical method is used ##' to find \eqn{\bold{w}} in this function. ##' ##' For continuous items, \eqn{\bold{S}_T} can be calculated by ##' ##' \deqn{ \bold{S}_T = \Lambda \Psi \Lambda^\prime,} ##' ##' where \eqn{\Lambda} is the factor loading matrix and \eqn{\Psi} is the ##' covariance matrix among factors. \eqn{\bold{S}_X} is directly obtained by ##' covariance among items. ##' ##' For categorical items, Green and Yang's (2009) method is used for ##' calculating \eqn{\bold{S}_T} and \eqn{\bold{S}_X}. The element \eqn{i} and ##' \eqn{j} of \eqn{\bold{S}_T} can be calculated by ##' ##' \deqn{ \left[\bold{S}_T\right]_{ij} = \sum^{C_i - 1}_{c_i = 1} \sum^{C_j - ##' 1}_{c_j - 1} \Phi_2\left( \tau_{x_{c_i}}, \tau_{x_{c_j}}, \left[ \Lambda ##' \Psi \Lambda^\prime \right]_{ij} \right) - \sum^{C_i - 1}_{c_i = 1} ##' \Phi_1(\tau_{x_{c_i}}) \sum^{C_j - 1}_{c_j - 1} \Phi_1(\tau_{x_{c_j}}),} ##' ##' where \eqn{C_i} and \eqn{C_j} represents the number of thresholds in Items ##' \eqn{i} and \eqn{j}, \eqn{\tau_{x_{c_i}}} represents the threshold \eqn{c_i} ##' of Item \eqn{i}, \eqn{\tau_{x_{c_j}}} represents the threshold \eqn{c_i} of ##' Item \eqn{j}, \eqn{ \Phi_1(\tau_{x_{c_i}})} is the cumulative probability of ##' \eqn{\tau_{x_{c_i}}} given a univariate standard normal cumulative ##' distribution and \eqn{\Phi_2\left( \tau_{x_{c_i}}, \tau_{x_{c_j}}, \rho ##' \right)} is the joint cumulative probability of \eqn{\tau_{x_{c_i}}} and ##' \eqn{\tau_{x_{c_j}}} given a bivariate standard normal cumulative ##' distribution with a correlation of \eqn{\rho} ##' ##' Each element of \eqn{\bold{S}_X} can be calculated by ##' ##' \deqn{ \left[\bold{S}_T\right]_{ij} = \sum^{C_i - 1}_{c_i = 1} \sum^{C_j - ##' 1}_{c_j - 1} \Phi_2\left( \tau_{V_{c_i}}, \tau_{V_{c_j}}, \rho^*_{ij} ##' \right) - \sum^{C_i - 1}_{c_i = 1} \Phi_1(\tau_{V_{c_i}}) \sum^{C_j - ##' 1}_{c_j - 1} \Phi_1(\tau_{V_{c_j}}),} ##' ##' where \eqn{\rho^*_{ij}} is a polychoric correlation between Items \eqn{i} ##' and \eqn{j}. ##' ##' ##' @importFrom lavaan lavInspect lavNames ##' ##' @param object A [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object, ##' expected to contain only exogenous common factors (i.e., a CFA model). ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return Maximal reliability values of each group. The maximal-reliability ##' weights are also provided. Users may extracted the weighted by the ##' `attr` function (see example below). ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso [reliability()] for reliability of an unweighted ##' composite score ##' ##' @references ##' Li, H. (1997). A unifying expression for the maximal reliability of a linear ##' composite. *Psychometrika, 62*(2), 245--249. \doi{10.1007/BF02295278} ##' ##' Raykov, T. (2012). Scale construction and development using structural ##' equation modeling. In R. H. Hoyle (Ed.), *Handbook of structural ##' equation modeling* (pp. 472--494). New York, NY: Guilford. ##' ##' @examples ##' ##' total <- 'f =~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 ' ##' fit <- cfa(total, data = HolzingerSwineford1939) ##' maximalRelia(fit) ##' ##' # Extract the weight ##' mr <- maximalRelia(fit) ##' attr(mr, "weight") ##' ##' @export maximalRelia <- function(object, omit.imps = c("no.conv","no.se")) { ngroups <- lavInspect(object, "ngroups") #TODO: adapt to multiple levels nLevels <- lavInspect(object, "nlevels") nblocks <- ngroups*nLevels #FIXME: always true? group.label <- if (ngroups > 1L) lavInspect(object, "group.label") else NULL #FIXME? lavInspect(object, "level.labels") clus.label <- if (nLevels > 1L) c("within", lavInspect(object, "cluster")) else NULL if (nblocks > 1L) { block.label <- paste(rep(group.label, each = nLevels), clus.label, sep = if (ngroups > 1L && nLevels > 1L) "_" else "") } ## parameters in GLIST format (not flat, need block-level list) if (inherits(object, "lavaan")) { param <- lavInspect(object, "est") ve <- lavInspect(object, "cov.lv") # model-implied latent covariance matrix S <- object@h1$implied$cov # observed sample covariance matrix (already a list) if (nblocks == 1L) { param <- list(param) ve <- list(ve) } } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) param <- object@coefList[[ useImps[1] ]] # first admissible as template coefList <- object@coefList[useImps] phiList <- object@phiList[useImps] ## add block-level list per imputation? if (nblocks == 1L) { param <- list(param) for (i in 1:m) { coefList[[i]] <- list(coefList[[i]]) phiList[[i]] <- list(phiList[[i]]) } } S <- vector("list", nblocks) # pooled observed covariance matrix ve <- vector("list", nblocks) ## loop over blocks for (b in 1:nblocks) { ## param: loop over GLIST elements for (mat in names(param[[b]])) { matList <- lapply(coefList, function(i) i[[b]][[mat]]) param[[b]][[mat]] <- Reduce("+", matList) / length(matList) } # mat ## pooled observed covariance matrix covList <- lapply(object@h1List[useImps], function(i) i$implied$cov[[b]]) S[[b]] <- Reduce("+", covList) / m ## pooled model-implied latent covariance matrix ve[[b]] <- Reduce("+", lapply(phiList, "[[", i = b) ) / m } # b } if (nblocks == 1L) { SigmaHat <- getMethod("fitted", class(object))(object)["cov"] # retain list format } else { SigmaHat <- sapply(getMethod("fitted", class(object))(object), "[[", "cov", simplify = FALSE) } ly <- lapply(param, "[[", "lambda") te <- lapply(param, "[[", "theta") categorical <- lavInspect(object, "categorical") threshold <- if (categorical) getThreshold(object, omit.imps = omit.imps) else NULL result <- list() for (i in 1:nblocks) { truevar <- ly[[i]] %*% ve[[i]] %*% t(ly[[i]]) varnames <- colnames(truevar) if (categorical) { invstdvar <- 1 / sqrt(diag(SigmaHat[[i]])) polyr <- diag(invstdvar) %*% truevar %*% diag(invstdvar) nitem <- ncol(SigmaHat[[i]]) result[[i]] <- calcMaximalReliaCat(polyr, threshold[[i]], S[[i]], nitem, varnames) } else { result[[i]] <- calcMaximalRelia(truevar, S[[i]], varnames) } } if (nblocks == 1L) { result <- result[[1]] } else names(result) <- block.label result } ## ---------------- ## Hidden Functions ## ---------------- computeAlpha <- function(S) { k <- nrow(S) k/(k - 1) * (1.0 - sum(diag(S)) / sum(S)) } #' @importFrom stats cov2cor pnorm omegaCat <- function(truevar, threshold, scales, denom) { ## must be in standardized latent scale R <- diag(scales) %*% truevar %*% diag(scales) ## denom could be model-implied polychoric correlation assuming diagonal theta, ## model-implied polychoric correlation accounting for error covariances, ## or "observed" polychoric correlation matrix. ## If parameterization="theta", standardize the polychoric coVARIANCE matrix denom <- cov2cor(denom) nitem <- ncol(denom) ## initialize sums of cumulative probabilities sumnum <- 0 # numerator addden <- 0 # denominator ## loop over all pairs of items for (j in 1:nitem) { for (jp in 1:nitem) { ## initialize sums of cumulative probabilities *per item* sumprobn2 <- 0 addprobn2 <- 0 ## for each pair of items, loop over all their thresholds t1 <- threshold[[j]] * scales[j] # on standardized latent scale t2 <- threshold[[jp]] * scales[jp] #FIXME: subtract intercept (or marginal mean?) for (c in 1:length(t1)) { for (cp in 1:length(t2)) { sumprobn2 <- sumprobn2 + p2(t1[c], t2[cp], R[j, jp]) addprobn2 <- addprobn2 + p2(t1[c], t2[cp], denom[j, jp]) } } sumprobn1 <- sum(pnorm(t1)) sumprobn1p <- sum(pnorm(t2)) sumnum <- sumnum + (sumprobn2 - sumprobn1 * sumprobn1p) addden <- addden + (addprobn2 - sumprobn1 * sumprobn1p) } } reliab <- sumnum / addden reliab } p2 <- function(t1, t2, r) { mnormt::pmnorm(c(t1, t2), c(0,0), matrix(c(1, r, r, 1), 2, 2)) } # polycorLavaan <- function(object) { # ngroups <- lavInspect(object, "ngroups") # coef <- lavInspect(object, "est") # targettaunames <- NULL # if (ngroups == 1L) { # targettaunames <- rownames(coef$tau) # } else { # targettaunames <- rownames(coef[[1]]$tau) # } # barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|")) # varnames <- unique(apply(data.frame(targettaunames, barpos - 1), MARGIN = 1, # FUN = function(x) substr(x[1], 1, x[2]))) # if (length(varnames)) # script <- "" # for (i in 2:length(varnames)) { # temp <- paste0(varnames[1:(i - 1)], collapse = " + ") # temp <- paste0(varnames[i], "~~", temp, "\n") # script <- paste(script, temp) # } # newobject <- refit(script, object) # if (ngroups == 1L) { # return(lavInspect(newobject, "est")$theta) # } # lapply(lavInspect(newobject, "est"), "[[", "theta") # } ##' @importFrom lavaan lavInspect lavNames getThreshold <- function(object, omit.imps = c("no.conv","no.se")) { ngroups <- lavInspect(object, "ngroups") #TODO: add nlevels when capable ordnames <- lavNames(object, "ov.ord") if (inherits(object, "lavaan")) { EST <- lavInspect(object, "est") } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) EST <- object@coefList[useImps] } if (ngroups == 1L) { if (inherits(object, "lavaan")) { thresholds <- EST$tau[,"threshold"] } else if (inherits(object, "lavaan.mi")) { tauList <- lapply(EST, function(x) x$tau[,"threshold"]) thresholds <- Reduce("+", tauList) / length(tauList) } result <- lapply(ordnames, function(nn) thresholds[grepl(paste0(nn, "\\|"), names(thresholds))]) names(result) <- ordnames ## needs to be within a list when called above within block-loops result <- list(result) } else { thresholds <- vector("list", ngroups) for (g in 1:ngroups) { if (inherits(object, "lavaan")) { thresholds[[g]] <- EST[[g]]$tau[,"threshold"] } else if (inherits(object, "lavaan.mi")) { tauList <- lapply(EST, function(x) x[[g]]$tau[,"threshold"]) thresholds[[g]] <- Reduce("+", tauList) / length(tauList) } } result <- list() group.label <- lavInspect(object, "group.label") for (g in 1:ngroups) { result[[ group.label[g] ]] <- lapply(ordnames, function(nn) { thresholds[[g]][ grepl(paste0(nn, "\\|"), names(thresholds[[g]])) ] }) names(result[[ group.label[g] ]]) <- ordnames } } return(result) } ##' @importFrom lavaan lavInspect lavNames getScales <- function(object, omit.imps = c("no.conv","no.se")) { ngroups <- lavInspect(object, "ngroups") #TODO: add nlevels when capable ordnames <- lavNames(object, "ov.ord") #TODO: use to allow mix of cat/con vars if (inherits(object, "lavaan")) { EST <- lavInspect(object, "est") } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) EST <- object@coefList[useImps] } if (ngroups == 1L) { if (inherits(object, "lavaan")) { result <- list(EST$delta[,"scales"]) } else if (inherits(object, "lavaan.mi")) { scales <- lapply(EST, function(x) x$delta[,"scales"]) result <- list(Reduce("+", scales) / length(scales)) } } else { result <- vector("list", ngroups) for (g in 1:ngroups) { if (inherits(object, "lavaan")) { result[[g]] <- EST[[g]]$delta[,"scales"] } else if (inherits(object, "lavaan.mi")) { scales <- lapply(EST, function(x) x[[g]]$delta[,"scales"]) result[[g]] <- Reduce("+", scales) / length(scales) } } } return(result) } invGeneralRelia <- function(w, truevar, totalvar) { 1 - (t(w) %*% truevar %*% w) / (t(w) %*% totalvar %*% w) } #' @importFrom stats pnorm invGeneralReliaCat <- function(w, polyr, threshold, denom, nitem) { # denom could be polychoric correlation, model-implied correlation, or model-implied without error correlation upper <- matrix(NA, nitem, nitem) lower <- matrix(NA, nitem, nitem) for (j in 1:nitem) { for (jp in 1:nitem) { sumprobn2 <- 0 addprobn2 <- 0 t1 <- threshold[[j]] t2 <- threshold[[jp]] for (c in 1:length(t1)) { for (cp in 1:length(t2)) { sumprobn2 <- sumprobn2 + p2(t1[c], t2[cp], polyr[j, jp]) addprobn2 <- addprobn2 + p2(t1[c], t2[cp], denom[j, jp]) } } sumprobn1 <- sum(pnorm(t1)) sumprobn1p <- sum(pnorm(t2)) upper[j, jp] <- (sumprobn2 - sumprobn1 * sumprobn1p) lower[j, jp] <- (addprobn2 - sumprobn1 * sumprobn1p) } } 1 - (t(w) %*% upper %*% w) / (t(w) %*% lower %*% w) } #' @importFrom stats nlminb calcMaximalRelia <- function(truevar, totalvar, varnames) { start <- rep(1, nrow(truevar)) out <- nlminb(start, invGeneralRelia, truevar = truevar, totalvar = totalvar) if (out$convergence != 0) stop("The numerical method for finding the maximal", " reliability did not converge.") result <- 1 - out$objective weight <- out$par / mean(out$par) names(weight) <- varnames attr(result, "weight") <- weight result } #' @importFrom stats nlminb calcMaximalReliaCat <- function(polyr, threshold, denom, nitem, varnames) { start <- rep(1, nrow(polyr)) out <- nlminb(start, invGeneralReliaCat, polyr = polyr, threshold = threshold, denom = denom, nitem = nitem) if (out$convergence != 0) stop("The numerical method for finding the maximal", " reliability did not converge.") result <- 1 - out$objective weight <- out$par / mean(out$par) names(weight) <- varnames attr(result, "weight") <- weight result } semTools/R/clipboard.R0000644000176200001440000003244414764264223014363 0ustar liggesusers### Sunthud Pornprasertmanit & Terrence D. Jorgensen ### Last updated: 12 March 2025 ### Copy or save each aspect of the lavaan object into a clipboard or a file ##' Copy or save the result of `lavaan` or `FitDiff` objects into a ##' clipboard or a file ##' ##' Copy or save the result of `lavaan` or [FitDiff-class] ##' object into a clipboard or a file. From the clipboard, users may paste the ##' result into the Microsoft Excel or spreadsheet application to create a table ##' of the output. ##' ##' ##' @aliases clipboard saveFile ##' ##' @param object An object of class [lavaan::lavaan-class] or ##' [FitDiff-class]. ##' @param what The attributes of the `lavaan` object to be copied in the ##' clipboard. `"summary"` is to copy the screen provided from the ##' `summary` function. `"mifit"` is to copy the result from the ##' [miPowerFit()] function. Other attributes listed in the ##' `inspect` method in the [lavaan::lavaan-class] could also be ##' used, such as `"coef"`, `"se"`, `"fit"`, `"samp"`, and ##' so on. Ignored for [FitDiff-class]-class objects. ##' @param file A file name used for saving the result. ##' @param tableFormat If `TRUE`, save the result in the table format using ##' tabs for separation. Otherwise, save the result as the output screen ##' printed in the R console. ##' @param fit.measures `character` vector specifying names of fit measures ##' returned by [lavaan::fitMeasures()] to be copied/saved. Only ##' relevant if `object` is class [FitDiff-class]. ##' @param writeArgs `list` of additional arguments to be passed to ##' [utils::write.table()] ##' @param \dots Additional arguments when passing a `lavaan` object to the ##' `summary` or [miPowerFit()] function. ##' ##' @return The resulting output will be saved into a clipboard or a file. If ##' using the `clipboard` function, users may paste it in the other ##' applications. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) ##' ##' @examples ##' ##' library(lavaan) ##' HW.model <- ' visual =~ x1 + c1*x2 + x3 ##' textual =~ x4 + c1*x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit <- cfa(HW.model, data = HolzingerSwineford1939, group = "school") ##' ##' if(interactive()){ ##' # Copy the summary of the lavaan object ##' clipboard(fit) ##' ##' # pass additional arguments to summary() method for class?lavaan ##' clipboard(fit, rsquare = TRUE, standardized = TRUE, fit.measures = TRUE) ##' ##' # Copy modification indices and fit stats from the miPowerFit() function ##' clipboard(fit, "mifit") ##' ##' # Copy the parameter estimates ##' clipboard(fit, "coef") ##' ##' # Copy the standard errors ##' clipboard(fit, "se") ##' ##' # Copy the sample statistics ##' clipboard(fit, "samp") ##' ##' # Copy the fit measures ##' clipboard(fit, "fit") ##' ##' # Save the summary of the lavaan object ##' saveFile(fit, "out.txt") ##' ##' # Save modification indices and fit stats from the miPowerFit() function ##' saveFile(fit, "out.txt", "mifit") ##' ##' # Save the parameter estimates ##' saveFile(fit, "out.txt", "coef") ##' ##' # Save the standard errors ##' saveFile(fit, "out.txt", "se") ##' ##' # Save the sample statistics ##' saveFile(fit, "out.txt", "samp") ##' ##' # Save the fit measures ##' saveFile(fit, "out.txt", "fit") ##' } ##' ##' @export clipboard <- function(object, what = "summary", ...) { if (.Platform$OS.type == "windows") { saveFile(object, file = "clipboard-128", what = what, tableFormat = TRUE, ...) cat("File saved in the clipboard; please paste it in any program you wish.\n") } else { ## Mac OS? if (system("pbcopy -help", ignore.stderr = TRUE) == 0) { CON <- pipe("pbcopy", "w") on.exit(close(CON)) saveFile(object, file = CON, what = what, tableFormat = TRUE, ...) cat("File saved in the clipboard; please paste it in any program you wish. If you cannot paste it, it is okay because this function works for some computers, which I still have no explanation currently. Please consider using the 'saveFile' function instead.\n") } else if (system("xclip -version", ignore.stderr = TRUE) == 0) { ## Linux OS? CON <- pipe("xclip -i", "w") on.exit(close(CON)) saveFile(object, file = CON, what = what, tableFormat = TRUE, ...) cat("File saved in the xclip; please paste it in any program you wish. If you cannot paste it, it is okay because this function works for some computers, which I still have no explanation currently. Please consider using the 'saveFile' function instead.\n") } else { stop("For Mac users, the 'pbcopy' command in the shell file does not work. For linux users, this function depends on the 'xclip' application. Please install and run the xclip application before using this function in R (it does not guarantee to work though). Alternatively, use the 'saveFile' function to write the output into a file.") } } } ##' @rdname clipboard ##' @export saveFile <- function(object, file, what = "summary", tableFormat = FALSE, fit.measures = "default", writeArgs = list(), ...) { # Check whether the object is in the lavaan class if (is(object, "lavaan")) { saveFileLavaan(object, file, what = what, tableFormat = tableFormat, writeArgs = writeArgs, ...) } else if (is(object, "FitDiff")) { saveFileFitDiff(object, file, what = what, tableFormat = tableFormat, fit.measures = fit.measures, writeArgs = writeArgs) } else { stop("The object must be a class?lavaan object or the", " output from the compareFit() function.") } } ## ---------------- ## Hidden functions ## ---------------- ##' @importFrom lavaan lavInspect saveFileLavaan <- function(object, file, what = "summary", tableFormat = FALSE, writeArgs = list(), ...) { if (length(what) > 1) message("only the first `what' option is used") # be case insensitive what <- tolower(what[1]) writeArgs$file <- file if (is.null(writeArgs$sep)) writeArgs$sep <- "\t" if (is.null(writeArgs$quote)) writeArgs$quote <- FALSE if (what == "summary") { if (tableFormat) { writeArgs <- copySummary(object, file = file, writeArgs = writeArgs, ...) } else { writeArgs$x <- paste(utils::capture.output(summary(object, ...)), collapse = "\n") } } else if (what == "mifit") { if (tableFormat) { writeArgs$x <- miPowerFit(object, ...) if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (is.null(writeArgs$col.names)) writeArgs$col.names <- TRUE } else { writeArgs$x <- paste(utils::capture.output(miPowerFit(object, ...)), collapse = "\n") } } else { target <- lavInspect(object, what=what) if (tableFormat) { if (is(target, "lavaan.data.frame") || is(target, "data.frame")) { writeArgs$x <- target if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (is.null(writeArgs$col.names)) writeArgs$col.names <- TRUE } else if (is(target, "list")) { if (is(target[[1]], "list")) { target <- lapply(target, listToDataFrame) target <- mapply(function(x, y) rbind(rep("", ncol(y)), c(x, rep("", ncol(y) - 1)), y), names(target), target, SIMPLIFY = FALSE) writeArgs$x <- do.call(rbind, target) if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (is.null(writeArgs$col.names)) writeArgs$col.names <- FALSE } else { writeArgs$x <- listToDataFrame(target) if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (is.null(writeArgs$col.names)) writeArgs$col.names <- FALSE } } else { writeArgs$x <- target if (is.null(writeArgs$row.names)) writeArgs$row.names <- TRUE if (is.null(writeArgs$col.names)) writeArgs$col.names <- TRUE } } else { writeArgs$x <- paste(utils::capture.output(target), collapse = "\n") } } do.call("write.table", writeArgs) } ## copySummary: copy the summary of the lavaan object into the clipboard and ## potentially be useful if users paste it into the Excel application ## object = lavaan object input copySummary <- function(object, file, writeArgs = list(), ...) { # Capture the output of the lavaan class outputText <- utils::capture.output(lavaan::summary(object, ...)) # Split the text by two spaces outputText <- strsplit(outputText, " ") # Trim and delete the "" elements outputText <- lapply(outputText, function(x) x[x != ""]) outputText <- lapply(outputText, trim) outputText <- lapply(outputText, function(x) x[x != ""]) # Group the output into three sections: fit, parameter estimates, and r-squared cut1 <- grep("Estimate", outputText)[1] cut2 <- grep("R-Square", outputText)[1] if (is.na(cut2)) { ## no R-squared output requested, so set2 == set3 cut2 <- length(outputText) } set1 <- outputText[1:(cut1 - 1)] set2 <- outputText[cut1:(cut2 - 1)] set3 <- outputText[cut2:length(outputText)] # Assign the number of columns in the resulting data frame and check whether the output contains any labels numcol <- 7 test <- set2[-grep("Estimate", set2)] test <- test[sapply(test, length) >= 2] if (any(sapply(test, function(x) is.na(suppressWarnings(as.numeric(x[2])))))) numcol <- numcol + 1 # A function to parse the fit-measures output set1Parse <- function(x, numcol) { if (length(x) == 0) { return(rep("", numcol)) } else if (length(x) == 1) { return(c(x, rep("", numcol - 1))) } else if ((length(x) >= 2) & (length(x) <= numcol)) { return(c(x[1], rep("", numcol - length(x)), x[2:length(x)])) } else { stop("Cannot parse text") } } set1 <- t(sapply(set1, set1Parse, numcol)) # A function to parse the parameter-estimates output set2Parse <- function(x, numcol) { if (length(x) == 0) return(rep("", numcol)) if (any(grepl("Estimate", x))) return(c(rep("", numcol-length(x)), x)) if (length(x) == 1) { return(c(x, rep("", numcol-1))) } else { group1 <- x[1] group2 <- x[2:length(x)] if (is.na(suppressWarnings(as.numeric(x[2])))) { group1 <- x[1:2] group2 <- x[3:length(x)] } else if (numcol == 8) { group1 <- c(group1, "") } if (length(group2) == 1) { group2 <- c(group2, rep("", 6 - length(group2))) } else if (length(group2) == 4) { group2 <- c(group2, rep("", 6 - length(group2))) } else { group2 <- c(group2[1], rep("", 6 - length(group2)), group2[2:length(group2)]) } return(c(group1, group2)) } } set2 <- t(sapply(set2, set2Parse, numcol)) # A function to parse the r-squared output set3Parse <- function(x, numcol) { if (length(x) == 0) { return(rep("", numcol)) } else { return(c(x, rep("", numcol - length(x)))) } } set3 <- t(sapply(set3, set3Parse, numcol)) # Copy the output into the clipboard writeArgs$x <- rbind(set1, set2, set3) writeArgs$file <- file if (is.null(writeArgs$quote)) writeArgs$quote <- FALSE if (is.null(writeArgs$sep)) writeArgs$sep <- "\t" if (is.null(writeArgs$row.names)) writeArgs$row.names <- FALSE if (is.null(writeArgs$col.names)) writeArgs$col.names <- FALSE # do.call("write.table", writeArgs) writeArgs } ## trim function from the R.oo package trim <- function(object) { s <- sub("^[\t\n\f\r ]*", "", as.character(object)); s <- sub("[\t\n\f\r ]*$", "", s); s; } ## listToDataFrame: Change a list with multiple elements into a single data.frame listToDataFrame <- function(object) { name <- names(object) # Count the maximum number of column (+1 is for the column for row name) numcol <- max(sapply(object, function(x) ifelse(is(x, "lavaan.matrix") || is(x, "lavaan.matrix.symmetric") || is(x, "matrix") || is(x, "data.frame"), return(ncol(x)), return(1)))) + 1 # Change all objects in the list into a data.frame with the specified column target <- lapply(object, niceDataFrame, numcol) # Paste the name of each object into each data.frame target <- mapply(function(x, y) rbind(rep("", ncol(y)), c(x, rep("", ncol(y) - 1)), y), name, target, SIMPLIFY=FALSE) # Combine into a single data.frame target <- do.call(rbind, target) target[-1,] } ## niceDataFrame: Change an object into a data.frame with a specified number of ## columns and the row and column names are included in the data.frame niceDataFrame <- function(object, numcol) { temp <- NULL if (is(object, "lavaan.matrix.symmetric")) { # save only the lower diagonal of the symmetric matrix temp <- matrix("", nrow(object), ncol(object)) for (i in 1:nrow(object)) { temp[i, 1:i] <- object[i, 1:i] } } else if (is(object, "data.frame") || is(object, "matrix") || is(object, "lavaan.matrix")) { # copy the matrix temp <- object } else if (is(object, "vector") || is(object, "lavaan.vector")) { # transform a vector into a matrix object <- as.matrix(object) temp <- object } else { stop("The 'niceDataFrame' function has a bug. Please contact the developer.") } # Transform into the result with a specified number of columns, excluding the row name result <- matrix("", nrow(temp), numcol - 1) # Parse the column names result[,1:ncol(temp)] <- temp firstRow <- colnames(object) ifelse(is.null(firstRow), firstRow <- rep("", ncol(result)), firstRow <- c(firstRow, rep("", numcol - length(firstRow) - 1))) # Parse the row names result <- rbind(firstRow, result) firstCol <- rownames(object) ifelse(is.null(firstCol), firstCol <- rep("", nrow(result)), firstCol <- c("", firstCol)) result <- cbind(firstCol, result) dimnames(result) <- NULL result } semTools/R/partialInvariance.R0000644000176200001440000026152014764267611016063 0ustar liggesusers### Sunthud Pornprasertmanit ### Last updated: 12 March 2025 ##' Partial Measurement Invariance Testing Across Groups ##' ##' This test will provide partial invariance testing by (a) freeing a parameter ##' one-by-one from nested model and compare with the original nested model or ##' (b) fixing (or constraining) a parameter one-by-one from the parent model ##' and compare with the original parent model. This function only works with ##' congeneric models. The `partialInvariance` is used for continuous ##' variable. The `partialInvarianceCat` is used for categorical variables. ##' ##' There are four types of partial invariance testing: ##' ##' \itemize{ ##' \item Partial weak invariance. The model named 'fit.configural' ##' from the list of models is compared with the model named 'fit.loadings'. ##' Each loading will be freed or fixed from the metric and configural ##' invariance models respectively. The modified models are compared with the ##' original model. Note that the objects in the list of models must have the ##' names of "fit.configural" and "fit.loadings". Users may use "metric", ##' "weak", "loading", or "loadings" in the `type` argument. Note that, for ##' testing invariance on marker variables, other variables will be assigned as ##' marker variables automatically. ##' ##' \item Partial strong invariance. The model ##' named 'fit.loadings' from the list of models is compared with the model ##' named either 'fit.intercepts' or 'fit.thresholds'. Each intercept will be ##' freed or fixed from the scalar and metric invariance models respectively. ##' The modified models are compared with the original model. Note that the ##' objects in the list of models must have the names of "fit.loadings" and ##' either "fit.intercepts" or "fit.thresholds". Users may use "scalar", ##' "strong", "intercept", "intercepts", "threshold", or "thresholds" in the ##' `type` argument. Note that, for testing invariance on marker variables, ##' other variables will be assigned as marker variables automatically. Note ##' that if all variables are dichotomous, scalar invariance testing is not ##' available. ##' ##' \item Partial strict invariance. The model named either ##' 'fit.intercepts' or 'fit.thresholds' (or 'fit.loadings') from the list of ##' models is compared with the model named 'fit.residuals'. Each residual ##' variance will be freed or fixed from the strict and scalar (or metric) ##' invariance models respectively. The modified models are compared with the ##' original model. Note that the objects in the list of models must have the ##' names of "fit.residuals" and either "fit.intercepts", "fit.thresholds", or ##' "fit.loadings". Users may use "strict", "residual", "residuals", "error", or ##' "errors" in the `type` argument. ##' ##' \item Partial mean invariance. The ##' model named either 'fit.intercepts' or 'fit.thresholds' (or 'fit.residuals' ##' or 'fit.loadings') from the list of models is compared with the model named ##' 'fit.means'. Each factor mean will be freed or fixed from the means and ##' scalar (or strict or metric) invariance models respectively. The modified ##' models are compared with the original model. Note that the objects in the ##' list of models must have the names of "fit.means" and either ##' "fit.residuals", "fit.intercepts", "fit.thresholds", or "fit.loadings". ##' Users may use "means" or "mean" in the `type` argument. } ##' ##' Two types of comparisons are used in this function: ##' \enumerate{ ##' \item `free`: The nested model is used as a template. Then, one ##' parameter indicating the differences between two models is free. The new ##' model is compared with the nested model. This process is repeated for all ##' differences between two models. The likelihood-ratio test and the difference ##' in CFI are provided. ##' ##' \item `fix`: The parent model is used as a template. Then, one parameter ##' indicating the differences between two models is fixed or constrained to be ##' equal to other parameters. The new model is then compared with the parent ##' model. This process is repeated for all differences between two models. The ##' likelihood-ratio test and the difference in CFI are provided. ##' ##' \item `wald`: This method is similar to the `fix` method. However, ##' instead of building a new model and compare them with likelihood-ratio test, ##' multivariate wald test is used to compare equality between parameter ##' estimates. See [lavaan::lavTestWald()] for further details. Note ##' that if any rows of the contrast cannot be summed to 0, the Wald test is not ##' provided, such as comparing two means where one of the means is fixed as 0. ##' This test statistic is not as accurate as likelihood-ratio test provided in ##' `fix`. I provide it here in case that likelihood-ratio test fails to ##' converge. ##' } ##' ##' Note that this function does not adjust for the inflated Type I error rate ##' from multiple tests. The degree of freedom of all tests would be the number ##' of groups minus 1. ##' ##' The details of standardized estimates and the effect size used for each ##' parameters are provided in the vignettes by running ##' `vignette("partialInvariance")`. ##' ##' @importFrom lavaan lavInspect parTable ##' @aliases partialInvariance partialInvarianceCat ##' ##' @param fit A list of models for invariance testing. Each model should be ##' assigned by appropriate names (see details). The result from ##' [measurementInvariance()] or ##' [measurementInvarianceCat()] could be used in this argument ##' directly. ##' @param type The types of invariance testing: "metric", "scalar", "strict", ##' or "means" ##' @param free A vector of variable names that are free across groups in ##' advance. If partial mean invariance is tested, this argument represents a ##' vector of factor names that are free across groups. ##' @param fix A vector of variable names that are constrained to be equal ##' across groups in advance. If partial mean invariance is tested, this ##' argument represents a vector of factor names that are fixed across groups. ##' @param refgroup The reference group used to make the effect size comparison ##' with the other groups. ##' @param poolvar If `TRUE`, the variances are pooled across group for ##' standardization. Otherwise, the variances of the reference group are used ##' for standardization. ##' @param p.adjust The method used to adjust p values. See ##' [stats::p.adjust()] for the options for adjusting p values. The ##' default is to not use any corrections. ##' @param fbound The z-scores of factor that is used to calculate the effect ##' size of the loading difference proposed by Millsap and Olivera-Aguilar ##' (2012). ##' @param return.fit Return the submodels fitted by this function ##' @param method The method used to calculate likelihood ratio test. See ##' [lavaan::lavTestLRT()] for available options ##' ##' @return A list of results are provided. The list will consists of at least ##' two elements: ##' \enumerate{ ##' \item `estimates`: The results of parameter estimates including pooled ##' estimates (`poolest`), the estimates for each group, standardized ##' estimates for each group (`std`), the difference in standardized ##' values, and the effect size statistic (*q* for factor loading ##' difference and *h* for error variance difference). See the details of ##' this effect size statistic by running `vignette("partialInvariance")`. ##' In the `partialInvariance` function, the additional effect statistics ##' proposed by Millsap and Olivera-Aguilar (2012) are provided. For factor ##' loading, the additional outputs are the observed mean difference ##' (`diff_mean`), the mean difference if factor scores are low ##' (`low_fscore`), and the mean difference if factor scores are high ##' (`high_fscore`). The low factor score is calculated by (a) finding the ##' factor scores that its *z* score equals -`bound` (the default is ##' \eqn{-2}) from all groups and (b) picking the minimum value among the ##' factor scores. The high factor score is calculated by (a) finding the ##' factor scores that its *z* score equals `bound` (default = 2) ##' from all groups and (b) picking the maximum value among the factor scores. ##' For measurement intercepts, the additional outputs are the observed means ##' difference (`diff_mean`) and the proportion of the differences in the ##' intercepts over the observed means differences (`propdiff`). For error ##' variances, the additional outputs are the proportion of the difference in ##' error variances over the difference in observed variances (`propdiff`). ##' ##' \item `results`: Statistical tests as well as the change in CFI are ##' provided. \eqn{\chi^2} and *p* value are provided for all methods. ##' ##' \item `models`: The submodels used in the `free` and `fix` ##' methods, as well as the nested and parent models. The nested and parent ##' models will be changed from the original models if `free` or ##' `fit` arguments are specified. ##' } ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso [measurementInvariance()] for measurement invariance for ##' continuous variables; [measurementInvarianceCat()] for measurement ##' invariance for categorical variables; [lavaan::lavTestWald()] for ##' multivariate Wald test ##' ##' @references Millsap, R. E., & Olivera-Aguilar, M. (2012). Investigating ##' measurement invariance using confirmatory factor analysis. In R. H. Hoyle ##' (Ed.), *Handbook of structural equation modeling* (pp. 380--392). New ##' York, NY: Guilford. ##' ##' @examples ##' ##' ## Conduct weak invariance testing manually by using fixed-factor ##' ## method of scale identification ##' ##' library(lavaan) ##' ##' conf <- " ##' f1 =~ NA*x1 + x2 + x3 ##' f2 =~ NA*x4 + x5 + x6 ##' f1 ~~ c(1, 1)*f1 ##' f2 ~~ c(1, 1)*f2 ##' " ##' ##' weak <- " ##' f1 =~ NA*x1 + x2 + x3 ##' f2 =~ NA*x4 + x5 + x6 ##' f1 ~~ c(1, NA)*f1 ##' f2 ~~ c(1, NA)*f2 ##' " ##' ##' configural <- cfa(conf, data = HolzingerSwineford1939, std.lv = TRUE, group="school") ##' weak <- cfa(weak, data = HolzingerSwineford1939, group="school", group.equal="loadings") ##' models <- list(fit.configural = configural, fit.loadings = weak) ##' partialInvariance(models, "metric") ##' ##' \donttest{ ##' partialInvariance(models, "metric", free = "x5") # "x5" is free across groups in advance ##' partialInvariance(models, "metric", fix = "x4") # "x4" is fixed across groups in advance ##' ##' ## Use the result from the measurementInvariance function ##' HW.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' models2 <- measurementInvariance(model = HW.model, data=HolzingerSwineford1939, ##' group="school") ##' partialInvariance(models2, "scalar") ##' ##' ## Conduct weak invariance testing manually by using fixed-factor ##' ## method of scale identification for dichotomous variables ##' ##' f <- rnorm(1000, 0, 1) ##' u1 <- 0.9*f + rnorm(1000, 1, sqrt(0.19)) ##' u2 <- 0.8*f + rnorm(1000, 1, sqrt(0.36)) ##' u3 <- 0.6*f + rnorm(1000, 1, sqrt(0.64)) ##' u4 <- 0.7*f + rnorm(1000, 1, sqrt(0.51)) ##' u1 <- as.numeric(cut(u1, breaks = c(-Inf, 0, Inf))) ##' u2 <- as.numeric(cut(u2, breaks = c(-Inf, 0.5, Inf))) ##' u3 <- as.numeric(cut(u3, breaks = c(-Inf, 0, Inf))) ##' u4 <- as.numeric(cut(u4, breaks = c(-Inf, -0.5, Inf))) ##' g <- rep(c(1, 2), 500) ##' dat2 <- data.frame(u1, u2, u3, u4, g) ##' ##' configural2 <- " ##' f1 =~ NA*u1 + u2 + u3 + u4 ##' u1 | c(t11, t11)*t1 ##' u2 | c(t21, t21)*t1 ##' u3 | c(t31, t31)*t1 ##' u4 | c(t41, t41)*t1 ##' f1 ~~ c(1, 1)*f1 ##' f1 ~ c(0, NA)*1 ##' u1 ~~ c(1, 1)*u1 ##' u2 ~~ c(1, NA)*u2 ##' u3 ~~ c(1, NA)*u3 ##' u4 ~~ c(1, NA)*u4 ##' " ##' ##' outConfigural2 <- cfa(configural2, data = dat2, group = "g", ##' parameterization = "theta", estimator = "wlsmv", ##' ordered = c("u1", "u2", "u3", "u4")) ##' ##' weak2 <- " ##' f1 =~ NA*u1 + c(f11, f11)*u1 + c(f21, f21)*u2 + c(f31, f31)*u3 + c(f41, f41)*u4 ##' u1 | c(t11, t11)*t1 ##' u2 | c(t21, t21)*t1 ##' u3 | c(t31, t31)*t1 ##' u4 | c(t41, t41)*t1 ##' f1 ~~ c(1, NA)*f1 ##' f1 ~ c(0, NA)*1 ##' u1 ~~ c(1, 1)*u1 ##' u2 ~~ c(1, NA)*u2 ##' u3 ~~ c(1, NA)*u3 ##' u4 ~~ c(1, NA)*u4 ##' " ##' ##' outWeak2 <- cfa(weak2, data = dat2, group = "g", parameterization = "theta", ##' estimator = "wlsmv", ordered = c("u1", "u2", "u3", "u4")) ##' modelsCat <- list(fit.configural = outConfigural2, fit.loadings = outWeak2) ##' ##' partialInvarianceCat(modelsCat, type = "metric") ##' ##' partialInvarianceCat(modelsCat, type = "metric", free = "u2") ##' partialInvarianceCat(modelsCat, type = "metric", fix = "u3") ##' ##' ## Use the result from the measurementInvarianceCat function ##' ##' model <- ' f1 =~ u1 + u2 + u3 + u4 ##' f2 =~ u5 + u6 + u7 + u8' ##' ##' modelsCat2 <- measurementInvarianceCat(model = model, data = datCat, group = "g", ##' parameterization = "theta", ##' estimator = "wlsmv", strict = TRUE) ##' ##' partialInvarianceCat(modelsCat2, type = "scalar") ##' } ##' ##' @export partialInvariance <- function(fit, type, free = NULL, fix = NULL, refgroup = 1, poolvar = TRUE, p.adjust = "none", fbound = 2, return.fit = FALSE, method = "satorra.bentler.2001") { # fit <- measurementInvariance(HW.model, data=HolzingerSwineford1939, group="school", strict = TRUE) # type <- "weak" # free <- NULL # fix <- "x1" # refgroup <- 1 # poolvar <- TRUE # p.adjust <- "none" # return.fit <- FALSE # fbound <- 2 # method <- "satorra.bentler.2001" type <- tolower(type) numType <- 0 fit1 <- fit0 <- NULL # fit0 = Nested model, fit1 = Parent model if(type %in% c("metric", "weak", "loading", "loadings")) { numType <- 1 if(all(c("fit.configural", "fit.loadings") %in% names(fit))) { fit1 <- fit$fit.configural fit0 <- fit$fit.loadings } else { stop("The elements named 'fit.configural' and 'fit.loadings' are needed in the 'fit' argument") } } else if (type %in% c("scalar", "strong", "intercept", "intercepts", "threshold", "thresholds")) { numType <- 2 if(all(c("fit.loadings", "fit.intercepts") %in% names(fit))) { fit1 <- fit$fit.loadings fit0 <- fit$fit.intercepts } else { stop("The elements named 'fit.loadings' and 'fit.intercepts' are needed in the 'fit' argument") } } else if (type %in% c("strict", "residual", "residuals", "error", "errors")) { numType <- 3 if(all(c("fit.intercepts", "fit.residuals") %in% names(fit))) { fit1 <- fit$fit.intercepts fit0 <- fit$fit.residuals } else { stop("The elements named 'fit.intercepts' and 'fit.residuals' are needed in the 'fit' argument") } } else if (type %in% c("means", "mean")) { numType <- 4 if("fit.means" %in% names(fit)) { fit0 <- fit$fit.means if("fit.residuals" %in% names(fit)) { fit1 <- fit$fit.residuals } else if ("fit.intercepts" %in% names(fit)) { fit1 <- fit$fit.intercepts } else { stop("The elements named either 'fit.residuals' or 'fit.intercepts ' is needed in the 'fit' argument") } } else { stop("The elements named 'fit.means' is needed in the 'fit' argument") } } else { stop("Please specify the correct type of measurement invariance. See the help page.") } pt1 <- parTable(fit1) pt0 <- parTable(fit0) pt0$start <- pt0$est <- pt0$se <- NULL pt1$start <- pt1$est <- pt1$se <- NULL pt1$label[substr(pt1$label, 1, 1) == "." & substr(pt1$label, nchar(pt1$label), nchar(pt1$label)) == "."] <- "" pt0$label[substr(pt0$label, 1, 1) == "." & substr(pt0$label, nchar(pt0$label), nchar(pt0$label)) == "."] <- "" namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) if(length(table(table(pt0$rhs[pt0$op == "=~"]))) != 1) stop("The model is not congeneric. This function does not support non-congeneric model.") varfree <- varnames <- unique(pt0$rhs[pt0$op == "=~"]) facnames <- unique(pt0$lhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)]) facrepresent <- table(pt0$lhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)], pt0$rhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)]) if(any(apply(facrepresent, 2, function(x) sum(x != 0)) > 1)) stop("The model is not congeneric. This function does not support non-congeneric model.") facList <- list() for(i in 1:nrow(facrepresent)) { facList[[i]] <- colnames(facrepresent)[facrepresent[i,] > 0] } names(facList) <- rownames(facrepresent) facList <- facList[match(names(facList), facnames)] fixLoadingFac <- list() for(i in seq_along(facList)) { select <- pt1$lhs == names(facList)[i] & pt1$op == "=~" & pt1$rhs %in% facList[[i]] & pt1$group == 1 & pt1$free == 0 & (!is.na(pt1$ustart) & pt1$ustart > 0) fixLoadingFac[[i]] <- pt1$rhs[select] } names(fixLoadingFac) <- names(facList) fixIntceptFac <- list() for(i in seq_along(facList)) { select <- pt1$op == "~1" & pt1$rhs %in% facList[[i]] & pt1$group == 1 & pt1$free == 0 fixIntceptFac[[i]] <- pt1$rhs[select] } names(fixIntceptFac) <- names(facList) ngroups <- max(pt0$group) neach <- lavInspect(fit0, "nobs") groupvar <- lavInspect(fit0, "group") grouplab <- lavInspect(fit0, "group.label") if(!is.numeric(refgroup)) refgroup <- which(refgroup == grouplab) grouporder <- 1:ngroups grouporder <- c(refgroup, setdiff(grouporder, refgroup)) grouplaborder <- grouplab[grouporder] complab <- paste(grouplaborder[2:ngroups], "vs.", grouplaborder[1]) if(ngroups <= 1) stop("Well, the number of groups is 1. Measurement invariance across 'groups' cannot be done.") if(numType == 4) { if(!all(c(free, fix) %in% facnames)) stop("'free' and 'fix' arguments should consist of factor names because mean invariance is tested.") } else { if(!all(c(free, fix) %in% varnames)) stop("'free' and 'fix' arguments should consist of variable names.") } result <- fixCon <- freeCon <- NULL estimates <- NULL listFreeCon <- listFixCon <- list() beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) if(numType == 1) { if(!is.null(free) | !is.null(fix)) { if(!is.null(fix)) { facinfix <- findFactor(fix, facList) dup <- duplicated(facinfix) for(i in seq_along(fix)) { if(dup[i]) { pt0 <- constrainParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } else { oldmarker <- fixLoadingFac[[facinfix[i]]] if(length(oldmarker) > 0) { oldmarkerval <- pt1$ustart[pt1$lhs == facinfix[i] & pt1$op == "=~" & pt1$rhs == oldmarker & pt1$group == 1] if(oldmarker == fix[i]) { pt0 <- fixParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) } else { pt0 <- freeParTable(pt0, facinfix[i], "=~", oldmarker, 1:ngroups) pt0 <- constrainParTable(pt0, facinfix[i], "=~", oldmarker, 1:ngroups) pt1 <- freeParTable(pt1, facinfix[i], "=~", oldmarker, 1:ngroups) pt0 <- fixParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) fixLoadingFac[[facinfix[i]]] <- fix[i] } } else { pt0 <- constrainParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } } } } if(!is.null(free)) { facinfree <- findFactor(free, facList) for(i in seq_along(free)) { # Need to change marker variable if fixed oldmarker <- fixLoadingFac[[facinfree[i]]] if(length(oldmarker) > 0 && oldmarker == free[i]) { oldmarkerval <- pt1$ustart[pt1$lhs == facinfix[i] & pt1$op == "=~" & pt1$rhs == oldmarker & pt1$group == 1] candidatemarker <- setdiff(facList[[facinfree[i]]], free[i])[1] pt0 <- freeParTable(pt0, facinfree[i], "=~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, facinfree[i], "=~", free[i], 1:ngroups) pt0 <- fixParTable(pt0, facinfix[i], "=~", candidatemarker, 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", candidatemarker, 1:ngroups, oldmarkerval) fixLoadingFac[[facinfix[i]]] <- candidatemarker } else { pt0 <- freeParTable(pt0, facinfree[i], "=~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, facinfree[i], "=~", free[i], 1:ngroups) } } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } obsmean <- sapply(lavInspect(fit0, "sampstat"), "[[", "mean") #FIXME: there might not be a mean structure obsmean <- obsmean[,grouporder] obsdiff <- obsmean[,2:ngroups, drop = FALSE] - matrix(obsmean[,1], nrow(obsmean), ngroups - 1) obsdiff <- obsdiff[varfree, , drop = FALSE] colnames(obsdiff) <- paste0("diff_mean:", complab) estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("load:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- esz <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) colnames(esz) <- paste0("q:", complab) esdiff <- matrix(NA, length(varfree), ngroups - 1) # Extract facmean, facsd, load, tau -> lowdiff, highdiff lowdiff <- matrix(NA, length(varfree), ngroups - 1) highdiff <- matrix(NA, length(varfree), ngroups - 1) colnames(lowdiff) <- paste0("low_fscore:", complab) colnames(highdiff) <- paste0("high_fscore:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$rhs %in% varfree) & (pt1$op == "=~") & (pt1$group == 1)) facinfix <- findFactor(fix, facList) varinfixvar <- unlist(facList[facinfix]) varinfixvar <- setdiff(varinfixvar, setdiff(varinfixvar, varfree)) indexfixvar <- which((pt1$rhs %in% varinfixvar) & (pt1$op == "=~") & (pt1$group == 1)) varnonfixvar <- setdiff(varfree, varinfixvar) indexnonfixvar <- setdiff(index, indexfixvar) pos <- 1 for(i in seq_along(indexfixvar)) { runnum <- indexfixvar[i] temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) loadVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- loadVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) totalVal <- sapply(lavaan::fitted.values(tempfit0), function(x, v) x$cov[v, v], v = pt0$rhs[runnum]) names(facVal) <- names(totalVal) <- grouplab ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdLoadVal <- loadVal * sqrt(refFacVal) / sqrt(refTotalVal) stdestimates[pos,] <- stdLoadVal stdLoadVal <- stdLoadVal[grouporder] esstd[pos,] <- stdLoadVal[2:ngroups] - stdLoadVal[1] if(any(abs(stdLoadVal) > 0.9999)) warning(paste("Standardized Loadings of", pt0$rhs[runnum], "in some groups are less than -1 or over 1. The standardized loadings used in Fisher z transformation are changed to -0.9999 or 0.9999.")) stdLoadVal[stdLoadVal > 0.9999] <- 0.9999 stdLoadVal[stdLoadVal < -0.9999] <- -0.9999 zLoadVal <- atanh(stdLoadVal) esz[pos,] <- zLoadVal[2:ngroups] - zLoadVal[1] facMean <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~1", "", 1:ngroups) wlow <- min(facMean - fbound * sqrt(facVal)) whigh <- max(facMean + fbound * sqrt(facVal)) intVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$rhs[runnum], "~1", "", 1:ngroups) loadVal <- loadVal[grouporder] intVal <- intVal[grouporder] loaddiff <- loadVal[2:ngroups] - loadVal[1] intdiff <- intVal[2:ngroups] - intVal[1] lowdiff[pos,] <- intdiff + wlow * loaddiff highdiff[pos,] <- intdiff + whigh * loaddiff } listFreeCon <- c(listFreeCon, tryresult0) waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) pos <- pos + 1 } facinvarfree <- findFactor(varnonfixvar, facList) for(i in seq_along(indexnonfixvar)) { runnum <- indexnonfixvar[i] # Need to change marker variable if fixed oldmarker <- fixLoadingFac[[facinvarfree[i]]] if(length(oldmarker) > 0 && oldmarker == varnonfixvar[i]) { candidatemarker <- setdiff(facList[[facinvarfree[i]]], varnonfixvar[i])[1] temp <- freeParTable(pt1, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) temp <- fixParTable(temp, facinvarfree[i], "=~", candidatemarker, 1:ngroups, ustart = 1) temp <- constrainParTable(temp, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) newparent <- freeParTable(pt1, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) newparent <- fixParTable(newparent, facinvarfree[i], "=~", candidatemarker, 1:ngroups, ustart = 1) newparentresult <- try(newparentfit <- refit(newparent, fit1), silent = TRUE) if(!is(newparentresult, "try-error")) { tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, newparentfit, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(newparentfit, tempfit)) } waldCon[pos,] <- waldConstraint(newparentfit, newparent, waldMat, cbind(facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups)) } } else { temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } listFixCon <- c(listFixCon, tryresult) if(length(oldmarker) > 0 && oldmarker == varnonfixvar[i]) { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) } else { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) } estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) loadVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- loadVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) totalVal <- sapply(lavaan::fitted.values(tempfit0), function(x, v) x$cov[v, v], v = pt0$rhs[runnum]) names(facVal) <- names(totalVal) <- grouplab ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdLoadVal <- loadVal * sqrt(refFacVal) / sqrt(refTotalVal) stdestimates[pos,] <- stdLoadVal stdLoadVal <- stdLoadVal[grouporder] esstd[pos,] <- stdLoadVal[2:ngroups] - stdLoadVal[1] if(any(abs(stdLoadVal) > 0.9999)) warning(paste("Standardized Loadings of", pt0$rhs[runnum], "in some groups are less than -1 or over 1. The standardized loadings used in Fisher z transformation are changed to -0.9999 or 0.9999.")) stdLoadVal[stdLoadVal > 0.9999] <- 0.9999 stdLoadVal[stdLoadVal < -0.9999] <- -0.9999 zLoadVal <- atanh(stdLoadVal) esz[pos,] <- zLoadVal[2:ngroups] - zLoadVal[1] facMean <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~1", "", 1:ngroups) wlow <- min(facMean - fbound * sqrt(facVal)) whigh <- max(facMean + fbound * sqrt(facVal)) intVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$rhs[runnum], "~1", "", 1:ngroups) loadVal <- loadVal[grouporder] intVal <- intVal[grouporder] loaddiff <- loadVal[2:ngroups] - loadVal[1] intdiff <- intVal[2:ngroups] - intVal[1] lowdiff[pos,] <- intdiff + wlow * loaddiff highdiff[pos,] <- intdiff + whigh * loaddiff } listFreeCon <- c(listFreeCon, tryresult0) pos <- pos + 1 } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[c(indexfixvar, indexnonfixvar)] estimates <- cbind(estimates, stdestimates, esstd, esz, obsdiff, lowdiff, highdiff) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 2) { if(!is.null(free) | !is.null(fix)) { if(!is.null(fix)) { facinfix <- findFactor(fix, facList) dup <- duplicated(facinfix) for(i in seq_along(fix)) { if(dup[i]) { pt0 <- constrainParTable(pt0, fix[i], "~1", "", 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } else { oldmarker <- fixIntceptFac[[facinfix[i]]] if(length(oldmarker) > 0) { oldmarkerval <- pt1$ustart[pt1$lhs == fix[i] & pt1$op == "~1" & pt1$rhs == "" & pt1$group == 1] if(oldmarker == fix[i]) { pt0 <- fixParTable(pt0, fix[i], "~1", "", 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, fix[i], "~1", "", 1:ngroups, oldmarkerval) } else { pt0 <- freeParTable(pt0, oldmarker, "~1", "", 1:ngroups) pt0 <- constrainParTable(pt0, oldmarker, "~1", "", 1:ngroups) pt1 <- freeParTable(pt1, oldmarker, "~1", "", 1:ngroups) pt0 <- fixParTable(pt0, fix[i], "~1", "", 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, fix[i], "~1", "", 1:ngroups, oldmarkerval) fixIntceptFac[[facinfix[i]]] <- fix[i] } } else { pt0 <- constrainParTable(pt0, fix[i], "~1", "", 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } } } } if(!is.null(free)) { facinfree <- findFactor(free, facList) for(i in seq_along(free)) { # Need to change marker variable if fixed oldmarker <- fixIntceptFac[[facinfree[i]]] if(length(oldmarker) > 0 && oldmarker == free[i]) { oldmarkerval <- pt1$ustart[pt1$lhs == oldmarker & pt1$op == "~1" & pt1$rhs == "" & pt1$group == 1] candidatemarker <- setdiff(facList[[facinfree[i]]], free[i])[1] pt0 <- freeParTable(pt0, free[i], "~1", "", 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~1", "", 1:ngroups) pt0 <- fixParTable(pt0, candidatemarker, "~1", "", 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, candidatemarker, "~1", "", 1:ngroups, oldmarkerval) fixIntceptFac[[facinfix[i]]] <- candidatemarker } else { pt0 <- freeParTable(pt0, free[i], "~1", "", 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~1", "", 1:ngroups) } } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } obsmean <- sapply(lavInspect(fit0, "sampstat"), "[[", "mean") #FIXME: there might not be a mean structure obsmean <- obsmean[,grouporder] obsdiff <- obsmean[,2:ngroups, drop = FALSE] - matrix(obsmean[,1], nrow(obsmean), ngroups - 1) obsdiff <- obsdiff[varfree, , drop = FALSE] colnames(obsdiff) <- paste0("diff_mean:", complab) # Prop diff propdiff <- matrix(NA, length(varfree), ngroups - 1) colnames(propdiff) <- paste0("propdiff:", complab) estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("int:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$lhs %in% varfree) & (pt1$op == "~1") & (pt1$group == 1)) facinfix <- findFactor(fix, facList) varinfixvar <- unlist(facList[facinfix]) varinfixvar <- setdiff(varinfixvar, setdiff(varinfixvar, varfree)) indexfixvar <- which((pt1$lhs %in% varinfixvar) & (pt1$op == "~1") & (pt1$group == 1)) varnonfixvar <- setdiff(varfree, varinfixvar) indexnonfixvar <- setdiff(index, indexfixvar) pos <- 1 for(i in seq_along(varinfixvar)) { runnum <- indexfixvar[i] temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) intVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- intVal totalVal <- sapply(lavaan::fitted.values(tempfit0), function(x, v) x$cov[v, v], v = pt0$lhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdIntVal <- intVal / sqrt(refTotalVal) stdestimates[pos,] <- stdIntVal stdIntVal <- stdIntVal[grouporder] esstd[pos,] <- stdIntVal[2:ngroups] - stdIntVal[1] intVal <- intVal[grouporder] propdiff[pos,] <- (intVal[2:ngroups] - intVal[1]) / obsdiff[pos,] } listFreeCon <- c(listFreeCon, tryresult0) waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) pos <- pos + 1 } facinvarfree <- findFactor(varfree, facList) for(i in seq_along(varnonfixvar)) { runnum <- indexnonfixvar[i] # Need to change marker variable if fixed oldmarker <- fixIntceptFac[[facinvarfree[i]]] if(length(oldmarker) > 0 && oldmarker == varfree[i]) { candidatemarker <- setdiff(facList[[facinvarfree[i]]], varfree[i])[1] temp <- freeParTable(pt1, varfree[i], "~1", "", 1:ngroups) temp <- constrainParTable(temp, varfree[i], "~1", "", 1:ngroups) temp <- fixParTable(temp, candidatemarker, "~1", "", 1:ngroups) newparent <- freeParTable(pt1, varfree[i], "~1", "", 1:ngroups) newparent <- fixParTable(newparent, candidatemarker, "~1", "", 1:ngroups) newparentresult <- try(newparentfit <- refit(newparent, fit1), silent = TRUE) if(!is(newparentresult, "try-error")) { tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, newparentfit, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(newparentfit, tempfit)) } waldCon[pos,] <- waldConstraint(newparentfit, newparent, waldMat, cbind(varfree[i], "~1", "", 1:ngroups)) } } else { temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } listFixCon <- c(listFixCon, tryresult) if(length(oldmarker) > 0 && oldmarker == varfree[i]) { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) } else { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) } estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) intVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- intVal totalVal <- sapply(lavaan::fitted.values(tempfit0), function(x, v) x$cov[v, v], v = pt0$lhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdIntVal <- intVal / sqrt(refTotalVal) stdestimates[pos,] <- stdIntVal stdIntVal <- stdIntVal[grouporder] esstd[pos,] <- stdIntVal[2:ngroups] - stdIntVal[1] intVal <- intVal[grouporder] propdiff[pos,] <- (intVal[2:ngroups] - intVal[1]) / obsdiff[pos,] } listFreeCon <- c(listFreeCon, tryresult0) pos <- pos + 1 } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[c(indexfixvar, indexnonfixvar)] estimates <- cbind(estimates, stdestimates, esstd, obsdiff, propdiff) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 3) { if(!is.null(free) | !is.null(fix)) { if(!is.null(fix)) { for(i in seq_along(fix)) { pt0 <- constrainParTable(pt0, fix[i], "~~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~~", fix[i], 1:ngroups) } } if(!is.null(free)) { for(i in seq_along(free)) { pt0 <- freeParTable(pt0, free[i], "~~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~~", free[i], 1:ngroups) } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } # Prop diff propdiff <- matrix(NA, length(varfree), ngroups - 1) colnames(propdiff) <- paste0("propdiff:", complab) estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("errvar:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- esz <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) colnames(esz) <- paste0("h:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$lhs %in% varfree) & (pt1$op == "~~") & (pt1$lhs == pt1$rhs) & (pt1$group == 1)) for(i in seq_along(index)) { runnum <- index[i] temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[i,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[i, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[i,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) errVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[i, 2:ncol(estimates)] <- errVal totalVal <- sapply(lavaan::fitted.values(tempfit0), function(x, v) x$cov[v, v], v = pt0$rhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdErrVal <- errVal / sqrt(refTotalVal) stdestimates[i,] <- stdErrVal stdErrVal <- stdErrVal[grouporder] esstd[i,] <- stdErrVal[2:ngroups] - stdErrVal[1] if(any(abs(stdErrVal) > 0.9999)) warning(paste("The uniqueness of", pt0$rhs[runnum], "in some groups are over 1. The uniqueness used in arctan transformation are changed to 0.9999.")) stdErrVal[stdErrVal > 0.9999] <- 0.9999 zErrVal <- asin(sqrt(stdErrVal)) esz[i,] <- zErrVal[2:ngroups] - zErrVal[1] errVal <- errVal[grouporder] totalVal <- totalVal[grouporder] errdiff <- errVal[2:ngroups] - errVal[1] totaldiff <- totalVal[2:ngroups] - totalVal[1] propdiff[i,] <- errdiff / totaldiff } listFreeCon <- c(listFreeCon, tryresult0) waldCon[i,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[index] estimates <- cbind(estimates, stdestimates, esstd, esz, propdiff) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 4) { varfree <- facnames if(!is.null(free) | !is.null(fix)) { if(!is.null(fix)) { for(i in seq_along(fix)) { pt0 <- constrainParTable(pt0, fix[i], "~1", "", 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } } if(!is.null(free)) { for(i in seq_along(free)) { pt0 <- freeParTable(pt0, free[i], "~1", "", 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~1", "", 1:ngroups) } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("mean:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$lhs %in% varfree) & (pt1$op == "~1") & (pt1$group == 1)) for(i in seq_along(index)) { runnum <- index[i] isfree <- pt1$free[runnum] != 0 if(isfree) { temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) } else { temp <- fixParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 2:ngroups, ustart = pt1$ustart[runnum]) } tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[i,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) isfree0 <- pt0$free[runnum] != 0 if(isfree0) { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) } else { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) } estimates[i, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if(!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if(!is(compresult0, "try-error")) freeCon[i,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) meanVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[i, 2:ncol(estimates)] <- meanVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) stdMeanVal <- meanVal / sqrt(refFacVal) stdestimates[i,] <- stdMeanVal stdMeanVal <- stdMeanVal[grouporder] esstd[i,] <- stdMeanVal[2:ngroups] - stdMeanVal[1] } listFreeCon <- c(listFreeCon, tryresult0) waldCon[i,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[index] estimates <- cbind(estimates, stdestimates, esstd) result <- cbind(freeCon, fixCon, waldCon) } if(return.fit) { return(invisible(list(estimates = estimates, results = result, models = list(free = listFreeCon, fix = listFixCon, nested = fit0, parent = fit1)))) } else { return(list(estimates = estimates, results = result)) } } ##' @importFrom lavaan lavInspect parTable ##' @rdname partialInvariance ##' @export partialInvarianceCat <- function(fit, type, free = NULL, fix = NULL, refgroup = 1, poolvar = TRUE, p.adjust = "none", return.fit = FALSE, method = "satorra.bentler.2001") { # model <- ' f1 =~ u1 + u2 + u3 + u4 # f2 =~ u5 + u6 + u7 + u8' # modelsCat2 <- measurementInvarianceCat(model, data = datCat, group = "g", parameterization="theta", # estimator="wlsmv", strict = TRUE) # fit <- modelsCat2 # type <- "weak" # free <- NULL # fix <- NULL # refgroup <- 1 # poolvar <- TRUE # p.adjust <- "none" # return.fit <- FALSE # method = "satorra.bentler.2001" type <- tolower(type) numType <- 1 fit1 <- fit0 <- NULL # fit0 = Nested model, fit1 = Parent model if (type %in% c("metric", "weak", "loading", "loadings")) { numType <- 1 if (all(c("fit.configural", "fit.loadings") %in% names(fit))) { fit1 <- fit$fit.configural fit0 <- fit$fit.loadings } else { stop("The elements named 'fit.configural' and 'fit.loadings' are needed", " in the 'fit' argument") } } else if (type %in% c("scalar", "strong", "intercept", "intercepts", "threshold", "thresholds")) { numType <- 2 if (all(c("fit.loadings", "fit.thresholds") %in% names(fit))) { fit1 <- fit$fit.loadings fit0 <- fit$fit.thresholds } else { stop("The elements named 'fit.loadings' and 'fit.thresholds' are needed", " in the 'fit' argument") } } else if (type %in% c("strict", "residual", "residuals", "error", "errors")) { numType <- 3 if ("fit.residuals" %in% names(fit)) { fit0 <- fit$fit.residuals if ("fit.thresholds" %in% names(fit)) { fit1 <- fit$fit.thresholds } else if ("fit.loadings" %in% names(fit)) { fit1 <- fit$fit.loadings } else { stop("The element named either 'fit.thresholds' or 'fit.loadings' is", " needed in the 'fit' argument") } } else { stop("The element named 'fit.residuals' is needed in the 'fit' argument") } } else if (type %in% c("means", "mean")) { numType <- 4 if ("fit.means" %in% names(fit)) { fit0 <- fit$fit.means if("fit.residuals" %in% names(fit)) { fit1 <- fit$fit.residuals } else if ("fit.thresholds" %in% names(fit)) { fit1 <- fit$fit.thresholds } else if ("fit.loadings" %in% names(fit)) { fit1 <- fit$fit.loadings } else { stop("The element named either 'fit.residuals', 'fit.thresholds',", " or 'fit.loadings' is needed in the 'fit' argument") } } else { stop("The element named 'fit.means' is needed in the 'fit' argument") } } else { stop("Please specify the correct type of measurement invariance. See the help page.") } pt1 <- parTable(fit1) pt0 <- parTable(fit0) pt0$start <- pt0$est <- pt0$se <- NULL pt1$start <- pt1$est <- pt1$se <- NULL pt1$label[substr(pt1$label, 1, 1) == "." & substr(pt1$label, nchar(pt1$label), nchar(pt1$label)) == "."] <- "" pt0$label[substr(pt0$label, 1, 1) == "." & substr(pt0$label, nchar(pt0$label), nchar(pt0$label)) == "."] <- "" namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) if (length(table(table(pt0$rhs[pt0$op == "=~"]))) != 1) stop("The model is not congeneric. This function does not support non-congeneric model.") varfree <- varnames <- unique(pt0$rhs[pt0$op == "=~"]) facnames <- unique(pt0$lhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)]) facrepresent <- table(pt0$lhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)], pt0$rhs[(pt0$op == "=~") & (pt0$rhs %in% varnames)]) if (any(apply(facrepresent, 2, function(x) sum(x != 0)) > 1)) stop("The model is not congeneric. This function does not support non-congeneric model.") facList <- list() for (i in 1:nrow(facrepresent)) { facList[[i]] <- colnames(facrepresent)[facrepresent[i,] > 0] } names(facList) <- rownames(facrepresent) facList <- facList[match(names(facList), facnames)] fixLoadingFac <- list() for (i in seq_along(facList)) { select <- pt1$lhs == names(facList)[i] & pt1$op == "=~" & pt1$rhs %in% facList[[i]] & pt1$group == 1 & pt1$free == 0 & (!is.na(pt1$ustart) & pt1$ustart > 0) fixLoadingFac[[i]] <- pt1$rhs[select] } names(fixLoadingFac) <- names(facList) # Find the number of thresholds # Check whether the factor configuration is the same across gorups conParTable <- lapply(pt1, "[", pt1$op == "==") group1pt <- lapply(pt1, "[", pt1$group != 1) numThreshold <- table(sapply(group1pt, "[", group1pt$op == "|")[,"lhs"]) plabelthres <- split(group1pt$plabel[group1pt$op == "|"], group1pt$lhs[group1pt$op == "|"]) numFixedThreshold <- sapply(lapply(plabelthres, function(vec) !is.na(match(vec, conParTable$lhs)) | !is.na(match(vec, conParTable$rhs))), sum)[names(numThreshold)] #numFixedThreshold <- table(sapply(group1pt, "[", group1pt$op == "|" & group1pt$eq.id != 0)[,"lhs"]) fixIntceptFac <- list() for (i in seq_along(facList)) { tmp <- numFixedThreshold[facList[[i]]] if (all(tmp > 1)) { fixIntceptFac[[i]] <- integer(0) } else { fixIntceptFac[[i]] <- names(which.max(tmp))[1] } } names(fixIntceptFac) <- names(facList) ngroups <- max(pt0$group) neach <- lavInspect(fit0, "nobs") groupvar <- lavInspect(fit0, "group") grouplab <- lavInspect(fit0, "group.label") if (!is.numeric(refgroup)) refgroup <- which(refgroup == grouplab) grouporder <- 1:ngroups grouporder <- c(refgroup, setdiff(grouporder, refgroup)) grouplaborder <- grouplab[grouporder] complab <- paste(grouplaborder[2:ngroups], "vs.", grouplaborder[1]) if (ngroups <= 1) stop("Well, the number of groups is 1. Measurement", " invariance across 'groups' cannot be done.") if (numType == 4) { if (!all(c(free, fix) %in% facnames)) stop("'free' and 'fix' arguments should consist of factor names because", " mean invariance is tested.") } else { if (!all(c(free, fix) %in% varnames)) stop("'free' and 'fix' arguments should consist of variable names.") } result <- fixCon <- freeCon <- NULL estimates <- NULL listFreeCon <- listFixCon <- list() beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) if (numType == 1) { if (!is.null(free) | !is.null(fix)) { if (!is.null(fix)) { facinfix <- findFactor(fix, facList) dup <- duplicated(facinfix) for (i in seq_along(fix)) { if (dup[i]) { pt0 <- constrainParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } else { oldmarker <- fixLoadingFac[[facinfix[i]]] if (length(oldmarker) > 0) { oldmarkerval <- pt1$ustart[pt1$lhs == facinfix[i] & pt1$op == "=~" & pt1$rhs == oldmarker & pt1$group == 1] if (oldmarker == fix[i]) { pt0 <- fixParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) } else { pt0 <- freeParTable(pt0, facinfix[i], "=~", oldmarker, 1:ngroups) pt0 <- constrainParTable(pt0, facinfix[i], "=~", oldmarker, 1:ngroups) pt1 <- freeParTable(pt1, facinfix[i], "=~", oldmarker, 1:ngroups) pt0 <- fixParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups, oldmarkerval) fixLoadingFac[[facinfix[i]]] <- fix[i] } } else { pt0 <- constrainParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } } } } if (!is.null(free)) { facinfree <- findFactor(free, facList) for (i in seq_along(free)) { # Need to change marker variable if fixed oldmarker <- fixLoadingFac[[facinfree[i]]] if (length(oldmarker) > 0 && oldmarker == free[i]) { oldmarkerval <- pt1$ustart[pt1$lhs == facinfix[i] & pt1$op == "=~" & pt1$rhs == oldmarker & pt1$group == 1] candidatemarker <- setdiff(facList[[facinfree[i]]], free[i])[1] pt0 <- freeParTable(pt0, facinfree[i], "=~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, facinfree[i], "=~", free[i], 1:ngroups) pt0 <- fixParTable(pt0, facinfix[i], "=~", candidatemarker, 1:ngroups, oldmarkerval) pt1 <- fixParTable(pt1, facinfix[i], "=~", candidatemarker, 1:ngroups, oldmarkerval) fixLoadingFac[[facinfix[i]]] <- candidatemarker } else { pt0 <- freeParTable(pt0, facinfree[i], "=~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, facinfree[i], "=~", free[i], 1:ngroups) } } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("load:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- esz <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) colnames(esz) <- paste0("q:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$rhs %in% varfree) & (pt1$op == "=~") & (pt1$group == 1)) facinfix <- findFactor(fix, facList) varinfixvar <- unlist(facList[facinfix]) varinfixvar <- setdiff(varinfixvar, setdiff(varinfixvar, varfree)) indexfixvar <- which((pt1$rhs %in% varinfixvar) & (pt1$op == "=~") & (pt1$group == 1)) varnonfixvar <- setdiff(varfree, varinfixvar) indexnonfixvar <- setdiff(index, indexfixvar) pos <- 1 for (i in seq_along(indexfixvar)) { runnum <- indexfixvar[i] temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) loadVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- loadVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) totalVal <- sapply(thetaImpliedTotalVar(tempfit0), function(x, v) x[v, v], v = pt0$rhs[runnum]) names(facVal) <- names(totalVal) <- grouplab ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdLoadVal <- loadVal * sqrt(refFacVal) / sqrt(refTotalVal) stdestimates[pos,] <- stdLoadVal stdLoadVal <- stdLoadVal[grouporder] esstd[pos,] <- stdLoadVal[2:ngroups] - stdLoadVal[1] if (any(abs(stdLoadVal) > 0.9999)) warning(paste("Standardized Loadings of", pt0$rhs[runnum], "in some groups are less than -1 or over 1. The", " standardized loadings used in Fisher z", " transformation are changed to -0.9999 or 0.9999.")) stdLoadVal[stdLoadVal > 0.9999] <- 0.9999 stdLoadVal[stdLoadVal < -0.9999] <- -0.9999 zLoadVal <- atanh(stdLoadVal) esz[pos,] <- zLoadVal[2:ngroups] - zLoadVal[1] } listFreeCon <- c(listFreeCon, tryresult0) waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) pos <- pos + 1 } facinvarfree <- findFactor(varnonfixvar, facList) for (i in seq_along(indexnonfixvar)) { runnum <- indexnonfixvar[i] # Need to change marker variable if fixed oldmarker <- fixLoadingFac[[facinvarfree[i]]] if (length(oldmarker) > 0 && oldmarker == varnonfixvar[i]) { candidatemarker <- setdiff(facList[[facinvarfree[i]]], varnonfixvar[i])[1] temp <- freeParTable(pt1, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) temp <- constrainParTable(temp, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) temp <- fixParTable(temp, facinvarfree[i], "=~", candidatemarker, 1:ngroups) newparent <- freeParTable(pt1, facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups) newparent <- fixParTable(newparent, facinvarfree[i], "=~", candidatemarker, 1:ngroups) newparentresult <- try(newparentfit <- refit(newparent, fit1), silent = TRUE) if (!is(newparentresult, "try-error")) { tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, newparentfit, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(newparentfit, tempfit)) } waldCon[pos,] <- waldConstraint(newparentfit, newparent, waldMat, cbind(facinvarfree[i], "=~", varnonfixvar[i], 1:ngroups)) } } else { temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } waldCon[pos,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } listFixCon <- c(listFixCon, tryresult) if (length(oldmarker) > 0 && oldmarker == varnonfixvar[i]) { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) } else { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) } estimates[pos, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) loadVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, 2:ncol(estimates)] <- loadVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) totalVal <- sapply(thetaImpliedTotalVar(tempfit0), function(x, v) x[v, v], v = pt0$rhs[runnum]) names(facVal) <- names(totalVal) <- grouplab ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdLoadVal <- loadVal * sqrt(refFacVal) / sqrt(refTotalVal) stdestimates[pos,] <- stdLoadVal stdLoadVal <- stdLoadVal[grouporder] esstd[pos,] <- stdLoadVal[2:ngroups] - stdLoadVal[1] if (any(abs(stdLoadVal) > 0.9999)) warning(paste("Standardized Loadings of", pt0$rhs[runnum], "in some groups are less than -1 or over 1. The", " standardized loadings used in Fisher z", " transformation are changed to -0.9999 or 0.9999.")) stdLoadVal[stdLoadVal > 0.9999] <- 0.9999 stdLoadVal[stdLoadVal < -0.9999] <- -0.9999 zLoadVal <- atanh(stdLoadVal) esz[pos,] <- zLoadVal[2:ngroups] - zLoadVal[1] } listFreeCon <- c(listFreeCon, tryresult0) pos <- pos + 1 } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[c(indexfixvar, indexnonfixvar)] estimates <- cbind(estimates, stdestimates, esstd, esz) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 2) { if (!is.null(free) | !is.null(fix)) { if (!is.null(fix)) { facinfix <- findFactor(fix, facList) dup <- duplicated(facinfix) for (i in seq_along(fix)) { numfixthres <- numThreshold[fix[i]] if (numfixthres > 1) { if (dup[i]) { for (s in 2:numfixthres) { pt0 <- constrainParTable(pt0, fix[i], "|", paste0("t", s), 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "|", paste0("t", s), 1:ngroups) } } else { oldmarker <- fixIntceptFac[[facinfix[i]]] numoldthres <- numThreshold[oldmarker] if (length(oldmarker) > 0) { if (oldmarker == fix[i]) { for (s in 2:numfixthres) { pt0 <- constrainParTable(pt0, fix[i], "|", paste0("t", s), 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "|", paste0("t", s), 1:ngroups) } } else { for (r in 2:numoldthres) { pt1 <- freeParTable(pt1, oldmarker, "|", paste0("t", r), 1:ngroups) } for (s in 2:numfixthres) { pt0 <- constrainParTable(pt0, fix[i], "|", paste0("t", s), 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "|", paste0("t", s), 1:ngroups) } fixIntceptFac[[facinfix[i]]] <- fix[i] } } else { for (s in 2:numfixthres) { pt0 <- constrainParTable(pt0, fix[i], "|", paste0("t", s), 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "|", paste0("t", s), 1:ngroups) } } } } } } if (!is.null(free)) { facinfree <- findFactor(free, facList) for (i in seq_along(free)) { numfreethres <- numThreshold[free[i]] # Need to change marker variable if fixed oldmarker <- fixIntceptFac[[facinfree[i]]] numoldthres <- numThreshold[oldmarker] if (length(oldmarker) > 0 && oldmarker == free[i]) { candidatemarker <- setdiff(facList[[facinfree[i]]], free[i]) candidatemarker <- candidatemarker[numThreshold[candidatemarker] > 1][1] numcandidatethres <- numThreshold[candidatemarker] pt0 <- constrainParTable(pt0, candidatemarker, "|", "t2", 1:ngroups) pt1 <- constrainParTable(pt1, candidatemarker, "|", "t2", 1:ngroups) for (s in 2:numfixthres) { pt0 <- freeParTable(pt0, free[i], "|", paste0("t", s), 1:ngroups) pt1 <- freeParTable(pt1, free[i], "|", paste0("t", s), 1:ngroups) } fixIntceptFac[[facinfix[i]]] <- candidatemarker } else { for (s in 2:numfixthres) { pt0 <- freeParTable(pt0, free[i], "|", paste0("t", s), 1:ngroups) pt1 <- freeParTable(pt1, free[i], "|", paste0("t", s), 1:ngroups) } } } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } maxcolumns <- max(numThreshold[varfree]) - 1 tname <- paste0("t", 2:(maxcolumns + 1)) estimates <- matrix(NA, length(varfree), (ngroups * length(tname)) + length(tname)) stdestimates <- matrix(NA, length(varfree), ngroups * length(tname)) tnameandlab <- expand.grid(tname, grouplab) colnames(estimates) <- c(paste0("pool:", tname), paste0(tnameandlab[,1], ":", tnameandlab[,2])) colnames(stdestimates) <- paste0("std:", tnameandlab[,1], ":", tnameandlab[,2]) esstd <- matrix(NA, length(varfree), (ngroups - 1)* length(tname)) tnameandcomplab <- expand.grid(tname, complab) colnames(esstd) <- paste0("diff_std:", tnameandcomplab[,1], ":", tnameandcomplab[,2]) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") facinfix <- findFactor(fix, facList) varinfixvar <- unlist(facList[facinfix]) varinfixvar <- setdiff(varinfixvar, setdiff(varinfixvar, varfree)) varnonfixvar <- setdiff(varfree, varinfixvar) pos <- 1 for (i in seq_along(varinfixvar)) { temp <- pt1 for (s in 2:numThreshold[varinfixvar[i]]) { runnum <- which((pt1$lhs == varfree[i]) & (pt1$op == "|") & (pt1$rhs == paste0("t", s)) & (pt1$group == 1)) temp <- constrainParTable(temp, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) } tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- pt0 for (s in 2:numThreshold[varinfixvar[i]]) { runnum <- which((pt0$lhs == varfree[i]) & (pt0$op == "|") & (pt0$rhs == paste0("t", s)) & (pt0$group == 1)) temp0 <- freeParTable(temp0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, s - 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) } tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) for (s in 2:numThreshold[varinfixvar[i]]) { runnum <- which((pt0$lhs == varfree[i]) & (pt0$op == "|") & (pt0$rhs == paste0("t", s)) & (pt0$group == 1)) thresVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, maxcolumns*(1:ngroups) + (s - 1)] <- thresVal totalVal <- sapply(thetaImpliedTotalVar(tempfit0), function(x, v) x[v, v], v = pt0$lhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdIntVal <- thresVal / sqrt(refTotalVal) stdestimates[pos, maxcolumns*(1:ngroups - 1) + (s - 1)] <- stdIntVal stdIntVal <- stdIntVal[grouporder] esstd[pos, maxcolumns*(1:length(complab) - 1) + (s - 1)] <- stdIntVal[2:ngroups] - stdIntVal[1] } } listFreeCon <- c(listFreeCon, tryresult0) args <- list(fit1, pt1, waldMat) for (s in 2:numThreshold[varinfixvar[i]]) { runnum <- which((pt1$lhs == varfree[i]) & (pt1$op == "|") & (pt1$rhs == paste0("t", s)) & (pt1$group == 1)) args <- c(args, list(cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups))) } waldCon[pos,] <- do.call(waldConstraint, args) pos <- pos + 1 } facinvarfree <- findFactor(varnonfixvar, facList) for (i in seq_along(varnonfixvar)) { # Need to change marker variable if fixed oldmarker <- fixIntceptFac[[facinvarfree[i]]] if (length(oldmarker) > 0 && oldmarker == varfree[i]) { candidatemarker <- setdiff(facList[[facinvarfree[i]]], varnonfixvar[i]) candidatemarker <- candidatemarker[numThreshold[candidatemarker] > 1][1] numcandidatethres <- numThreshold[candidatemarker] newparent <- constrainParTable(pt1, candidatemarker, "|", "t2", 1:ngroups) for (s in 2:numcandidatethres) { newparent <- freeParTable(newparent, varnonfixvar[i], "|", paste0("t", s), 1:ngroups) } temp <- newparent for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((newparent$lhs == varnonfixvar[i]) & (newparent$op == "|") & (newparent$rhs == paste0("t", s)) & (newparent$group == 1)) temp <- constrainParTable(temp, newparent$lhs[runnum], newparent$op[runnum], newparent$rhs[runnum], 1:ngroups) } newparentresult <- try(newparentfit <- refit(newparent, fit1), silent = TRUE) if (!is(newparentresult, "try-error")) { tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, newparentfit, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(newparentfit, tempfit)) } args <- list(newparentfit, newparent, waldMat) for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((newparent$lhs == varnonfixvar[i]) & (newparent$op == "|") & (newparent$rhs == paste0("t", s)) & (newparent$group == 1)) args <- c(args, list(cbind(newparent$lhs[runnum], newparent$op[runnum], newparent$rhs[runnum], 1:ngroups))) } waldCon[pos,] <- do.call(waldConstraint, args) } } else { temp <- pt1 for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((pt1$lhs == varfree[i]) & (pt1$op == "|") & (pt1$rhs == paste0("t", s)) & (pt1$group == 1)) temp <- constrainParTable(temp, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) } tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[pos,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } args <- list(fit1, pt1, waldMat) for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((pt1$lhs == varfree[i]) & (pt1$op == "|") & (pt1$rhs == paste0("t", s)) & (pt1$group == 1)) args <- c(args, list(cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups))) } waldCon[pos,] <- do.call(waldConstraint, args) } listFixCon <- c(listFixCon, tryresult) temp0 <- pt0 for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((pt0$lhs == varfree[i]) & (pt0$op == "|") & (pt0$rhs == paste0("t", s)) & (pt0$group == 1)) temp0 <- freeParTable(temp0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, s - 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) } tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[pos,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) for (s in 2:numThreshold[varnonfixvar[i]]) { runnum <- which((pt0$lhs == varfree[i]) & (pt0$op == "|") & (pt0$rhs == paste0("t", s)) & (pt0$group == 1)) thresVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[pos, maxcolumns*(1:ngroups) + (s - 1)] <- thresVal totalVal <- sapply(thetaImpliedTotalVar(tempfit0), function(x, v) x[v, v], v = pt0$lhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdIntVal <- thresVal / sqrt(refTotalVal) stdestimates[pos, maxcolumns*(1:ngroups - 1) + (s - 1)] <- stdIntVal stdIntVal <- stdIntVal[grouporder] esstd[pos, maxcolumns*(1:length(complab) - 1) + (s - 1)] <- stdIntVal[2:ngroups] - stdIntVal[1] } } listFreeCon <- c(listFreeCon, tryresult0) pos <- pos + 1 } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- paste0(c(varinfixvar, varnonfixvar), "|") estimates <- cbind(estimates, stdestimates, esstd) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 3) { if (!is.null(free) | !is.null(fix)) { if (!is.null(fix)) { for (i in seq_along(fix)) { pt0 <- constrainParTable(pt0, fix[i], "~~", fix[i], 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~~", fix[i], 1:ngroups) } } if (!is.null(free)) { for (i in seq_along(free)) { pt0 <- freeParTable(pt0, free[i], "~~", free[i], 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~~", free[i], 1:ngroups) } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("errvar:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- esz <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) colnames(esz) <- paste0("h:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$lhs %in% varfree) & (pt1$op == "~~") & (pt1$lhs == pt1$rhs) & (pt1$group == 1)) for (i in seq_along(index)) { runnum <- index[i] ustart <- getValue(pt1, beta, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1) temp <- fixParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 2:ngroups, ustart) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[i,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) estimates[i, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[i,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) errVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[i, 2:ncol(estimates)] <- errVal totalVal <- sapply(thetaImpliedTotalVar(tempfit0), function(x, v) x[v, v], v = pt0$rhs[runnum]) ifelse(poolvar, refTotalVal <- poolVariance(totalVal, neach), refTotalVal <- totalVal[refgroup]) stdErrVal <- errVal / sqrt(refTotalVal) stdestimates[i,] <- stdErrVal stdErrVal <- stdErrVal[grouporder] esstd[i,] <- stdErrVal[2:ngroups] - stdErrVal[1] if (any(abs(stdErrVal) > 0.9999)) warning(paste("The uniqueness of", pt0$rhs[runnum], "in some groups are over 1. The uniqueness used in", " arctan transformation are changed to 0.9999.")) stdErrVal[stdErrVal > 0.9999] <- 0.9999 zErrVal <- asin(sqrt(stdErrVal)) esz[i,] <- zErrVal[2:ngroups] - zErrVal[1] } listFreeCon <- c(listFreeCon, tryresult0) waldCon[i,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[index] estimates <- cbind(estimates, stdestimates, esstd, esz) result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 4) { varfree <- facnames if (!is.null(free) | !is.null(fix)) { if (!is.null(fix)) { for (i in seq_along(fix)) { pt0 <- constrainParTable(pt0, fix[i], "~1", "", 1:ngroups) pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } } if (!is.null(free)) { for (i in seq_along(free)) { pt0 <- freeParTable(pt0, free[i], "~1", "", 1:ngroups) pt1 <- freeParTable(pt1, free[i], "~1", "", 1:ngroups) } } namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) fit0 <- refit(pt0, fit0) fit1 <- refit(pt1, fit1) beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } estimates <- matrix(NA, length(varfree), ngroups + 1) stdestimates <- matrix(NA, length(varfree), ngroups) colnames(estimates) <- c("poolest", paste0("mean:", grouplab)) colnames(stdestimates) <- paste0("std:", grouplab) esstd <- matrix(NA, length(varfree), ngroups - 1) colnames(esstd) <- paste0("diff_std:", complab) fixCon <- freeCon <- matrix(NA, length(varfree), 4) waldCon <- matrix(NA, length(varfree), 3) colnames(fixCon) <- c("fix.chi", "fix.df", "fix.p", "fix.cfi") colnames(freeCon) <- c("free.chi", "free.df", "free.p", "free.cfi") colnames(waldCon) <- c("wald.chi", "wald.df", "wald.p") index <- which((pt1$lhs %in% varfree) & (pt1$op == "~1") & (pt1$group == 1)) for (i in seq_along(index)) { runnum <- index[i] isfree <- pt1$free[runnum] != 0 if (isfree) { temp <- constrainParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups) } else { temp <- fixParTable(pt1, pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 2:ngroups, ustart = pt1$ustart[runnum]) } tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if (!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if (!is(compresult, "try-error")) fixCon[i,] <- c(unlist(modelcomp[2,5:7]), deltacfi(fit1, tempfit)) } listFixCon <- c(listFixCon, tryresult) isfree0 <- pt0$free[runnum] != 0 if (isfree0) { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) } else { temp0 <- freeParTable(pt0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 2:ngroups) } estimates[i, 1] <- getValue(pt0, beta0, pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1) tryresult0 <- try(tempfit0 <- refit(temp0, fit0), silent = TRUE) if (!is(tryresult0, "try-error")) { compresult0 <- try(modelcomp0 <- lavaan::lavTestLRT(tempfit0, fit0, method = method), silent = TRUE) if (!is(compresult0, "try-error")) freeCon[i,] <- c(unlist(modelcomp0[2,5:7]), deltacfi(tempfit0, fit0)) meanVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], pt0$op[runnum], pt0$rhs[runnum], 1:ngroups) estimates[i, 2:ncol(estimates)] <- meanVal facVal <- getValue(temp0, lavaan::coef(tempfit0), pt0$lhs[runnum], "~~", pt0$lhs[runnum], 1:ngroups) ifelse(poolvar, refFacVal <- poolVariance(facVal, neach), refFacVal <- facVal[refgroup]) stdMeanVal <- meanVal / sqrt(refFacVal) stdestimates[i,] <- stdMeanVal stdMeanVal <- stdMeanVal[grouporder] esstd[i,] <- stdMeanVal[2:ngroups] - stdMeanVal[1] } listFreeCon <- c(listFreeCon, tryresult0) waldCon[i,] <- waldConstraint(fit1, pt1, waldMat, cbind(pt1$lhs[runnum], pt1$op[runnum], pt1$rhs[runnum], 1:ngroups)) } freeCon[,3] <- stats::p.adjust(freeCon[,3], p.adjust) fixCon[,3] <- stats::p.adjust(fixCon[,3], p.adjust) waldCon[,3] <- stats::p.adjust(waldCon[,3], p.adjust) rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[index] estimates <- cbind(estimates, stdestimates, esstd) result <- cbind(freeCon, fixCon, waldCon) } if (return.fit) { return(invisible(list(estimates = estimates, results = result, models = list(free = listFreeCon, fix = listFixCon, nested = fit0, parent = fit1)))) } else { return(list(estimates = estimates, results = result)) } } ## ---------------- ## Hidden Functions ## ---------------- findFactor <- function(var, facList) { tempfac <- lapply(facList, intersect, var) facinvar <- rep(names(tempfac), sapply(tempfac, length)) facinvar[match(unlist(tempfac), var)] } ## Terry moved here from wald.R so that wald() could be removed (redundant with lavaan::lavTestWald) ## FIXME: Update WaldConstraint to rely on lavaan::lavTestWald instead #' @importFrom stats pchisq waldContrast <- function(object, contrast) { beta <- lavaan::coef(object) acov <- lavaan::vcov(object) chisq <- t(contrast %*% beta) %*% solve(contrast %*% as.matrix(acov) %*% t(contrast)) %*% (contrast %*% beta) df <- nrow(contrast) p <- pchisq(chisq, df, lower.tail=FALSE) c(chisq = chisq, df = df, p = p) } #' @importFrom lavaan parTable waldConstraint <- function(fit, pt, mat, ...) { dotdotdot <- list(...) overallMat <- NULL for(i in seq_along(dotdotdot)) { target <- dotdotdot[[i]] tempMat <- mat element <- apply(target, 1, matchElement, parTable = pt) freeIndex <- pt$free[element] tempMat[,freeIndex[1]] <- -1 for(m in 2:length(freeIndex)) { tempMat[m - 1, freeIndex[m]] <- 1 } overallMat <- rbind(overallMat, tempMat) } result <- rep(NA, 3) if(!any(apply(overallMat, 1, sum) != 0)) { try(result <- waldContrast(fit, overallMat), silent = TRUE) } return(result) } poolVariance <- function(var, n) { nm <- n - 1 sum(var * nm) / sum(nm) } deltacfi <- function(parent, nested) lavaan::fitmeasures(nested)["cfi"] - lavaan::fitmeasures(parent)["cfi"] ## For categorical. FIXME: Why is this even necessary? ## Did Sunthud not know implied Sigma is available? #' @importFrom lavaan lavInspect thetaImpliedTotalVar <- function(object) { # param <- lavInspect(object, "est") # ngroup <- lavInspect(object, "ngroups") # name <- names(param) # if(ngroup == 1) { # ly <- param[name == "lambda"] # } else { # ly <- lapply(param, "[[", "lambda") # } # ps <- lavInspect(object, "cov.lv") # if(ngroup == 1) ps <- list(ps) # if(ngroup == 1) { # te <- param[name == "theta"] # } else { # te <- lapply(param, "[[", "theta") # } # result <- list() # for(i in 1:ngroup) { # result[[i]] <- ly[[i]] %*% ps[[i]] %*% t(ly[[i]]) + te[[i]] # } # result if (lavInspect(object, "ngroups") == 1L) return(list(lavInspect(object, "cov.ov"))) lavInspect(object, "cov.ov") } semTools/R/measEq.R0000644000176200001440000045301114764271042013631 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### lavaan model syntax-writing engine for new measEq() to replace ### measurementInvariance(), measurementInvarianceCat(), and longInvariance() ## ---------------------- ## Model-Fitting Function ## ---------------------- measEq <- function(configural.model, ID.fac = c("std.lv","auto.fix.first","effects.coding"), ID.cat = c("Wu.Estabrook.2016","Mplus","Millsap.Tein.2004","LISREL"), ID.thr = c(1L, 2L), # only for ID.cat == "Millsap.Tein.2004" group = NULL, longFacNames = list(), longIndNames = list(), #group.equal = "", long.equal = "", group.partial = "", long.partial = "", auto = "all", extra = NULL, test.seq = c("thresholds","loadings","intercepts","means", "lv.variances","residuals"), # optional resid/lv.autocov, residual/lv.covariances #fixed.x = TRUE, strict = FALSE, quiet = FALSE, warn = TRUE, debug = FALSE, alpha = .05, fit.measures = "default", argsLRT = list(), ...) { #TODO: check GLIST structure for multilevel (with single and multiple groups) #TODO: compatibility with auxiliary(), runMI(), parcelAllocation(), permuteMeasEq() #TODO: develop automated anchorSelection() and measEq.partial() #TODO: if (inherits(configural.model, "lavaan.measEq")) {continue sequence}? ## This example might help: https://groups.google.com/d/msg/lavaan/LvALeUpJBDg/2zD1CoikAQAJ #TODO: add argument to accept measEq.partial output, to continue sequence (or make and update() method?) if (is.character(group.partial)) { if ((group.partial == "")[1L] && length(group.partial) == 1L) { group.partial <- data.frame(stringsAsFactors = FALSE, lhs = character(0), op = character(0), rhs = character(0)) } else { group.partial <- lavaan::lavParseModelString(group.partial, as.data.frame. = TRUE, warn = warn, debug = debug) } } #TODO: else {extract information from a measEq.partial object} if (is.character(long.partial)) { if ((long.partial == "")[1L] && length(long.partial) == 1L) { long.partial <- data.frame(stringsAsFactors = FALSE, lhs = character(0), op = character(0), rhs = character(0)) } else { long.partial <- lavaan::lavParseModelString(long.partial, as.data.frame. = TRUE, warn = warn, debug = debug) } } #TODO: else {extract information from a measEq.partial object} ## pass arguments to measEq.syntax(), which performs checks } ## ----------------- ## Class and Methods ## ----------------- ##' Class for Representing a Measurement-Equivalence Model ##' ##' This class of object stores information used to automatically generate ##' lavaan model syntax to represent user-specified levels of measurement ##' equivalence/invariance across groups and/or repeated measures. See ##' [measEq.syntax()] for details. ##' ##' ##' @name measEq.syntax-class ##' @aliases measEq.syntax-class show,measEq.syntax-method ##' summary,measEq.syntax-method as.character,measEq.syntax-method ##' update,measEq.syntax-method ##' @docType class ##' ##' @slot package `character` indicating the software package used to ##' represent the model. Currently, only `"lavaan"` is available, which ##' uses the LISREL representation (see [lavaan::lavOptions()]). ##' In the future, `"OpenMx"` may become available, using RAM ##' representation. ##' @slot model.type `character`. Currently, only "cfa" is available. ##' Future versions may allow for MIMIC / RFA models, where invariance can be ##' tested across levels of exogenous variables explicitly included as ##' predictors of indicators, controlling for their effects on (or correlation ##' with) the common factors. ##' @slot call The function call as returned by `match.call()`, with ##' some arguments updated if necessary for logical consistency. ##' @slot meanstructure `logical` indicating whether a mean structure is ##' included in the model. ##' @slot numeric `character` vector naming `numeric` manifest indicators. ##' @slot ordered `character` vector naming `ordered` indicators. ##' @slot parameterization `character`. See [lavaan::lavOptions()]. ##' @slot specify `list` of parameter matrices, similar in form to the ##' output of `lavInspect(fit, "free")`. These matrices ##' are `logical`, indicating whether each parameter should be specified ##' in the model syntax. ##' @slot values `list` of parameter matrices, similar in form to the ##' output of `lavInspect(fit, "free")`. These matrices ##' are `numeric`, indicating whether each parameter should be freely ##' estimated (indicated by `NA`) or fixed to a particular value. ##' @slot labels `list` of parameter matrices, similar in form to the ##' output of `lavInspect(fit, "free")`. These matrices ##' contain `character` labels used to constrain parameters to equality. ##' @slot constraints `character` vector containing additional equality ##' constraints used to identify the model when `ID.fac = "fx"`. ##' @slot ngroups `integer` indicating the number of groups. ##' ##' @param x,object an object of class `measEq.syntax` ##' @param package `character` indicating the package for which the model ##' syntax should be generated. Currently, only `"lavaan"` and ##' `"mplus"` are supported. ##' @param params `character` vector indicating which type(s) of parameter ##' to print syntax for. Must match a type that can be passed to ##' `group.equal` or `long.equal`, but `"residual.covariances"` ##' and `"lv.covariances"` will be silently ignored. Instead, requesting ##' `"residuals"` or `"lv.variances"` will return covariances along ##' with variances. By default (`NULL`), all types are printed. ##' @param single `logical` indicating whether to concatenate lavaan ##' [lavaan::model.syntax()] into a single `character` string. ##' Setting `FALSE` will return a vector of strings, which may be ##' convenient (or even necessary to prevent an error) in ##' models with long variable names, many variables, or many groups. ##' @param groups.as.blocks `logical` indicating whether to write lavaan ##' [lavaan::model.syntax()] using vectors of labels and values ##' for multiple groups (the default: `FALSE`), or whether to write ##' a separate "block" of syntax per group. The block structure could allow ##' users to apply the generated multigroup syntax (after some editing) to ##' test invariance across levels in a multilevel SEM (see final example on ##' [measEq.syntax()] help page). ##' @param verbose `logical` indicating whether to print a summary to the ##' screen (default). If `FALSE`, only a pattern matrix is returned. ##' @param ... Additional arguments to the `call`, or arguments with ##' changed values. ##' @param evaluate If `TRUE`, evaluate the new `call`; otherwise, ##' return the new `call`. ##' @param change.syntax [lavaan::model.syntax()] specifying ##' labels or fixed/free values of parameters in `object`. ##' These provide some flexibility to customize ##' existing parameters without having to copy/paste the output of ##' `as.character(object)` into an R script. For example, ##' `group.partial` will free a parameter across all groups, but ##' `update` allows users to free the parameter in just one group ##' while maintaining equality constraints among other groups. ##' ##' @return ##' \item{summary}{`signature(object = "measEq.syntax", verbose = TRUE)`: ##' A `character` matrix indicating the pattern of `numeric`, ##' `ordered`, or latent indicators loading on common factors. ##' By default (`verbose = TRUE`), `summary` also prints descriptive ##' details about the model, including the numbers of indicators and factors, ##' and which parameters are constrained to equality.} ##' \item{show}{`signature(object = "measEq.syntax")`: Prints a message ##' about how to use the `object` for model fitting. Invisibly ##' returns the `object`.} ##' \item{update}{`signature(object = "measEq.syntax", ..., ##' evaluate = TRUE, change.syntax = NULL)`: Creates a new ##' `object` with updated arguments in `...`, or updated ##' parameter labels or fixed/free specifications in `object`.} ##' \item{as.character}{`signature(x = "measEq.syntax", package = "lavaan")`: ##' Converts the `measEq.syntax` object to model syntax that can be ##' copy/pasted or written to a syntax file to be edited before analysis, ##' or simply passed to [lavaan::lavaan()] to fit the model to ##' data. Generated M*plus* syntax could also be utilized using the ##' \pkg{MplusAuthomation} package.} ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @examples ##' ## See ?measEq.syntax help page for examples using lavaan ##' ## ## Here, we illustrate how measEq.syntax() objects can be used in ## ## tandem with MplusAutomation. ## ## \donttest{ ## ## borrow example data from Mplus user guide ## myData <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.16.dat") ## names(myData) <- c("u1","u2","u3","u4","u5","u6","x1","x2","x3","g") ## bin.mod <- ' ## FU1 =~ u1 + u2 + u3 ## FU2 =~ u4 + u5 + u6 ## ' ## ## pretend the 2 factors actually measure the same factor (FU) twice ## longFacNames <- list(FU = c("FU1","FU2")) ## syntax.scalar <- measEq.syntax(configural.model = bin.mod, ## data = myData, ordered = paste0("u", 1:6), ## parameterization = "theta", ## ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ## group = "g", longFacNames = longFacNames, ## group.equal = c("thresholds","loadings","intercepts"), ## long.equal = c("thresholds","loadings","intercepts")) ## if(requireNamespace("MplusAutomation")){ ## library(MplusAutomation) ## mpInp <- mplusObject(rdata = myData, TITLE = "Scalar Invariance", ## VARIABLE = "GROUPING = g (1=g1 2=g2);", ## usevariables = c(paste0("u", 1:6), "g"), ## ANALYSIS = "ESTIMATOR = WLSMV;", ## ## model specification from measEq.syntax(): ## MODEL = as.character(syntax.scalar, package = "mplus")) ## ## add details for Mplus script: ## mpInp <- update(mpInp, ANALYSIS = ~ . + "PARAMETERIZATION = THETA;", ## VARIABLE = ~ . + "CATEGORICAL = u1 u2 u3 u4 u5 u6;") ## ## fit model ## mpOut <- mplusModeler(mpInp, modelout = "scalar.inp", run = 1L) ## } ## } #TODO: add configural and DIFFTEST example ##' setClass("measEq.syntax", slots = c(package = "character", # lavaan, OpenMx in the future? model.type = "character", # cfa, extend to mimic/rfa? call = "call", meanstructure = "logical", numeric = "character", ordered = "character", parameterization = "character", specify = "list", values = "list", labels = "list", constraints = "character", updates = "list", # 2 data.frames: labels and values ngroups = "integer")) ##' @rdname measEq.syntax-class ##' @aliases as.character,measEq.syntax-method ##' @export setMethod("as.character", "measEq.syntax", function(x, package = "lavaan", params = NULL, single = TRUE, groups.as.blocks = FALSE) { package <- tolower(package)[1] if (package == "mplus") { LL <- x@specify[[1]]$lambda nn <- c(rownames(LL), colnames(LL)) over8 <- nchar(nn) > 8L if (any(over8)) warning('Mplus only allows variable names to have 8 ', 'characters. The following variable names in ', 'your model exceed 8 characters:\n', paste(nn[over8], collapse = ", "), '\n', 'Consider shortening variable names before ', 'printing an Mplus MODEL statement.') ## print everything leading up to the MODEL command script <- c("MODEL:\n") if (length(x@ordered)) { script <- c(paste0("!Make sure your VARIABLE command indicates the ", "following variables as CATEGORICAL:\n!", paste(x@ordered, collapse = ", "), '\n'), script) } if (x@ngroups > 1L) { script <- c(script, "!This is the first group's MODEL.\n!Group 2's MODEL", "!will be labeled as 'g2', and so on for any other groups.\n") } script <- c(script, write.mplus.syntax(object = x, group = 1L, params = params)) if (x@ngroups > 1L) for (g in 2:x@ngroups) { script <- c(script, paste0("\nMODEL g", g, ":\n"), write.mplus.syntax(object = x, group = g, params = params)) } return(paste(script, collapse = "\n")) # always return a single string } else if (package == "lavaan") { script <- character(0) pmatList <- c("lambda","tau","nu","delta","theta","alpha","psi") names(pmatList) <- c("loadings","thresholds","intercepts","scales", "residuals","means","lv.variances") ## selected parameter types? if (!is.null(params)) { requested <- intersect(names(pmatList), params) if (!length(requested)) stop('invalid choice: params = c("', paste(params, collapse = '", "'), '")\n', 'Valid choices include: ', paste(names(pmatList), collapse = ", ")) pmatList <- pmatList[requested] } if (groups.as.blocks) { ## loop over groups for (gg in 1:x@ngroups) { script <- c(script, paste("group:", gg, "\n", collapse = "")) ## loop over pmats for (pm in pmatList) { if (!pm %in% names(x@specify[[gg]])) next if (pm == "lambda" && "beta" %in% names(x@specify[[gg]])) { ## add higher-order loadings to lambda matrix specify <- list(rbind(x@specify[[gg]]$lambda, x@specify[[gg]]$beta)) value <- list(rbind(x@values[[gg]]$lambda, x@values[[gg]]$beta)) label <- list(rbind(x@labels[[gg]]$lambda, x@labels[[gg]]$beta)) } else { specify <- list(x@specify[[gg]][[pm]]) value <- list(x@values[[gg]][[pm]]) label <- list(x@labels[[gg]][[pm]]) } script <- c(script, write.lavaan.syntax(pmat = pm, specify = specify, value = value, label = label)) } # end pm } # end gg } else { ## the usual multigroup lavaan syntax: ## loop over pmats, send all groups together for (pm in pmatList) { if (!pm %in% names(x@specify[[1]])) next if (pm == "lambda" && "beta" %in% names(x@specify[[1]])) { ## add higher-order loadings to lambda matrix specify.l <- lapply(x@specify, "[[", i = "lambda") value.l <- lapply(x@values , "[[", i = "lambda") label.l <- lapply(x@labels , "[[", i = "lambda") specify.b <- lapply(x@specify, "[[", i = "beta") value.b <- lapply(x@values , "[[", i = "beta") label.b <- lapply(x@labels , "[[", i = "beta") specify <- mapply(rbind, specify.l, specify.b, SIMPLIFY = FALSE) value <- mapply(rbind, value.l , value.b , SIMPLIFY = FALSE) label <- mapply(rbind, label.l , label.b , SIMPLIFY = FALSE) } else { specify <- lapply(x@specify, "[[", i = pm) value <- lapply(x@values, "[[", i = pm) label <- lapply(x@labels, "[[", i = pm) } script <- c(script, write.lavaan.syntax(pmat = pm, specify = specify, value = value, label = label)) } } if (length(x@constraints)) script <- c(script, "## MODEL CONSTRAINTS:\n", x@constraints, "") } #TODO: else if (package == "openmx") # concatenate matrices for RAM specification ## convert GLIST objects to a character string if (single) return(paste(script, collapse = "\n")) script }) ##' @rdname measEq.syntax-class ##' @aliases show,measEq.syntax-method ##' @export setMethod("show", "measEq.syntax", function(object) { cat('This object contains information for specifying a CFA using lavaan', 'model syntax.\nTo print the syntax (to copy/paste it into an R script),', 'use the as.character() method:\n\n\tcat(as.character(object))\n\nTo fit', 'this model to data, save the syntax to an object and pass it to lavaan:', '\n\n\tmodel <- as.character(object)\n\tfit <- lavaan(model, ...)', '\n\nTo view some key features of the model use: \n\n\tsummary(object)') invisible(object) }) ##' @rdname measEq.syntax-class ##' @aliases summary,measEq.syntax-method ##' @export setMethod("summary", "measEq.syntax", function(object, verbose = TRUE) { nG <- object@ngroups nOrd <- length(object@ordered) higher <- !is.null(object@specify[[1]]$beta) ## create pattern matrix lambda <- object@specify[[1]]$lambda lambda[!lambda] <- "" for (RR in 1:nrow(lambda)) { if (rownames(lambda)[RR] %in% object@ordered) { lambda[RR, object@specify[[1]]$lambda[RR, ] ] <- "ord" } else lambda[RR, object@specify[[1]]$lambda[RR, ] ] <- "num" } if (higher) { beta <- object@specify[[1]]$beta beta[!beta] <- "" for (RR in 1:nrow(beta)) { beta[RR, object@specify[[1]]$beta[RR, ] ] <- "lat" } rownames(beta) <- paste("**", rownames(beta), "**") lambda <- rbind(lambda, beta) } if (!verbose) return(lambda) ## Basics: number of groups, factors, and indicators (higher order?); ID.fac nHigher <- if (higher) sum(apply(object@specify[[1]]$beta, 2, any)) else 0L if (object@call$ID.fac == "ul" && !object@meanstructure) { ID.fac.text <- 'first indicator`s factor loading was fixed to 1.' } else if (object@call$ID.fac == "ul" && object@meanstructure) { ID.fac.text <- paste('first indicator`s intercept and factor loading were', 'fixed to 0 and 1, respectively.') } else if (object@call$ID.fac == "uv" && !object@meanstructure) { ID.fac.text <- paste('factor variances were fixed to 1, unless equality', 'constraints on factor loadings allow them to be freed.') } else if (object@call$ID.fac == "uv" && object@meanstructure) { ID.fac.text <- paste('factor means and variances were fixed to 0 and 1,', 'respectively, unless equality constraints on', 'measurement parameters allow them to be freed.') } else if (object@call$ID.fac == "fx") { ID.fac.text <- paste('factor loadings were constrained to average 1', if (object@meanstructure) 'and intercepts were constrained to average 0', 'within each factor. In models with partial', 'invariance, only the factor loadings', if (object@meanstructure) 'and intercepts', 'that were constrained to equality across ALL groups', 'and repeated measures (when applicable) are used to', 'identify the common-factor distribution.') } cat('This lavaan model syntax specifies a CFA with ', nrow(object@specify[[1]]$lambda), ' manifest indicators ', if (nOrd == 1L) { paste0('(', nOrd, ' of which is ordinal) ') } else if (nOrd > 1L) { paste0('(', nOrd, ' of which are ordinal) ') }, 'of ', ncol(object@specify[[1]]$lambda), ' common factor(s)', if (nHigher == 1L) { paste(',', nHigher, 'of which is a higher-order factor. ') } else if (nHigher > 1L) { paste(',', nHigher, 'of which are higher-order factors. ') } else '.\n\n', 'To identify the ', if (object@meanstructure) 'location and ', 'scale of each common factor, the ', ID.fac.text, "\n\n", sep = '') ## if (ordered) ID.cat and parameterization if (nOrd) { if (object@call$ID.cat == "wu") { ID.cat.author <- 'recommended by Wu & Estabrook (2016). ' ID.cat.DOI <- 'https://doi.org/10.1007/s11336-016-9506-0 \n\n' } else if (object@call$ID.cat == "millsap") { ID.cat.author <- 'recommended by Millsap & Tein (2004). ' } else if (object@call$ID.cat == "mplus") { ID.cat.author <- 'used by default in the Mplus (and lavaan) software. ' } else if (object@call$ID.cat == "lisrel") { ID.cat.author <- 'used by default in the LISREL software. ' } if (object@call$ID.cat != "wu") ID.cat.DOI <- 'http://dx.doi.org/10.1207/S15327906MBR3903_4 \n\n' cat('The location and scale of each latent item-response underlying ', nOrd, ' ordinal indicators were identified using the "', object@parameterization, '" parameterization, and the identification constraints ', ID.cat.author, 'For details, read:\n\n\t', ID.cat.DOI, sep = '') } ## number of occassions per longitudinal construct if (length(object@call$longFacNames)) { cat('The following factors were measured on multiple occasions:\n') for (f in names(object@call$longFacNames)) { cat('\t"', f, '" was measured on ', length(object@call$longFacNames[[f]]), ' occasions\n', sep = '') } cat('\n') } ## print pattern matrix cat('Pattern matrix indicating num(eric), ord(ered), and lat(ent)', 'indicators per factor:\n\n') print(lambda, quote = FALSE) cat('\n') ## without any constraints, call it the configural model no.group.equal <- length(object@call$group.equal) == 1L && object@call$group.equal == "" no.long.equal <- length(object@call$long.equal) == 1L && object@call$long.equal == "" if (no.group.equal && no.long.equal) { cat('\nThis model hypothesizes only configural invariance.\n\n') ## return pattern matrix return(invisible(lambda)) } ## otherwise, print the constraints & exceptions ## constrained parameters across groups (+ partial exceptions) if (nG > 1L) { if (no.group.equal) { cat('No parameters were constrained to equality across groups.\n') } else { cat('The following types of parameter were constrained to', 'equality across groups:\n\n') for (i in object@call$group.equal) { group.partial <- object@call$group.partial ## first, check for exceptions if (i == "loadings") { man.ind <- group.partial$rhs %in% rownames(object@specify[[1]]$lambda) group.partial <- group.partial[group.partial$op == "=~" & man.ind, ] } else if (i == "regressions") { lat.ind <- group.partial$rhs %in% colnames(object@specify[[1]]$lambda) group.partial <- group.partial[group.partial$op == "=~" & lat.ind, ] } else if (i == "thresholds") { man.ind <- group.partial$lhs %in% rownames(object@specify[[1]]$lambda) group.partial <- group.partial[group.partial$op == "|" & man.ind, ] } else if (i == "residuals") { man.ind <- group.partial$rhs %in% rownames(object@specify[[1]]$lambda) same.ind <- group.partial$rhs == group.partial$lhs group.partial <- group.partial[group.partial$op == "~~" & man.ind & same.ind, ] } else if (i == "residual.covariances") { man.ind <- group.partial$rhs %in% rownames(object@specify[[1]]$lambda) same.ind <- group.partial$rhs == group.partial$lhs group.partial <- group.partial[group.partial$op == "~~" & man.ind & !same.ind, ] } else if (i == "lv.variances") { lat <- group.partial$rhs %in% colnames(object@specify[[1]]$lambda) same <- group.partial$rhs == group.partial$lhs group.partial <- group.partial[group.partial$op == "~~" & lat & same, ] } else if (i == "lv.covariances") { lat <- group.partial$rhs %in% colnames(object@specify[[1]]$lambda) same <- group.partial$rhs == group.partial$lhs group.partial <- group.partial[group.partial$op == "~~" & lat & !same, ] } else if (i == "intercepts") { man.ind <- group.partial$lhs %in% rownames(object@specify[[1]]$lambda) group.partial <- group.partial[group.partial$op == "~1" & man.ind, ] } else if (i == "means") { lat <- group.partial$lhs %in% colnames(object@specify[[1]]$lambda) group.partial <- group.partial[group.partial$op == "~1" & lat, ] } ## then print a message cat('\t', i, if (nrow(group.partial)) ', with the exception of:\n', '\n', sep = '') if (nrow(group.partial)) { rownames(group.partial) <- paste(" row-", rownames(group.partial), ": ", sep = "") print(group.partial) cat('\n') } } } cat('\n') } ## constrained parameters across repeated measures (+ partial exceptions) if (length(object@call$longFacNames)) { if (no.long.equal) { cat('No parameters were constrained to equality across repeated measures:\n') } else { cat('The following types of parameter were constrained to equality', 'across repeated measures:\n\n') for (i in object@call$long.equal) { long.partial <- object@call$long.partial ## first, check for exceptions if (i == "loadings") { man.ind <- long.partial$rhs %in% names(object@call$longIndNames) long.partial <- long.partial[long.partial$op == "=~" & man.ind, ] } else if (i == "regressions") { lat.ind <- long.partial$rhs %in% names(object@call$longFacNames) long.partial <- long.partial[long.partial$op == "=~" & lat.ind, ] } else if (i == "thresholds") { man.ind <- long.partial$lhs %in% names(object@call$longIndNames) long.partial <- long.partial[long.partial$op == "|" & man.ind, ] } else if (i == "residuals") { man.ind <- long.partial$rhs %in% names(object@call$longIndNames) same.ind <- long.partial$rhs == long.partial$lhs long.partial <- long.partial[long.partial$op == "~~" & man.ind & same.ind, ] } else if (i == "lv.variances") { lat <- long.partial$rhs %in% names(object@call$longFacNames) same <- long.partial$rhs == long.partial$lhs long.partial <- long.partial[long.partial$op == "~~" & lat & same, ] } else if (i == "intercepts") { man.ind <- long.partial$lhs %in% names(object@call$longIndNames) long.partial <- long.partial[long.partial$op == "~1" & man.ind, ] } else if (i == "means") { lat <- long.partial$lhs %in% names(object@call$longFacNames) long.partial <- long.partial[long.partial$op == "~1" & lat, ] } ## then print a message cat('\t', i, if (nrow(long.partial)) ', with the exception of:\n', '\n', sep = '') if (nrow(long.partial)) { rownames(long.partial) <- paste(" row-", rownames(long.partial), ": ", sep = "") print(long.partial) cat('\n') } } } cat('\n') } ## return pattern matrix invisible(lambda) }) updateMeasEqSyntax <- function(object, ..., evaluate = TRUE, change.syntax = NULL) { # data.frame(stringsAsFactors = FALSE, extras = c(TRUE, FALSE), # override = c(TRUE, TRUE, FALSE, FALSE), # eval = c(TRUE, TRUE, TRUE, TRUE, # FALSE, FALSE, FALSE, FALSE), # TODO = c("extras; eval; transfer, augment, and apply @updates", # "apply and augment @updates", # "extras; eval; transfer and apply @updates", "return object", # "nothing, can't add to call", "nothing, can't add to call", # "extras, return call", "return call")) -> foo # foo[order(foo$extras), ] # extras override eval TODO # 1 FALSE TRUE TRUE apply and augment @updates # 2 FALSE FALSE TRUE return object * # 3 FALSE TRUE FALSE nothing, can't add to call * # 4 FALSE FALSE FALSE return call * # 5 TRUE TRUE TRUE extras; eval; transfer, augment, and apply @updates # 6 TRUE FALSE TRUE extras, eval, transfer @updates # 7 TRUE TRUE FALSE nothing, can't add to call * # 8 TRUE FALSE FALSE extras, return call * #extras <- match.call(expand.dots = FALSE)$... extras <- list(...) custom <- !is.null(change.syntax) ## regardless of customization/evaluation, extras can be added to call first if (length(extras)) { ## prep 5:8 call <- object@call existing <- !is.na(match(names(extras), names(call))) for (a in names(extras)[existing]) call[[a]] <- extras[[a]] if (any(!existing)) { call <- c(as.list(call), extras[!existing]) call <- as.call(call) } if (!evaluate) { if (custom) warning('cannot apply "change.syntax" ', 'argument when evaluate=FALSE.') ## finish 7:8 return(call) } } else if (!evaluate) { if (custom) warning('cannot apply "change.syntax" ', 'argument when evaluate=FALSE.') ## finish 3:4 return(object@call) } else if (!custom) { ## finish 2 return(object) } # extras override eval TODO # 1 FALSE TRUE TRUE apply and augment @updates # 5 TRUE TRUE TRUE eval; transfer, augment, and apply @updates # 6 TRUE FALSE TRUE eval; transfer and apply @updates if (length(extras)) { ## prep 5:6 out <- eval(call, parent.frame()) if (nrow(object@updates$values)) out@updates$values <- object@updates$values if (nrow(object@updates$labels)) out@updates$labels <- object@updates$labels } else out <- object # "prep" 1 # extras override eval TODO # 1 FALSE TRUE TRUE apply and augment @updates # 5 TRUE TRUE TRUE augment, and apply @updates # 6 TRUE FALSE TRUE apply @updates ## check before augmenting to prep 1 and 5 if (!is.null(change.syntax)) { stopifnot(is.character(change.syntax)) ## convert syntax to data.frame of updates to make UPDATES <- char2update(object, change.syntax, return.object = FALSE) out@updates$values <- rbind(out@updates$values, UPDATES$values) out@updates$labels <- rbind(out@updates$labels, UPDATES$labels) } ## nothing left to do but apply @updates ## loop over any values/labels (now stored) to finish 1 and 5:6 if (nrow(out@updates$values)) for (RR in 1:nrow(out@updates$values)) { valueArgs <- c(list(object = out, slotName = "values"), as.list(out@updates$values[RR, ])) BB <- out@updates$values$group[RR] matName <- out@updates$values$matName[RR] out@values[[BB]][[matName]] <- do.call(override, valueArgs) } if (nrow(out@updates$labels)) for (RR in 1:nrow(out@updates$labels)) { labelArgs <- c(list(object = out, slotName = "labels"), as.list(out@updates$labels[RR, ])) BB <- out@updates$labels$group[RR] matName <- out@updates$labels$matName[RR] out@labels[[BB]][[matName]] <- do.call(override, labelArgs) } ## user-specified parameters to override MUST include: ## - group (eventually block), defaults to 1 (convenient for longitudinal CFA) ## - matName (e.g., lambda) ## - row and col (integer or character indices) ## - replacement (NA or numeric for values, character for labels) out } ##' @rdname measEq.syntax-class ##' @aliases update,measEq.syntax-method ##' @importFrom stats update ##' @export setMethod("update", "measEq.syntax", updateMeasEqSyntax) ## ----------------------- ## Syntax-Writing Function ## ----------------------- ##' Syntax for measurement equivalence ##' ##' Automatically generates `lavaan` model syntax to specify a confirmatory ##' factor analysis (CFA) model with equality constraints imposed on ##' user-specified measurement (or structural) parameters. Optionally returns ##' the fitted model (if data are provided) representing some chosen level of ##' measurement equivalence/invariance across groups and/or repeated measures. ##' ##' This function is a pedagogical and analytical tool to generate model syntax ##' representing some level of measurement equivalence/invariance across any ##' combination of multiple groups and/or repeated measures. Support is provided ##' for confirmatory factor analysis (CFA) models with simple or complex ##' structure (i.e., cross-loadings and correlated residuals are allowed). ##' For any complexities that exceed the limits of automation, this function is ##' intended to still be useful by providing a means to generate syntax that ##' users can easily edit to accommodate their unique situations. ##' ##' Limited support is provided for bifactor models and higher-order constructs. ##' Because bifactor models have cross-loadings by definition, the option ##' `ID.fac = "effects.code"` is unavailable. `ID.fac = "UV"` is ##' recommended for bifactor models, but `ID.fac = "UL"` is available on ##' the condition that each factor has a unique first indicator in the ##' `configural.model`. In order to maintain generality, higher-order ##' factors may include a mix of manifest and latent indicators, but they must ##' therefore require `ID.fac = "UL"` to avoid complications with ##' differentiating lower-order vs. higher-order (or mixed-level) factors. ##' The keyword `"loadings"` in `group.equal` or `long.equal` ##' constrains factor loadings of all manifest indicators (including loadings on ##' higher-order factors that also have latent indicators), whereas the keyword ##' `"regressions"` constrains factor loadings of latent indicators. Users ##' can edit the model syntax manually to adjust constraints as necessary, or ##' clever use of the `group.partial` or `long.partial` arguments ##' could make it possible for users to still automated their model syntax. ##' The keyword `"intercepts"` constrains the intercepts of all manifest ##' indicators, and the keyword `"means"` constrains intercepts and means ##' of all latent common factors, regardless of whether they are latent ##' indicators of higher-order factors. To test equivalence of lower-order and ##' higher-order intercepts/means in separate steps, the user can either ##' manually edit their generated syntax or conscientiously exploit the ##' `group.partial` or `long.partial` arguments as necessary. ##' ##' **`ID.fac`:** If the `configural.model` fixes any (e.g., ##' the first) factor loadings, the generated syntax object will retain those ##' fixed values. This allows the user to retain additional constraints that ##' might be necessary (e.g., if there are only 1 or 2 indicators). Some methods ##' must be used in conjunction with other settings: ##' \itemize{ ##' \item `ID.cat = "Millsap"` requires `ID.fac = "UL"` and ##' `parameterization = "theta"`. ##' \item `ID.cat = "LISREL"` requires `parameterization = "theta"`. ##' \item `ID.fac = "effects.code"` is unavailable when there are any ##' cross-loadings. ##' } ##' ##' **`ID.cat`:** Wu & Estabrook (2016) recommended constraining ##' thresholds to equality first, and doing so should allow releasing any ##' identification constraints no longer needed. For each `ordered` ##' indicator, constraining one threshold to equality will allow the item's ##' intercepts to be estimated in all but the first group or repeated measure. ##' Constraining a second threshold (if applicable) will allow the item's ##' (residual) variance to be estimated in all but the first group or repeated ##' measure. For binary data, there is no independent test of threshold, ##' intercept, or residual-variance equality. Equivalence of thresholds must ##' also be assumed for three-category indicators. These guidelines provide the ##' least restrictive assumptions and tests, and are therefore the default. ##' ##' The default setting in M*plus* is similar to Wu & Estabrook (2016), ##' except that intercepts are always constrained to zero (so they are assumed ##' to be invariant without testing them). Millsap & Tein (2004) recommended ##' `parameterization = "theta"` and identified an item's residual variance ##' in all but the first group (or occasion; Liu et al., 2017) by constraining ##' its intercept to zero and one of its thresholds to equality. A second ##' threshold for the reference indicator (so `ID.fac = "UL"`) is used to ##' identify the common-factor means in all but the first group/occasion. The ##' LISREL software fixes the first threshold to zero and (if applicable) the ##' second threshold to 1, and assumes any remaining thresholds to be equal ##' across groups / repeated measures; thus, the intercepts are always ##' identified, and residual variances (`parameterization = "theta"`) are ##' identified except for binary data, when they are all fixed to one. ##' ##' **Repeated Measures:** If each repeatedly measured factor is measured ##' by the same indicators (specified in the same order in the ##' `configural.model`) on each occasion, without any cross-loadings, the ##' user can let `longIndNames` be automatically generated. Generic names ##' for the repeatedly measured indicators are created using the name of the ##' repeatedly measured factors (i.e., `names(longFacNames)`) and the ##' number of indicators. So the repeatedly measured first indicator ##' (`"ind"`) of a longitudinal construct called "factor" would be ##' generated as `"._factor_ind.1"`. ##' ##' The same types of parameter can be specified for `long.equal` as for ##' `group.equal` (see [lavaan::lavOptions()] for a list), except ##' for `"residual.covariances"` or `"lv.covariances"`. Instead, users ##' can constrain *auto*covariances using keywords `"resid.autocov"` ##' or `"lv.autocov"`. Note that `group.equal = "lv.covariances"` or ##' `group.equal = "residual.covariances"` will constrain any ##' autocovariances across groups, along with any other covariances the user ##' specified in the `configural.model`. Note also that autocovariances ##' cannot be specified as exceptions in `long.partial`, so anything more ##' complex than the `auto` argument automatically provides should instead ##' be manually specified in the `configural.model`. ##' ##' When users set `orthogonal=TRUE` in the `configural.model` (e.g., ##' in bifactor models of repeatedly measured constructs), autocovariances of ##' each repeatedly measured factor will still be freely estimated in the ##' generated syntax. ##' ##' **Missing Data:** If users wish to utilize the [auxiliary()] ##' function to automatically include auxiliary variables in conjunction with ##' `missing = "FIML"`, they should first generate the hypothesized-model ##' syntax, then submit that syntax as the model to `auxiliary()`. ##' If users utilized [lavaan.mi::lavaan.mi()] to fit their `configural.model` ##' to multiply imputed data, that model can also be passed to the ##' `configural.model` argument, and if `return.fit = TRUE`, the ##' generated model will be fitted to the multiple imputations. ##' ##' @importFrom lavaan lavInspect lavNames parTable cfa ##' ##' @param configural.model A model with no measurement-invariance constraints ##' (i.e., representing only configural invariance), unless required for model ##' identification. `configural.model` can be either: ##' \itemize{ ##' \item [lavaan::model.syntax()] or a [lavaan::parTable()] specifying the ##' configural model. Using this option, the user can also provide ##' either raw `data` or summary statistics via `sample.cov` ##' and (optionally) `sample.mean`. See argument descriptions in ##' [lavaan::lavaan()]. In order to include thresholds in ##' the generated syntax, either users must provide raw `data`, ##' or the `configural.model` syntax must specify all thresholds ##' (see first example). If raw `data` are not provided, the ##' number of blocks (groups, levels, or combination) must be ##' indicated using an arbitrary `sample.nobs` argument (e.g., ##' 3 groups could be specified using `sample.nobs=rep(1, 3)`). ##' \item a fitted [lavaan::lavaan-class] model (e.g., as returned by ##' [lavaan::cfa()]) estimating the configural model ##' } ##' Note that the specified or fitted model must not contain any latent ##' structural parameters (i.e., it must be a CFA model), unless they are ##' higher-order constructs with latent indicators (i.e., a second-order CFA). ##' ##' @param ... Additional arguments (e.g., `data`, `ordered`, or ##' `parameterization`) passed to the [lavaan::lavaan()] ##' function. See also [lavaan::lavOptions()]. ##' ##' @param ID.fac `character`. The method for identifying common-factor ##' variances and (if `meanstructure = TRUE`) means. Three methods are ##' available, which go by different names in the literature: ##' \itemize{ ##' \item Standardize the common factor (mean = 0, *SD* = 1) by ##' specifying any of: `"std.lv"`, `"unit.variance"`, ##' `"UV"`, `"fixed.factor"`, ##' `"fixed-factor"` ##' \item Choose a reference indicator by specifying any of: ##' `"auto.fix.first"`, `"unit.loading"`, `"UL"`, ##' `"marker"`, `"ref"`, `"ref.indicator"`, ##' `"reference.indicator"`, `"reference-indicator"`, ##' `"marker.variable"`, `"marker-variable"` ##' \item Apply effects-code constraints to loadings and intercepts by ##' specifying any of: `"FX"`, `"EC"`, `"effects"`, ##' `"effects.coding"`, `"effects-coding"`, ##' `"effects.code"`, `"effects-code"` ##' } ##' See Kloessner & Klopp (2019) for details about all three methods. ##' ##' @param ID.cat `character`. The method for identifying (residual) ##' variances and intercepts of latent item-responses underlying any ##' `ordered` indicators. Four methods are available: ##' \itemize{ ##' \item To follow Wu & Estabrook's (2016) guidelines (default), specify ##' any of: `"Wu.Estabrook.2016"`, `"Wu.2016"`, ##' `"Wu.Estabrook"`, `"Wu"`, `"Wu2016"`. For ##' consistency, specify `ID.fac = "std.lv"`. ##' \item To use the default settings of M*plus* and `lavaan`, ##' specify any of: `"default"`, `"Mplus"`, `"Muthen"`. ##' Details provided in Millsap & Tein (2004). ##' \item To use the constraints recommended by Millsap & Tein (2004; see ##' also Liu et al., 2017, for the longitudinal case) ##' specify any of: `"millsap"`, `"millsap.2004"`, ##' `"millsap.tein.2004"`. For consistency, specify ##' `ID.fac = "marker"` and `parameterization = "theta"`. ##' \item To use the default settings of LISREL, specify `"LISREL"` ##' or `"Joreskog"`. Details provided in Millsap & Tein (2004). ##' For consistency, specify `parameterization = "theta"`. ##' } ##' See **Details** and **References** for more information. ##' ##' @param ID.thr `integer`. Only relevant when ##' `ID.cat = "Millsap.Tein.2004"`. Used to indicate which thresholds ##' should be constrained for identification. The first integer indicates the ##' threshold used for all indicators, the second integer indicates the ##' additional threshold constrained for a reference indicator (ignored if ##' binary). ##' ##' @param group optional `character` indicating the name of a grouping ##' variable. See [lavaan::cfa()]. ##' ##' @param group.equal optional `character` vector indicating type(s) of ##' parameter to equate across groups. Ignored if `is.null(group)`. ##' See [lavaan::lavOptions()]. ##' ##' @param group.partial optional `character` vector or a parameter table ##' indicating exceptions to `group.equal` (see ##' [lavaan::lavOptions()]). Any variables not appearing in the ##' `configural.model` will be ignored, and any parameter constraints ##' needed for identification (e.g., two thresholds per indicator when ##' `ID.cat = "Millsap"`) will be removed. ##' ##' @param longFacNames optional named `list` of `character` vectors, ##' each indicating multiple factors in the model that are actually the same ##' construct measured repeatedly. See **Details** and **Examples**. ##' ##' @param longIndNames optional named `list` of `character` vectors, ##' each indicating multiple indicators in the model that are actually the ##' same indicator measured repeatedly. See **Details** and ##' **Examples**. ##' ##' @param long.equal optional `character` vector indicating type(s) of ##' parameter to equate across repeated measures. Ignored if no factors are ##' indicated as repeatedly measured in `longFacNames`. ##' ##' @param long.partial optional `character` vector or a parameter table ##' indicating exceptions to `long.equal`. Any longitudinal variable ##' names not appearing in `names(longFacNames)` or ##' `names(longIndNames)` will be ignored, and any parameter constraints ##' needed for identification will be removed. ##' ##' @param auto Used to automatically included autocorrelated measurement errors ##' among repeatedly measured indicators in `longIndNames`. Specify a ##' single `integer` to set the maximum order (e.g., `auto = 1L` ##' indicates that an indicator's unique factors should only be correlated ##' between adjacently measured occasions). `auto = TRUE` or `"all"` ##' will specify residual covariances among all possible lags per repeatedly ##' measured indicator in `longIndNames`. ##' ##' @param warn,debug `logical`. Passed to [lavaan::lavaan()] ##' and [lavaan::lavParseModelString()]. ##' See [lavaan::lavOptions()]. ##' ##' @param return.fit `logical` indicating whether the generated syntax ##' should be fitted to the provided `data` (or summary statistics, if ##' provided via `sample.cov`). If `configural.model` is a fitted ##' lavaan model, the generated syntax will be fitted using the `update` ##' method (see [lavaan::lavaan-class]), and \dots will be passed to ##' [lavaan::lavaan()]. If neither data nor a fitted lavaan model ##' were provided, this must be `FALSE`. If `TRUE`, the generated ##' `measEq.syntax` object will be included in the `lavaan` object's ##' `@@external` slot, accessible by `fit@@external$measEq.syntax`. ##' ##' @return By default, an object of class [measEq.syntax-class]. ##' If `return.fit = TRUE`, a fitted [lavaan::lavaan()] ##' model, with the `measEq.syntax` object stored in the ##' `@@external` slot, accessible by `fit@@external$measEq.syntax`. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [compareFit()] ##' ##' @references ##' Kloessner, S., & Klopp, E. (2019). Explaining constraint interaction: How ##' to interpret estimated model parameters under alternative scaling methods. ##' *Structural Equation Modeling, 26*(1), 143--155. ##' \doi{10.1080/10705511.2018.1517356} ##' ##' Liu, Y., Millsap, R. E., West, S. G., Tein, J.-Y., Tanaka, R., & Grimm, ##' K. J. (2017). Testing measurement invariance in longitudinal data with ##' ordered-categorical measures. *Psychological Methods, 22*(3), ##' 486--506. \doi{10.1037/met0000075} ##' ##' Millsap, R. E., & Tein, J.-Y. (2004). Assessing factorial invariance in ##' ordered-categorical measures. *Multivariate Behavioral Research, 39*(3), ##' 479--515. \doi{10.1207/S15327906MBR3903_4} ##' ##' Wu, H., & Estabrook, R. (2016). Identification of confirmatory factor ##' analysis models of different levels of invariance for ordered categorical ##' outcomes. *Psychometrika, 81*(4), 1014--1045. ##' \doi{10.1007/s11336-016-9506-0} ##' ##' @examples ##' mod.cat <- ' FU1 =~ u1 + u2 + u3 + u4 ##' FU2 =~ u5 + u6 + u7 + u8 ' ##' ## the 2 factors are actually the same factor (FU) measured twice ##' longFacNames <- list(FU = c("FU1","FU2")) ##' ##' ## CONFIGURAL model: no constraints across groups or repeated measures ##' syntax.config <- measEq.syntax(configural.model = mod.cat, ##' # NOTE: data provides info about numbers of ##' # groups and thresholds ##' data = datCat, ##' ordered = paste0("u", 1:8), ##' parameterization = "theta", ##' ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ##' group = "g", longFacNames = longFacNames) ##' ## print lavaan syntax to the Console ##' cat(as.character(syntax.config)) ##' ## print a summary of model features ##' summary(syntax.config) ##' ##' ## THRESHOLD invariance: ##' ## only necessary to specify thresholds if you have no data ##' mod.th <- ' ##' u1 | t1 + t2 + t3 + t4 ##' u2 | t1 + t2 + t3 + t4 ##' u3 | t1 + t2 + t3 + t4 ##' u4 | t1 + t2 + t3 + t4 ##' u5 | t1 + t2 + t3 + t4 ##' u6 | t1 + t2 + t3 + t4 ##' u7 | t1 + t2 + t3 + t4 ##' u8 | t1 + t2 + t3 + t4 ##' ' ##' syntax.thresh <- measEq.syntax(configural.model = c(mod.cat, mod.th), ##' # NOTE: data not provided, so syntax must ##' # include thresholds, and number of ##' # groups == 2 is indicated by: ##' sample.nobs = c(1, 1), ##' parameterization = "theta", ##' ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ##' group = "g", group.equal = "thresholds", ##' longFacNames = longFacNames, ##' long.equal = "thresholds") ##' ## notice that constraining 4 thresholds allows intercepts and residual ##' ## variances to be freely estimated in all but the first group & occasion ##' cat(as.character(syntax.thresh)) ##' ## print a summary of model features ##' summary(syntax.thresh) ##' ##' ##' ## Fit a model to the data either in a subsequent step (recommended): ##' mod.config <- as.character(syntax.config) ##' fit.config <- cfa(mod.config, data = datCat, group = "g", ##' ordered = paste0("u", 1:8), parameterization = "theta") ##' ## or in a single step (not generally recommended): ##' fit.thresh <- measEq.syntax(configural.model = mod.cat, data = datCat, ##' ordered = paste0("u", 1:8), ##' parameterization = "theta", ##' ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ##' group = "g", group.equal = "thresholds", ##' longFacNames = longFacNames, ##' long.equal = "thresholds", return.fit = TRUE) ##' ## compare their fit to test threshold invariance ##' anova(fit.config, fit.thresh) ##' ##' ##' ## -------------------------------------------------------- ##' ## RECOMMENDED PRACTICE: fit one invariance model at a time ##' ## -------------------------------------------------------- ##' ##' ## - A downside of setting return.fit=TRUE is that if the model has trouble ##' ## converging, you don't have the opportunity to investigate the syntax, ##' ## or even to know whether an error resulted from the syntax-generator or ##' ## from lavaan itself. ##' ## - A downside of automatically fitting an entire set of invariance models ##' ## (like the old measurementInvariance() function did) is that you might ##' ## end up testing models that shouldn't even be fitted because less ##' ## restrictive models already fail (e.g., don't test full scalar ##' ## invariance if metric invariance fails! Establish partial metric ##' ## invariance first, then test equivalent of intercepts ONLY among the ##' ## indicators that have invariate loadings.) ##' ##' ## The recommended sequence is to (1) generate and save each syntax object, ##' ## (2) print it to the screen to verify you are fitting the model you expect ##' ## to (and potentially learn which identification constraints should be ##' ## released when equality constraints are imposed), and (3) fit that model ##' ## to the data, as you would if you had written the syntax yourself. ##' ##' ## Continuing from the examples above, after establishing invariance of ##' ## thresholds, we proceed to test equivalence of loadings and intercepts ##' ## (metric and scalar invariance, respectively) ##' ## simultaneously across groups and repeated measures. ##' ##' \donttest{ ##' ##' ## metric invariance ##' syntax.metric <- measEq.syntax(configural.model = mod.cat, data = datCat, ##' ordered = paste0("u", 1:8), ##' parameterization = "theta", ##' ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ##' group = "g", longFacNames = longFacNames, ##' group.equal = c("thresholds","loadings"), ##' long.equal = c("thresholds","loadings")) ##' summary(syntax.metric) # summarize model features ##' mod.metric <- as.character(syntax.metric) # save as text ##' cat(mod.metric) # print/view lavaan syntax ##' ## fit model to data ##' fit.metric <- cfa(mod.metric, data = datCat, group = "g", ##' ordered = paste0("u", 1:8), parameterization = "theta") ##' ## test equivalence of loadings, given equivalence of thresholds ##' anova(fit.thresh, fit.metric) ##' ##' ## scalar invariance ##' syntax.scalar <- measEq.syntax(configural.model = mod.cat, data = datCat, ##' ordered = paste0("u", 1:8), ##' parameterization = "theta", ##' ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ##' group = "g", longFacNames = longFacNames, ##' group.equal = c("thresholds","loadings", ##' "intercepts"), ##' long.equal = c("thresholds","loadings", ##' "intercepts")) ##' summary(syntax.scalar) # summarize model features ##' mod.scalar <- as.character(syntax.scalar) # save as text ##' cat(mod.scalar) # print/view lavaan syntax ##' ## fit model to data ##' fit.scalar <- cfa(mod.scalar, data = datCat, group = "g", ##' ordered = paste0("u", 1:8), parameterization = "theta") ##' ## test equivalence of intercepts, given equal thresholds & loadings ##' anova(fit.metric, fit.scalar) ##' ##' ##' ## For a single table with all results, you can pass the models to ##' ## summarize to the compareFit() function ##' Comparisons <- compareFit(fit.config, fit.thresh, fit.metric, fit.scalar) ##' summary(Comparisons) ##' ##' ##' ## ------------------------------------------------------ ##' ## NOT RECOMMENDED: fit several invariance models at once ##' ## ------------------------------------------------------ ##' test.seq <- c("thresholds","loadings","intercepts","means","residuals") ##' meq.list <- list() ##' for (i in 0:length(test.seq)) { ##' if (i == 0L) { ##' meq.label <- "configural" ##' group.equal <- "" ##' long.equal <- "" ##' } else { ##' meq.label <- test.seq[i] ##' group.equal <- test.seq[1:i] ##' long.equal <- test.seq[1:i] ##' } ##' meq.list[[meq.label]] <- measEq.syntax(configural.model = mod.cat, ##' data = datCat, ##' ordered = paste0("u", 1:8), ##' parameterization = "theta", ##' ID.fac = "std.lv", ##' ID.cat = "Wu.Estabrook.2016", ##' group = "g", ##' group.equal = group.equal, ##' longFacNames = longFacNames, ##' long.equal = long.equal, ##' return.fit = TRUE) ##' } ##' ##' evalMeasEq <- compareFit(meq.list) ##' summary(evalMeasEq) ##' ##' ##' ## ----------------- ##' ## Binary indicators ##' ## ----------------- ##' ##' ## borrow example data from Mplus user guide ##' myData <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.16.dat") ##' names(myData) <- c("u1","u2","u3","u4","u5","u6","x1","x2","x3","g") ##' bin.mod <- ' ##' FU1 =~ u1 + u2 + u3 ##' FU2 =~ u4 + u5 + u6 ##' ' ##' ## Must SIMULTANEOUSLY constrain thresholds, loadings, and intercepts ##' test.seq <- list(strong = c("thresholds","loadings","intercepts"), ##' means = "means", ##' strict = "residuals") ##' meq.list <- list() ##' for (i in 0:length(test.seq)) { ##' if (i == 0L) { ##' meq.label <- "configural" ##' group.equal <- "" ##' long.equal <- "" ##' } else { ##' meq.label <- names(test.seq)[i] ##' group.equal <- unlist(test.seq[1:i]) ##' # long.equal <- unlist(test.seq[1:i]) ##' } ##' meq.list[[meq.label]] <- measEq.syntax(configural.model = bin.mod, ##' data = myData, ##' ordered = paste0("u", 1:6), ##' parameterization = "theta", ##' ID.fac = "std.lv", ##' ID.cat = "Wu.Estabrook.2016", ##' group = "g", ##' group.equal = group.equal, ##' #longFacNames = longFacNames, ##' #long.equal = long.equal, ##' return.fit = TRUE) ##' } ##' ##' evalMeasEq <- compareFit(meq.list) ##' summary(evalMeasEq) ##' ##' #TODO: add ternary example? or note to start with EQ thresholds? ##' ##' ## --------------------- ##' ## Multilevel Invariance ##' ## --------------------- ##' ##' ## To test invariance across levels in a MLSEM, specify syntax as though ##' ## you are fitting to 2 groups instead of 2 levels. ##' ##' mlsem <- ' f1 =~ y1 + y2 + y3 ##' f2 =~ y4 + y5 + y6 ' ##' ## metric invariance ##' syntax.metric <- measEq.syntax(configural.model = mlsem, meanstructure = TRUE, ##' ID.fac = "std.lv", sample.nobs = c(1, 1), ##' group = "cluster", group.equal = "loadings") ##' ## by definition, Level-1 means must be zero, so fix them ##' syntax.metric <- update(syntax.metric, ##' change.syntax = paste0("y", 1:6, " ~ c(0, NA)*1")) ##' ## save as a character string ##' mod.metric <- as.character(syntax.metric, groups.as.blocks = TRUE) ##' ## convert from multigroup to multilevel ##' mod.metric <- gsub(pattern = "group:", replacement = "level:", ##' x = mod.metric, fixed = TRUE) ##' ## fit model to data ##' fit.metric <- lavaan(mod.metric, data = Demo.twolevel, cluster = "cluster") ##' summary(fit.metric) ##' } ##' @export measEq.syntax <- function(configural.model, ..., ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ID.thr = c(1L, 2L), group = NULL, group.equal = "", group.partial = "", longFacNames = list(), longIndNames = list(), long.equal = "", long.partial = "", auto = "all", warn = TRUE, debug = FALSE, return.fit = FALSE) { mc <- match.call(expand.dots = TRUE) ## evaluate promises that might change before being evaluated ## (e.g., for-loops or Monte Carlo studies) mc$ID.fac <- eval(ID.fac) mc$ID.cat <- eval(ID.cat) mc$ID.thr <- eval(ID.thr) mc$group <- eval(group) mc$group.equal <- eval(group.equal) mc$group.partial <- eval(group.partial) mc$longFacNames <- eval(longFacNames) mc$longIndNames <- eval(longIndNames) mc$long.equal <- eval(long.equal) mc$long.partial <- eval(long.partial) mc$auto <- eval(auto) ## ------------------------------- ## Preliminary checks on arguments ## ------------------------------- ## check identification arguments ID.fac <- tolower(as.character(ID.fac)[1]) if (ID.fac %in% c("std.lv","unit.variance","uv", "fixed.factor","fixed-factor")) { ID.fac <- "uv" mc$ID.fac <- "uv" } else if (ID.fac %in% c("auto.fix.first","unit.loading","ul","marker","ref", "marker.variable","marker-variable","ref.indicator", "reference.indicator","reference-indicator")) { ID.fac <- "ul" mc$ID.fac <- "ul" } else if (ID.fac %in% c("fx","ec","effects","effects.coding", "effects-coding","effects.code","effects-code")) { ID.fac <- "fx" mc$ID.fac <- "fx" } else stop('Invalid choice for argument: ID.fac = "', ID.fac, '"') ID.cat <- tolower(as.character(ID.cat)[1]) if (ID.cat %in% c("wu.estabrook.2016","wu.2016","wu.estabrook","wu","wu2016")) { ID.cat <- "wu" mc$ID.cat <- "wu" } else if (ID.cat %in% c("millsap","millsap.2004","millsap.tein.2004")) { ID.cat <- "millsap" mc$ID.cat <- "millsap" } else if (ID.cat %in% c("default","mplus","muthen")) { ID.cat <- "mplus" mc$ID.cat <- "mplus" } else if (ID.cat %in% c("joreskog","lisrel")) { ID.cat <- "lisrel" mc$ID.cat <- "lisrel" } else stop('Invalid choice for argument: ID.cat = "', ID.cat, '"') ## pass arguments to lavaan dots <- list(...) dots$debug <- debug dots$warn <- warn dots$group <- group ## check lavaan arguments if (!is.null(dots$model)) stop('A model should be specified only with the ', '"configural.model=" argument, not "model=".') if (is.null(dots$meanstructure)) { constrMeanStr <- c("intercepts","means") %in% c(group.equal, long.equal) if (is.null(dots$data) && is.null(dots$sample.mean) && is.null(dots$sample.th) && !any(constrMeanStr)) { dots$meanstructure <- FALSE mc$meanstructure <- FALSE } else { dots$meanstructure <- TRUE mc$meanstructure <- TRUE } } ## lavaan template from configural model if (inherits(configural.model, c("lavaan","lavaanList"))) { lavTemplate <- configural.model ## check that first loading is not constrained unless ID.fac == "ul" if (ID.fac != "ul" && lavInspect(lavTemplate, "options")$auto.fix.first) { stop('The "configural.model" argument is a lavaan model fitted using ', 'auto.fix.first=TRUE (or std.lv=FALSE), which conflicts with the ', 'requested "ID.fac" method. To generate syntax using the fixed-', 'factor or effects-coding method of identification, set std.lv=TRUE', ' to prevent initial loadings from being fixed to 1 in the syntax.') } ## check that if (!meanstructure), not set TRUE in call if (!is.null(mc$meanstructure)) { if (!lavInspect(lavTemplate, "options")$meanstructure && mc$meanstructure) stop('Request for meanstructure=TRUE requires configural.model to be ', 'fitted with meanstructure=TRUE') } else mc$meanstructure <- lavInspect(lavTemplate, "options")$meanstructure # just in case } else { lavArgs <- dots if (ID.fac != "ul") lavArgs$std.lv <- TRUE lavArgs$model <- configural.model # let lavaan() do its own checks lavArgs$do.fit <- FALSE lavTemplate <- do.call("cfa", lavArgs, envir = getNamespace("lavaan")) mc$meanstructure <- lavInspect(lavTemplate, "options")$meanstructure # just in case mc$configural.model <- lavTemplate } ## warn about regression parameters if (any(parTable(lavTemplate)$op == "~")) warning('Regression operator (~) detected. measEq.syntax() was designed ', 'only for multigroup CFA models. Regression operator (~) could be ', 'used to define a higher-order factor (although the =~ operator ', 'is easier), but structural regressions should not be specified.') ## prevent inconsistency if (lavInspect(lavTemplate, "categorical") && ID.cat %in% c("wu","mplus") && ID.fac != "uv") warning('For factors measured only by categorical ', 'indicators, constraints on intercepts are ', 'insufficient to identify latent means when the ', 'intercepts are already fixed to zero in order ', 'to identify latent item scales. To prevent', 'underidentified models, it is recommended to ', 'instead set ID.fac = "std.lv".') ## convert *.partial strings to parTables if (is.character(group.partial)) { if ((group.partial == "")[1L] && length(group.partial) == 1L) { group.partial <- data.frame(stringsAsFactors = FALSE, lhs = character(0), op = character(0), rhs = character(0)) } else { group.partial <- lavaan::lavParseModelString(group.partial, as.data.frame. = TRUE, warn = warn, debug = debug) } } #TODO: else {extract information from a measEq.partial object} if (is.character(long.partial)) { if ((long.partial == "")[1L] && length(long.partial) == 1L) { long.partial <- data.frame(stringsAsFactors = FALSE, lhs = character(0), op = character(0), rhs = character(0)) } else { long.partial <- lavaan::lavParseModelString(long.partial, as.data.frame. = TRUE, warn = warn, debug = debug) } } #TODO: else {extract information from a measEq.partial object} ## only relevant when there are longitudinal factors if (length(longFacNames) > 0L) { if (!is.atomic(auto)) stop("'auto' must be a non-negative integer or the character 'all'.") if (is.logical(auto)) { if (auto) auto <- "all" else auto <- 0L} if (is.factor(auto)) auto <- as.character(auto) if (is.character(auto) && auto != "all") stop("'auto' must be a non-negative integer or the character 'all'.") if (is.numeric(auto)) { auto <- as.integer(auto[1]) # only the first integer if (auto < 1L) auto <- NULL } mc$auto <- auto } ## extract options and other information if (is.null(mc$parameterization)) { parameterization <- lavInspect(lavTemplate, "options")$parameterization } else { parameterization <- try(eval(mc$parameterization), silent = TRUE) if (inherits(parameterization, "try-error")) { parameterization <- try(eval.parent(mc$parameterization, 1), silent = TRUE) } } if (is.null(mc$meanstructure)) { meanstructure <- lavInspect(lavTemplate, "options")$meanstructure } else meanstructure <- mc$meanstructure nG <- lavInspect(lavTemplate, "ngroups") ## names of ordinal indicators, number of thresholds for each allOrdNames <- lavNames(lavTemplate, type = "ov.ord") if (length(allOrdNames)) { #TODO: add nThr= argument (named numeric vector?) so data= not required nThr <- table(sapply(strsplit(lavNames(lavTemplate, "th"), split = "|", fixed = TRUE), "[", i = 1)) } else nThr <- numeric(0) if (length(allOrdNames) && ID.cat == "millsap") { ## Check for ID.thr if (is.numeric(ID.thr)) { if (length(ID.thr) == 1L) ID.thr <- rep(ID.thr, 2) ID.thr <- sapply(allOrdNames, function(x) ID.thr[1:2], simplify = FALSE) } else if (is.list(ID.thr)) { if (length((setdiff(allOrdNames, names(ID.thr))))) stop('If the same thresholds will not be used for all ordered indicators,', ' then "ID.thr" must specify 2 integers per ordered indicator in ', 'a named list (using names of ordered indicators).') } ## check identification methods ID.fac <- "ul" if (parameterization != "theta") stop('If ID.cat == "millsap", you must ', 'use parameterization = "theta"') } if (length(allOrdNames) && ID.cat == "lisrel") { if (parameterization != "theta") stop('If ID.cat == "lisrel", you must ', 'use parameterization = "theta"') ## thresholds must be constrained to equality if (!"thresholds" %in% group.equal) group.equal <- c("thresholds", group.equal) if (!"thresholds" %in% long.equal) long.equal <- c("thresholds", long.equal) ## so remove any thresholds from *.partial partial.thr <- group.partial$op == "|" if (any(partial.thr)) group.partial <- group.partial[!partial.thr, ] partial.thr <- long.partial$op == "|" if (any(partial.thr)) long.partial <- long.partial[!partial.thr, ] } if (length(allOrdNames) && ID.cat %in% c("millsap","mplus")) { ## scalar invariance implies equal intercepts, even though they are ## fixed to zero anyway. This will correctly trigger freeing latent mean(s) if ("loadings" %in% group.equal && "thresholds" %in% group.equal && !"intercepts" %in% group.equal) group.equal <- c("intercepts", group.equal) if ("loadings" %in% long.equal && "thresholds" %in% long.equal && !"intercepts" %in% long.equal) long.equal <- c("intercepts", long.equal) } if (!meanstructure) { ## make sure *.equal includes no mean-structure parameters eq.means <- which(group.equal %in% c("means","intercepts")) if (length(eq.means)) group.equal <- group.equal[-eq.means] eq.means <- which(long.equal %in% c("means","intercepts")) if (length(eq.means)) long.equal <- long.equal[-eq.means] ## make sure *.partial includes no mean-structure parameters partial.means <- group.partial$op == "~1" if (any(partial.means)) group.partial <- group.partial[!partial.means, ] partial.means <- long.partial$op == "~1" if (any(partial.means)) long.partial <- long.partial[!partial.means, ] } mc$group.partial <- group.partial[c("lhs","op","rhs")] #FIXME: any more? "block" for multilevel? mc$long.partial <- long.partial[c("lhs","op","rhs")] ## check logic of constraints if (length(allOrdNames) && parameterization == "delta") { if ("residuals" %in% long.equal) { stop('Residual variances cannot be tested for invariance ', 'across repeated measures when parameterization = "delta". \n', 'Please set parameterization = "theta". \n') } if ("residuals" %in% group.equal) { stop('Residual variances cannot be tested for invariance ', 'across groups when parameterization = "delta". \n', 'Please set parameterization = "theta". \n') } } if (warn) { if (any(c("lv.variances","lv.autocov") %in% long.equal) && !"loadings" %in% long.equal) warning('Latent (co)variances are not comparable over repeated measures ', 'if their respective factor loadings are not equal ', 'over repeated measures.') if (any(c("lv.variances","lv.covariances") %in% group.equal) && !"loadings" %in% group.equal) warning('Latent (co)variances are not comparable across groups ', 'if their respective factor loadings are not equal across groups.') if ("intercepts" %in% long.equal && !"loadings" %in% long.equal) warning('Indicator intercepts are not comparable over repeated measures ', 'if their respective factor loadings are not equal ', 'over repeated measures.') if ("intercepts" %in% group.equal && !"loadings" %in% group.equal) warning('Indicator intercepts are not comparable over across groups ', 'if their respective factor loadings are not equal across groups.') if ("means" %in% long.equal && !all(c("loadings","intercepts") %in% long.equal)) warning('Latent means are not comparable over repeated measures if their ', 'respective factor loadings and intercepts are not equal ', 'over repeated measures.') if ("means" %in% group.equal && !all(c("loadings","intercepts") %in% group.equal)) warning('Latent means are not comparable across groups if their ', 'respective factor loadings and intercepts are not equal ', 'across groups.') if ("resid.autocov" %in% long.equal && !"residuals" %in% long.equal) warning('Residual auto-covariances might not be comparable over repeated ', 'measures if their respective residual variances are not equal ', 'over repeated measures.') if ("residual.covariances" %in% group.equal && !"residuals" %in% group.equal) warning('Residual covariances might not be comparable across groups if ', 'their respective residual variances are not equal across groups.') if ("lv.autocov" %in% long.equal && !"lv.variances" %in% long.equal) warning('Latent auto-covariances might not be comparable over repeated ', 'measures if their respective latent variances are not equal ', 'over repeated measures.') if ("lv.covariances" %in% group.equal && !"lv.variances" %in% group.equal) warning('Latent covariances might not be comparable across groups if ', 'their respective latent variances are not equal across groups.') } ## ------------------ ## Parameter Matrices ## ------------------ ## Parameter matrices used for labels, fixed/free values, and whether to specify GLIST.free <- lavInspect(lavTemplate, "free") if (nG == 1L) GLIST.free <- list(`1` = GLIST.free) ## only save relevant matrices to specify pmats <- intersect(c("tau","lambda","beta", if (meanstructure) "nu" else NULL , "theta", if (meanstructure) "alpha" else NULL , "psi", if (length(allOrdNames) && parameterization == "delta") "delta" else NULL), names(GLIST.free[[1]])) if ("beta" %in% pmats && ID.fac != "ul") { ID.fac <- "ul" #FIXME: could use effects-coding with relative ease? mc$ID.fac <- ID.fac message('Higher-order factors detected. ID.fac set to "ul".') } ## matrices with estimates depends on class of model if (inherits(lavTemplate, "lavaan")) { GLIST.est <- lavInspect(lavTemplate, "est") if (nG == 1L) GLIST.est <- list(`1` = GLIST.est) } else if (inherits(lavTemplate, "lavaanList")) { nn <- names(lavTemplate@Model@GLIST) #FIXME: will @Model continue to exist? GLIST.est <- list() for (g in 1:nG) { GLIST.est[[g]] <- list() for (p in pmats) { GLIST.est[[g]][[p]] <- lavTemplate@Model@GLIST[[ which(nn == p)[g] ]] ## add dimnames to matrices dimnames(GLIST.est[[g]][[p]]) <- dimnames(GLIST.free[[g]][[p]]) } } } for (g in 1:nG) { GLIST.est[[g]] <- GLIST.est[[g]][pmats] GLIST.free[[g]] <- GLIST.free[[g]][pmats] if (g > 1L) { ## make sure all groups have the same observed & latent variables same.obs <- all(rownames(GLIST.free[[g]]$lambda) == rownames(GLIST.free[[1]]$lambda)) same.lat <- all(colnames(GLIST.free[[g]]$lambda) == colnames(GLIST.free[[1]]$lambda)) if (!same.obs) stop('Models contain different observed variables across ', 'groups/blocks. Configural invariance impossible.') if (!same.lat) stop('Models contain different latent variables across ', 'groups/blocks. Configural invariance impossible.') } } ## FIXME: check for others? (e.g., test invariance across multiple levels?) ## In general, specify if GLIST.free > 0 | (GLIST.free == 0 & GLIST.est != 0) ## - tau : specify all ## - lambda: specify any nonzero in free + fixed-nonzero (e.g., auto.fix.first) ## - beta : treat as second-order lambda ## - nu : specify all ## - theta : specify diagonal (unless delta?) + any nonzero off-diagonal ## - delta : specify ONLY if parameterization == "delta" ## - alpha : specify all ## - psi : specify all GLIST.specify <- sapply(names(GLIST.free), function(g) list()) for (g in 1:nG) { for (p in pmats) { ## THRESHOLDS if (p == "tau") { GLIST.specify[[g]]$tau <- GLIST.free[[g]]$tau == 0 GLIST.specify[[g]]$tau[ , 1] <- TRUE next } ## LOADINGS if (p == "lambda") { free.loading <- GLIST.free[[g]]$lambda > 0L fixed.nonzero.loading <- GLIST.free[[g]]$lambda == 0L & GLIST.est[[g]]$lambda != 0 GLIST.specify[[g]]$lambda <- free.loading | fixed.nonzero.loading next } ## SECOND-ORDER LOADINGS if (p == "beta") { free.loading <- GLIST.free[[g]]$beta > 0L fixed.nonzero.loading <- GLIST.free[[g]]$beta == 0L & GLIST.est[[g]]$beta != 0 GLIST.specify[[g]]$beta <- free.loading | fixed.nonzero.loading next } ## INTERCEPTS if (p == "nu") { GLIST.specify[[g]]$nu <- GLIST.free[[g]]$nu == 0 GLIST.specify[[g]]$nu[ , 1] <- TRUE next } ## LATENT MEANS if (p == "alpha") { GLIST.specify[[g]]$alpha <- GLIST.free[[g]]$alpha == 0 GLIST.specify[[g]]$alpha[ , 1] <- TRUE next } ## LATENT (CO)VARIANCES if (p == "psi") { GLIST.specify[[g]]$psi <- matrix(TRUE, nrow = nrow(GLIST.free[[g]]$psi), ncol = ncol(GLIST.free[[g]]$psi), dimnames = dimnames(GLIST.free[[g]]$psi)) ## only specify lower triangle GLIST.specify[[g]]$psi[upper.tri(GLIST.specify[[g]]$psi)] <- FALSE next } ## RESIDUAL (CO)VARIANCES if (p == "theta") { free.var <- GLIST.free[[g]]$theta > 0L fixed.nonzero.var <- GLIST.free[[g]]$theta == 0L & GLIST.est[[g]]$theta != 0 GLIST.specify[[g]]$theta <- free.var | fixed.nonzero.var ## can't specify for ordinal indicators using delta parameterization if (parameterization == "delta") diag(GLIST.specify[[g]]$theta)[allOrdNames] <- FALSE ## only specify lower triangle GLIST.specify[[g]]$theta[upper.tri(GLIST.specify[[g]]$theta)] <- FALSE next } ## SCALING FACTORS (delta parameters for latent item-responses) if (p == "delta") { GLIST.specify[[g]]$delta <- GLIST.free[[g]]$delta == 1 GLIST.specify[[g]]$delta[ , 1] <- parameterization == "delta" } ## end loops } } ## check for any cross-loadings #TODO: special check for bifactor models possible? Find factors whose indicators all cross-load... anyXload <- FALSE for (g in 1:nG) { if (any(apply(GLIST.specify[[g]]$lambda, 1, sum) > 1)) anyXload <- TRUE } ## can the effects-coding identification method be used? if (ID.fac == "fx" && anyXload) { stop('Effects-coding method of factor identification ', '("ID.fac") unavailable in models with cross-loadings.') } ## Warn about constraining intercepts but not means freeMeans <- ("intercepts" %in% group.equal && !("means" %in% group.equal)) || ("intercepts" %in% long.equal && !("means" %in% long.equal) ) if (ID.fac == "uv" && anyXload && freeMeans) { warning('A factor\'s mean cannot be freed unless it has at least one ', 'indicator without a cross-loading whose intercept is constrained ', 'to equality. Use cat(as.character()) to check whether the syntax ', 'returned by measEq.syntax() must be manually adapted to free the ', 'necessary latent means.') } ## If it is estimated in the user's configural model, free it (NA). ## If it is specified as fixed but != 0, retain fixed value. GLIST.values <- sapply(names(GLIST.free), function(g) list()) for (g in 1:nG) { GLIST.values[[g]] <- mapply(function(est, free) { est[free > 0L] <- NA est }, SIMPLIFY = FALSE, est = GLIST.est[[g]], free = GLIST.free[[g]]) ## constrain first loadings to 1 and first indicators to 0? if (ID.fac == "ul") { ## matrix to store whether each indicator is a reference indicator lambda.first <- matrix(FALSE, nrow = nrow(GLIST.values[[g]]$lambda), ncol = ncol(GLIST.values[[g]]$lambda), dimnames = dimnames(GLIST.values[[g]]$lambda)) if ("beta" %in% pmats) { beta.first <- matrix(FALSE, nrow = nrow(GLIST.values[[g]]$beta), ncol = ncol(GLIST.values[[g]]$beta), dimnames = dimnames(GLIST.values[[g]]$beta)) } ## loop over factors to constrain loadings to 1 for (f in colnames(GLIST.values[[g]]$lambda)) { ## if any loading(s) is(are) fixed to 1 already, no changes needed ones.lambda <- which(GLIST.values[[g]]$lambda[ , f] == 1L) if ("beta" %in% pmats) ones.beta <- which(GLIST.values[[g]]$beta[ , f] == 1L) any1.lambda <- length(ones.lambda) > 0L any1.beta <- if ("beta" %in% pmats) length(ones.beta) > 0L else FALSE if (!any1.lambda && !any1.beta) { ## If not already indicated, find the first indicator and fix it to 1. ## Prioritize latent indicators to be first (in case observed has cross-loading) if ("beta" %in% pmats) { indicators <- names(which(GLIST.specify[[g]]$beta[ , f])) if (length(indicators)) { first.indicator <- indicators[1] } else first.indicator <- NULL } else first.indicator <- NULL if (length(first.indicator)) { ## only true if ("beta" %in% pmats) GLIST.values[[g]]$beta[first.indicator, f] <- 1L beta.first[first.indicator, f] <- TRUE } else { ## no latent indicators, so look in lambda indicators <- names(which(GLIST.specify[[g]]$lambda[ , f])) first.indicator <- indicators[1] #FIXME: no chance of NA by now, right? GLIST.values[[g]]$lambda[first.indicator, f] <- 1L lambda.first[first.indicator, f] <- TRUE } ## otherwise, use first fixed == 1 indicator as the marker variable } else if (any1.beta) { beta.first[ones.beta[1], f] <- TRUE } else if (any1.lambda) { lambda.first[ones.lambda[1], f] <- TRUE } } ## loop over indicators to constrain intercepts to zero if (meanstructure) { ## manifest indicators for (i in rownames(GLIST.specify[[g]]$lambda)) { ## for the first indicator of a construct, constrain to zero first.indicator <- lambda.first[i, ] if (sum(first.indicator) > 1L) stop('The intercept of indicator "', i, '" can only be fixed to zero ', 'in order to identify one latent mean, but it is specified as ', 'the first indicator of the following factors:\n\t', paste(names(which(first.indicator)), collapse = ", "), '\n', 'Please respecify the model so that each factor has a unique ', 'first indicator to use as a reference indicator.') if (any(first.indicator)) GLIST.values[[g]]$nu[i, 1] <- 0 } ## latent indicators of higher-order constructs if ("beta" %in% pmats) for (i in rownames(GLIST.specify[[g]]$beta)) { ## for the first indicator of a construct, constrain to zero first.indicator <- beta.first[i, ] if (sum(first.indicator) > 1L) stop('The intercept of indicator "', i, '" can only be fixed to zero ', 'in order to identify one factor mean, but it is specified as ', 'the first indicator of the following factors:\n\t', paste(names(which(first.indicator)), collapse = ", "), '\n', 'Please respecify the model so that each factor has a unique ', 'first indicator to use as a reference indicator.') if (any(first.indicator)) { GLIST.values[[g]]$alpha[i, 1] <- 0 } else GLIST.values[[g]]$alpha[i, 1] <- NA } } } } ## Make labels GLIST.labels <- sapply(names(GLIST.free), function(g) list()) for (g in 1:nG) { for (p in pmats) { if (p == "tau") { ## THRESHOLDS GLIST.labels[[g]]$tau <- cbind(gsub(x = rownames(GLIST.free[[g]]$tau), pattern = "|t", replacement = ".thr", fixed = TRUE)) dimnames(GLIST.labels[[g]]$tau) <- dimnames(GLIST.free[[g]]$tau) } else { ## ANY OTHER PARAMETERS GLIST.labels[[g]][[p]] <- matrix("", nrow = nrow(GLIST.free[[g]][[p]]), ncol = ncol(GLIST.free[[g]][[p]]), dimnames = dimnames(GLIST.free[[g]][[p]])) for (RR in rownames(GLIST.free[[g]][[p]])) { for (CC in colnames(GLIST.free[[g]][[p]])) { GLIST.labels[[g]][[p]][RR, CC] <- getLabel(GLIST.labels[[g]], parMat = p, RR = RR, CC = CC) } } } ## end loops } ## no labels for scaling factors (cannot equate, not a measuremet parameter) GLIST.labels[[g]]$delta <- NULL } ## ------------------------------------ ## Preliminary checks on model and data ## ------------------------------------ ## check longitudinal factor names if (!is.list(longFacNames)) stop('"longFacNames" must be a list of character vectors.') ## check that no longitudinal factors are only at 1 occasion if (length(longFacNames)) longFacNames <- longFacNames[sapply(longFacNames, length) > 1L] ## also check longIndNames, and each non-NULL element if (!is.list(longIndNames)) stop('"longIndNames" must be a list of character vectors.') if (length(longIndNames)) { longIndList <- sapply(longIndNames, is.character) if (!all(longIndList)) stop('"longIndNames" must be a list of character vectors.') ## No problem if any(length == 1L). It just won't be constrained. } ## names of factors in syntax allFacNames <- lapply(GLIST.free, function(x) colnames(x$lambda)) ## collapse names of longitudinal factors (plus non-longitudinal factors) # reducedFacNames <- c(names(longFacNames), setdiff(unlist(allFacNames), # unlist(longFacNames))) ## check for longitudinal indicator names, automatically generate if empty make.longIndNames <- length(longIndNames) == 0L for (f in names(longFacNames)) { ## time-specific factor names fs <- longFacNames[[f]] nT <- length(fs) # number of occasions ## get indicators of each indNames <- sapply(fs, function(ff) { names(which(GLIST.specify[[1]]$lambda[ , ff])) }, simplify = FALSE) if (make.longIndNames) { # check for same number of indicators, match across factors nInd <- length(indNames[[1]]) if (!all(sapply(indNames, length) == nInd)) stop('The number of indicators for longitudinal factor "', f, '" differs across measurement occasions. Please use the ', '"longIndNames" argument to specify which longitudinal indicators', ' are the same indicator on different occasions of measurement.') if (nInd > 0L) for (i in 1:nInd) { longIndNames[[paste0("._", f, "_.ind.", i)]] <- sapply(indNames, "[", i = i, USE.NAMES = FALSE) } } else { ## add unique indicators per factor (omitted from user-specified matches) ## NO LONGER NECESSARY # for (i in fs) { # extraIndicators <- setdiff(indNames[[i]], unlist(longIndNames[[f]])) # longIndNames[[f]][extraIndicators] <- extraIndicators # } } } ## check none have cross-loadings longIndTable <- table(unlist(longIndNames)) if (any(longIndTable > 1L)) stop('Some longitudinal indicators define more than one factor:\n ', paste(names(longIndTable[longIndTable > 1L]), collapse = ", "), "\n ", 'The "longIndNames=" argument must be explicitly declared.') ## check equivalence of data type (ordinal vs. continuous) across time longOrdNames <- sapply(longIndNames, "%in%", table = allOrdNames, simplify = FALSE) someNotAll <- sapply(longOrdNames, function(i) any(i) & !all(i)) if (any(someNotAll)) { stop('At least one longitudinal indicator is declared as "ordered" on', ' at least one, but not every, occasion: \n ', paste(names(which(someNotAll)), collapse = ", ")) } ## check number of thresholds/categories is equivalent across time allOrd <- sapply(longOrdNames, all) if (length(allOrd)) for (i in which(allOrd)) { checkThr <- nThr[ longIndNames[[ names(allOrd)[i] ]] ] if (!all(checkThr == checkThr[1])) stop('These "ordered" longitudinal indicators do not have the same ', 'number of thresholds (endorsed categories) on every occasion: \n', paste(names(checkThr), collapse = ", "), "\nConsider collapsing rarely endorsed categories.") } ## create a backward-key for finding long(Fac/Ind)Names from variable names longFacKey <- rep(names(longFacNames), times = sapply(longFacNames, length)) names(longFacKey) <- unlist(longFacNames) longIndKey <- rep(names(longIndNames), times = sapply(longIndNames, length)) names(longIndKey) <- unlist(longIndNames) mc$longFacNames <- longFacNames mc$longIndNames <- longIndNames ## ----------------- ## Apply constraints ## ----------------- ## THRESHOLDS (+ intercept & variance ID constraints for allOrdNames) ## longitudinal constraints (one group at a time, but same across groups) for (g in 1:nG) { ## loop over ordinal indicators for (i in allOrdNames) { ## when other variables are this same indicator? longInds <- names(longIndKey)[ which(longIndKey == longIndKey[i]) ] if (length(longInds) == 0L) next ## keep track of how many thresholds for the i_th indicator have been ## constrained, in case identification constraints can be released nEqThr <- 0L ## loop over thresholds of the i_th ordinal indicator for (th in 1:(nThr[i])) { ## (ADD) constraints across repeated measures? equate.long <- "thresholds" %in% long.equal ## check whether not to equate because it is in long.partial partial.th <- long.partial$op == "|" & long.partial$rhs == paste0("t", th) if (equate.long && any(partial.th)) { partial.inds <- longIndNames[ long.partial$lhs[which(partial.th)] ] equate.long <- !i %in% unlist(partial.inds) } ## check whether to equate for identification (overrides *.partial) if (ID.cat == "millsap") { ## always equate the first (or only, if binary) if (th == ID.thr[[i]][1]) { equate.long <- TRUE ## remove this from long.partial, if necessary rm.th <- which(long.partial$lhs == longIndKey[i] & partial.th) if (length(rm.th)) long.partial <- long.partial[-rm.th, ] } ## for the first indicator of a construct, equate the second fs <- which(GLIST.specify[[g]]$lambda[i, ]) first.indicator <- sapply(fs, function(f) { lams <- GLIST.specify[[g]]$lambda[ , f] lam.eq.1 <- which(GLIST.values[[g]]$lambda[ , f] == 1) if (length(lam.eq.1)) return(names(lams[ lam.eq.1[1] ]) == i) names(which(lams))[1] == i }) if (th == ID.thr[[i]][2] && any(first.indicator)) { equate.long <- TRUE if (length(fs) > 1L && warn) warning('Millsap & Tein`s (2004) identification constraints might ', 'not be optimal when the reference indicator ("', i, '") has a cross-loading (on factors "', paste0(names(fs), collapse = '", "'), '")') ## remove this from long.partial, if necessary rm.th <- which(long.partial$lhs == longIndKey[i] & partial.th) if (length(rm.th)) long.partial <- long.partial[-rm.th, ] } } ## apply longitudinal constraint? if (equate.long) { ## iterate count of constrained thresholds nEqThr <- nEqThr + 1L ## apply longitudinal constraint this.th <- paste0(i, "|t", th) first.th <- paste0(longInds[1], "|t", th) GLIST.labels[[g]]$tau[this.th, 1] <- GLIST.labels[[g]]$tau[first.th, 1] } } ## end loop over thresholds ## check whether enough thresholds were equated to free ## IDENTIFICATION CONSTRAINTS on intercepts & residuals equate.int <- "intercepts" %in% long.equal && !any(long.partial$lhs == longIndKey[i] & long.partial$op == "~1") equate.resid <- "residuals" %in% long.equal && !any(long.partial$lhs == longIndKey[i] & long.partial$rhs == longIndKey[i] & long.partial$op == "~~") #FIXME: leave resid==0 for reference indicators if (i == longInds[1]) { if (ID.cat == "lisrel") { ## always estimate intercepts, and variances unless binary GLIST.values[[g]]$nu[i, 1] <- NA diag(GLIST.values[[g]]$theta)[i] <- if (nThr[i] == 1L) 1 else NA } else { ## always set reference occasion's intercepts to 0 and variances to 1 GLIST.values[[g]]$nu[i, 1] <- 0 if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- 1 } else { GLIST.values[[g]]$delta[i, 1] <- 1 } } } else if (ID.cat == "wu") { ## priority to freeing intercepts if (nEqThr == 0L || equate.int) { GLIST.values[[g]]$nu[i, 1] <- 0 } else GLIST.values[[g]]$nu[i, 1] <- NA if (nEqThr == 0L || (nEqThr < 2L && !equate.int) || equate.resid) { ## keep (residual) variances fixed if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- 1 } else { GLIST.values[[g]]$delta[i, 1] <- 1 } } else { ## free (residual) variances if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- NA } else { GLIST.values[[g]]$delta[i, 1] <- NA } } } else if (ID.cat %in% c("mplus","millsap")) { ## never free intercepts, only variances if (nEqThr == 0L || equate.resid) { ## keep (residual) variances fixed if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- 1 } else { GLIST.values[[g]]$delta[i, 1] <- 1 } } else { ## free (residual) variances if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- NA } else { GLIST.values[[g]]$delta[i, 1] <- NA } } } else if (ID.cat == "lisrel") { ## always estimate intercepts, and variances unless binary GLIST.values[[g]]$nu[i, 1] <- NA diag(GLIST.values[[g]]$theta)[i] <- if (nThr[i] == 1L) 1 else NA } } } ## group constraints if (nG == 1L && ID.cat == "lisrel") { ## Single-group model for repeated measures: ## Longitudinal loop above only places LISREL equality constraints on ## thresholds. Here, still neeed to fix the first 2 == {0, 1}. ## loop over ordinal indicators for (i in allOrdNames) { ## loop over thresholds of the i_th ordinal indicator for (th in 1:(nThr[i])) { ## always fix the first (or only, if binary) to zero if (th == 1L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- 0 ## always fix the second to one if (th == 2L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- 1 ## estimate any others if (th > 2L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- NA } ## end loop over thresholds } ## end loop over ordinal indicators } else if (nG > 1L) for (g in 1:nG) { ## loop over ordinal indicators for (i in allOrdNames) { ## keep track of how many thresholds for the i_th indicator have ## constrained, in case identification constraints can be released nEqThr <- 0L ## loop over thresholds of the i_th ordinal indicator for (th in 1:(nThr[i])) { ## (REMOVE) constraints across groups? equate.group <- "thresholds" %in% group.equal ## check whether not to equate because it is in group.partial partial.th <- group.partial$lhs == i & group.partial$op == "|" & group.partial$rhs == paste0("t", th) if (equate.group) equate.group <- !any(partial.th) ## check whether to equate for identification (overrides *.partial) if (ID.cat == "millsap") { ## always equate the first (or only, if binary) if (th == ID.thr[[i]][1]) { equate.group <- TRUE ## remove this from group.partial, if necessary rm.th <- which(partial.th) if (length(rm.th)) group.partial <- group.partial[-rm.th, ] } ## for the first indicator of a construct, equate the second fs <- which(GLIST.specify[[g]]$lambda[i, ]) first.indicator <- sapply(fs, function(f) { lams <- GLIST.specify[[g]]$lambda[ , f] lam.eq.1 <- which(GLIST.values[[g]]$lambda[ , f] == 1) if (length(lam.eq.1)) return(names(lams[ lam.eq.1[1] ]) == i) names(which(lams))[1] == i }) if (th == ID.thr[[i]][2] && any(first.indicator)) { equate.group <- TRUE if (length(fs) > 1L && warn) warning('Millsap & Tein`s (2004) identification constraints might ', 'not be optimal when the reference indicator ("', i, '") has a cross-loading (on factors "', paste0(names(fs), collapse = '", "'), '")') ## remove this from group.partial, if necessary rm.th <- which(partial.th) if (length(rm.th)) group.partial <- group.partial[-rm.th, ] } } else if (ID.cat == "lisrel") { ## always fix the first (or only, if binary) to zero if (th == 1L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- 0 ## always fix the second to one if (th == 2L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- 1 ## estimate any others if (th > 2L) GLIST.values[[g]]$tau[paste0(i, "|t", th), 1] <- NA } ## apply group-specific label, unless constrained if (!equate.group) { ## row in GLIST RR <- paste0(i, "|t", th) GLIST.labels[[g]]$tau[RR, 1] <- paste0(GLIST.labels[[g]]$tau[RR, 1], ".g", g) } else nEqThr <- nEqThr + 1L # iterate count of constrained thresholds } ## end loop over thresholds ## check whether enough thresholds were equated to free ## IDENTIFICATION CONSTRAINTS on intercepts & residuals. ## Note: Group 1 constraints already set in longitudinal loop, ONLY if ## there are repeated measures identified by longInds. ## Section below only RELEASES constraints. ## DON'T OVERWRITE FREED CONSTRAINTS AFTER TIME 1. equate.int <- "intercepts" %in% group.equal && !any(group.partial$lhs == i & group.partial$op == "~1") equate.resid <- "residuals" %in% group.equal && !any(group.partial$lhs == i & group.partial$rhs == i & group.partial$op == "~~") if (g > 1L && ID.cat == "wu") { ## priority to freeing intercepts #FIXME: binary indicators, latent mean arbitrarily freed, nesting problems if (nEqThr >= 1L && !equate.int) GLIST.values[[g]]$nu[i, 1] <- NA if ((nEqThr >= 2L || (nEqThr >= 1L && equate.int)) && !equate.resid) { ## free (residual) variances if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- NA } else { GLIST.values[[g]]$delta[i, 1] <- NA } } } else if (g > 1L && ID.cat %in% c("mplus","millsap")) { ## never free intercepts, only variances if (nEqThr >= 1L && !equate.resid) { ## free (residual) variances if (parameterization == "theta") { diag(GLIST.values[[g]]$theta)[i] <- NA } else { GLIST.values[[g]]$delta[i, 1] <- NA } } } else if (ID.cat == "lisrel") { ## always estimate intercepts, and variances unless binary GLIST.values[[g]]$nu[i, 1] <- NA diag(GLIST.values[[g]]$theta)[i] <- if (nThr[i] == 1L) 1 else NA } } } ## LATENT MEANS ## longitudinal constraints (one group at a time, but same across groups) if (meanstructure) for (g in 1:nG) { ## fix or free factor means? if (ID.fac == "uv") { GLIST.values[[g]]$alpha[ , 1] <- 0 # free below, if any loading is constrained ## freed when any loading is constrained to equality } else if ("beta" %in% pmats) { ## latent indicators of any higher-order factors already set to 0 or NA ## in GLIST.values loop above } else GLIST.values[[g]]$alpha[ , 1] <- NA ## loop over factors for (f in rownames(GLIST.labels[[g]]$alpha)) { ## which other variables are this same factor? longFacs <- names(longFacKey)[ which(longFacKey == longFacKey[f]) ] if (length(longFacs) == 0L) { ## not a longitudinal factor, set first group's mean to 0 for Millsap if (ID.cat == "millsap" && g == 1L) GLIST.values[[g]]$alpha[f, 1] <- 0 next } ## first time a factor is measured, set first group's mean to 0 for Millsap if (ID.cat == "millsap" && g == 1L && longFacs[1] == f) { GLIST.values[[g]]$alpha[f, 1] <- 0 } ## assign labels equate.means <- "means" %in% long.equal && !any(long.partial$lhs == longFacKey[f] & long.partial$op == "~1") if (equate.means) { GLIST.labels[[g]]$alpha[f, 1] <- GLIST.labels[[g]]$alpha[longFacs[1], 1] } } } ## group constraints if (meanstructure && nG > 1L) for (g in 1:nG) { ## loop over factors for (f in rownames(GLIST.labels[[g]]$alpha)) { ## assign labels equate.means <- "means" %in% group.equal && !any(group.partial$lhs == f & group.partial$op == "~1") if (!equate.means) { GLIST.labels[[g]]$alpha[f, 1] <- paste0(GLIST.labels[[g]]$alpha[f, 1], ".g", g) } } } ## LATENT VARIANCES ## longitudinal constraints (one group at a time, but same across groups) for (g in 1:nG) { ## fix or free factor variances? if (ID.fac == "uv") { diag(GLIST.values[[g]]$psi) <- 1 # free below, if any loading is constrained ## freed when any loading is constrained to equality } else diag(GLIST.values[[g]]$psi) <- NA ## loop over factors for (f in colnames(GLIST.labels[[g]]$lambda)) { ## which other variables are this same factor? longFacs <- names(longFacKey)[ which(longFacKey == longFacKey[f]) ] if (length(longFacs) == 0L) next ## assign labels equate.var <- "lv.variances" %in% long.equal && !any(long.partial$lhs == longFacKey[f] & long.partial$op == "~~" & long.partial$rhs == longFacKey[f]) if (equate.var) { GLIST.labels[[g]]$psi[f, f] <- GLIST.labels[[g]]$psi[longFacs[1], longFacs[1]] } } } ## group constraints if (nG > 1L) for (g in 1:nG) { ## loop over factors for (f in colnames(GLIST.labels[[g]]$lambda)) { ## assign labels equate.var <- "lv.variances" %in% group.equal && !any(group.partial$lhs == f & group.partial$op == "~~" & group.partial$rhs == f) if (!equate.var) { GLIST.labels[[g]]$psi[f, f] <- paste0(GLIST.labels[[g]]$psi[f, f], ".g", g) } } } ## LOADINGS ## longitudinal constraints (one group at a time, but same across groups) for (g in 1:nG) { ## loop over factors for (f in colnames(GLIST.labels[[g]]$lambda)) { ## which other factors are this same factor? longFacs <- names(longFacKey)[ which(longFacKey == longFacKey[f]) ] if (length(longFacs) == 0L) next ## loop over any manifest indicators within each factor for (i in names(which(GLIST.specify[[g]]$lambda[ , f])) ) { ## which other variables are this same indicator? longInds <- names(longIndKey)[ which(longIndKey == longIndKey[i]) ] if (length(longInds) == 0L) next ## assign labels equate.load <- "loadings" %in% long.equal && !any(long.partial$lhs == longFacKey[f] & long.partial$op == "=~" & long.partial$rhs == longIndKey[i]) if (equate.load) { GLIST.labels[[g]]$lambda[i, f] <- GLIST.labels[[g]]$lambda[longInds[1], longFacs[1]] ## free factor variance(s) after Time 1 if (ID.fac == "uv" && f %in% longFacs[-1]) diag(GLIST.values[[g]]$psi)[f] <- NA } } ## loop over any latent indicators within each factor if ("beta" %in% pmats) for (i in names(which(GLIST.specify[[g]]$beta[ , f])) ) { ## which other factors are this same factor? longInds <- names(longFacKey)[ which(longFacKey == longFacKey[i]) ] if (length(longInds) == 0L) next ## assign labels equate.load <- "regressions" %in% long.equal && !any(long.partial$lhs == longFacKey[f] & long.partial$op == "=~" & long.partial$rhs == longFacKey[i]) if (equate.load) { GLIST.labels[[g]]$beta[i, f] <- GLIST.labels[[g]]$beta[longInds[1], longFacs[1]] } } } } ## group constraints if (nG > 1L) for (g in 1:nG) { ## loop over factors for (f in colnames(GLIST.labels[[g]]$lambda)) { ## loop over any manifest indicators within each factor for (i in names(which(GLIST.specify[[g]]$lambda[ , f])) ) { ## assign labels equate.load <- "loadings" %in% group.equal && !any(group.partial$lhs == f & group.partial$op == "=~" & group.partial$rhs == i) if (!equate.load) { GLIST.labels[[g]]$lambda[i, f] <- paste0(GLIST.labels[[g]]$lambda[i, f], ".g", g) } else if (ID.fac == "uv" && g > 1L) { ## free factor variance(s) in group(s) other than the first diag(GLIST.values[[g]]$psi)[f] <- NA } } ## loop over any latent indicators within each factor if ("beta" %in% pmats) for (i in names(which(GLIST.specify[[g]]$beta[ , f])) ) { ## assign labels equate.load <- "regressions" %in% group.equal && !any(group.partial$lhs == f & group.partial$op == "=~" & group.partial$rhs == i) if (!equate.load) { GLIST.labels[[g]]$beta[i, f] <- paste0(GLIST.labels[[g]]$beta[i, f], ".g", g) } } } } ## INTERCEPTS ## longitudinal constraints (one group at a time, but same across groups) if (meanstructure) for (g in 1:nG) { ## loop over indicators for (i in lavNames(lavTemplate, "ov.ind", group = g)) { ## when other variables are this same indicator? longInds <- names(longIndKey)[ which(longIndKey == longIndKey[i]) ] if (length(longInds) == 0L) next ## assign labels equate.int <- "intercepts" %in% long.equal && !any(long.partial$lhs == longIndKey[i] & long.partial$op == "~1") if (equate.int) { GLIST.labels[[g]]$nu[i, 1] <- GLIST.labels[[g]]$nu[longInds[1], 1] ## free factor mean(s) after Time 1 only if an indicator without a ## cross-loading has an equality-constrained intercept if (ID.fac == "uv") { ## factors this indicator measures fs <- colnames(GLIST.specify[[g]]$lambda)[ GLIST.specify[[g]]$lambda[i,] ] only.measures.1 <- length(fs) == 1L ## name(s) of longitudinal factor(s) LFN <- longFacKey[fs] not.time.1 <- fs[1] %in% names(which(longFacKey == LFN))[-1] if (only.measures.1 && not.time.1) GLIST.values[[g]]$alpha[fs, 1] <- NA } } } } ## group constraints if (meanstructure && nG > 1L) for (g in 1:nG) { ## loop over indicators for (i in lavNames(lavTemplate, "ov.ind", group = g)) { ## assign labels equate.int <- "intercepts" %in% group.equal && !any(group.partial$lhs == i & group.partial$op == "~1") if (!equate.int) { GLIST.labels[[g]]$nu[i, 1] <- paste0(GLIST.labels[[g]]$nu[i, 1], ".g", g) } else if (ID.fac == "uv") { ## factors this indicator measures fs <- colnames(GLIST.specify[[g]]$lambda)[ GLIST.specify[[g]]$lambda[i,] ] only.measures.1 <- length(fs) == 1L ## free factor mean(s) other than group 1 only if an indicator without a ## cross-loading has an equality-constrained intercept if (only.measures.1 && g > 1L) GLIST.values[[g]]$alpha[fs, 1] <- NA } } } ## RESIDUAL VARIANCES ## longitudinal constraints (one group at a time, but same across groups) for (g in 1:nG) { ## loop over indicators for (i in lavNames(lavTemplate, "ov.ind", group = g)) { ## when other variables are this same indicator? longInds <- names(longIndKey)[ which(longIndKey == longIndKey[i]) ] if (length(longInds) == 0L) next ## assign labels equate.resid <- "residuals" %in% long.equal && !any(long.partial$lhs == longIndKey[i] & long.partial$rhs == longIndKey[i] & long.partial$op == "~~") if (equate.resid) { diag(GLIST.labels[[g]]$theta)[i] <- diag(GLIST.labels[[g]]$theta)[ longInds[1] ] } } } ## group constraints if (nG > 1L) for (g in 1:nG) { ## loop over indicators for (i in lavNames(lavTemplate, "ov.ind", group = g)) { ## assign labels equate.resid <- "residuals" %in% group.equal && !any(group.partial$lhs == i & group.partial$rhs == i & group.partial$op == "~~") if (!equate.resid) { diag(GLIST.labels[[g]]$theta)[i] <- paste0(diag(GLIST.labels[[g]]$theta)[i], ".g", g) } } } ## RESIDUAL AUTO-COVARIANCES: longitudinal constraints only if (length(longIndNames) && !is.null(auto)) for (g in 1:nG) { ## loop over longitudinal indicators for (i in names(longIndNames)) { nn <- longIndNames[[i]] nT <- length(nn) # number repeated measures of indicator i auto.i <- suppressWarnings(as.integer(auto))[1] # nT can vary over i if (auto == "all" | is.na(auto.i)) auto.i <- nT - 1L # max lag if (auto.i >= nT | auto.i < 0L ) auto.i <- nT - 1L # max lag ## for each lag... for (lag in 1:auto.i) { for (tt in 1:(nT - lag)) { ## sort indices to ensure the lower.tri is always specified, in case ## order of longIndNames does not match order in syntax/theta nn.idx <- c(which(rownames(GLIST.specify[[g]]$theta) == nn[tt]), which(rownames(GLIST.specify[[g]]$theta) == nn[tt + lag])) idx1 <- nn.idx[ which.max(nn.idx) ] # row index idx2 <- nn.idx[ which.min(nn.idx) ] # column index ## specify and set free GLIST.specify[[g]]$theta[idx1, idx2] <- TRUE GLIST.values[[g]]$theta[ idx1, idx2] <- NA ## constrain to equality across repeated measures? if ("resid.autocov" %in% long.equal && tt > 1L) { o.idx <- c(which(rownames(GLIST.specify[[g]]$theta) == nn[1]), which(rownames(GLIST.specify[[g]]$theta) == nn[1 + lag])) o1 <- o.idx[ which.max(o.idx) ] # row index o2 <- o.idx[ which.min(o.idx) ] # column index first.label <- GLIST.labels[[g]]$theta[o1, o2] GLIST.labels[[g]]$theta[idx1, idx2] <- first.label } } } } } ## group constraints on any RESIDUAL COVARIANCES if (nG > 1) for (g in 1:nG) { ## add group-specific labels to any off-diagonal GLIST.specify? freeTheta <- which(GLIST.specify[[g]]$theta, arr.ind = TRUE) offDiag <- freeTheta[ , "row"] > freeTheta[ , "col"] if (sum(offDiag) == 0) break # nothing to do ## loop over elements that require action free.offDiag <- freeTheta[offDiag, , drop = FALSE] for (RR in 1:nrow(free.offDiag)) { i <- free.offDiag[RR, "row"] j <- free.offDiag[RR, "col"] ## check group.partial in both directions partial.ij <- any(group.partial$lhs == i & group.partial$rhs == j & group.partial$op == "~~") partial.ji <- any(group.partial$lhs == j & group.partial$rhs == i & group.partial$op == "~~") equate.rescov <- "residual.covariances" %in% group.equal && !any(partial.ij | partial.ji) ## assign group-specific labels? if (!equate.rescov) { GLIST.labels[[g]]$theta[i, j] <- paste0(GLIST.labels[[g]]$theta[i, j], ".g", g) } } } ## LATENT AUTO-COVARIANCES: longitudinal constraints only if (length(longFacNames)) for (g in 1:nG) { ## loop over longitudinal indicators for (i in names(longFacNames)) { nn <- longFacNames[[i]] nT <- length(nn) # number repeated measures of indicator i ## for each lag... for (lag in 1:(nT - 1) ) { for (tt in 1:(nT - lag) ) { ## specify and set free (overwrite possible "orthogonal=TRUE") GLIST.specify[[g]]$psi[ nn[tt + lag], nn[tt] ] <- TRUE GLIST.values[[g]]$psi[ nn[tt + lag], nn[tt] ] <- NA ## constrain to equality across repeated measures? if ("lv.autocov" %in% long.equal && tt > 1L) { first.label <- GLIST.labels[[g]]$psi[ nn[1 + lag], nn[1] ] GLIST.labels[[g]]$psi[ nn[tt + lag], nn[tt] ] <- first.label } } } } } ## group constraints on any LATENT COVARIANCES if (nG > 1) for (g in 1:nG) { ## add group-specific labels to any off-diagonal GLIST.specify? freePsi <- which(GLIST.specify[[g]]$psi, arr.ind = TRUE) offDiag <- freePsi[ , "row"] > freePsi[ , "col"] if (sum(offDiag) == 0) break # nothing to do ## loop over elements that require action free.offDiag <- freePsi[offDiag, , drop = FALSE] for (RR in 1:nrow(free.offDiag)) { i <- free.offDiag[RR, "row"] j <- free.offDiag[RR, "col"] ## check group.partial in both directions partial.ij <- any(group.partial$lhs == i & group.partial$rhs == j & group.partial$op == "~~") partial.ji <- any(group.partial$lhs == j & group.partial$rhs == i & group.partial$op == "~~") equate.latcov <- "lv.covariances" %in% group.equal && !any(partial.ij | partial.ji) ## assign group-specific labels? if (!equate.latcov) { GLIST.labels[[g]]$psi[i, j] <- paste0(GLIST.labels[[g]]$psi[i, j], ".g", g) } } } ## assemble parameter labels for effects-code identification constraints fxList <- character(0) if (ID.fac == "fx") { listLabels.L <- list() if (meanstructure) listLabels.I <- list() for (g in 1:nG) { ## loadings labels listLabels.L[[g]] <- sapply(colnames(GLIST.labels[[g]]$lambda), function(f) { GLIST.labels[[g]]$lambda[GLIST.specify[[g]]$lambda[ , f], f] }, simplify = FALSE) ## intercept labels if (meanstructure) { listLabels.I[[g]] <- sapply(colnames(GLIST.labels[[g]]$lambda), function(f) { GLIST.labels[[g]]$nu[GLIST.specify[[g]]$lambda[ , f], 1] }, simplify = FALSE) #TODO: threshold labels } } ## names of factors measured in each group gFacNames <- lapply(listLabels.L, names) ## loop over common-factor names for (f in unique(unlist(allFacNames))) { ## in which groups is this factor measured? groups.with.f <- which(sapply(gFacNames, function(gn) f %in% gn)) ## get the labels used for indicators in each group allLabels.L <- lapply(listLabels.L[groups.with.f], "[[", i = f) if (meanstructure) allLabels.I <- lapply(listLabels.I[groups.with.f], "[[", i = f) ## one group, one time --> no checks necessary if (length(groups.with.f) == 1L && !f %in% names(longFacKey)) { fxList <- c(fxList, make.FX.constraint(allLabels.L[[1]], "loadings")) if (meanstructure) { fxList <- c(fxList, make.FX.constraint(allLabels.I[[1]], "intercepts")) } } ## one group, multiple times if (length(groups.with.f) == 1L && f %in% names(longFacKey)) { ## this factor's name on all occasions LFN <- names(which(longFacKey == longFacKey[f])) ## count constraints on loadings across time allConstrained <- which(table(unlist(listLabels.L[[1]][LFN])) == length(LFN)) if (length(allConstrained)) { if (f == LFN[1]) { fxList <- c(fxList, make.FX.constraint(names(allConstrained), "loadings")) } } else { ## no constraints, each factor gets its own fxList <- c(fxList, make.FX.constraint(allLabels.L[[1]], "loadings")) } ## count constraints on intercepts across time if (meanstructure) { allConstrained <- which(table(unlist(listLabels.I[[1]][LFN])) == length(LFN)) if (length(allConstrained)) { if (f == LFN[1]) { fxList <- c(fxList, make.FX.constraint(names(allConstrained), "intercepts")) } } else { ## no constraints, each factor gets its own fxList <- c(fxList, make.FX.constraint(allLabels.I[[1]], "intercepts")) } } } ## multiple groups, one time if (length(groups.with.f) > 1L && !f %in% names(longFacKey)) { ## count constraints on loadings across groups allConstrained <- which(table(unlist(allLabels.L)) == length(groups.with.f)) if (length(allConstrained)) { fxList <- c(fxList, make.FX.constraint(names(allConstrained), "loadings")) } else { ## no constraints, each group gets its own for (g in groups.with.f) { fxList <- c(fxList, make.FX.constraint(allLabels.L[[g]], "loadings")) } } ## count constraints on intercepts across groups if (meanstructure) { allConstrained <- which(table(unlist(allLabels.I)) == length(groups.with.f)) if (length(allConstrained)) { fxList <- c(fxList, make.FX.constraint(names(allConstrained), "intercepts")) } else { ## no constraints, each group gets its own for (g in groups.with.f) { fxList <- c(fxList, make.FX.constraint(allLabels.I[[g]], "loadings")) } } } } ## multiple groups, multiple times: Constrain across any/all dimensions? if (length(groups.with.f) > 1L && f %in% names(longFacKey)) { ## This factor's name on all occasions LFN <- names(which(longFacKey == longFacKey[f])) ## Number of dimensions (number of groups times number of occasions). ## Assumes each occasion was measured in each group. nGT <- length(LFN)*length(groups.with.f) ## count constraints on loadings across both dimensions all.GL.Labels.L <- lapply(LFN, function(ff) { lapply(listLabels.L[groups.with.f], "[[", i = ff) }) all.GL.Constrained.L <- which(table(unlist(all.GL.Labels.L)) == nGT) if (length(all.GL.Constrained.L)) { if (f == LFN[1]) { fxList <- c(fxList, make.FX.constraint(names(all.GL.Constrained.L), "loadings")) } } else { if (f == LFN[1]) warning('No indicators of longitudinal factor "', longFacKey[f], '" have loadings constrained across all groups and all ', 'occasions, so the automatically generated syntax applies ', 'effects-code identification constraints separately for each', ' occasion and group. If at least 1 loading is constrained ', 'across either groups or occasions, the user should save the', ' syntax to manually reduce the number of identification ', 'constraints by applying them only to loadings constrained ', 'to equality across groups or occasions.') #TODO: update() method for (g in groups.with.f) { fxList <- c(fxList, make.FX.constraint(allLabels.L[[g]], "loadings")) } } ## count constraints on intercepts across both dimensions if (meanstructure) { all.GL.Labels.I <- lapply(LFN, function(ff) { lapply(listLabels.I[groups.with.f], "[[", i = ff) }) all.GL.Constrained.I <- which(table(unlist(all.GL.Labels.I)) == nGT) if (length(all.GL.Constrained.I)) { if (f == LFN[1]) { fxList <- c(fxList, make.FX.constraint(names(all.GL.Constrained.I), "intercepts")) } } else { if (f == LFN[1]) warning('No indicators of longitudinal factor "', longFacKey[f], '" have intercepts constrained across all groups and all ', 'occasions, so the automatically generated syntax applies ', 'effects-code identification constraints separately for each', ' occasion and group. If at least 1 loading is constrained ', 'across either groups or occasions, the user should save the', ' syntax to manually reduce the number of identification ', 'constraints by applying them only to intercepts constrained ', 'to equality across groups or occasions.') #TODO: update() method for (g in groups.with.f) { fxList <- c(fxList, make.FX.constraint(allLabels.I[[g]], "intercepts")) } } } } } # end loop over common factors #TODO: Implement effects-coding constraints for thresholds? # For each latent item-response, mean(thresholds) == 0, which # identifies intercepts, resolving the problem of effects-coding with # categorical indicators! # (i.e., constraining intercepts that == 0 to average 0 is redundant) } ## ------------- ## Return object ## ------------- out <- new("measEq.syntax", package = "lavaan", model.type = "cfa", call = mc, meanstructure = meanstructure, numeric = lavNames(lavTemplate, "ov.num"), ordered = lavNames(lavTemplate, "ov.ord"), parameterization = parameterization, specify = GLIST.specify, values = GLIST.values, labels = GLIST.labels, constraints = fxList, updates = list(values = data.frame(NULL), labels = data.frame(NULL)), ngroups = nG) if (return.fit) { if (inherits(configural.model, "lavaan")) { fit <- try(lavaan::update(configural.model, model = as.character(out), ...), silent = TRUE) } else if (inherits(configural.model, "lavaanList")) { configural.model@call$model <- as.character(out) configural.model@call$do.fit <- TRUE fit <- try(eval(configural.model@call, parent.frame()), silent = TRUE) } else { lavArgs$model <- as.character(out) lavArgs$do.fit <- TRUE fit <- try(do.call("cfa", lavArgs, envir = getNamespace("lavaan")), silent = TRUE) } ## check whether the model could be fit if (inherits(fit, "try-error")) { warning('The generated model syntax was not successfully fit to the ', 'data, and generated the following error message(s): \n\n', fit[1:length(fit)], "\n", "The measEq.syntax object was returned instead.") } else { fit@external$measEq.syntax <- out # save the syntax to the lavaan(.mi) object out <- fit # return the fitted lavaan(.mi) object } } out } ## ---------------- ## Hidden Functions ## ---------------- ## function to label a parameter by its location in a parameter matrix getLabel <- function(GLIST, parMat, RR, CC = 1L) { dn <- dimnames(GLIST[[parMat]]) out <- paste(parMat, which(dn[[1]] == RR), sep = ".") if (!parMat %in% c("alpha","nu")) out <- paste(out, which(dn[[2]] == CC), sep = "_") out } ## function to assemble a model constraint for effects-code identification make.FX.constraint <- function(parLabels, param) { nCon <- length(parLabels) conVal <- if (param == "loadings") nCon else 0 #TODO: algorithm for thresholds out <- paste0(parLabels[1], " == ", conVal) if (nCon > 1) out <- paste(c(out, parLabels[-1]), collapse = " - ") out } ## function to generate a character vector of lines of syntax (for as.character) write.lavaan.syntax <- function(pmat, specify, value, label) { nG <- length(specify) ## LOADINGS if (pmat == "lambda") { params <- "## LOADINGS:\n" for (fac in colnames(specify[[1]])) { for (ind in rownames(specify[[1]])) { if (!specify[[1]][ind, fac]) next if (nG > 1L) { params <- c(params, paste0(fac, " =~ c(", paste(sapply(value, "[", i = ind, j = fac), collapse = ", "), ")*", ind, " + c(", paste(sapply(label, "[", i = ind, j = fac), collapse = ", "), ")*", ind)) } else { params <- c(params, paste0(fac, " =~ ", value[[1]][ind, fac], "*", ind, " + ", label[[1]][ind, fac], "*", ind)) } } } return(c(params, "")) } ## THRESHOLDS if (pmat == "tau") { params <- sapply(rownames(specify[[1]]), function(th) { th.names <- strsplit(th, split = "|", fixed = TRUE)[[1]] if (nG > 1L) { param <- paste0(th.names[1], " | c(", paste(sapply(value, "[", i = th, j = 1), collapse = ", "), ")*", th.names[2], " + c(", paste(sapply(label, "[", i = th, j = 1), collapse = ", "), ")*", th.names[2]) } else { param <- paste0(th.names[1], " | ", value[[1]][th, 1], "*", th.names[2], " + ", label[[1]][th, 1], "*", th.names[2]) } param }) return(c("## THRESHOLDS:\n", params, "")) } ## INTERCEPTS or LATENT MEANS if (pmat %in% c("nu","alpha")) { ## specify all, so no need to check params <- sapply(rownames(specify[[1]]), function(x) { if (nG > 1L) { param <- paste0(x, " ~ c(", paste(sapply(value, "[", i = x, j = 1), collapse = ", "), ")*1 + c(", paste(sapply(label, "[", i = x, j = 1), collapse = ", "), ")*1") } else { param <- paste0(x, " ~ ", value[[1]][x, 1], "*1 + ", label[[1]][x, 1], "*1") } param }) if (pmat == "nu") params <- c("## INTERCEPTS:\n", params) if (pmat == "alpha") params <- c("## LATENT MEANS/INTERCEPTS:\n", params) return(c(params, "")) } ## SCALING FACTORS (delta) if (pmat == "delta") { ## specify any? spec.delta <- which(specify[[1]][ , 1]) if (length(spec.delta) == 0L) return(NULL) ## if so... params <- sapply(names(spec.delta), function(x) { if (nG > 1L) { param <- paste0(x, " ~*~ c(", paste(sapply(value, "[", i = x, j = 1), collapse = ", "), ")*", x) } else { param <- paste0(x, " ~*~ ", value[[1]][x, 1], "*", x) } param }) return(c("## SCALING FACTORS:\n", params, "")) } ## LATENT or RESIDUAL (CO)VARIANCES if (pmat %in% c("theta","psi")) { ## do diagonal first, then check for off-diagonal spec.vars <- which(diag(specify[[1]])) if (pmat == "psi") { params <- "## COMMON-FACTOR VARIANCES:\n" } else if (pmat == "theta" && length(spec.vars)) { params <- "## UNIQUE-FACTOR VARIANCES:\n" } else params <- character(0) ## variances if (length(spec.vars)) { params <- c(params, sapply(names(spec.vars), function(x) { if (nG > 1L) { param <- paste0(x, " ~~ c(", paste(sapply(value, function(j) diag(j)[x]), collapse = ", "), ")*", x, " + c(", paste(sapply(label, function(j) diag(j)[x]), collapse = ", "), ")*", x) } else { param <- paste0(x, " ~~ ", diag(value[[1]])[x], "*", x, " + ", diag(label[[1]])[x], "*", x) } param })) } ## covariances if (any(specify[[1]][lower.tri(specify[[1]], diag = FALSE)])) { if (pmat == "psi") params <- c(params, "\n## COMMON-FACTOR COVARIANCES:\n") if (pmat == "theta") params <- c(params, "\n## UNIQUE-FACTOR COVARIANCES:\n") } nn <- rownames(specify[[1]]) if (length(nn) > 1L) for (CC in 1:(length(nn) - 1)) { for (RR in (CC + 1):length(nn)) { if (!specify[[1]][RR, CC]) next if (nG > 1L) { params <- c(params, paste0(nn[CC], " ~~ c(", paste(sapply(value, "[", i = RR, j = CC), collapse = ", "), ")*", nn[RR], " + c(", paste(sapply(label, "[", i = RR, j = CC), collapse = ", "), ")*", nn[RR])) } else { params <- c(params, paste0(nn[CC], " ~~ ", value[[1]][RR, CC], "*", nn[RR], " + ", label[[1]][RR, CC], "*", nn[RR])) } } } return(c(params, "")) } ## out of options, should never get this far invisible(NULL) } #TODO: adapt routine to write Mplus MODEL statements and OpenMx RAM commands write.mplus.syntax <- function(object, group = 1, params = NULL) { out <- character() pmatList <- intersect(c("lambda","tau","nu", object@parameterization, "alpha","psi"), names(object@specify[[group]])) names(pmatList) <- c("loadings","thresholds","intercepts", ifelse(object@parameterization == "delta", "scales", "residuals"),"means","lv.variances") ## selected parameter types? if (!is.null(params)) { requested <- intersect(names(pmatList), params) if (!length(requested)) stop('invalid choice: params = c("', paste(params, collapse = '", "'), '")\n', 'Valid choices include: ', paste(names(pmatList), collapse = ", ")) pmatList <- pmatList[requested] } ## concatenate all latent-variable definitions if ("beta" %in% names(object@specify[[group]])) { specify.lambda <- rbind(object@specify[[group]]$lambda, object@specify[[group]]$beta) values.lambda <- rbind(object@values[[group]]$lambda, object@values[[group]]$beta) labels.lambda <- rbind(object@labels[[group]]$lambda, object@labels[[group]]$beta) } else { specify.lambda <- object@specify[[group]]$lambda values.lambda <- object@values[[group]]$lambda labels.lambda <- object@labels[[group]]$lambda } ## check for @ordered, define latent item-response factors, if (length(object@ordered)) { out <- c(out, "! Define LATENT ITEM-RESPONSES as factors", paste0("LIR", 1:length(object@ordered), " BY ", object@ordered, "@1; LIR", 1:length(object@ordered), "@0;")) for (i in seq_along(object@ordered)) { ## update rownames in Lambda #FIXME: update names in concatenated Lambda instead? idx <- which(rownames(object@specify[[group]]$lambda) == object@ordered[i]) rownames(specify.lambda)[idx] <- paste0("LIR", i) rownames(values.lambda)[ idx] <- paste0("LIR", i) rownames(labels.lambda)[ idx] <- paste0("LIR", i) ## update rownames in Nu idx <- which(rownames(object@specify[[group]]$nu) == object@ordered[i]) rownames(object@specify[[group]]$nu)[idx] <- paste0("LIR", i) rownames(object@values[[group]]$nu)[idx] <- paste0("LIR", i) rownames(object@labels[[group]]$nu)[idx] <- paste0("LIR", i) } } out <- c(out, "! FACTOR LOADINGS") ## shorten labels labels.lambda <- gsub(pattern = "lambda.", replacement = "L", x = labels.lambda, fixed = TRUE) labels.lambda <- gsub(pattern = ".g", replacement = "_", x = labels.lambda, fixed = TRUE) ## loop over factors for (fac in colnames(specify.lambda)) { out <- c(out, paste(fac, "BY")) ind <- names(which(specify.lambda[ , fac])) lastInd <- rev(ind)[1] for (i in ind) { val <- values.lambda[i, fac] out <- c(out, paste0(" ", i, if (is.na(val)) "*" else paste0("@", val), " (", labels.lambda[i, fac], ")", if (i == lastInd) ";" else "")) } } if ("tau" %in% pmatList) { out <- c(out, "! THRESHOLDS") ## find unique names to shorten labels allThrNames <- unique(do.call(c, lapply(object@labels, "[[", i = "tau"))) ## loop over ordinal indicators, specify set on a single line for (i in object@ordered) { iThr <- grep(paste0(i, "\\|"), rownames(object@labels[[group]]$tau)) specify <- object@specify[[group]]$tau[iThr, 1] #NOTE: These are now vectors values <- object@values[[ group]]$tau[iThr, 1] labels <- object@labels[[ group]]$tau[iThr, 1] ## identify unique parameter number among thresholds (for short labels) idx <- integer() for (lab in labels) idx <- c(idx, which(allThrNames == lab)) out <- c(out, paste0("[", i, "$", 1:length(iThr), ifelse(is.na(values), "", paste("@", values)), "] (T", idx, ");", collapse = " ")) } } ## INDICATOR-LEVEL PARAMETERS hasInts <- object@meanstructure hasResid <- length(object@numeric) || object@parameterization == "theta" hasScales <- length(object@ordered) && object@parameterization == "delta" ## assemble comment for this section if (sum(hasInts, hasResid, hasScales) == 3L) { out <- c(out, "! INDICATOR INTERCEPTS, RESIDUAL VARIANCES, & SCALING FACTORS") } else { element.names <- c("INTERCEPTS","RESIDUAL VARIANCES","SCALING FACTORS") element.tests <- c(hasInts, hasResid, hasScales) out <- c(out, paste0("! INDICATOR ", paste(element.names[element.tests], collapse = " and "))) } i.nu <- character() i.var <- character() ## Loop over indicators for (i in 1:nrow(object@specify[[group]]$lambda)) { LIR <- rownames(specify.lambda)[i] # LIR names RR <- rownames(object@specify[[group]]$lambda)[i] if (object@meanstructure) { ## INTERCEPTS N.val <- object@values[[group]]$nu[LIR, 1] ## shorten labels N.lab <- gsub(pattern = "nu.", replacement = "N", x = object@labels[[group]]$nu[LIR, 1], fixed = TRUE) N.lab <- gsub(pattern = ".g", replacement = "_", x = N.lab, fixed = TRUE) i.nu <- c(i.nu, paste0("[", LIR, ifelse(is.na(N.val), yes = "*", no = paste0("@", N.val)), "] (", N.lab, "); ")) } if (RR %in% object@ordered && object@parameterization == "delta") { ## SCALING FACTORS E.val <- object@values[[group]]$delta[RR, 1] E.lab <- "" i.var <- c(i.var, paste0("{", RR, ifelse(is.na(E.val), yes = "*", no = paste0("@", E.val)), "};")) } else { ## RESIDUAL VARIANCES E.val <- object@values[[group]]$theta[RR, RR] ## shorten labels E.lab <- gsub(pattern = "theta.", replacement = "E", x = object@labels[[group]]$theta[RR, RR], fixed = TRUE) E.lab <- gsub(pattern = ".g", replacement = "_", x = E.lab, fixed = TRUE) i.var <- c(i.var, paste0(RR, ifelse(is.na(E.val), yes = "*", no = paste0("@", E.val)), " (", E.lab, ");")) } } out <- c(out, paste(i.nu, i.var)) E.specify <- object@specify[[group]]$theta LT <- E.specify & lower.tri(E.specify, diag = FALSE) if (any(LT)) { out <- c(out, "! RESIDUAL COVARIANCES") E.values <- object@values[[group]]$theta ## shorten labels E.labels <- gsub(pattern = "theta.", replacement = "E", x = object@labels[[group]]$theta, fixed = TRUE) E.labels <- gsub(pattern = ".g", replacement = "_", x = E.labels, fixed = TRUE) for (CC in 1:(ncol(LT) - 1)) { if (!any(LT[ , CC])) next if (sum(LT[ , CC]) == 1L) { RR <- which(LT[ , CC]) out <- c(out, paste0(colnames(LT)[CC], " WITH ", rownames(LT)[RR], ifelse(is.na(E.values[RR, CC]), yes = "", no = paste("@", E.values[RR, CC])), " (", E.labels[RR, CC], ");")) next } ## else, there are multiple covariates with LT[CC] out <- c(out, paste(colnames(LT)[CC], "WITH")) ind <- names(which(LT[ , CC])) lastInd <- rev(ind)[1] for (RR in ind) { val <- E.values[RR, CC] out <- c(out, paste0(" ", RR, if (is.na(val)) "" else paste0("@", val), " (", E.labels[RR, CC], ")", if (RR == lastInd) ";" else "")) } } } ## FACTOR-LEVEL PARAMETERS out <- c(out, paste("! FACTOR", if (object@meanstructure) "INTERCEPTS &" else NULL, "(RESIDUAL) VARIANCES")) i.alpha <- character() i.psi <- character() ## Loop over factors for (i in rownames(object@specify[[group]]$psi)) { if (object@meanstructure) { ## INTERCEPTS A.val <- object@values[[group]]$alpha[i, 1] ## shorten labels A.lab <- gsub(pattern = "alpha.", replacement = "A", x = object@labels[[group]]$alpha[i, 1], fixed = TRUE) A.lab <- gsub(pattern = ".g", replacement = "_", x = A.lab, fixed = TRUE) i.alpha <- c(i.alpha, paste0("[", i, ifelse(is.na(A.val), yes = "*", no = paste0("@", A.val)), "] (", A.lab, "); ")) } ## RESIDUAL VARIANCES P.val <- object@values[[group]]$psi[i, i] ## shorten labels P.lab <- gsub(pattern = "psi.", replacement = "P", x = object@labels[[group]]$psi[i, i], fixed = TRUE) P.lab <- gsub(pattern = ".g", replacement = "_", x = P.lab, fixed = TRUE) i.psi <- c(i.psi, paste0(i, ifelse(is.na(P.val), yes = "", no = paste0("@", P.val)), " (", P.lab, ");")) } out <- c(out, paste(i.alpha, i.psi)) P.specify <- object@specify[[group]]$psi LT <- P.specify & lower.tri(P.specify, diag = FALSE) if (any(LT)) { out <- c(out, "! FACTOR COVARIANCES") P.values <- object@values[[group]]$psi ## shorten labels P.labels <- gsub(pattern = "psi.", replacement = "P", x = object@labels[[group]]$psi, fixed = TRUE) P.labels <- gsub(pattern = ".g", replacement = "_", x = P.labels, fixed = TRUE) for (CC in 1:(ncol(LT) - 1)) { if (!any(LT[ , CC])) next if (sum(LT[ , CC]) == 1L) { RR <- which(LT[ , CC]) out <- c(out, paste0(colnames(LT)[CC], " WITH ", rownames(LT)[RR], ifelse(is.na(P.values[RR, CC]), yes = "", no = paste("@", P.values[RR, CC])), " (", P.labels[RR, CC], ");")) next } ## else, there are multiple covariates with LT[CC] out <- c(out, paste(colnames(LT)[CC], "WITH")) ind <- names(which(LT[ , CC])) lastInd <- rev(ind)[1] for (RR in ind) { val <- P.values[RR, CC] out <- c(out, paste0(" ", RR, if (is.na(val)) "" else paste0("@", val), " (", P.labels[RR, CC], ")", if (RR == lastInd) ";" else "")) } } } ## MODEL CONSTRAINTs if (length(object@constraints) && group == object@ngroups) { con <- object@constraints con <- gsub("lambda.", "L", con) con <- gsub("theta.", "E", con) con <- gsub("psi.", "P", con) if (length(object@ordered)) for (th in object@labels[[group]]$tau[ , 1]) { con <- gsub(th, paste0("T", which(allThrNames == th)), con) } if (object@meanstructure) { con <- gsub("nu.", "N", con) con <- gsub("alpha.", "A", con) } con <- gsub(".g", "_", con) con <- gsub("==", "=", con) out <- c(out, "\nMODEL CONSTRAINT:", paste0(con, ";")) } #TODO: gsub = for ==, add ";", anything else? object@constraints, "") paste(out, collapse = "\n") } # write.OpenMx.syntax <- function(pmat, specify, value, label) {} ## function to allow users to customize syntax with update(), ## so they don't necessarily have to copy/paste a script to adapt it. override <- function(object, slotName = "values", group = 1L, matName, row, col, replacement) { stopifnot(inherits(object, "measEq.syntax")) MM <- methods::slot(object, slotName)[[group]] # only "values" or "labels" ## check indices if (is.character(row)) { if (! row %in% rownames(MM[[matName]])) stop("'", row, "' not found in rownames(", deparse(substitute(object)), "@", slotName, "[[", group, "]]$", matName, ")") } else if (is.numeric(row)) { if (! as.integer(row) %in% 1:nrow(MM[[matName]])) stop(as.integer(row), "' is outside the number of nrow(", deparse(substitute(object)), "@", slotName, "[[", group, "]]$", matName, ")") } else stop('row argument must be numeric/character indices') ## repeat for col if (matName %in% c("nu","alpha","delta","tau")) col <- 1L else { if (is.character(col)) { if (! col %in% colnames(MM[[matName]])) stop("'", col, "' not found in colnames(", deparse(substitute(object)), "@", slotName, "[[", group, "]]$", matName, ")") } else if (is.numeric(col)) { if (! as.integer(col) %in% 1:ncol(MM[[matName]])) stop(as.integer(col), "' is outside the number of ncol(", deparse(substitute(object)), "@", slotName, "[[", group, "]]$", matName, ")") } else stop('col argument must be numeric/character indices') } newM <- MM[[matName]] newM[row, col] <- replacement if (matName %in% c("theta","psi")) newM[col, row] <- replacement newM } ## function to assemble values/labels to update char2update <- function(object, model, return.object = TRUE) { stopifnot(inherits(object, "measEq.syntax")) stopifnot(inherits(model, "character")) PT <- lavaan::lavParseModelString(model, as.data.frame. = TRUE) indNames <- lapply(object@values, function(x) rownames(x$lambda)) # per block facNames <- lapply(object@values, function(x) colnames(x$lambda)) values <- PT$fixed labels <- PT$label ## check for multigroup specification of values/labels if (any(grepl(pattern = ";", x = values))) { values <- strsplit(values, split = ";") nValues <- sapply(values, length) } else nValues <- rep(1L, length(values)) if (any(grepl(pattern = ";", x = labels))) { labels <- strsplit(labels, split = ";") nLabels <- sapply(labels, length) } else nLabels <- rep(1L, length(labels)) nBlocks <- length(facNames) values.DF <- data.frame(NULL) labels.DF <- data.frame(NULL) for (RR in 1:nrow(PT)) { ## check whether numbers match if (nValues[RR] > 1L && nValues[RR] != nBlocks) { stop('Number of fixed/free values (', nValues[RR], ') specified for parameter "', PT$lhs[RR], PT$op[RR], PT$rhs[RR], '" does not match the number of groups (', nBlocks, ')') } if (nLabels[RR] > 1L && nLabels[RR] != nBlocks) { stop('Number of labels (', nLabels[RR], ') specified for parameter "', PT$lhs[RR], PT$op[RR], PT$rhs[RR], '" does not match the number of groups (', nBlocks, ')') } ## loop over blocks (currently only groups) for (BB in 1:nBlocks) { ## make template for values and labels, depending on parameter matrix ## INTERCEPTS if (PT$op[RR] == "~1" && PT$lhs[RR] %in% indNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "nu", row = PT$lhs[RR], col = "intercept") ## LATENT MEANS } else if (PT$op[RR] == "~1" && PT$lhs[RR] %in% facNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "alpha", row = PT$lhs[RR], col = "intercept") ## LOADINGS } else if (PT$op[RR] == "=~" && PT$rhs[RR] %in% indNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "lambda", row = PT$rhs[RR], col = PT$lhs[RR]) ## SECOND-ORDER LOADINGS } else if (PT$op[RR] == "=~" && PT$rhs[RR] %in% facNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "beta", row = PT$rhs[RR], col = PT$lhs[RR]) ## LATENT (CO)VARIANCES } else if (PT$op[RR] == "~~" && PT$rhs[RR] %in% facNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "psi", # symmetry handled in override row = PT$rhs[RR], col = PT$lhs[RR]) ## RESIDUAL (CO)VARIANCES } else if (PT$op[RR] == "~~" && PT$rhs[RR] %in% indNames[[BB]]) { DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "theta", # symmetry handled in override row = PT$rhs[RR], col = PT$lhs[RR]) ## THRESHOLDS } else if (PT$op[RR] == "|") { if (!length(object@ordered)) { warning('Thresholds ignored when no indicators are declared as ordered') } DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "tau", row = paste0(PT$lhs[RR], "|", PT$rhs[RR]), col = "threshold") ## SCALING FACTORS (delta parameters for latent item-responses) } else if (PT$op[RR] == "~*~") { if (!length(object@ordered)) { warning('Thresholds ignored when no indicators are declared as ordered') } if (object@parameterization == "theta") { warning('Latent-response scales (specified with the "~*~" operator) ', 'ignored when parameterization = "theta"') } if (PT$lhs[RR] != PT$rhs[RR]) { warning('Latent-response scales (specified with the "~*~" operator) ', 'ignored when left- and right-hand side do not match (', PT$lhs[RR], '~*~', PT$rhs[RR], ')') next } DF <- data.frame(stringsAsFactors = FALSE, group = BB, matName = "delta", row = PT$lhs[RR], col = "scales") } #FIXME? anything that does not match is simply ignored (no error messages) ## change labels? if (BB > 1L && nLabels[RR] == 1L) { if (labels[[RR]] != "") { labels.DF <- rbind(labels.DF, cbind(DF, stringsAsFactors = FALSE, replacement = labels[[RR]])) } } else if (labels[[RR]][BB] != "") { labels.DF <- rbind(labels.DF, cbind(DF, stringsAsFactors = FALSE, replacement = labels[[RR]][BB])) } ## change fixed/free values? if (BB > 1L && nValues[RR] == 1L) { if (values[[RR]] != "") { values.DF <- rbind(values.DF, cbind(DF, stringsAsFactors = FALSE, replacement = values[[RR]])) } } else if (values[[RR]][BB] != "") { values.DF <- rbind(values.DF, cbind(DF, stringsAsFactors = FALSE, replacement = values[[RR]][BB])) } } # end loop over blocks } # end loop over parameters ## make sure values are stored as numeric, not character if (nrow(values.DF)) { suppressWarnings(values.DF$replacement <- as.numeric(values.DF$replacement)) } if (return.object) { object@updates$values <- rbind(object@updates$values, values.DF) object@updates$labels <- rbind(object@updates$labels, labels.DF) return(object) } ## else return the list of data.frames with updates to make list(values = values.DF, labels = labels.DF) } semTools/R/loadingFromAlpha.R0000644000176200001440000000132514006342740015613 0ustar liggesusers### Sunthud Pornprasertmanit ### Last updated: 3 April 2017 #' Find standardized factor loading from coefficient alpha #' #' Find standardized factor loading from coefficient alpha assuming that all #' items have equal loadings. #' #' @param alpha A desired coefficient alpha value. #' @param ni A desired number of items. #' @return \item{result}{The standardized factor loadings that make desired #' coefficient alpha with specified number of items.} #' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) #' @examples #' #' loadingFromAlpha(0.8, 4) #' #' @export loadingFromAlpha <- function(alpha, ni) { denominator <- ni - ((ni - 1) * alpha) result <- sqrt(alpha/denominator) return(result) } semTools/R/quark.R0000644000176200001440000004626014764270116013546 0ustar liggesusers### Steven R. Chesnut, Danny Squire, Terrence D. Jorgensen ### Last updated: 12 March 2025 ##' Quark ##' ##' The `quark` function provides researchers with the ability to calculate ##' and include component scores calculated by taking into account the variance ##' in the original dataset and all of the interaction and polynomial effects of ##' the data in the dataset. ##' ##' The `quark` function calculates these component scores by first filling ##' in the data via means of multiple imputation methods and then expanding the ##' dataset by aggregating the non-overlapping interaction effects between ##' variables by calculating the mean of the interactions and polynomial ##' effects. The multiple imputation methods include one of iterative sampling ##' and group mean substitution and multiple imputation using a polytomous ##' regression algorithm (mice). During the expansion process, the dataset is ##' expanded to three times its normal size (in width). The first third of the ##' dataset contains all of the original data post imputation, the second third ##' contains the means of the polynomial effects (squares and cubes), and the ##' final third contains the means of the non-overlapping interaction effects. A ##' full principal componenent analysis is conducted and the individual ##' components are retained. The subsequent [combinequark()] function ##' provides researchers the control in determining how many components to ##' extract and retain. The function returns the dataset as submitted (with ##' missing values) and the component scores as requested for a more accurate ##' multiple imputation in subsequent steps. ##' ##' @param data The data frame is a required component for `quark`. In ##' order for `quark` to process a data frame, it must not contain any ##' factors or text-based variables. All variables must be in numeric format. ##' Identifiers and dates can be left in the data; however, they will need to be ##' identified under the `id` argument. ##' @param id Identifiers and dates within the dataset will need to be ##' acknowledged as `quark` cannot process these. By acknowledging the ##' identifiers and dates as a vector of column numbers or variable names, ##' `quark` will remove them from the data temporarily to complete its main ##' processes. Among many potential issues of not acknowledging identifiers and ##' dates are issues involved with imputation, product and polynomial effects, ##' and principal component analysis. ##' @param order Order is an optional argument provided by quark that can be ##' used when the imputation procedures in mice fail. Under some circumstances, ##' mice cannot calculate missing values due to issues with extreme missingness. ##' Should an error present itself stating a failure due to not having any ##' columns selected, set the argument `order = 2` in order to reorder the ##' imputation method procedure. Otherwise, use the default `order = 1`. ##' @param silent If `FALSE`, the details of the `quark` process are ##' printed. ##' @param \dots additional arguments to pass to [mice::mice()]. ##' ##' @return The output value from using the quark function is a list. It will ##' return a list with 7 components. ##' \item{ID Columns}{Is a vector of the identifier columns entered when ##' running quark.} ##' \item{ID Variables}{Is a subset of the dataset that contains the identifiers ##' as acknowledged when running quark.} ##' \item{Used Data}{Is a matrix / dataframe of the data provided by user as ##' the basis for quark to process.} ##' \item{Imputed Data}{Is a matrix / dataframe of the data after the multiple ##' method imputation process.} ##' \item{Big Matrix}{Is the expanded product and polynomial matrix.} ##' \item{Principal Components}{Is the entire dataframe of principal components ##' for the dataset. This dataset will have the same number of rows of the big ##' matrix, but will have 1 less column (as is the case with principal ##' component analyses).} ##' \item{Percent Variance Explained}{Is a vector of the percent variance ##' explained with each column of principal components.} ##' ##' @author Steven R. Chesnut (University of Southern Mississippi; ##' \email{Steven.Chesnut@@usm.edu}) ##' ##' Danny Squire (Texas Tech University) ##' ##' Terrence D. Jorgensen (University of Amsterdam) ##' ##' The PCA code is copied and modified from the `FactoMineR` package. ##' ##' @seealso [combinequark()] ##' ##' @references Howard, W. J., Rhemtulla, M., & Little, T. D. (2015). Using ##' Principal Components as Auxiliary Variables in Missing Data Estimation. ##' *Multivariate Behavioral Research, 50*(3), 285--299. ##' \doi{10.1080/00273171.2014.999267} ##' ##' @examples ##' ##' set.seed(123321) ##' ##' dat <- HolzingerSwineford1939[,7:15] ##' misspat <- matrix(runif(nrow(dat) * 9) < 0.3, nrow(dat)) ##' dat[misspat] <- NA ##' dat <- cbind(HolzingerSwineford1939[,1:3], dat) ##' \donttest{ ##' quark.list <- quark(data = dat, id = c(1, 2)) ##' ##' final.data <- combinequark(quark = quark.list, percent = 80) ##' ##' ## Example to rerun quark after imputation failure: ##' quark.list <- quark(data = dat, id = c(1, 2), order = 2) ##' } ##' ##' @export quark <- function(data, id, order = 1, silent = FALSE, ...){ if(!is.data.frame(data) && !is.matrix(data)) { stop("Inappropriate data file provided.") } if(!silent) cat("Data Check Passed.\n") if(is.character(id)) id <- match(id, colnames(data)) for(i in 1:length(id)){ if(id[i] > ncol(data) || id[i] < 1){ stop("At least one of the IDs is out of bounds.") } } if(!silent) cat("ID Check Passed.\n") if(!(order %in% 1:2)) stop("Currently, the order argument can take either 1 or 2.") final.collect <- list() final.collect$ID_Columns <- id final.collect$ID_Vars <- data[,id] final.collect$Used_Data <- data[,-c(id)] ##FIXME 26-June-2018: Terrence had to add a logical check for whether mice ## is installed, otherwise won't pass CRAN checks. checkMice <- requireNamespace("mice", quietly = TRUE) if (!checkMice) { message('The quark function requires the "mice" package to be installed.') return(invisible(NULL)) } final.collect$Imputed_Data <- imputequark(data = final.collect$Used_Data, order = order, silent = silent, ...) final.collect$Big_Data_Matrix <- bigquark(data = final.collect$Imputed_Data, silent = silent) cmp <- compquark(data = final.collect$Big_Data_Matrix, silent = silent) final.collect$Prin_Components <- cmp[[1]] final.collect$Prin_Components_Prcnt <- cmp[[2]] return(final.collect) } ##' Combine the results from the quark function ##' ##' This function builds upon the [quark()] function to provide a ##' final dataset comprised of the original dataset provided to ##' [quark()] and enough principal components to be able to account ##' for a certain level of variance in the data. ##' ##' ##' @param quark Provide the [quark()] object that was returned. It ##' should be a list of objects. Make sure to include it in its entirety. ##' @param percent Provide a percentage of variance that you would like to have ##' explained. That many components (columns) will be extracted and kept with ##' the output dataset. Enter this variable as a number WITHOUT a percentage ##' sign. ##' ##' @return The output of this function is the original dataset used in quark ##' combined with enough principal component scores to be able to account for ##' the amount of variance that was requested. ##' ##' @author Steven R. Chesnut (University of Southern Mississippi ##' \email{Steven.Chesnut@@usm.edu}) ##' ##' @seealso [quark()] ##' ##' @examples ##' ##' set.seed(123321) ##' dat <- HolzingerSwineford1939[,7:15] ##' misspat <- matrix(runif(nrow(dat) * 9) < 0.3, nrow(dat)) ##' dat[misspat] <- NA ##' dat <- cbind(HolzingerSwineford1939[,1:3], dat) ##' ##' quark.list <- quark(data = dat, id = c(1, 2)) ##' ##' final.data <- combinequark(quark = quark.list, percent = 80) ##' ##' @export combinequark <- function(quark, percent) { data <- cbind(quark$ID_Vars, quark$Used_Data) pct <- quark$Prin_Components_Prcnt comp <- quark$Prin_Components for (i in 1:length(pct)) { if(pct[i] >= percent) { num <- i break } } return(cbind(data, comp[,1:num])) } ## ---------------- ## Hidden Functions ## ---------------- imputequark <- function(data, order, silent = FALSE, ...){ if (order == 1){ data <- aImp(data = data, silent = silent, ...) data <- gImp(data = data, silent = silent) } else if(order == 2) { data <- gImp(data = data, silent = silent) if (length(which(is.na(data > 0)))) { data <- aImp(data = data, silent = silent, ...) } } return(data) } #' @importFrom stats cor gImp <- function(data, silent = FALSE) { imputed_data <- data num_adds <- vector(length = ncol(data)) # number of columns combined into one for averaging. data.cor <- cor(data, use = "pairwise", method = "pearson") class(data.cor) <- c("lavaan.matrix.symmetric","matrix") if (!silent) print(data.cor) #populate multiple matrices that can then be utilized to determine if one column should enhance another based upon #the correlations they share... if (!silent) cat("Imputing Column... \n") for (a in 1:ncol(data)) { temp_mat <- matrix(ncol = ncol(data), nrow = nrow(data)) list <- unique(sort(data[,a])) if (length(list) > 1 && length(list) <= 10) { for (b in 1:nrow(data)) { for (c in 1:length(list)) { if (data[b, a] == list[c] && !is.na(data[b,a])) { temp_mat[b,] <- round(colMeans(subset(data, data[ , a] == list[c]), na.rm = TRUE), digits = 1) } else if (is.na(data[b,a])) { for (p in 1:ncol(data)) temp_mat[b,p] <- data[b,p] } } } # Here I need to determine if the other columns are correlated enough with # the reference to ensure accuracy of predictions temp_cor <- data.cor[,a] # if (countNA(temp_cor)==0) { for (i in 1:length(temp_cor)) { if (i != a) { if (abs(temp_cor[i]) >= .5 && !is.na(temp_cor[i])) { # Using a moderate effect size, column a, will inform other columns. for (x in 1:nrow(imputed_data)){ imputed_data[x,i] <- sum(imputed_data[x,i], temp_mat[x,a], na.rm = TRUE) } num_adds[i] <- num_adds[i] + 1 } } } #} if (!silent) cat("\t", colnames(data)[a]) } } if (!silent) cat("\n") imputed_data <- cleanMat(m1 = data, m2 = imputed_data, impact = num_adds) imputed_data <- fixData(imputed_data) return(imputed_data) } cleanMat <- function(m1, m2, impact) { #Impact is the number of influences on each column... #We need to clean up and then try to determine what final values should be... #Go through each of the cells... new_mat <- m2 for (a in 1:ncol(m1)) { for (b in 1:nrow(m1)) { if (!is.na(m1[b,a])) { new_mat[b,a] <- m1[b,a] } else if (is.na(m1[b,a])) { new_mat[b,a] <- new_mat[b,a] / impact[a] } } } return(new_mat) } fixData <- function(data) { for (a in 1:ncol(data)) { for (b in 1:nrow(data)) { data[b,a] <- round(data[b,a], digits = 1) } } return(data) } aImp <- function(data, silent = FALSE, ...) { miceArgs <- list(...) miceArgs$data <- data miceArgs$maxit <- 1 miceArgs$m <- 1 miceArgs$printFlag <- !silent if (!("package:mice" %in% search())) attachNamespace("mice") if (!silent) cat("Starting Algorithm Imputation...\n") impData <- mice::complete(do.call("mice", miceArgs)) if (!silent) cat("Ending Algorithm Imputation...\n") return(impData) } bigquark <- function(data, silent = FALSE) { if (!silent) cat("Calculating Polynomial Effects.\n") poly <- ((data^2)+(data^3))/2 if (!silent) cat("Creating Matrix for Interaction Effects.\n") prod <- matrix(ncol=(ncol(data)-1),nrow=nrow(data)) if (!silent) cat("Calculating Interaction Effects...0%..") for (i in 1:nrow(data)) { if (!silent) printpct(percent = i/nrow(data)) for (j in 1:(ncol(data)-1)) { prod[i,j] <- mean(as.numeric(data[i,j])*as.numeric(data[i,(j+1):ncol(data)])) } } cat("\n") data <- cbind(data,poly,prod) return(data) } compquark <- function(data, silent = FALSE) { if (!silent) cat("Calculating values for the PCA\n") pcam <- pcaquark(data, ncp = ncol(data)) cmp <- list() cmp$pca <- pcam$ind$coord cmp$var <- pcam$eig[,3] colnames(cmp$pca) <- c(paste0("AuxVar",1:ncol(cmp$pca))) return(cmp) } printpct <- function(percent) { if (round(percent, digits = 10) == 0) cat("0%..") if (round(percent, digits = 10) == .10) cat("10%..") if (round(percent, digits = 10) == .20) cat("20%..") if (round(percent, digits = 10) == .30) cat("30%..") if (round(percent, digits = 10) == .40) cat("40%..") if (round(percent, digits = 10) == .50) cat("50%..") if (round(percent, digits = 10) == .60) cat("60%..") if (round(percent, digits = 10) == .70) cat("70%..") if (round(percent, digits = 10) == .80) cat("80%..") if (round(percent, digits = 10) == .90) cat("90%..") if (round(percent, digits = 10) == 1) cat("100%..") } ## This function is modified from the FactoMinoR package. pcaquark <- function(X, ncp = 5) { moy.p <- function(V, poids) res <- sum(V * poids)/sum(poids) ec <- function(V, poids) res <- sqrt(sum(V^2 * poids)/sum(poids)) X <- as.data.frame(X) if (any(is.na(X))) { warnings("Missing values are imputed by the mean of the variable: you should use the imputePCA function of the missMDA package") X[is.na(X)] <- matrix(apply(X,2,mean,na.rm=TRUE),ncol=ncol(X),nrow=nrow(X),byrow=TRUE)[is.na(X)] } if (is.null(rownames(X))) rownames(X) <- 1:nrow(X) if (is.null(colnames(X))) colnames(X) <- paste("V", 1:ncol(X), sep = "") colnames(X)[colnames(X) == ""] <- paste("V", 1:sum(colnames(X)==""),sep="") rownames(X)[is.null(rownames(X))] <- paste("row",1:sum(rownames(X)==""),sep="") Xtot <- X if (any(!sapply(X, is.numeric))) { auxi <- NULL for (j in 1:ncol(X)) if (!is.numeric(X[, j])) auxi <- c(auxi, colnames(X)[j]) stop(paste("\nThe following variables are not quantitative: ", auxi)) } ncp <- min(ncp, nrow(X) - 1, ncol(X)) row.w <- rep(1, nrow(X)) row.w.init <- row.w row.w <- row.w/sum(row.w) col.w <- rep(1, ncol(X)) centre <- apply(X, 2, moy.p, row.w) X <- as.matrix(sweep(as.matrix(X), 2, centre, FUN = "-")) ecart.type <- apply(X, 2, ec, row.w) ecart.type[ecart.type <= 1e-16] <- 1 X <- sweep(as.matrix(X), 2, ecart.type, FUN = "/") dist2.ind <- apply(sweep(X,2,sqrt(col.w),FUN="*")^2,1,sum) dist2.var <- apply(sweep(X,1,sqrt(row.w),FUN="*")^2,2,sum) tmp <- svd.triplet.quark(X, row.w = row.w, col.w = col.w, ncp = ncp) eig <- tmp$vs^2 vp <- as.data.frame(matrix(NA, length(eig), 3)) rownames(vp) <- paste("comp", 1:length(eig)) colnames(vp) <- c("eigenvalue","percentage of variance", "cumulative percentage of variance") vp[, "eigenvalue"] <- eig vp[, "percentage of variance"] <- (eig/sum(eig)) * 100 vp[, "cumulative percentage of variance"] <- cumsum(vp[, "percentage of variance"]) V <- tmp$V U <- tmp$U eig <- eig[1:ncp] coord.ind <- sweep(as.matrix(U), 2, sqrt(eig), FUN = "*") coord.var <- sweep(as.matrix(V), 2, sqrt(eig), FUN = "*") contrib.var <- sweep(as.matrix(coord.var^2), 2, eig, "/") contrib.var <- sweep(as.matrix(contrib.var), 1, col.w, "*") dist2 <- dist2.var cor.var <- sweep(as.matrix(coord.var), 1, sqrt(dist2), FUN = "/") cos2.var <- cor.var^2 rownames(coord.var) <- rownames(cos2.var) <- rownames(cor.var) <- rownames(contrib.var) <- colnames(X) colnames(coord.var) <- colnames(cos2.var) <- colnames(cor.var) <- colnames(contrib.var) <- paste("Dim", c(1:ncol(V)), sep = ".") res.var <- list(coord = coord.var[, 1:ncp], cor = cor.var[, 1:ncp], cos2 = cos2.var[, 1:ncp], contrib = contrib.var[, 1:ncp] * 100) dist2 <- dist2.ind cos2.ind <- sweep(as.matrix(coord.ind^2), 1, dist2, FUN = "/") contrib.ind <- sweep(as.matrix(coord.ind^2), 1, row.w/sum(row.w), FUN = "*") contrib.ind <- sweep(as.matrix(contrib.ind), 2, eig, FUN = "/") rownames(coord.ind) <- rownames(cos2.ind) <- rownames(contrib.ind) <- names(dist2) <- rownames(X) colnames(coord.ind) <- colnames(cos2.ind) <- colnames(contrib.ind) <- paste("Dim", c(1:ncol(U)), sep = ".") res.ind <- list(coord = coord.ind[, 1:ncp], cos2 = cos2.ind[, 1:ncp], contrib = contrib.ind[, 1:ncp] * 100, dist = sqrt(dist2)) res <- list(eig = vp, var = res.var, ind = res.ind, svd = tmp) class(res) <- c("PCA", "list") return(res) } ## This function is modified from the FactoMinoR package. svd.triplet.quark <- function (X, row.w = NULL, col.w = NULL, ncp = Inf) { tryCatch.W.E <- function(expr) { ## function proposed by Maechlmr W <- NULL w.handler <- function(w) { # warning handler W <<- w invokeRestart("muffleWarning") } list(value = withCallingHandlers(tryCatch(expr, error = function(e) e), warning = w.handler), warning = W) } ncp <- min(ncp,nrow(X)-1,ncol(X)) row.w <- row.w / sum(row.w) X <- sweep(X, 2, sqrt(col.w), FUN = "*") X <- sweep(X, 1, sqrt(row.w), FUN = "*") if (ncol(X) < nrow(X)) { svd.usuelle <- tryCatch.W.E(svd(X, nu = ncp, nv = ncp))$val if (names(svd.usuelle)[[1]] == "message") { svd.usuelle <- tryCatch.W.E(svd(t(X), nu = ncp, nv = ncp))$val if (names(svd.usuelle)[[1]] == "d") { aux <- svd.usuelle$u svd.usuelle$u <- svd.usuelle$v svd.usuelle$v <- aux } else { bb <- eigen(t(X) %*% X, symmetric = TRUE) svd.usuelle <- vector(mode = "list", length = 3) svd.usuelle$d[svd.usuelle$d < 0] <- 0 svd.usuelle$d <- sqrt(svd.usuelle$d) svd.usuelle$v <- bb$vec[,1:ncp] svd.usuelle$u <- sweep(X %*% svd.usuelle$v, 2, svd.usuelle$d[1:ncp], FUN = "/") } } U <- svd.usuelle$u V <- svd.usuelle$v if (ncp > 1) { mult <- sign(apply(V, 2, sum)) mult[mult == 0] <- 1 U <- sweep(U, 2, mult, FUN = "*") V <- sweep(V, 2, mult, FUN = "*") } U <- sweep(as.matrix(U), 1, sqrt(row.w), FUN = "/") V <- sweep(as.matrix(V), 1, sqrt(col.w), FUN = "/") } else { svd.usuelle <- tryCatch.W.E(svd(t(X), nu = ncp, nv = ncp))$val if (names(svd.usuelle)[[1]] == "message") { svd.usuelle <- tryCatch.W.E(svd(X, nu = ncp, nv = ncp))$val if (names(svd.usuelle)[[1]] == "d") { aux <- svd.usuelle$u svd.usuelle$u <- svd.usuelle$v svd.usuelle$v <- aux } else { bb <- eigen(X%*%t(X),symmetric=TRUE) svd.usuelle <- vector(mode = "list", length = 3) svd.usuelle$d[svd.usuelle$d < 0] <- 0 svd.usuelle$d <- sqrt(svd.usuelle$d) svd.usuelle$v <- bb$vec[,1:ncp] svd.usuelle$u <- sweep(t(X) %*% svd.usuelle$v, 2, svd.usuelle$d[1:ncp], FUN = "/") } } U <- svd.usuelle$v V <- svd.usuelle$u mult <- sign(apply(V, 2, sum)) mult[mult == 0] <- 1 V <- sweep(V, 2, mult, FUN = "*") U <- sweep(U, 2, mult, FUN = "*") U <- sweep(U, 1, sqrt(row.w), FUN = "/") V <- sweep(V, 1, sqrt(col.w), FUN = "/") } vs <- svd.usuelle$d[1:min(ncol(X), nrow(X) - 1)] num <- which(vs[1:ncp] < 1e-15) if (length(num)==1) { U[,num] <- U[,num] * vs[num] V[,num] <- V[,num] * vs[num] } if (length(num) > 1) { U[,num] <- sweep(U[,num], 2, vs[num], FUN = "*") V[,num] <- sweep(V[,num], 2, vs[num], FUN = "*") } res <- list(vs = vs, U = U, V = V) return(res) } semTools/R/TSML.R0000644000176200001440000006702514753125033013177 0ustar liggesusers## Terrence D. Jorgensen ### Last updated: 12 February 2025 ### semTools function to implement 2-stage ML ## ----------------- ## Class and Methods ## ----------------- ##' Class for the Results of 2-Stage Maximum Likelihood (TSML) Estimation for ##' Missing Data ##' ##' This class contains the results of 2-Stage Maximum Likelihood (TSML) ##' estimation for missing data. The `summary`, `anova`, `vcov` ##' methods return corrected *SE*s and test statistics. Other methods are ##' simply wrappers around the corresponding [lavaan::lavaan-class] ##' methods. ##' ##' ##' @name twostage-class ##' @aliases twostage-class show,twostage-method summary,twostage-method ##' anova,twostage-method vcov,twostage-method coef,twostage-method ##' fitted.values,twostage-method fitted,twostage-method ##' residuals,twostage-method resid,twostage-method nobs,twostage-method ##' @docType class ##' ##' @slot saturated A fitted [lavaan::lavaan-class] object containing the ##' saturated model results ##' @slot target A fitted [lavaan::lavaan-class] object containing the ##' target/hypothesized model results ##' @slot baseline A fitted [lavaan::lavaan-class] object containing the ##' baseline/null model results ##' @slot auxNames A character string (potentially of `length == 0`) of any ##' auxiliary variable names, if used ##' ##' @param object An object of class `twostage`. ##' @param ... arguments passed to [lavaan::parameterEstimates()]. ##' @param h1 An object of class `twostage` in which `object` is ##' nested, so that their difference in fit can be tested using ##' `anova` (see **Value** section for details). ##' @param baseline `logical` indicating whether to return results for the ##' baseline model, rather than the default target (hypothesized) model. ##' @param type The meaning of this argument varies depending on which method it ##' it used for. Find detailed descriptions in the **Value** section ##' under `coef`, `nobs`, and `residuals`. ##' @param model `character` naming the slot for which to return the ##' model-implied sample moments (see `fitted.values` description.) ##' @param labels `logical` indicating whether the model-implied sample ##' moments should have (row/column) labels. ##' ##' @return ##' \item{show}{`signature(object = "twostage"):` The `show` function ##' is used to display the results of the `anova` method, as well as the ##' header of the (uncorrected) target model results.} ##' \item{summary}{`signature(object = "twostage", ...):` The summary ##' function prints the same information from the `show` method, but also ##' provides (and returns) the output of ##' `parameterEstimates(object@target, ...)` with corrected ##' *SE*s, test statistics, and confidence intervals. Additional ##' arguments can be passed to [lavaan::parameterEstimates()], ##' including `fmi = TRUE` to provide an estimate of the fraction of ##' missing information.} ##' \item{anova}{`signature(object = "twostage", h1 = NULL, baseline = FALSE):` ##' The `anova` function returns the residual-based \eqn{\chi^2} test ##' statistic result, as well as the scaled \eqn{\chi^2} test statistic result, ##' for the model in the `target` slot, or for the model in the ##' `baseline` slot if `baseline = TRUE`. The user can also provide ##' a single additional `twostage` object to the `h1` argument, in ##' which case `anova` returns residual-based and scaled ##' (\eqn{\Delta})\eqn{\chi^2} test results, under the assumption that the ##' models are nested. The models will be automatically sorted according their ##' degrees of freedom.} ##' \item{nobs}{`signature(object = "twostage", ##' type = c("ntotal", "ngroups", "n.per.group", "norig", "patterns", "coverage")):` ##' The `nobs` function will return the total sample sized used in the ##' analysis by default. Also available are the number of groups or the sample ##' size per group, the original sample size (if any rows were deleted because ##' all variables were missing), the missing data patterns, and the matrix of ##' coverage (diagonal is the proportion of sample observed on each variable, ##' and off-diagonal is the proportion observed for both of each pair of ##' variables).} ##' \item{coef}{`signature(object = "twostage", type = c("free", "user")):` ##' This is simply a wrapper around the corresponding ##' [lavaan::lavaan-class] method, providing point estimates from the ##' `target` slot.} ##' \item{vcov}{`signature(object = "twostage", baseline = FALSE):` Returns ##' the asymptotic covariance matrix of the estimated parameters (corrected for ##' additional uncertainty due to missing data) for the model in the ##' `target` slot, or for the model in the `baseline` slot if ##' `baseline = TRUE`.} ##' \item{fitted.values, fitted}{`signature(object = "twostage", ##' model = c("target", "saturated", "baseline")):` This is simply a wrapper ##' around the corresponding [lavaan::lavaan-class] method, providing ##' model-implied sample moments from the slot specified in the `model` ##' argument.} ##' \item{residuals, resid}{`signature(object = "twostage", type = c("raw", ##' "cor", "normalized", "standardized")):` This is simply a wrapper around the ##' corresponding [lavaan::lavaan-class] method, providing residuals of ##' the specified `type` from the `target` slot.} ##' ##' @section Objects from the Class: Objects can be created via the ##' [twostage()] function. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [twostage()] ##' ##' @examples ##' ##' # See the example from the twostage function ##' setClass("twostage", slots = c(saturated = "lavaan", target = "lavaan", baseline = "lavaan", auxNames = "character")) ##' @rdname twostage-class ##' @aliases show,twostage-method ##' @export setMethod("show", "twostage", function(object) { ## show chi-squared test results cat("Chi-squared test(s) results, ADJUSTED for missing data:\n\n") getMethod("anova", "twostage")(object) cat("\n\nChi-squared test results, UNADJUSTED for missing data:\n\n") show(object@target) invisible(object) }) ##' @rdname twostage-class ##' @aliases summary,twostage-method ##' @importFrom stats pnorm qnorm ##' @importFrom lavaan parTable ##' @export setMethod("summary", "twostage", function(object, ...) { ## show chi-squared test results AND estimates getMethod("show", "twostage")(object) cat("\n\nParameter Estimates, with SEs (and tests/CIs) ADJUSTED for missing data:\n\n") dots <- list(...) if (!"fmi" %in% names(dots)) dots$fmi <- FALSE if (!"ci" %in% names(dots)) dots$ci <- TRUE if (!"level" %in% names(dots)) dots$level <- .95 PT <- parTable(object@target) PT <- PT[PT$group > 0, ] PE <- do.call(lavaan::parameterEstimates, c(dots, object = object@target)) SEs <- sqrt(diag(getMethod("vcov", "twostage")(object))) PE$se[PT$free > 0] <- SEs[PT$free] PE$z[PT$free > 0] <- PE$est[PT$free > 0] / PE$se[PT$free > 0] PE$pvalue[PT$free > 0] <- pnorm(abs(PE$z[PT$free > 0]), lower.tail = FALSE)*2 if (dots$ci) { crit <- qnorm(1 - (1 - dots$level) / 2) PE$ci.lower[PT$free > 0] <- PE$est[PT$free > 0] - crit * PE$se[PT$free > 0] PE$ci.upper[PT$free > 0] <- PE$est[PT$free > 0] + crit * PE$se[PT$free > 0] } if (dots$fmi) { compVar <- diag(lavaan::vcov(object@target))[PT$free] # uncorrected Stage-2 SE estimates # compFit <- lavaan::update(object@target, sample.nobs = lavaan::nobs(object@target), # sample.cov = lavInspect(object@target, "cov.ov"), # sample.mean = lavInspect(object@target, "mean.ov")) # compVar <- diag(lavaan::vcov(compFit))[PT$free] missVar <- SEs^2 PE$fmi[PT$free > 0] <- 1 - compVar / missVar } PE }) ## (hidden) function utilized by vcov and anova methods ##' @importFrom lavaan lavInspect parTable twostageMatrices <- function(object, baseline) { SLOT <- if (baseline) "baseline" else "target" ## extract parameter table to isolate estimates by group PTsat <- parTable(object@saturated) nG <- max(PTsat$group) isMG <- nG > 1L ## model derivatives delta <- lavInspect(slot(object, SLOT), "delta") if (!isMG) delta <- list(delta) for (g in 1:nG) { covparams <- grep(pattern = "~~", x = rownames(delta[[g]])) meanparams <- grep(pattern = "~1", x = rownames(delta[[g]])) delta[[g]] <- delta[[g]][c(covparams, meanparams), ] } ## stack groups' deltas into 1 matrix delta <- do.call(rbind, delta) ## extract estimated moments from saturated model, and number of moments satSigma <- lavInspect(object@saturated, "cov.ov") satMu <- lavInspect(object@saturated, "mean.ov") if (!isMG) { satSigma <- list(satSigma) satMu <- list(satMu) } if (length(object@auxNames)) { an <- object@auxNames tn <- lavaan::lavNames(slot(object, SLOT)) for (g in 1:nG) { satSigma[[g]] <- satSigma[[g]][tn, tn] satMu[[g]] <- satMu[[g]][tn] } } p <- length(satMu[[1]]) pStar <- p*(p + 1) / 2 ## extract model-implied moments muHat <- lavInspect(slot(object, SLOT), "mean.ov") sigmaHat <- lavInspect(slot(object, SLOT), "cov.ov") if (!isMG) { sigmaHat <- list(sigmaHat) muHat <- list(muHat) } shinv <- list() for (g in 1:nG) { muHat[[g]] <- muHat[[g]][names(satMu[[g]])] sigmaHat[[g]] <- sigmaHat[[g]][rownames(satSigma[[g]]), colnames(satSigma[[g]])] shinv[[g]] <- solve(sigmaHat[[g]]) } ## assemble complete-data information matrix H <- list() for (g in 1:nG) H[[g]] <- matrix(0, (pStar + p), (pStar + p)) # if (lavInspect(slot(object, SLOT), "options")$estimator == "expected") { if (TRUE) { ## complete-data expected information (Savalei, 2010, Eq. 6; Savalei & Bentler, 2009, Eq. 7) for (g in 1:nG) { H[[g]][1:pStar, 1:pStar] <- .5*lavaan::lav_matrix_duplication_pre_post(shinv[[g]] %x% shinv[[g]]) H[[g]][(pStar + 1):(pStar + p), (pStar + 1):(pStar + p)] <- shinv[[g]] } } else { ## information == "observed" (Savalei, 2010, Eq. 5) dMu <- list() for (g in 1:nG) { dMu[[g]] <- satMu[[g]] - muHat[[g]] H[[g]][1:pStar, 1:pStar] <- lavaan::lav_matrix_duplication_pre_post(shinv[[g]] %x% (shinv[[g]] %*% (satSigma[[g]] + dMu[[g]] %*% t(dMu[[g]])) %*% shinv[[g]] - .5*shinv[[g]])) H[[g]][(pStar + 1):(pStar + p), 1:pStar] <- lavaan::lav_matrix_duplication_post(shinv[[g]] %x% (t(dMu[[g]]) %*% shinv[[g]])) H[[g]][1:pStar, (pStar + 1):(pStar + p)] <- t(H[[g]][(pStar + 1):(pStar + p), 1:pStar]) H[[g]][(pStar + 1):(pStar + p), (pStar + 1):(pStar + p)] <- shinv[[g]] } } ## combine into 1 block-diagonal matrix H <- do.call(lavaan::lav_matrix_bdiag, H) ## asymptotic information and covariance matrices of target model satACOV <- lavaan::vcov(object@saturated) #FIXME: inverting this is NOT equivalent to satInfo <- solve(satACOV * lavaan::nobs(object@saturated)) # weighing by first-order info ## all(round(acov*N, 8) == round(solve(info), 8)) ## all(round(acov, 8) == round(solve(info)/N, 8)) if (length(object@auxNames)) { dimTar <- !(PTsat$lhs %in% an | PTsat$rhs %in% an) dimAux <- PTsat$lhs %in% an | PTsat$rhs %in% an infoTar <- satInfo[dimTar, dimTar] infoAux <- satInfo[dimAux, dimAux] infoAT <- satInfo[dimAux, dimTar] satInfo <- infoTar - t(infoAT) %*% solve(infoAux) %*% infoAT satACOV <- solve(satInfo) / lavaan::nobs(object@saturated) } list(delta = delta, H = H, satACOV = satACOV, satInfo = satInfo) } ## (hidden?) function utilized by anova method to test 1 or 2 models ##' @importFrom stats pchisq ##' @importFrom lavaan lavInspect twostageLRT <- function(object, baseline, print = FALSE) { SLOT <- if (baseline) "baseline" else "target" ## calculate model derivatives and complete-data information matrix MATS <- twostageMatrices(object, baseline) ## residual-based statistic (Savalei & Bentler, 2009, eq. 8) N <- lavaan::nobs(slot(object, SLOT)) nG <- lavInspect(slot(object, SLOT), "ngroups") res <- lavaan::residuals(slot(object, SLOT)) if (nG == 1L) res <- list(res) etilde <- do.call(c, lapply(res, function(x) c(lavaan::lav_matrix_vech(x$cov), x$mean))) ID <- MATS$satInfo %*% MATS$delta T.res <- N*t(etilde) %*% (MATS$satInfo - ID %*% MASS::ginv(t(MATS$delta) %*% ID) %*% t(ID)) %*% etilde # FIXME: why not solve()? DF <- lavInspect(slot(object, SLOT), "fit")[["df"]] pval.res <- pchisq(T.res, df = DF, lower.tail = FALSE) residual <- c(chisq = T.res, df = DF, pvalue = pval.res) class(residual) <- c("lavaan.vector","numeric") ## scaled test statistic (Savalei & Bentler, 2009, eq. 9) meat <- MATS$H %*% MATS$delta bread <- MASS::ginv(t(MATS$delta) %*% meat) # FIXME: why not solve()? cc <- DF / sum(diag(N*MATS$satACOV %*% (MATS$H - meat %*% bread %*% t(meat)))) chisq <- lavaan::lavTest(slot(object, SLOT))$stat T.scaled <- cc * chisq pval.scaled <- pchisq(T.scaled, df = DF, lower.tail = FALSE) scaled <- c(chisq.naive = chisq, scaling.factor = 1 / cc, chisq.scaled = T.scaled, df = DF, pvalue = pval.scaled) class(scaled) <- c("lavaan.vector","numeric") ## return both statistics if (print) { if (lavInspect(object@saturated, "options")$se == "standard") { cat("Browne (1984) residual-based test statistic:\n\n") print(residual) } cat("\n\nSatorra-Bentler (2001) scaled test statistic:\n\n") print(scaled) } invisible(list(residual = residual, scaled = scaled)) } ##' @rdname twostage-class ##' @aliases anova,twostage-method ##' @importFrom lavaan lavInspect ##' @export setMethod("anova", "twostage", function(object, h1 = NULL, baseline = FALSE) { if (is.null(h1)) { return(twostageLRT(object, baseline, print = TRUE)) } H0 <- twostageLRT(object, baseline = FALSE) H1 <- twostageLRT(h1, baseline = FALSE) DF0 <- H0$residual[["df"]] DF1 <- H1$residual[["df"]] if (DF0 == DF1) stop("Models have the same degrees of freedom.") if (min(c(DF0, DF1)) == 0L) return(twostageLRT(object, baseline, print = TRUE)) parent <- which.min(c(DF0, DF1)) if (parent == 1L) { parent <- H0 H0 <- H1 H1 <- parent DF0 <- H0$residual[["df"]] DF1 <- H1$residual[["df"]] } DF <- DF0 - DF1 ## residual-based statistic T.res <- H0$residual[["chisq"]] - H1$residual[["chisq"]] residual <- c(chisq = T.res, df = DF, pvalue = pchisq(T.res, df = DF, lower.tail = FALSE)) class(residual) <- c("lavaan.vector","numeric") ## scaled test statistic chisq.naive <- H0$scaled[["chisq.naive"]] - H1$scaled[["chisq.naive"]] cc <- (DF0*H0$scaled[["scaling.factor"]] - DF1*H1$scaled[["scaling.factor"]]) / DF if (cc < 0) { warning("Scaling factor is negative, so it was set to missing.") cc <- NA } scaled <- c(chisq.naive = chisq.naive, scaling.factor = cc, chisq.scaled = chisq.naive / cc, DF = DF, pvalue = pchisq(chisq.naive / cc, df = DF, lower.tail = FALSE)) class(scaled) <- c("lavaan.vector","numeric") ## return both statistics if (lavInspect(object@saturated, "options")$se == "standard") { cat("Difference test for Browne (1984) residual-based statistics:\n\n") print(residual) } cat("\n\nSatorra-Bentler (2001) scaled difference test:\n\n") print(scaled) invisible(list(residual = residual, scaled = scaled)) }) ##' @rdname twostage-class ##' @aliases nobs,twostage-method ##' @importFrom lavaan lavInspect ##' @export setMethod("nobs", "twostage", function(object, type = c("ntotal","ngroups","n.per.group","norig", "patterns","coverage")) { type <- type[1] if (type == "n.per.group") type <- "nobs" lavInspect(object@saturated, what = type) }) ##' @rdname twostage-class ##' @aliases coef,twostage-method ##' @export setMethod("coef", "twostage", function(object, type = c("free","user")) { type <- type[1] lavaan::coef(object@target, type = type) }) ##' @rdname twostage-class ##' @aliases vcov,twostage-method ##' @export setMethod("vcov", "twostage", function(object, baseline = FALSE) { SLOT <- if (baseline) "baseline" else "target" ## calculate model derivatives and complete-data information matrix MATS <- twostageMatrices(object, baseline) meat <- MATS$H %*% MATS$delta bread <- MASS::ginv(t(MATS$delta) %*% meat) # FIXME: why not solve()? out <- bread %*% t(meat) %*% MATS$satACOV %*% meat %*% bread class(out) <- c("lavaan.matrix.symmetric","matrix") if (baseline) { rownames(out) <- names(getMethod("coef", "lavaan")(object@baseline)) } else { rownames(out) <- names(getMethod("coef", "twostage")(object)) } colnames(out) <- rownames(out) out }) ##' @rdname twostage-class ##' @aliases fitted.values,twostage-method ##' @export setMethod("fitted.values", "twostage", function(object, model = c("target","saturated","baseline"), type = "moments", labels = TRUE) { model <- model[1] lavaan::fitted.values(slot(object, model), type = type, labels = labels) }) ##' @rdname twostage-class ##' @aliases fitted,twostage-method ##' @export setMethod("fitted", "twostage", function(object, model = c("target","saturated","baseline"), type = "moments", labels = TRUE) { model <- model[1] lavaan::fitted.values(slot(object, model), type = type, labels = labels) }) ##' @rdname twostage-class ##' @aliases residuals,twostage-method ##' @export setMethod("residuals", "twostage", function(object, type = c("raw","cor","normalized","standardized")) { type <- type[1] lavaan::residuals(object@target, type = type) }) ##' @rdname twostage-class ##' @aliases resid,twostage-method ##' @export setMethod("resid", "twostage", function(object, type = c("raw","cor","normalized","standardized")) { type <- type[1] lavaan::residuals(object@target, type = type) }) # fitS <- cfa(model = model, data = dat1, missing = "fiml", se = "standard") # fitR <- cfa(model = model, data = dat1, missing = "fiml", se = "robust.huber.white") # all(lavInspect(fitS, "information") == lavInspect(fitR, "information")) # all(vcov(fitS) == vcov(fitR)) ## --------------------- ## Constructor Functions ## --------------------- ##' Fit a lavaan model using 2-Stage Maximum Likelihood (TSML) estimation for ##' missing data. ##' ##' This function automates 2-Stage Maximum Likelihood (TSML) estimation, ##' optionally with auxiliary variables. Step 1 involves fitting a saturated ##' model to the partially observed data set (to variables in the hypothesized ##' model as well as auxiliary variables related to missingness). Step 2 ##' involves fitting the hypothesized model to the model-implied means and ##' covariance matrix (also called the "EM" means and covariance matrix) as if ##' they were complete data. Step 3 involves correcting the Step-2 standard ##' errors (*SE*s) and chi-squared statistic to account for additional ##' uncertainty due to missing data (using information from Step 1; see ##' References section for sources with formulas). ##' ##' All variables (including auxiliary variables) are treated as endogenous ##' varaibles in the Step-1 saturated model (`fixed.x = FALSE`), so data ##' are assumed continuous, although not necessarily multivariate normal ##' (dummy-coded auxiliary variables may be included in Step 1, but categorical ##' endogenous variables in the Step-2 hypothesized model are not allowed). To ##' avoid assuming multivariate normality, request `se = ##' "robust.huber.white"`. CAUTION: In addition to setting `fixed.x = ##' FALSE` and `conditional.x = FALSE` in [lavaan::lavaan()], ##' this function will automatically set `meanstructure = TRUE`, ##' `estimator = "ML"`, `missing = "fiml"`, and `test = ##' "standard"`. [lavaan::lavaan()]'s `se` option can only be ##' set to `"standard"` to assume multivariate normality or to ##' `"robust.huber.white"` to relax that assumption. ##' ##' ##' @aliases twostage cfa.2stage sem.2stage growth.2stage lavaan.2stage ##' @importFrom lavaan lavInspect ##' ##' @param \dots Arguments passed to the [lavaan::lavaan()] function ##' specified in the `fun` argument. See also ##' [lavaan::lavOptions()]. At a minimum, the user must supply the ##' first two named arguments to [lavaan::lavaan()] (i.e., ##' `model` and `data`). ##' @param aux An optional character vector naming auxiliary variable(s) in ##' `data` ##' @param fun The character string naming the lavaan function used to fit the ##' Step-2 hypothesized model (`"cfa"`, `"sem"`, `"growth"`, or ##' `"lavaan"`). ##' @param baseline.model An optional character string, specifying the lavaan ##' [lavaan::model.syntax()] for a user-specified baseline model. ##' Interested users can use the fitted baseline model to calculate incremental ##' fit indices (e.g., CFI and TLI) using the corrected chi-squared values (see ##' the `anova` method in [twostage-class]). If `NULL`, ##' the default "independence model" (i.e., freely estimated means and ##' variances, but all covariances constrained to zero) will be specified ##' internally. ##' ##' @return The [twostage-class] object contains 3 fitted lavaan ##' models (saturated, target/hypothesized, and baseline) as well as the names ##' of auxiliary variables. None of the individual models provide the correct ##' model results (except the point estimates in the target model are unbiased). ##' Use the methods in [twostage-class] to extract corrected ##' *SE*s and test statistics. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso [twostage-class] ##' ##' @references ##' Savalei, V., & Bentler, P. M. (2009). A two-stage approach to missing data: ##' Theory and application to auxiliary variables. ##' *Structural Equation Modeling, 16*(3), 477--497. ##' \doi{10.1080/10705510903008238} ##' ##' Savalei, V., & Falk, C. F. (2014). Robust two-stage approach outperforms ##' robust full information maximum likelihood with incomplete nonnormal data. ##' *Structural Equation Modeling, 21*(2), 280--302. ##' \doi{10.1080/10705511.2014.882692} ##' ##' @examples ##' ##' ## impose missing data for example ##' HSMiss <- HolzingerSwineford1939[ , c(paste("x", 1:9, sep = ""), ##' "ageyr","agemo","school")] ##' set.seed(12345) ##' HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) ##' age <- HSMiss$ageyr + HSMiss$agemo/12 ##' HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) ##' ##' ## specify CFA model from lavaan's ?cfa help page ##' HS.model <- ' ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' ' ##' ##' ## use ageyr and agemo as auxiliary variables ##' out <- cfa.2stage(model = HS.model, data = HSMiss, aux = c("ageyr","agemo")) ##' ##' ## two versions of a corrected chi-squared test results are shown ##' out ##' ## see Savalei & Bentler (2009) and Savalei & Falk (2014) for details ##' ##' ## the summary additionally provides the parameter estimates with corrected ##' ## standard errors, test statistics, and confidence intervals, along with ##' ## any other options that can be passed to parameterEstimates() ##' summary(out, standardized = TRUE) ##' ##' ##' ##' ## use parameter labels to fit a more constrained model ##' modc <- ' ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + a*x8 + a*x9 ##' ' ##' outc <- cfa.2stage(model = modc, data = HSMiss, aux = c("ageyr","agemo")) ##' ##' ##' ## use the anova() method to test this constraint ##' anova(out, outc) ##' ## like for a single model, two corrected statistics are provided ##' ##' @export twostage <- function(..., aux, fun, baseline.model = NULL) { if (all(aux == "")) aux <- NULL dots <- list(...) if (is.null(dots$model)) stop("lavaan model syntax argument must be named 'model'.") lavaanifyArgs <- dots[intersect(names(dots), names(formals(lavaan::lavaanify)))] args4lavaan <- c(names(formals(lavaan::lavaan)), names(lavaan::lavOptions())) funArgs <- dots[intersect(names(dots), args4lavaan)] ## set some non-optional lavaan arguments funArgs$meanstructure <- TRUE funArgs$conditional.x <- FALSE funArgs$fixed.x <- FALSE funArgs$missing <- "fiml" funArgs$estimator <- "ML" funArgs$test <- "standard" if (is.null(funArgs$information)) funArgs$information <- "observed" if (funArgs$information[1] == "expected") { message("If data are MAR, only the observed information matrix is consistent.") if (!is.null(aux)) { funArgs$information <- "observed" message(c("Using auxiliary variables implies assuming that data are MAR. ", "The lavaan argument 'information' was set to 'observed'.")) } if (!is.null(funArgs$se)) if(funArgs$se != "standard") { funArgs$information <- "observed" message(c("The lavaan argument 'information' was set to 'observed' ", "because adjusting SEs for non-normality requires it.")) } } funArgs$NACOV <- NULL funArgs$do.fit <- NULL ## STAGE 1: ## fit saturated model if (!is.null(funArgs$group)) lavaanifyArgs$ngroups <- length(table(funArgs$data[ , funArgs$group])) targetNames <- lavaan::lavNames(do.call(lavaan::lavaanify, lavaanifyArgs)) varnames <- c(targetNames, aux) covstruc <- outer(varnames, varnames, function(x, y) paste(x, "~~", y)) satArgs <- funArgs satArgs$constraints <- NULL satArgs$group.equal <- "" satArgs$model <- c(covstruc[lower.tri(covstruc, diag = TRUE)], paste(varnames, "~ 1")) satFit <- do.call(lavaan::lavaan, satArgs) ## check for robust estimators opts <- lavInspect(satFit, "options") if (!opts$se %in% c("standard","robust.huber.white")) stop(c("Two-Stage estimation requires either se = 'standard' for ", "multivariate normal data or se = 'robust.huber.white' to ", "correct for non-normality.")) ## STAGE 2: ## fit target model to saturated estimates targetArgs <- funArgs targetArgs$data <- NULL targetArgs$sample.cov <- lavInspect(satFit, "cov.ov") targetArgs$sample.mean <- lavInspect(satFit, "mean.ov") targetArgs$sample.nobs <- lavInspect(satFit, "nobs") targetArgs$se <- "standard" targetArgs$sample.cov.rescale <- FALSE targetFit <- do.call(fun, targetArgs) ## STAGE 0: ## fit baseline model (for incremental fit indices) baseArgs <- targetArgs if (is.null(baseline.model)) { basecov <- outer(targetNames, targetNames, function(x, y) paste0(x, " ~~ 0*", y)) diag(basecov) <- paste(targetNames, "~~", targetNames) baseArgs$model <- c(basecov[lower.tri(basecov, diag = TRUE)], paste(targetNames, "~ 1")) } else baseArgs$model <- baseline.model baseArgs$se <- "standard" baseFit <- do.call(lavaan::lavaan, baseArgs) if (length(setdiff(lavaan::lavNames(baseFit), targetNames))) warning("The baseline model includes variables excluded from the target model.") if (length(setdiff(targetNames, lavaan::lavNames(baseFit)))) warning("The target model includes variables excluded from the baseline model.") ## return both models out <- new("twostage", saturated = satFit, target = targetFit, baseline = baseFit, auxNames = as.character(aux)) out } ##' @rdname twostage ##' @export lavaan.2stage <- function(..., aux = NULL, baseline.model = NULL) { twostage(..., aux = aux, fun = "lavaan", baseline.model = baseline.model) } ##' @rdname twostage ##' @export cfa.2stage <- function(..., aux = NULL, baseline.model = NULL) { twostage(..., aux = aux, fun = "cfa", baseline.model = baseline.model) } ##' @rdname twostage ##' @export sem.2stage <- function(..., aux = NULL, baseline.model = NULL) { twostage(..., aux = aux, fun = "sem", baseline.model = baseline.model) } ##' @rdname twostage ##' @export growth.2stage <- function(..., aux = NULL, baseline.model = NULL) { twostage(..., aux = aux, fun = "growth", baseline.model = baseline.model) } semTools/R/ordMoments.R0000644000176200001440000003465514751370431014554 0ustar liggesusers### Terrence D. Jorgensen & Andrew R. Johnson ### Last updated: 20 January 2025 ### function to derive ordinal-scale moments implied by LRV-scale moments ##' Calculate Population Moments for Ordinal Data Treated as Numeric ##' ##' This function calculates ordinal-scale moments implied by LRV-scale moments ##' ##' Binary and ordinal data are frequently accommodated in SEM by incorporating ##' a threshold model that links each observed categorical response variable to ##' a corresponding latent response variable that is typically assumed to be ##' normally distributed (Kamata & Bauer, 2008; Wirth & Edwards, 2007). ##' This function can be useful for real-data analysis or for designing ##' Monte Carlo simulations, as described by Jorgensen and Johnson (2022). ##' ##' @importFrom stats dnorm setNames ##' @importFrom lavaan lavInspect ##' @importFrom pbivnorm pbivnorm ##' ##' @param Sigma Population covariance [matrix()], with variable names ##' saved in the [dimnames()] attribute. ##' @param Mu Optional `numeric` vector of population means. If missing, ##' all means will be set to zero. ##' @param thresholds Either a single `numeric` vector of population ##' thresholds used to discretize each normally distributed variable, or a ##' named `list` of each discretized variable's vector of thresholds. ##' The discretized variables may be a subset of all variables in `Sigma` ##' if the remaining variables are intended to be observed rather than latent ##' normally distributed variables. ##' @param cWts Optional (default when missing is to use 0 for the lowest ##' category, followed by successive integers for each higher category). ##' Either a single `numeric` vector of category weights (if they are ##' identical across all variables) or a named `list` of each ##' discretized variable's vector of category weights. ##' ##' @return A `list` including the LRV-scale population moments (means, ##' covariance matrix, correlation matrix, and thresholds), the category ##' weights, a `data.frame` of implied univariate moments (means, ##' *SD*s, skewness, and excess kurtosis (i.e., in excess of 3, which is ##' the kurtosis of the normal distribution) for discretized data treated as ##' `numeric`, and the implied covariance and correlation matrix of ##' discretized data treated as `numeric`. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' Andrew R. Johnson (Curtin University; \email{andrew.johnson@@curtin.edu.au}) ##' ##' @references ##' ##' Jorgensen, T. D., & Johnson, A. R. (2022). How to derive expected values of ##' structural equation model parameters when treating discrete data as ##' continuous. *Structural Equation Modeling, 29*(4), 639--650. ##' \doi{10.1080/10705511.2021.1988609} ##' ##' Kamata, A., & Bauer, D. J. (2008). A note on the relation between factor ##' analytic and item response theory models. ##' *Structural Equation Modeling, 15*(1), 136--153. ##' \doi{10.1080/10705510701758406} ##' ##' Wirth, R. J., & Edwards, M. C. (2007). Item factor analysis: Current ##' approaches and future directions. *Psychological Methods, 12*(1), ##' 58--79. \doi{10.1037/1082-989X.12.1.58} ##' ##' @examples ##' ##' ## SCENARIO 1: DIRECTLY SPECIFY POPULATION PARAMETERS ##' ##' ## specify population model in LISREL matrices ##' Nu <- rep(0, 4) ##' Alpha <- c(1, -0.5) ##' Lambda <- matrix(c(1, 1, 0, 0, 0, 0, 1, 1), nrow = 4, ncol = 2, ##' dimnames = list(paste0("y", 1:4), paste0("eta", 1:2))) ##' Psi <- diag(c(1, .75)) ##' Theta <- diag(4) ##' Beta <- matrix(c(0, .5, 0, 0), nrow = 2, ncol = 2) ##' ##' ## calculate model-implied population means and covariance matrix ##' ## of latent response variables (LRVs) ##' IB <- solve(diag(2) - Beta) # to save time and space ##' Mu_LRV <- Nu + Lambda %*% IB %*% Alpha ##' Sigma_LRV <- Lambda %*% IB %*% Psi %*% t(IB) %*% t(Lambda) + Theta ##' ##' ## Specify (unstandardized) thresholds to discretize normally distributed data ##' ## generated from Mu_LRV and Sigma_LRV, based on marginal probabilities ##' PiList <- list(y1 = c(.25, .5, .25), ##' y2 = c(.17, .33, .33, .17), ##' y3 = c(.1, .2, .4, .2, .1), ##' ## make final variable highly asymmetric ##' y4 = c(.33, .25, .17, .12, .08, .05)) ##' sapply(PiList, sum) # all sum to 100% ##' CumProbs <- sapply(PiList, cumsum) ##' ## unstandardized thresholds ##' TauList <- mapply(qnorm, p = lapply(CumProbs, function(x) x[-length(x)]), ##' m = Mu_LRV, sd = sqrt(diag(Sigma_LRV))) ##' for (i in 1:4) names(TauList[[i]]) <- paste0(names(TauList)[i], "|t", ##' 1:length(TauList[[i]])) ##' ##' ## assign numeric weights to each category (optional, see default) ##' NumCodes <- list(y1 = c(-0.5, 0, 0.5), y2 = 0:3, y3 = 1:5, y4 = 1:6) ##' ##' ##' ## Calculate Population Moments for Numerically Coded Ordinal Variables ##' lrv2ord(Sigma = Sigma_LRV, Mu = Mu_LRV, thresholds = TauList, cWts = NumCodes) ##' ##' ##' ## SCENARIO 2: USE ESTIMATED PARAMETERS AS POPULATION ##' ##' data(datCat) # already stored as c("ordered","factor") ##' fit <- cfa(' f =~ 1*u1 + 1*u2 + 1*u3 + 1*u4 ', data = datCat) ##' lrv2ord(Sigma = fit, thresholds = fit) # use same fit for both ##' ## or use estimated thresholds with specified parameters, but note that ##' ## lrv2ord() will only extract standardized thresholds ##' dimnames(Sigma_LRV) <- list(paste0("u", 1:4), paste0("u", 1:4)) ##' lrv2ord(Sigma = cov2cor(Sigma_LRV), thresholds = fit) ##' ##' @export lrv2ord <- function(Sigma, Mu, thresholds, cWts) { if (inherits(Sigma, "lavaan")) { if (lavInspect(Sigma, "ngroups") > 1L || lavInspect(Sigma, "nlevels") > 1L) { stop('Sigma= only accepts single-group/level lavaan models') } fitSigma <- Sigma Sigma <- lavInspect(fitSigma, "cov.ov") } else stopifnot(is.matrix(Sigma)) vn <- rownames(Sigma) # variable names SDs <- sqrt(diag(Sigma)) if (missing(Mu)) { Mu <- rep(0, nrow(Sigma)) } else if (inherits(Mu, "lavaan")) { if (lavInspect(Mu, "ngroups") > 1L || lavInspect(Mu, "nlevels") > 1L) { stop('Mu= only accepts single-group/level lavaan models') } fitMu <- Mu Mu <- lavInspect(fitMu, "mean.ov") } names(Mu) <- names(SDs) <- vn ## If a single vector of thresholds is passed, broadcast to a list if (inherits(thresholds, "lavaan")) { if (lavInspect(thresholds, "ngroups") > 1L || lavInspect(thresholds, "nlevels") > 1L) { stop('thresholds= only accepts single-group/level lavaan models') } ## check whether diag(Sigma) == 1 isSTD <- sapply(SDs, function(x) { isTRUE(all.equal(x, current = 1, tolerance = .001)) }) if (!all(isSTD)) warning('standardized thresholds= extracted from a ', 'lavaan object, but Sigma= is not a ', 'correlation matrix.') fitThr <- thresholds thresholds <- lavInspect(fitThr, "th") # STANDARDIZED thresholds thresh <- lapply(unique(lavInspect(fitThr, "th.idx")), function(x) { thresholds[lavInspect(fitThr, "th.idx") == x] }) names(thresh) <- sapply(thresh, function(x) { strsplit(names(x)[1], "|t", fixed = TRUE)[[1]][1] }) } else if (is.atomic(thresholds)) { thresh <- sapply(vn, function(x) {thresholds}, simplify = FALSE) } else { stopifnot(is.list(thresholds)) # must be a list stopifnot(length(thresholds) <= nrow(Sigma)) # no more than 1 per variable stopifnot(all(names(thresholds) %in% vn)) # names must match thresh <- thresholds } cn <- names(thresh) stopifnot(length(cn) > 0L) ## If no category weights are passed, default to 0:nCat if (missing(cWts)) { cWts <- sapply(thresh, function(x) { 0:length(x) }, simplify = FALSE) } else if (is.atomic(cWts)) { ## If a single vector of category weights is passed, broadcast to a list #FIXME: assumes same number of thresholds across variables cWts <- sapply(cn, function(x) { cWts }, simplify = FALSE) } else { stopifnot(is.list(cWts)) # must be a list stopifnot(length(cWts) <= nrow(Sigma)) # no more than 1 per variable stopifnot(all(names(cWts) %in% vn)) # names must match stopifnot(all(cn %in% names(cWts))) # names must match cWts <- cWts[cn] # discard any others } stopifnot(all((sapply(thresh, length) + 1L) == sapply(cWts, length))) ## Calculate marginal probabilities implied by thresholds on moments get_marg_probs <- function(threshs, m, sd) { thr <- c(-Inf, threshs, Inf) sapply(2:length(thr), function(k) { pnorm(thr[k], m, sd) - pnorm(thr[k-1], m, sd) }) } marginal_probs <- mapply(get_marg_probs, SIMPLIFY = FALSE, threshs = thresh, m = Mu[cn], sd = SDs[cn]) ## Marginal means Mu_ord <- Mu Mu_ord[cn] <- mapply(function(p, w) { stopifnot(length(p) == length(w)) sum(p * w) }, p = marginal_probs, w = cWts) ## marginal variances (fill in covariances below) Sigma_ord <- Sigma if (length(cn) == 1) { ## drop=FALSE is not a solution (yields different error) Sigma_ord[cn,cn] <- mapply(function(p, w, mu) { stopifnot(length(p) == length(w)) sum(p * (w - mu)^2) }, p = marginal_probs, w = cWts, mu = Mu_ord[cn]) } else { diag(Sigma_ord[cn,cn]) <- mapply(function(p, w, mu) { stopifnot(length(p) == length(w)) sum(p * (w - mu)^2) }, p = marginal_probs, w = cWts, mu = Mu_ord[cn]) } ## marginal (standardized) skew skew_ord <- setNames(rep(0, nrow(Sigma)), nm = vn) skew_ord[cn] <- mapply(function(p, w, mu) { stopifnot(length(p) == length(w)) numerator <- sum(p * (w - mu)^3) Moment2 <- sum(p * (w - mu)^2) denominator <- sqrt(Moment2)^3 numerator / denominator }, p = marginal_probs, w = cWts, mu = Mu_ord[cn]) ## marginal (standardized, excess) kurtosis kurt_ord <- setNames(rep(0, nrow(Sigma)), nm = vn) kurt_ord[cn] <- mapply(function(p, w, mu) { stopifnot(length(p) == length(w)) numerator <- sum(p * (w - mu)^4) Moment2 <- sum(p * (w - mu)^2) denominator <- sqrt(Moment2)^4 numerator / denominator }, p = marginal_probs, w = cWts, mu = Mu_ord[cn]) - 3 # excess kurtosis ## all marginal descriptives (margMoments <- data.frame(Mean = Mu_ord, SD = sqrt(diag(Sigma_ord)), Skew = skew_ord, Kurtosis3 = kurt_ord, row.names = vn)) class(margMoments) <- c("lavaan.data.frame","data.frame") # for printing ## save old copies to return with new out <- list(Mu_LRV = Mu, Sigma_LRV = Sigma, R_LRV = stats::cov2cor(Sigma), Thresholds = thresh, Category_weights = cWts, Uni_ord = margMoments) class(out$Mu_LRV) <- c("lavaan.vector","numeric") class(out$Sigma_LRV) <- c("lavaan.matrix.symmetric","matrix") class(out$R_LRV) <- c("lavaan.matrix.symmetric","matrix") out$Thresholds <- lapply(out$Thresholds, "class<-", c("lavaan.vector","numeric")) out$Category_weights <- lapply(out$Category_weights, "class<-", c("lavaan.vector","numeric")) ## need bivariate moments? if (length(vn) == 1L) return(out) ## function to apply to any pair of indicators (i and j) in Sigma getOrdCov <- function(i, j) { ## to use apply(), i= can be 2 values indicating the [row, column] if (length(i) > 1L) { if (!missing(j)) warning("j ignored when i has multiple values") if (length(i) > 2L) stop("i had ", length(i), " values. Only the first 2 were used.") j <- i[2] i <- i[1] } ## if i/j are numeric, get names if (is.numeric(i)) i <- vn[i] if (is.numeric(j)) j <- vn[j] ## make sure thresholds are standardized # i.thr <- # j.thr <- ## template for matrices of joint probabilities and cross-products JointProbs <- CP <- matrix(0, nrow = length(cWts[[i]]), ncol = length(cWts[[j]])) i.thr <- c(-1e5, (thresh[[i]] - Mu[i]) / SDs[i], 1e5) j.thr <- c(-1e5, (thresh[[j]] - Mu[j]) / SDs[j], 1e5) tCombos <- cbind(expand.grid(i = i.thr, j = j.thr), expand.grid(cat1 = c(0, seq_along(cWts[[i]])), cat2 = c(0, seq_along(cWts[[j]])))) tCombos$cp <- pbivnorm(x = tCombos$i, y = tCombos$j, rho = out$R_LRV[i,j]) ## loop over rows & columns for (RR in seq_along(cWts[[i]])) for (CC in seq_along(cWts[[j]])) { ## calculate joint probabilities idx1 <- which(tCombos$cat1 == RR & tCombos$cat2 == CC ) idx2 <- which(tCombos$cat1 == RR - 1 & tCombos$cat2 == CC ) idx3 <- which(tCombos$cat1 == RR & tCombos$cat2 == CC - 1) idx4 <- which(tCombos$cat1 == RR - 1 & tCombos$cat2 == CC - 1) JointProbs[RR,CC] <- tCombos$cp[idx1] - tCombos$cp[idx2] - tCombos$cp[idx3] + tCombos$cp[idx4] ## calculate cross-products CP[RR,CC] <- (cWts[[i]][RR] - Mu_ord[i]) * (cWts[[j]][CC] - Mu_ord[j]) } sum(JointProbs * CP) # return covariance } ## check whether all variables are being discretized stayCon <- setdiff(vn, cn) if (length(stayCon) == 0) { ## all are polychoric (ij <- which(lower.tri(Sigma_ord), arr.ind = TRUE)) Sigma_ord[ij] <- mapply(getOrdCov, i = ij[,1], j = ij[,2]) Sigma_ord[ ij[,2:1] ] <- Sigma_ord[ij] # copy lower to upper triangle } else { ## pair by pair, choose polychoric or polyserial for (i in vn[-length(vn)]) for (j in vn[(which(vn == i)+1):length(vn)]) { if (i %in% stayCon && j %in% stayCon) next if (j %in% cn && j %in% cn) { ## both discretized, calculate polychoric Sigma_ord[i,j] <- Sigma_ord[j,i] <- getOrdCov(i, j) next } ## else, calculate polyserial if (i %in% stayCon) { CON <- i CAT <- j } else { CAT <- i CON <- j } DENS <- mapply(function(tau, interval, m = 0, sd = 1) { dnorm(tau, mean = m, sd = sd) * interval }, tau = thresh[[CAT]], interval = diff(cWts[[CAT]]), m = Mu[CAT], sd = SDs[CAT]) ## Note: polyserial correlation divides by sqrt(diag(Sigma_ord)[CAT]), ## but that cancels out when scaling by both SDs to get covariance Sigma_ord[CON, CAT] <- Sigma_ord[CAT, CON] <- out$R_LRV[CON, CAT] * sum(DENS) * sqrt(diag(out$Sigma_LRV)[CON]) } } class(Sigma_ord) <- c("lavaan.matrix.symmetric","matrix") if (nrow(Sigma_ord) > 1L) { R_ord <- cov2cor(Sigma_ord) class(R_ord) <- c("lavaan.matrix.symmetric","matrix") } else R_ord <- NULL c(out, list(Sigma_ord = Sigma_ord, R_ord = R_ord)) } semTools/R/gorica.R0000644000176200001440000001046614753073531013666 0ustar liggesusers### Leonard Vanbrabant (Roxygen edits by Terrence D. Jorgensen) ### Last updated: 12 February 2025 ##' Wrapper for `goric.lavaan()` from the `restriktor` package ##' ##' The `goricaSEM()` function is an interface to [restriktor::goric.lavaan()], ##' allowing users to perform generalized order-restricted information criterion ##' approximation (GORICA) analysis specifically for structural equation ##' models fitted using the \pkg{lavaan} package. ##' ##' @details ##' This function is designed as a wrapper for the [restriktor::goric.lavaan()] ##' function. It calculates GORICA values and weights, which can be used to ##' compare models or hypotheses under inequality constraints. ##' ##' The `hypotheses=` argument allows users to specify constraints in text-based ##' syntax or matrix notation. For text-based syntax, constraints are specified ##' as a string (e.g., `"a1 > a2"`). For matrix notation, a named list with ##' `$constraints`, `$rhs`, and `$neq` elements can be provided. ##' ##' The `comparison=` argument determines whether the specified hypothesis is ##' compared against its `"complement"`, the `"unconstrained"` model, or ##' neither (`"none"`). ##' ##' @param object A [lavaan::lavaan-class] object. ##' @param hypotheses A named `list` of hypotheses to test. See **Details** for ##' information on how to specify hypotheses. ##' @param comparison A `character` string specifying the type of comparison. ##' Options are `"unconstrained"`, `"complement"`, or `"none"`. ##' Default behavior depends on the number of hypotheses. ##' @param type A `character` string indicating the type of analysis, either ##' `"gorica"` (default) or `"goricac"`. ##' @param standardized `logical` indicating whether standardized estimates are ##' used in the analysis. Defaults to `FALSE`. ##' @param debug `logical` indicating whether to print debugging information. ##' Defaults to \code{FALSE}. ##' @param ... Additional arguments passed to [restriktor::goric.lavaan()]. ##' ##' @return ##' A `list` containing the results of the \code{goric.lavaan} function, ##' including: ##' \itemize{ ##' \item The log-likelihood. ##' \item Penalty term. ##' \item GORIC(A) values and weights. ##' \item Relative GORIC(A) weights. ##' } ##' ##' @references ##' Kuiper, R. M., Hoijtink, H., & Silvapulle, M. J. (2011). An Akaike-type ##' information criterion for model selection under inequality constraints. ##' \emph{Biometrika, 98}(2), 495--501. \doi{10.1093/biomet/asr002} ##' ##' Vanbrabant, L., Van Loey, N., & Kuiper, R. M. (2020). Evaluating a ##' theory-based hypothesis against its complement using an AIC-type ##' information criterion with an application to facial burn injury. ##' \emph{Psychological Methods, 25}(2), 129--142. \doi{10.1037/met0000238} ##' ##' @seealso [restriktor::goric.lavaan()] ##' ##' @author Leonard Vanbrabant and Rebecca Kuiper ##' ##' @examples ##' ##' ## Example: Perform GORICA analysis on a lavaan model ##' library(lavaan) ##' library(restriktor) ##' ##' ## Define the SEM model ##' model <- ' ##' ind60 =~ x1 + x2 + x3 ##' dem60 =~ y1 + a1*y2 + b1*y3 + c1*y4 ##' dem65 =~ y5 + a2*y6 + b2*y7 + c2*y8 ##' dem60 ~ ind60 ##' dem65 ~ ind60 + dem60 ##' y1 ~~ y5 ##' y2 ~~ y4 + y6 ##' y3 ~~ y7 ##' y4 ~~ y8 ##' y6 ~~ y8 ##' ' ##' ##' ## Fit the model ##' data(PoliticalDemocracy) ##' fit <- sem(model, data = PoliticalDemocracy) ##' ##' ## Define hypotheses ##' myHypothesis <- 'a1 > a2, b1 > b2, c1 > c2' ##' ##' ## Perform GORICA analysis ##' result <- goricaSEM(fit, hypotheses = list(H1 = myHypothesis), ##' standardized = FALSE, comparison = "complement", ##' type = "gorica") ##' ##' ## Print result ##' print(result) ##' ##' @export goricaSEM <- function(object, ..., hypotheses = NULL, comparison = NULL, type = "gorica", standardized = FALSE, debug = FALSE) { ## Check if the original function is available if (!requireNamespace("restriktor", quietly = TRUE)) { stop("The 'restriktor' package is required but not installed.") } ## Call the original function restriktor::goric.lavaan( object = object, hypotheses = hypotheses, comparison = comparison, type = type, standardized = standardized, debug = debug, ... ) } semTools/R/zzz.R0000644000176200001440000000340414634011255013242 0ustar liggesusers.onAttach <- function(libname, pkgname) { version <- read.dcf(file = system.file("DESCRIPTION", package = pkgname), fields = "Version") packageStartupMessage(" ") packageStartupMessage("###############################################################################") packageStartupMessage("This is ", paste(pkgname, version)) packageStartupMessage("All users of R (or SEM) are invited to submit functions or ideas for functions.") packageStartupMessage("###############################################################################") ## if lavaan.mi is already loaded, warn users to use :: or switch order if ("lavaan.mi" %in% names(utils::sessionInfo()$otherPkgs)) { packageStartupMessage(" ") packageStartupMessage("The lavaan.mi package was already attached when semTools was attached.") packageStartupMessage("To access lavaan.mi functions masked by semTools, use the double-colon:") packageStartupMessage(" ") packageStartupMessage("\t lavaan.mi::cfa.mi() or lavaan.mi::lavTestLRT.mi()\n") packageStartupMessage("It is preferable to first attach semTools, then attach lavaan.mi, but") packageStartupMessage("you can change the path order by detaching and reloading lavaan.mi,") packageStartupMessage("using this syntax:\n") packageStartupMessage('\t detach("package:lavaan.mi", unload = TRUE)') packageStartupMessage('\t library(lavaan.mi) \n') packageStartupMessage("Then the deprecated semTools::lavaan.mi functionality will be masked.") } } .onLoad <- function(libname, pkgname) { ## "register" emmeans functionality emInstalled <- try(loadNamespace("emmeans"), silent = TRUE) if (!inherits(emInstalled, "try-error")) { emmeans::.emm_register("lavaan", pkgname) } } semTools/R/efa.R0000644000176200001440000006646114764264620013166 0ustar liggesusers### Sunthud Pornprasertmanit & Terrence D. Jorgensen ### Last updated: 27 May 2020 ### DEPRECATED 24 November 2022 (after 0.5-6 was on CRAN) ### REMOVED next time! ### fit and rotate EFA models in lavaan ## ------------------------------------- ## Exploratory Factor Analysis in lavaan ## ------------------------------------- ##' Analyze Unrotated Exploratory Factor Analysis Model ##' ##' This function will analyze unrotated exploratory factor analysis model. The ##' unrotated solution can be rotated by the \code{\link{orthRotate}} and ##' \code{\link{oblqRotate}} functions. ##' ##' This function will generate a lavaan script for unrotated exploratory factor ##' analysis model such that (1) all factor loadings are estimated, (2) factor ##' variances are fixed to 1, (3) factor covariances are fixed to 0, and (4) the ##' dot products of any pairs of columns in the factor loading matrix are fixed ##' to zero (Johnson & Wichern, 2002). The reason for creating this function ##' to supplement the \code{\link{factanal}} function is that users can enjoy ##' some advanced features from the \code{lavaan} package, such as scaled ##' \eqn{\chi^2}, diagonally weighted least squares estimation for ordinal ##' indicators, or full-information maximum likelihood (FIML) to handle ##' incomplete data. ##' ##' @importFrom lavaan lavInspect parTable ##' @importFrom stats factanal ##' ##' @param data A target \code{data.frame} ##' @param nf The desired number of factors ##' @param varList Target observed variables. If not specified, all variables in ##' \code{data} will be used (or \code{sample.cov} if \code{is.null(data)}; ##' see \code{\link[lavaan]{cfa}} for argument descriptions). ##' @param start Use starting values in the analysis from the ##' \code{\link{factanal}} \code{function}. If \code{FALSE}, the starting values ##' from the \code{lavaan} package will be used. \code{TRUE} is ignored with a ##' warning if the \code{aux} argument is used. ##' @param aux The list of auxiliary variables. These variables will be included ##' in the model by the saturated-correlates approach to account for missing ##' information. ##' @param \dots Other arguments in the \code{\link[lavaan]{cfa}} function in ##' the \code{lavaan} package, such as \code{ordered}, \code{se}, ##' \code{estimator}, or \code{sample.cov} and \code{sample.nobs}. ##' ##' @return A \code{lavaan} output of unrotated exploratory factor analysis ##' solution. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @examples ##' ##' \donttest{ ##' ##' unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, ##' varList = paste0("x", 1:9), estimator = "mlr") ##' summary(unrotated, std = TRUE) ##' inspect(unrotated, "std") ##' ##' dat <- data.frame(HolzingerSwineford1939, ##' z = rnorm(nrow(HolzingerSwineford1939), 0, 1)) ##' unrotated2 <- efaUnrotate(dat, nf = 2, varList = paste0("x", 1:9), aux = "z") ##' } ##' ##' @name efaUnrotate-deprecated ##' @usage ##' efaUnrotate(data = NULL, nf, varList = NULL, ##' start = TRUE, aux = NULL, ...) ##' @seealso \code{\link{semTools-deprecated}} ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' ##' @section Support functions for exploratory factor analysis in \code{lavaan}: ##' The \code{efaUnrotate}, \code{orthRotate}, \code{oblqRotate}, and ##' \code{funRotate} functions will no longer be supported. These functions ##' allowed users to estimate EFA parameters with \code{lavaan}. Instead, users ##' can now directly use \code{lavaan}'s \code{\link[lavaan]{efa}()} function. ##' Exploratory SEM (ESEM) is also supported by lavaan using special operators ##' in \code{lavaan}'s \code{\link[lavaan]{model.syntax}}; see ##' \url{https://github.com/yrosseel/lavaan/issues/112} for details. ##' ##' @export efaUnrotate <- function(data = NULL, nf, varList = NULL, start = TRUE, aux = NULL, ...) { .Deprecated(msg = c("The efaUnrotate function is deprecated, and it will ", "cease to be included in future versions of semTools. ", "The lavaan package itself now provides EFA support. ", "See help('semTools-deprecated) for details.")) efaArgs <- list(...) if (is.null(data)) { ## check for summary statistics sample.cov <- efaArgs$sample.cov sample.mean <- efaArgs$sample.mean sample.nobs <- efaArgs$sample.nobs sample.th <- efaArgs$sample.th WLS.V <- efaArgs$WLS.V NACOV <- efaArgs$NACOV if (is.null(sample.cov)) stop('User must supply either raw data or ', 'summary statistics to pass to lavaan().') if (is.null(varList)) varList <- colnames(sample.cov) anyOrdered <- !is.null(sample.th) ordNames <- efaArgs$ordered if (anyOrdered & (is.logical(ordNames) | is.null(ordNames))) { if (is.null(ordNames)) { message('Thresholds supplied, but not an ordered= argument. Must ', 'assume all model variables are ordered.') } ordNames <- varList } } else { sample.cov <- NULL sample.mean <- NULL sample.nobs <- NULL sample.th <- NULL WLS.V <- NULL NACOV <- NULL efaArgs$data <- data if (is.null(varList)) varList <- colnames(data) anyOrdered <- checkOrdered(data, varList, ...) ordNames <- checkOrdered(data, varList, ..., return.names = TRUE) if (!is.null(efaArgs$group)) stop("Multi-group EFA is not currently supported.") } if (!is.null(aux)) { if (anyOrdered) { stop("The analysis model or the analysis data have ordered categorical", " variables. The auxiliary variable feature is not available for", " the models for categorical variables with the weighted least", " square approach.") } efaArgs$fixed.x <- FALSE efaArgs$missing <- "fiml" efaArgs$aux <- aux lavaancfa <- function(...) { cfa.auxiliary(...)} } else lavaancfa <- function(...) { lavaan::cfa(...)} nvar <- length(varList) facnames <- paste0("factor", 1:nf) loading <- outer(1:nvar, 1:nf, function(x, y) paste0("load", x, "_", y)) syntax <- "" for (i in 1:nf) { variablesyntax <- paste(paste0(loading[,i], "*", varList), collapse = " + ") factorsyntax <- paste0(facnames[i], " =~ NA*", varList[1], " + ", variablesyntax, "\n") syntax <- paste(syntax, factorsyntax) } syntax <- paste(syntax, paste(paste0(facnames, " ~~ 1*", facnames), collapse = "\n"), "\n") dataSupportsMeans <- length(setdiff(varList, ordNames)) && !(is.null(data) && is.null(sample.mean)) meanstructure <- efaArgs$meanstructure if (is.null(meanstructure)) meanstructure <- anyOrdered #FIXME: wise default for EFA? stopifnot(is.logical(meanstructure)) if (meanstructure && dataSupportsMeans) { syntax <- paste(syntax, paste(paste0(setdiff(varList, ordNames), " ~ 1"), collapse = "\n"), "\n") } if (nf > 1) { covsyntax <- outer(facnames, facnames, function(x, y) paste0(x, " ~~ 0*", y, "\n"))[lower.tri(diag(nf), diag = FALSE)] syntax <- paste(syntax, paste(covsyntax, collapse = " ")) for (i in 2:nf) { for (j in 1:(i - 1)) { loadconstraint <- paste(paste0(loading[,i], "*", loading[,j]), collapse=" + ") syntax <- paste(syntax, paste0("0 == ", loadconstraint), "\n") } } } if (start) { if (is.null(aux)) { List <- c(list(model = syntax, data = data), list(...)) List$do.fit <- FALSE outtemp <- do.call(lavaancfa, List) covtemp <- lavInspect(outtemp, "sampstat")$cov partemp <- parTable(outtemp) err <- try(startload <- factanal(factors = nf, covmat = covtemp)$loadings[], silent = TRUE) if (is(err, "try-error")) stop("The starting values from the factanal", " function cannot be calculated. Please", " use start = FALSE instead.") startval <- sqrt(diag(diag(covtemp))) %*% startload partemp$ustart[match(as.vector(loading), partemp$label)] <- as.vector(startval) partemp$est <- partemp$se <- NULL syntax <- partemp } else warning("The 'start' argument was ignored because factanal() does", " not support auxiliary variables. When using auxiliary", " variables, set 'start = FALSE' ") } else { ## FIXME: optimizer can't escape loadings == 0 without starting values from ## factanal() or by using theta parameterization ## https://groups.google.com/d/msg/lavaan/ujkHmCVirEY/-LGut4ewAwAJ parameterization <- efaArgs$parameterization if (is.null(parameterization)) parameterization <- lavaan::lavOptions("parameterization") if (anyOrdered && parameterization != "theta") warning('If the default parameterization = "delta" returns results with ', 'all factor loadings equal to zero, try either setting start ', '= TRUE or setting parameterization = "theta" instead.') } efaArgs$model <- syntax do.call(lavaancfa, efaArgs) } ## ----------------- ## Class and Methods ## ----------------- ##' Class For Rotated Results from EFA ##' ##' This class contains the results of rotated exploratory factor analysis ##' ##' ##' @name EFA-class ##' @aliases EFA-class show,EFA-method summary,EFA-method ##' @docType class ##' @slot loading Rotated standardized factor loading matrix ##' @slot rotate Rotation matrix ##' @slot gradRotate gradient of the objective function at the rotated loadings ##' @slot convergence Convergence status ##' @slot phi: Factor correlation matrix. Will be an identity matrix if ##' orthogonal rotation is used. ##' @slot se Standard errors of the rotated standardized factor loading matrix ##' @slot method Method of rotation ##' @slot call The command used to generate this object ##' @section Objects from the Class: Objects can be created via the ##' \code{\link{orthRotate}} or \code{\link{oblqRotate}} function. ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso \code{\link{efaUnrotate}}; \code{\link{orthRotate}}; ##' \code{\link{oblqRotate}} ##' @examples ##' ##' \donttest{ ##' ##' unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, ##' varList = paste0("x", 1:9), estimator = "mlr") ##' summary(unrotated, std = TRUE) ##' lavInspect(unrotated, "std") ##' ##' # Rotated by Quartimin ##' rotated <- oblqRotate(unrotated, method = "quartimin") ##' summary(rotated) ##' } ##' setClass("EFA", representation(loading = "matrix", rotate = "matrix", gradRotate = "matrix", convergence = "logical", phi = "matrix", se = "matrix", method = "character", call = "call")) ##' @rdname EFA-class ##' @aliases show,EFA-method ##' @export setMethod("show", signature(object = "EFA"), function(object) { cat("Standardized Rotated Factor Loadings\n") print(printLoadings(object)) cat("\nFactor Correlation\n") print(object@phi) cat("\nMethod of rotation:\t") cat(object@method, "\n") message("The standard errors are close but do not match with other packages.", " Be mindful when using it.") }) ##' @rdname EFA-class ##' @aliases summary,EFA-method ##' @param object object of class \code{EFA} ##' @param suppress any standardized loadings less than the specified value ##' will not be printed to the screen ##' @param sort \code{logical}. If \code{TRUE} (default), factor loadings will ##' be sorted by their size in the console output ##' @export setMethod("summary", signature(object = "EFA"), function(object, suppress = 0.1, sort = TRUE) { cat("Standardized Rotated Factor Loadings\n") print(printLoadings(object, suppress = suppress, sort = sort)) cat("\nFactor Correlation\n") print(object@phi) cat("\nMethod of rotation:\t") cat(object@method, "\n") cat("\nTest Statistics for Standardized Rotated Factor Loadings\n") print(testLoadings(object)) }) ## ------------------------------ ## Rotation Constructor Functions ## ------------------------------ ##' Implement orthogonal or oblique rotation ##' ##' These functions will implement orthogonal or oblique rotation on ##' standardized factor loadings from a lavaan output. ##' ##' These functions will rotate the unrotated standardized factor loadings by ##' orthogonal rotation using the \code{\link[GPArotation]{GPForth}} function or ##' oblique rotation using the \code{\link[GPArotation]{GPFoblq}} function the ##' \code{GPArotation} package. The resulting rotation matrix will be used to ##' calculate standard errors of the rotated standardized factor loading by ##' delta method by numerically computing the Jacobian matrix by the ##' \code{\link[lavaan]{lav_func_jacobian_simple}} function. ##' ## @aliases orthRotate oblqRotate funRotate ## @rdname rotate ##' @param object A lavaan output ##' @param method The method of rotations, such as \code{"varimax"}, ##' \code{"quartimax"}, \code{"geomin"}, \code{"oblimin"}, or any gradient ##' projection algorithms listed in the \code{\link[GPArotation]{GPA}} function ##' in the \code{GPArotation} package. ##' @param fun The name of the function that users wish to rotate the ##' standardized solution. The functions must take the first argument as the ##' standardized loading matrix and return the \code{GPArotation} object. Check ##' this page for available functions: \code{\link[GPArotation]{rotations}}. ##' @param \dots Additional arguments for the \code{\link[GPArotation]{GPForth}} ##' function (for \code{orthRotate}), the \code{\link[GPArotation]{GPFoblq}} ##' function (for \code{oblqRotate}), or the function that users provide in the ##' \code{fun} argument. ##' @return An \code{linkS4class{EFA}} object that saves the rotated EFA solution ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @examples ##' ##' \donttest{ ##' ##' unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, ##' varList = paste0("x", 1:9), estimator = "mlr") ##' ##' # Orthogonal varimax ##' out.varimax <- orthRotate(unrotated, method = "varimax") ##' summary(out.varimax, sort = FALSE, suppress = 0.3) ##' ##' # Orthogonal Quartimin ##' orthRotate(unrotated, method = "quartimin") ##' ##' # Oblique Quartimin ##' oblqRotate(unrotated, method = "quartimin") ##' ##' # Geomin ##' oblqRotate(unrotated, method = "geomin") ##' ##' # Target rotation ##' library(GPArotation) ##' target <- matrix(0, 9, 3) ##' target[1:3, 1] <- NA ##' target[4:6, 2] <- NA ##' target[7:9, 3] <- NA ##' colnames(target) <- c("factor1", "factor2", "factor3") ##' ## This function works with GPArotation version 2012.3-1 ##' funRotate(unrotated, fun = "targetQ", Target = target) ##' } ##' ##' @name rotate-deprecated ##' ##' @usage ##' orthRotate(object, method = "varimax", ...) ##' ##' oblqRotate(object, method = "quartimin", ...) ##' ##' funRotate(object, fun, ...) ##' ##' @seealso \code{\link{semTools-deprecated}} ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export orthRotate <- function(object, method = "varimax", ...) { .Deprecated(msg = c("The orthRotate function is deprecated, and it will ", "cease to be included in future versions of semTools. ", "The lavaan package itself now provides support EFA. ", "See help('semTools-deprecated) for details.")) requireNamespace("GPArotation") if (!("package:GPArotation" %in% search())) attachNamespace("GPArotation") mc <- match.call() initL <- getLoad(object) rotated <- GPArotation::GPForth(initL, method=method, ...) # rotateMat <- t(solve(rotated$Th)) # defined but never used LIST <- seStdLoadings(rotated, object, fun = GPArotation::GPForth, MoreArgs = c(method = method, list(...))) # orthogonal <- rotated$orthogonal # define but never used loading <- rotated$loadings rotate <- rotated$Th gradRotate <- rotated$Gq convergence <- rotated$convergence method <- rotated$method phi <- diag(ncol(loading)) lv.names <- colnames(loading) dimnames(phi) <- list(lv.names, lv.names) new("EFA", loading = loading, rotate = rotate, gradRotate = gradRotate, convergence = convergence, phi = phi, se = LIST, method = method, call = mc) } ##' @rdname semTools-deprecated ##' @export oblqRotate <- function(object, method = "quartimin", ...) { .Deprecated(msg = c("The oblqRotate function is deprecated, and it will ", "cease to be included in future versions of semTools. ", "The lavaan package itself now provides support EFA. ", "See help('semTools-deprecated) for details.")) requireNamespace("GPArotation") if (!("package:GPArotation" %in% search())) attachNamespace("GPArotation") mc <- match.call() initL <- getLoad(object) rotated <- GPArotation::GPFoblq(initL, method = method, ...) # rotateMat <- t(solve(rotated$Th)) # defined but never used LIST <- seStdLoadings(rotated, object, fun = GPArotation::GPFoblq, MoreArgs = c(method = method, list(...))) # orthogonal <- rotated$orthogonal # defined but never used loading <- rotated$loadings rotate <- rotated$Th gradRotate <- rotated$Gq convergence <- rotated$convergence method <- rotated$method phi <- rotated$Phi lv.names <- colnames(loading) dimnames(phi) <- list(lv.names, lv.names) new("EFA", loading=loading, rotate = rotate, gradRotate = gradRotate, convergence = convergence, phi = phi, se = LIST, method = method, call = mc) } ##' @rdname semTools-deprecated ##' @export funRotate <- function(object, fun, ...) { .Deprecated(msg = c("The funRotate function is deprecated, and it will ", "cease to be included in future versions of semTools. ", "The lavaan package itself now provides support EFA. ", "See help('semTools-deprecated) for details.")) stopifnot(is.character(fun)) requireNamespace("GPArotation") if (!("package:GPArotation" %in% search())) attachNamespace("GPArotation") mc <- match.call() initL <- getLoad(object) rotated <- do.call(fun, c(list(L = initL), list(...))) # rotateMat <- t(solve(rotated$Th)) # defined but never used gradRotate <- rotated$Gq LIST <- seStdLoadings(rotated, object, fun = fun, MoreArgs = list(...)) # orthogonal <- rotated$orthogonal # defined but never used loading <- rotated$loadings rotate <- rotated$Th convergence <- rotated$convergence method <- rotated$method phi <- rotated$Phi if (is.null(phi)) phi <- diag(ncol(loading)) lv.names <- colnames(loading) dimnames(phi) <- list(lv.names, lv.names) new("EFA", loading = loading, rotate = rotate, gradRotate = gradRotate, convergence = convergence, phi = phi, se = LIST, method = method, call = mc) } ## ---------------- ## Hidden Functions ## ---------------- printLoadings <- function(object, suppress = 0.1, sort = TRUE) { loading <- object@loading nf <- ncol(loading) loadingText <- sprintf("%.3f", object@loading) sig <- ifelse(testLoadings(object)$p < 0.05, "*", " ") loadingText <- paste0(loadingText, sig) loadingText[abs(loading) < suppress] <- "" loadingText <- matrix(loadingText, ncol = nf, dimnames = dimnames(loading)) lead <- apply(abs(loading), 1, which.max) ord <- NULL if (sort) { for (i in 1:nf) { ord <- c(ord, intersect(order(abs(loading[,i]), decreasing = TRUE), which(lead == i))) } loadingText <- loadingText[ord,] } as.data.frame(loadingText) } ##' @importFrom stats pnorm qnorm testLoadings <- function(object, level = 0.95) { se <- object@se loading <- object@loading lv.names <- colnames(loading) z <- loading / se p <- 2 * (1 - pnorm( abs(z) )) crit <- qnorm(1 - (1 - level)/2) est <- as.vector(loading) se <- as.vector(se) warning("The standard error is currently invalid because it does not account", " for the variance of the rotation function. It is simply based on", " the delta method.") out <- data.frame(lhs=lv.names[col(loading)], op = "=~", rhs = rownames(loading)[row(loading)], std.loading = est, se = se, z = as.vector(z), p = as.vector(p), ci.lower = (est - crit*se), ci.upper = (est + crit*se)) class(out) <- c("lavaan.data.frame", "data.frame") out } ##' @importFrom lavaan lavInspect getLoad <- function(object, std = TRUE) { out <- lavInspect(object, "est")$lambda #FIXME: check for multiple groups if (std) { impcov <- lavaan::fitted.values(object)$cov impsd <- sqrt(diag(diag(impcov))) out <- solve(impsd) %*% out } rownames(out) <- lavaan::lavNames(object@ParTable, "ov", group = 1) if (!is.null(object@external$aux)) { out <- out[!(rownames(out) %in% object@external$aux),] } class(out) <- c("loadings", out) out } fillMult <- function(X, Y, fillrowx = 0, fillrowy = 0, fillcolx = 0, fillcoly = 0) { tempX <- matrix(0, nrow = nrow(X) + fillrowx, ncol = ncol(X) + fillcolx) tempY <- matrix(0, nrow = nrow(Y) + fillrowy, ncol = ncol(Y) + fillcoly) tempX[1:nrow(X), 1:ncol(X)] <- X tempY[1:nrow(Y), 1:ncol(Y)] <- Y result <- tempX %*% tempY result[1:nrow(X), 1:ncol(Y)] } ##' @importFrom lavaan lavInspect stdRotatedLoadings <- function(est, object, fun, aux = NULL, rotate = NULL, MoreArgs = NULL) { ov.names <- lavaan::lavNames(object@ParTable, "ov", group = 1) lv.names <- lavaan::lavNames(object@ParTable, "lv", group = 1) ind.names <- setdiff(ov.names, aux) # Compute model-implied covariance matrix partable <- object@ParTable # LY load.idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names)) loading <- matrix(est[load.idx], ncol = length(lv.names)) loading <- rbind(loading, matrix(0, length(aux), ncol(loading))) # Nu if (lavInspect(object, "options")$meanstructure) { int.idx <- which(partable$op == "~1" & (partable$rhs == "") & (partable$lhs %in% ov.names)) intcept <- matrix(est[int.idx], ncol = 1) } # Theta th.idx <- which(partable$op == "~~" & (partable$rhs %in% ov.names) & (partable$lhs %in% ov.names)) theta <- matrix(0, nrow = length(ov.names), ncol = length(ov.names), dimnames = list(ov.names, ov.names)) for (i in th.idx) { theta[partable$lhs[i], partable$rhs[i]] <- theta[partable$rhs[i], partable$lhs[i]] <- est[i] } OV <- loading %*% t(loading) + theta invsd <- solve(sqrt(diag(diag(OV)))) requireNamespace("GPArotation") if (!("package:GPArotation" %in% search())) attachNamespace("GPArotation") # Compute standardized results loading <- invsd %*% loading obj <- do.call(fun, c(list(loading), MoreArgs)) # GPArotation::GPFoblq(loading, method = "geomin") loading <- obj$loadings rotMat <- t(solve(obj$Th)) # %*% rotate est[load.idx] <- as.vector(loading[seq_along(ind.names),]) if (lavInspect(object, "options")$meanstructure) { est[int.idx] <- as.vector(invsd %*% intcept) } theta <- invsd %*% theta %*% invsd rownames(theta) <- colnames(theta) <- ov.names for(i in th.idx) est[i] <- theta[partable$lhs[i], partable$rhs[i]] # Put phi rv.idx <- which(partable$op == "~~" & partable$rhs %in% lv.names) templhs <- match(partable$lhs[rv.idx], lv.names) temprhs <- match(partable$rhs[rv.idx], lv.names) # rotate2 <- t(solve(rotate)) # phi <- t(rotate2) %*% rotate2 phi <- obj$Phi if (!is.null(phi)) { for (i in seq_along(templhs)) { est[rv.idx[i]] <- phi[templhs[i], temprhs[i]] } } est } ##' @importFrom lavaan lavInspect parTable seStdLoadings <- function(rotate, object, fun, MoreArgs) { # object <- efaUnrotate(HolzingerSwineford1939, nf=3, varList=paste0("x", 1:9), estimator="mlr") # initL <- getLoad(object) # rotate <- GPArotation::GPFoblq(initL, method="oblimin") rotMat <- t(solve(rotate$Th)) gradient <- rotate$Gq loading <- rotate$loadings phi <- rotate$Phi if (is.null(phi)) phi <- diag(ncol(loading)) est <- lavaan::parameterEstimates(object)$est aux <- object@external$aux # Standardized results JAC1 <- lavaan::lav_func_jacobian_simple(func = stdRotatedLoadings, x = object@Fit@est, object = object, aux = aux, rotate = rotMat, fun = fun, MoreArgs = MoreArgs) LIST <- lavInspect(object, "list") free.idx <- which(LIST$free > 0L) m <- ncol(phi) phi.idx <- which(LIST$op == "~~" & LIST$lhs != LIST$rhs & (LIST$lhs %in% paste0("factor", 1:m))) JAC1 <- JAC1[c(free.idx, phi.idx), free.idx] VCOV <- as.matrix(lavaan::vcov(object, labels = FALSE)) if(object@Model@eq.constraints) { JAC1 <- JAC1 %*% object@Model@eq.constraints.K } COV1 <- JAC1 %*% VCOV %*% t(JAC1) # I1 <- MASS::ginv(COV1) # I1p <- matrix(0, nrow(I1) + length(phi.idx), ncol(I1) + length(phi.idx)) # I1p[1:nrow(I1), 1:ncol(I1)] <- I1 # phi.idx2 <- nrow(I1) + 1:length(phi.idx) # p <- nrow(loading) # dconlambda <- matrix(0, m^2 - m, p*m) # gradphi <- gradient %*% solve(phi) # lambgradphi <- t(loading) %*% gradphi # lambphi <- loading %*% solve(phi) # lamblamb <- t(loading) %*% loading # runrow <- 1 # descript <- NULL # for(u in 1:m) { # for(v in setdiff(1:m, u)) { # runcol <- 1 # for(r in 1:m) { # for(i in 1:p) { # mir <- (1 - 1/p) * sum(loading[i,]^2) + sum(loading[,r]^2)/p - loading[i,r]^2 # dur <- 0 # if(u == r) dur <- 1 # dconlambda[runrow, runcol] <- dur * gradphi[i, v] + 4 * mir * loading[i, u] * phi[r, v] + (8 - 8/p)*loading[i,r]*loading[i,u]*lambphi[i,v] + 8*loading[i,r]*lamblamb[u,r]*phi[r,v]/p - 8*loading[i,r]^2*loading[i,u]*phi[r,v] # descript <- rbind(descript, c(runrow, runcol, u, v, i, r)) # runcol <- runcol + 1 # } # } # runrow <- runrow + 1 # } # } # dconphi <- matrix(0, m^2 - m, m*(m-1)/2) # runrow <- 1 # descript2 <- NULL # for(u in 1:m) { # for(v in setdiff(1:m, u)) { # runcol <- 1 # for(x in 2:m) { # for(y in 1:(x - 1)) { # dux <- 0 # if(u == x) dux <- 1 # duy <- 0 # if(u == y) duy <- 1 # dconphi[runrow, runcol] <- -(dux * phi[y, v] + duy * phi[x, v]) * lambgradphi[u, u] # descript2 <- rbind(descript2, c(runrow, runcol, u, v, x, y)) # runcol <- runcol + 1 # } # } # runrow <- runrow + 1 # } # } # I2 <- matrix(0, nrow(I1p) + m^2 - m, ncol(I1p) + m^2 - m) # I2[1:nrow(I1p), 1:ncol(I1p)] <- I1p # I2[lamb.idx, 1:(m^2 - m) + nrow(I1p)] <- t(dconlambda) # I2[1:(m^2 - m) + nrow(I1p), lamb.idx] <- dconlambda # I2[phi.idx2, 1:(m^2 - m) + nrow(I1p)] <- t(dconphi) # I2[1:(m^2 - m) + nrow(I1p), phi.idx2] <- dconphi # COV2 <- MASS::ginv(I2)[1:nrow(I1p), 1:ncol(I1p)] COV2 <- COV1 LIST <- LIST[,c("lhs", "op", "rhs", "group")] LIST$se <- rep(NA, length(LIST$lhs)) LIST$se[c(free.idx, phi.idx)] <- sqrt(diag(COV2)) tmp.se <- ifelse( LIST$se == 0.0, NA, LIST$se) lv.names <- lavaan::lavNames(object@ParTable, "lv", group = 1) partable <- parTable(object) idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names)) matrix(LIST$se[idx], ncol = length(lv.names)) } checkOrdered <- function(dat, varnames, ..., return.names = FALSE) { ord <- list(...)$ordered if (is.null(ord)) { ord <- FALSE } else { ord <- TRUE } if (is.null(dat)) { orderedVar <- FALSE } else { orderedVar <- sapply(dat[,varnames], function(x) "ordered" %in% is(x)) } if (return.names) { ## added by TDJ 4-Feb-2020 return(unique(c(list(...)$ordered, names(orderedVar[orderedVar])))) } any(c(ord, orderedVar)) } semTools/R/tukeySEM.R0000644000176200001440000000505514632016456014125 0ustar liggesusers### Alexander M. Schoemann ### Last updated: 9 March 2018 #' Tukey's WSD post-hoc test of means for unequal variance and sample size #' #' This function computes Tukey's WSD post hoc test of means when variances and #' sample sizes are not equal across groups. It can be used as a post hoc test #' when comparing latent means in multiple group SEM. #' #' After conducting an omnibus test of means across three of more groups, #' researchers often wish to know which sets of means differ at a particular #' Type I error rate. Tukey's WSD test holds the error rate stable across #' multiple comparisons of means. This function implements an adaptation of #' Tukey's WSD test from Maxwell & Delaney (2004), that allows variances and #' sample sizes to differ across groups. #' #' #' @importFrom stats ptukey #' #' @param m1 Mean of group 1. #' @param m2 Mean of group 2. #' @param var1 Variance of group 1. #' @param var2 Variance of group 2. #' @param n1 Sample size of group 1. #' @param n2 Sample size of group 2. #' @param ng Total number of groups to be compared (i.e., the number of groups #' compared in the omnibus test). #' @return A vector with three elements: #' \enumerate{ #' \item `q`: The *q* statistic #' \item `df`: The degrees of freedom for the *q* statistic #' \item `p`: A *p* value based on the *q* statistic, *df*, #' and the total number of groups to be compared #' } #' @author Alexander M. Schoemann (East Carolina University; #' \email{schoemanna@@ecu.edu}) #' @references Maxwell, S. E., & Delaney, H. D. (2004). *Designing #' experiments and analyzing data: A model comparison perspective* (2nd ed.). #' Mahwah, NJ: Lawrence Erlbaum Associates. #' @examples #' #' ## For a case where three groups have been compared: #' ## Group 1: mean = 3.91, var = 0.46, n = 246 #' ## Group 2: mean = 3.96, var = 0.62, n = 465 #' ## Group 3: mean = 2.94, var = 1.07, n = 64 #' #' ## compare group 1 and group 2 #' tukeySEM(3.91, 3.96, 0.46, 0.62, 246, 425, 3) #' #' ## compare group 1 and group 3 #' tukeySEM(3.91, 2.94, 0.46, 1.07, 246, 64, 3) #' #' ## compare group 2 and group 3 #' tukeySEM(3.96, 2.94, 0.62, 1.07, 465, 64, 3) #' #' @export tukeySEM <- function(m1, m2, var1, var2, n1, n2, ng) { qNum <- abs(m1 - m2) qDenom <- sqrt(((var1/n1) + (var2/n2))/2) Tukeyq <- qNum / qDenom Tukeydf <- ((var1/n1) + (var2/n2))^2 / (((var1/n1)^2 / (n1 - 1)) + ((var2/n2)^2 / (n2 - 1))) c(q = Tukeyq, df = Tukeydf, p = 1 - ptukey(Tukeyq, ng, Tukeydf)) } ##Example from Schoemann (2013) ##Bio vs. policial science on evo misconceptions #tukeySEM(3.91, 3.96,.46, .62, 246, 425,3) semTools/R/miPowerFit.R0000644000176200001440000003654614632143376014517 0ustar liggesusers### Sunthud Pornprasertmanit and Terrence D. Jorgensen (added ... argument) ### Last updated: 2 September 2021 ##' Modification indices and their power approach for model fit evaluation ##' ##' The model fit evaluation approach using modification indices and expected ##' parameter changes. ##' ##' To decide whether a parameter should be freed, one can inspect its ##' modification index (MI) and expected parameter change (EPC). ##' Those values can be used to evaluate model fit by 2 methods. ##' ##' Method 1: Saris, Satorra, and van der Veld (2009, pp. 570--573) used ##' power (probability of detecting a significant MI) and EPC to decide whether ##' to free a parametr. First, one should evaluate whether a parameter's MI ##' is significant. Second, one should evaluate whether the power to detect a ##' target EPC is high enough. The combination of criteria leads to the ##' so-called "JRule" first implemented with LISREL (van der Veld et al., 2008): ##' ##' \itemize{ ##' \item If the MI is not significant and the power is low, ##' the test is inconclusive. ##' \item If the MI is not significant and the power is high, ##' there is no misspecification. ##' \item If the MI is significant and the power is low, ##' the fixed parameter is misspecified. ##' \item If the MI is significant and the power is high, ##' the EPC is investigated. If the EPC is large (greater than the ##' the target EPC), the parameter is misspecified. If the EPC is low ##' (lower than the target EPC), the parameter is not misspecificied. ##' } ##' ##' Method 2: The confidence interval (CI) of an EPC is calculated. ##' These CIs are compared with the range of trivial ##' misspecification, which could be (-`delta`, `delta`) or (0, ##' `delta`) for nonnegative parameters. ##' ##' \itemize{ ##' \item If a CI overlaps with the range of trivial misspecification, ##' the test is inconclusive. ##' \item If a CI completely exceeds the range of trivial misspecification, ##' the fixed parameters are severely misspecified. ##' \item If a CI is completely within the range of trivial misspecification, ##' the fixed parameters are trivially misspecified. ##' } ##' ##' ##' @aliases miPowerFit miPowerFit ##' @importFrom lavaan lavInspect ##' @importFrom stats qnorm qchisq pchisq ##' ##' @param lavaanObj The lavaan model object used to evaluate model fit ##' @param stdLoad The amount of standardized factor loading that one would like ##' to be detected (rejected). The default value is 0.4, which is suggested by ##' Saris and colleagues (2009, p. 571). ##' @param cor The amount of factor or error correlations that one would like to ##' be detected (rejected). The default value is 0.1, which is suggested by ##' Saris and colleagues (2009, p. 571). ##' @param stdBeta The amount of standardized regression coefficients that one ##' would like to be detected (rejected). The default value is 0.1, which is ##' suggested by Saris and colleagues (2009, p. 571). ##' @param intcept The amount of standardized intercept (similar to Cohen's ##' *d* that one would like to be detected (rejected). The default value ##' is 0.2, which is equivalent to a low effect size proposed by Cohen (1988, ##' 1992). ##' @param stdDelta The vector of the standardized parameters that one would ##' like to be detected (rejected). If this argument is specified, the value ##' here will overwrite the other arguments above. The order of the vector ##' must be the same as the row order from modification indices from the ##' `lavaan` object. If a single value is specified, the value will be ##' applied to all parameters. ##' @param delta The vector of the unstandardized parameters that one would like ##' to be detected (rejected). If this argument is specified, the value here ##' will overwrite the other arguments above. The order of the vector must be ##' the same as the row order from modification indices from the `lavaan` ##' object. If a single value is specified, the value will be applied to all ##' parameters. ##' @param cilevel The confidence level of the confidence interval of expected ##' parameter changes. The confidence intervals are used in the equivalence ##' testing. ##' @param \dots arguments passed to [lavaan::modificationIndices()], ##' except for `delta`, which is already an argument (which can be ##' substituted for `stdDelta` or specific sets of parameters using ##' `stdLoad`, `cor`, `stdBeta`, and `intcept`). ##' ##' @return A data frame with these variables: ##' \enumerate{ ##' \item `lhs`: The left-hand side variable, with respect to the operator in ##' in the lavaan [lavaan::model.syntax()] ##' \item `op`: The lavaan syntax operator: "~~" represents covariance, ##' "=~" represents factor loading, "~" represents regression, and ##' "~1" represents intercept. ##' \item `rhs`: The right-hand side variable ##' \item `group`: The level of the group variable for the parameter in question ##' \item `mi`: The modification index of the fixed parameter ##' \item `epc`: The EPC if the parameter is freely estimated ##' \item `target.epc`: The target EPC that represents the minimum size ##' of misspecification that one would like to be detected ##' by the test with a high power ##' \item `std.epc`: The standardized EPC if the parameter is freely estimated ##' \item `std.target.epc`: The standardized target expected parameter change ##' \item `significant.mi`: Represents whether the modification index value is ##' significant ##' \item `high.power`: Represents whether the power is enough to detect the ##' target expected parameter change ##' \item `decision.pow`: The decision whether the parameter is misspecified ##' or not based on Saris et al's method: `"M"` represents the parameter ##' is misspecified, `"NM"` represents the parameter is not misspecified, ##' `"EPC:M"` represents the parameter is misspecified decided by ##' checking the expected parameter change value, `"EPC:NM"` represents ##' the parameter is not misspecified decided by checking the expected ##' parameter change value, and `"I"` represents the decision is ##' inconclusive. ##' \item `se.epc`: The standard errors of the expected parameter changes. ##' \item `lower.epc`: The lower bound of the confidence interval of expected ##' parameter changes. ##' \item `upper.epc`: The upper bound of the confidence interval of expected ##' parameter changes. ##' \item `lower.std.epc`: Lower confidence limit of standardized EPCs ##' \item `upper.std.epc`: Upper confidence limit of standardized EPCs ##' \item `decision.ci`: Decision whether the parameter is misspecified ##' based on the CI method: `"M"` represents the ##' parameter is misspecified, `"NM"` represents the parameter is not ##' misspecified, and `"I"` represents the decision is inconclusive. ##' } ##' ##' The row numbers matches with the results obtained from the ##' `inspect(object, "mi")` function. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso [moreFitIndices()] For the additional fit indices ##' information ##' ##' @references ##' Cohen, J. (1988). *Statistical power analysis for the ##' behavioral sciences* (2nd ed.). Hillsdale, NJ: Erlbaum. ##' ##' Cohen, J. (1992). A power primer. *Psychological Bulletin, 112*(1), ##' 155--159. \doi{10.1037/0033-2909.112.1.155} ##' ##' Saris, W. E., Satorra, A., & van der Veld, W. M. (2009). Testing structural ##' equation models or detection of misspecifications? *Structural Equation ##' Modeling, 16*(4), 561--582. \doi{10.1080/10705510903203433} ##' ##' van der Veld, W. M., Saris, W. E., & Satorra, A. (2008). ##' *JRule 3.0 Users Guide*. \doi{10.13140/RG.2.2.13609.90729} ##' ##' @examples ##' ##' library(lavaan) ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ' ##' fit <- cfa(HS.model, data = HolzingerSwineford1939, ##' group = "sex", group.equal = c("loadings","intercepts")) ##' miPowerFit(fit, free.remove = FALSE, op = "=~") # loadings ##' miPowerFit(fit, free.remove = FALSE, op = "~1") # intercepts ##' ##' model <- ' ##' # latent variable definitions ##' ind60 =~ x1 + x2 + x3 ##' dem60 =~ y1 + a*y2 + b*y3 + c*y4 ##' dem65 =~ y5 + a*y6 + b*y7 + c*y8 ##' ##' # regressions ##' dem60 ~ ind60 ##' dem65 ~ ind60 + dem60 ##' ##' # residual correlations ##' y1 ~~ y5 ##' y2 ~~ y4 + y6 ##' y3 ~~ y7 ##' y4 ~~ y8 ##' y6 ~~ y8 ##' ' ##' fit2 <- sem(model, data = PoliticalDemocracy, meanstructure = TRUE) ##' miPowerFit(fit2, stdLoad = 0.3, cor = 0.2, stdBeta = 0.2, intcept = 0.5) ##' ##' @export miPowerFit <- function(lavaanObj, stdLoad = 0.4, cor = 0.1, stdBeta = 0.1, intcept = 0.2, stdDelta = NULL, delta = NULL, cilevel = 0.90, ...) { mi <- lavaan::modificationIndices(lavaanObj, ...) mi <- mi[mi$op != "==",] sigma <- mi[,"epc"] / sqrt(mi[,"mi"]) if (is.null(delta)) { if (is.null(stdDelta)) stdDelta <- getTrivialEpc(mi, stdLoad = stdLoad, cor = cor, stdBeta = stdBeta, intcept = intcept) if (length(stdDelta) == 1) stdDelta <- rep(stdDelta, nrow(mi)) delta <- unstandardizeEpc(mi, stdDelta, findTotalVar(lavaanObj)) } if (length(delta) == 1) delta <- rep(delta, nrow(mi)) ncp <- (delta / sigma)^2 alpha <- 0.05 desiredPow <- 0.80 cutoff <- qchisq(1 - alpha, df = 1) pow <- 1 - pchisq(cutoff, df = 1, ncp = ncp) sigMI <- mi[,"mi"] > cutoff highPow <- pow > desiredPow group <- rep(1, nrow(mi)) if ("group" %in% colnames(mi)) group <- mi[ , "group"] decision <- mapply(decisionMIPow, sigMI = sigMI, highPow = highPow, epc = mi[ , "epc"], trivialEpc = delta) if (is.null(stdDelta)) stdDelta <- standardizeEpc(mi, findTotalVar(lavaanObj), delta = delta) result <- cbind(mi[ , 1:3], group, as.numeric(mi[ , "mi"]), mi[ , "epc"], delta, standardizeEpc(mi, findTotalVar(lavaanObj)), stdDelta, sigMI, highPow, decision) # New method crit <- abs(qnorm((1 - cilevel)/2)) seepc <- abs(result[,6]) / sqrt(abs(result[,5])) lowerepc <- result[,6] - crit * seepc upperepc <- result[,6] + crit * seepc stdlowerepc <- standardizeEpc(mi, findTotalVar(lavaanObj), delta = lowerepc) stdupperepc <- standardizeEpc(mi, findTotalVar(lavaanObj), delta = upperepc) isVar <- mi[,"op"] == "~~" & mi[,"lhs"] == mi[,"rhs"] decisionci <- mapply(decisionCIEpc, targetval = as.numeric(stdDelta), lower = stdlowerepc, upper = stdupperepc, positiveonly = isVar) result <- cbind(result, seepc, lowerepc, upperepc, stdlowerepc, stdupperepc, decisionci) result <- result[!is.na(decision), ] colnames(result) <- c("lhs","op","rhs","group","mi","epc","target.epc", "std.epc","std.target.epc","significant.mi", "high.power","decision.pow","se.epc","lower.epc", "upper.epc","lower.std.epc","upper.std.epc","decision.ci") class(result) <- c("lavaan.data.frame","data.frame") return(result) } ## ---------------- ## Hidden Functions ## ---------------- ## totalFacVar: Find total factor variances when regression coeffient matrix ## and factor residual covariance matrix are specified totalFacVar <- function(beta, psi) { ID <- diag(nrow(psi)) total <- solve(ID - beta) %*% psi %*% t(solve(ID - beta)) return(diag(total)) } ## findTotalVar: find the total indicator and factor variances ##' @importFrom lavaan lavInspect findTotalVar <- function(lavaanObj) { result <- list() nGroups <- lavInspect(lavaanObj, "ngroups") cov.all <- lavInspect(lavaanObj, "cov.all") if (nGroups == 1) cov.all <- list(cov.all) for (i in 1:nGroups) { temp <- diag(cov.all[[i]]) names(temp) <- rownames(cov.all[[i]]) result[[i]] <- temp } return(result) } ## getTrivialEpc: find the trivial misspecified expected parameter changes ## given the type of parameters in each row of modification indices getTrivialEpc <- function(mi, stdLoad=0.4, cor=0.1, stdBeta=0.1, intcept=0.2) { op <- mi[,"op"] result <- gsub("=~", stdLoad, op) result <- gsub("~~", cor, result) result <- gsub("~1", intcept, result) result <- gsub("~", stdBeta, result) return(result) } ## unstandardizeEpc: Transform from standardized EPC to unstandardized EPC unstandardizeEpc <- function(mi, delta, totalVar) { name <- names(totalVar[[1]]) lhsPos <- match(mi[,"lhs"], name) rhsPos <- match(mi[,"rhs"], name) group <- rep(1, nrow(mi)) if("group" %in% colnames(mi)) group <- mi[,"group"] getVar <- function(pos, group) totalVar[[group]][pos] lhsVar <- mapply(getVar, pos=lhsPos, group=group) rhsVar <- mapply(getVar, pos=rhsPos, group=group) FUN <- function(op, lhsVar, rhsVar, delta) { if(op == "|") return(NA) lhsSD <- sqrt(lhsVar) rhsSD <- sqrt(rhsVar) if(!is.numeric(delta)) delta <- as.numeric(delta) if(op == "=~") { return((rhsSD * delta) / lhsSD) } else if (op == "~~") { return(lhsSD * delta * rhsSD) } else if (op == "~1") { return(lhsSD * delta) } else if (op == "~") { return((lhsSD * delta) / rhsSD) } else { return(NA) } } unstdDelta <- mapply(FUN, op=mi[,"op"], lhsVar=lhsVar, rhsVar=rhsVar, delta=delta) return(unstdDelta) } ## unstandardizeEpc: Transform from unstandardized EPC to standardized EPC. ## If delta is null, the unstandardized epc from the modification indices ## data.frame are used standardizeEpc <- function(mi, totalVar, delta = NULL) { if(is.null(delta)) delta <- mi[,"epc"] name <- names(totalVar[[1]]) lhsPos <- match(mi[,"lhs"], name) rhsPos <- match(mi[,"rhs"], name) group <- rep(1, nrow(mi)) if("group" %in% colnames(mi)) group <- mi[,"group"] getVar <- function(pos, group) totalVar[[group]][pos] lhsVar <- mapply(getVar, pos=lhsPos, group=group) rhsVar <- mapply(getVar, pos=rhsPos, group=group) FUN <- function(op, lhsVar, rhsVar, delta) { lhsSD <- sqrt(lhsVar) rhsSD <- sqrt(rhsVar) if(!is.numeric(delta)) delta <- as.numeric(delta) if(op == "=~") { #stdload = beta * sdlatent / sdindicator = beta * lhs / rhs return((delta / rhsSD) * lhsSD) } else if (op == "~~") { #r = cov / (sd1 * sd2) return(delta / (lhsSD * rhsSD)) } else if (op == "~1") { #d = meanDiff/sd return(delta / lhsSD) } else if (op == "~") { #beta = b * sdX / sdY = b * rhs / lhs return((delta / lhsSD) * rhsSD) } else { return(NA) } } stdDelta <- mapply(FUN, op=mi[,"op"], lhsVar=lhsVar, rhsVar=rhsVar, delta=delta) return(stdDelta) } ## decisionMIPow: provide the decision given the significance of modification ## indices and power to detect trivial misspecification decisionMIPow <- function(sigMI, highPow, epc, trivialEpc) { if(is.na(sigMI) | is.na(highPow)) return(NA) if(sigMI & highPow) { if(abs(epc) > abs(trivialEpc)) { return("EPC:M") } else { return("EPC:NM") } } else if (sigMI & !highPow) { return("M") } else if (!sigMI & highPow) { return("NM") } else if (!sigMI & !highPow) { return("I") } else { return(NA) } } decisionCIEpc <- function(targetval, lower, upper, positiveonly = FALSE) { if(is.na(lower) | is.na(upper)) return(NA) if(positiveonly) { if(lower > targetval) { return("M") } else if (upper < targetval) { return("NM") } else { return("I") } } else { negtargetval <- -targetval if(lower > targetval | upper < negtargetval) { return("M") } else if (upper < targetval & negtargetval < lower) { return("NM") } else { return("I") } } } semTools/R/plausibleValues.R0000644000176200001440000006520314764326230015560 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### function to draw plausible values of factor scores from lavPredict # library(blavaan) # bfit <- bcfa(HS.model, data=HolzingerSwineford1939, save.lvs = TRUE, # bcontrol=list(method="rjparallel"), group = "school", # #target = "stan", control=list(cores = 4, seed = 123), # burnin = 4000, sample = 30, n.chains = 2) # bFS <- do.call(rbind, blavInspect(bfit, "lvs")) # do.call() ## ------------- ## Main function ## ------------- ##' Plausible-Values Imputation of Factor Scores Estimated from a lavaan Model ##' ##' Draw plausible values of factor scores estimated from a fitted ##' [lavaan::lavaan()] model, then treat them as multiple imputations ##' of missing data using [lavaan.mi::lavaan.mi()]. ##' ##' ##' Because latent variables are unobserved, they can be considered as missing ##' data, which can be imputed using Monte Carlo methods. This may be of ##' interest to researchers with sample sizes too small to fit their complex ##' structural models. Fitting a factor model as a first step, ##' [lavaan::lavPredict()] provides factor-score estimates, which can ##' be treated as observed values in a path analysis (Step 2). However, the ##' resulting standard errors and test statistics could not be trusted because ##' the Step-2 analysis would not take into account the uncertainty about the ##' estimated factor scores. Using the asymptotic sampling covariance matrix ##' of the factor scores provided by [lavaan::lavPredict()], ##' `plausibleValues` draws a set of `nDraws` imputations from the ##' sampling distribution of each factor score, returning a list of data sets ##' that can be treated like multiple imputations of incomplete data. If the ##' data were already imputed to handle missing data, `plausibleValues` ##' also accepts an object of class [lavaan.mi::lavaan.mi-class], and will ##' draw `nDraws` plausible values from each imputation. Step 2 would ##' then take into account uncertainty about both missing values and factor ##' scores. Bayesian methods can also be used to generate factor scores, as ##' available with the \pkg{blavaan} package, in which case plausible ##' values are simply saved parameters from the posterior distribution. See ##' Asparouhov and Muthen (2010) for further technical details and references. ##' ##' Each returned `data.frame` includes a `case.idx` column that ##' indicates the corresponding rows in the data set to which the model was ##' originally fitted (unless the user requests only Level-2 variables). This ##' can be used to merge the plausible values with the original observed data, ##' but users should note that including any new variables in a Step-2 model ##' might not accurately account for their relationship(s) with factor scores ##' because they were not accounted for in the Step-1 model from which factor ##' scores were estimated. ##' ##' If `object` is a multilevel `lavaan` model, users can request ##' plausible values for latent variables at particular levels of analysis by ##' setting the [lavaan::lavPredict()] argument `level=1` or ##' `level=2`. If the `level` argument is not passed via \dots, ##' then both levels are returned in a single merged data set per draw. For ##' multilevel models, each returned `data.frame` also includes a column ##' indicating to which cluster each row belongs (unless the user requests only ##' Level-2 variables). ##' ##' ##' @importFrom lavaan lavInspect lavPredict ##' ##' @param object A fitted model of class [lavaan::lavaan-class], ##' [blavaan::blavaan-class], or [lavaan.mi::lavaan.mi-class] ##' @param nDraws `integer` specifying the number of draws, analogous to ##' the number of imputed data sets. If `object` is of class ##' [lavaan.mi::lavaan.mi-class], this will be the number of draws taken ##' *per imputation*. If `object` is of class ##' [blavaan::blavaan-class], `nDraws` cannot exceed ##' `blavInspect(object, "niter") * blavInspect(bfitc, "n.chains")` ##' (number of MCMC samples from the posterior). The drawn samples will be ##' evenly spaced (after permutation for `target="stan"`), using ##' [ceiling()] to resolve decimals. ##' @param seed `integer` passed to [set.seed()]. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations when `object` is of class [lavaan.mi::lavaan.mi-class]. ##' Can include any of `c("no.conv", "no.se", "no.npd")`. ##' @param ... Optional arguments to pass to [lavaan::lavPredict()]. ##' `assemble` will be ignored because multiple groups are always ##' assembled into a single `data.frame` per draw. `type` will be ##' ignored because it is set internally to `type="lv"`. ##' ##' @return A `list` of length `nDraws`, each of which is a ##' `data.frame` containing plausible values, which can be treated as ##' a `list` of imputed data sets to be passed to [runMI()] ##' (see **Examples**). If `object` is of class ##' [lavaan.mi::lavaan.mi-class], the `list` will be of length ##' `nDraws*m`, where `m` is the number of imputations. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Asparouhov, T. & Muthen, B. O. (2010). *Plausible values for latent ##' variables using M*plus. Technical Report. Retrieved from ##' www.statmodel.com/download/Plausible.pdf ##' ##' @seealso [lavaan.mi::lavaan.mi()], [lavaan.mi::lavaan.mi-class] ##' ##' @examples ##' ##' ## example from ?cfa and ?lavPredict help pages ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit1 <- cfa(HS.model, data = HolzingerSwineford1939) ##' fs1 <- plausibleValues(fit1, nDraws = 3, ##' ## lavPredict() can add only the modeled data ##' append.data = TRUE) ##' lapply(fs1, head) ##' ##' \donttest{ ##' ## To merge factor scores to original data.frame (not just modeled data) ##' fs1 <- plausibleValues(fit1, nDraws = 3) ##' idx <- lavInspect(fit1, "case.idx") # row index for each case ##' if (is.list(idx)) idx <- do.call(c, idx) # for multigroup models ##' data(HolzingerSwineford1939) # copy data to workspace ##' HolzingerSwineford1939$case.idx <- idx # add row index as variable ##' ## loop over draws to merge original data with factor scores ##' for (i in seq_along(fs1)) { ##' fs1[[i]] <- merge(fs1[[i]], HolzingerSwineford1939, by = "case.idx") ##' } ##' lapply(fs1, head) ##' ##' ##' ## multiple-group analysis, in 2 steps ##' step1 <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", ##' group.equal = c("loadings","intercepts")) ##' PV.list <- plausibleValues(step1) ##' ##' ## subsequent path analysis ##' path.model <- ' visual ~ c(t1, t2)*textual + c(s1, s2)*speed ' ##' if(requireNamespace("lavaan.mi")){ ##' library(lavaan.mi) ##' step2 <- sem.mi(path.model, data = PV.list, group = "school") ##' ## test equivalence of both slopes across groups ##' lavTestWald.mi(step2, constraints = 't1 == t2 ; s1 == s2') ##' } ##' ##' ##' ## multilevel example from ?Demo.twolevel help page ##' model <- ' ##' level: 1 ##' fw =~ y1 + y2 + y3 ##' fw ~ x1 + x2 + x3 ##' level: 2 ##' fb =~ y1 + y2 + y3 ##' fb ~ w1 + w2 ##' ' ##' msem <- sem(model, data = Demo.twolevel, cluster = "cluster") ##' mlPVs <- plausibleValues(msem, nDraws = 3) # both levels by default ##' lapply(mlPVs, head, n = 10) ##' ## only Level 1 ##' mlPV1 <- plausibleValues(msem, nDraws = 3, level = 1) ##' lapply(mlPV1, head) ##' ## only Level 2 ##' mlPV2 <- plausibleValues(msem, nDraws = 3, level = 2) ##' lapply(mlPV2, head) ##' ##' ##' ##' ## example with 20 multiple imputations of missing data: ##' nPVs <- 5 ##' nImps <- 20 ##' ##' if(requireNamespace("lavaan.mi")){ ##' data(HS20imps, package = "lavaan.mi") ##' ##' ## specify CFA model from lavaan's ?cfa help page ##' HS.model <- ' ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' ' ##' out2 <- cfa.mi(HS.model, data = HS20imps) ##' PVs <- plausibleValues(out2, nDraws = nPVs) ##' ##' idx <- out2@@Data@@case.idx # can't use lavInspect() on lavaan.mi ##' ## empty list to hold expanded imputations ##' impPVs <- list() ##' for (m in 1:nImps) { ##' HS20imps[[m]]["case.idx"] <- idx ##' for (i in 1:nPVs) { ##' impPVs[[ nPVs*(m - 1) + i ]] <- merge(HS20imps[[m]], ##' PVs[[ nPVs*(m - 1) + i ]], ##' by = "case.idx") ##' } ##' } ##' lapply(impPVs, head) ##' } ##' ##' } ##' ##' @export plausibleValues <- function(object, nDraws = 20L, seed = 12345, omit.imps = c("no.conv","no.se"), ...) { if (inherits(object, "lavaan")) { ## generate vector of seeds set.seed(seed) seeds <- sample(100000:9999999, size = nDraws, replace = FALSE) PV <- lapply(seeds, plaus.lavaan, object = object, ...) } else if (inherits(object, "lavaan.mi")) { ## generate vector of seeds set.seed(seed) seeds <- sample(100000:9999999, size = nDraws, replace = FALSE) PV <- plaus.mi(object, seeds = seeds, omit.imps = omit.imps, ...) } else if (inherits(object, "blavaan")) { PV <- plaus.blavaan(object, nDraws = nDraws, seed = seed, ...) #TODO: pass nDraws to sample() iterations? } else stop("object's class not valid: ", class(object)) PV } ## ---------------- ## Hidden functions ## ---------------- ## draw 1 set of plausible values from a lavaan object ##' @importFrom lavaan lavInspect lavPredict lavNames plaus.lavaan <- function(seed = 1, object, ...) { stopifnot(inherits(object, "lavaan")) if (lavInspect(object, "categorical")) { stop("Plausible values not available (yet) for categorical data") } if (lavInspect(object, "options")$missing %in% c("ml", "ml.x")) { #TODO: verify this: stop("Plausible values not available (yet) for missing data + fiml.\n", " Multiple imputations can be used via lavaan.mi()") } #FIXME? https://github.com/yrosseel/lavaan/issues/156 set.seed(seed) cluster <- lavInspect(object, "cluster") group <- lavInspect(object, "group") group.label <- lavInspect(object, "group.label") nG <- lavInspect(object, "ngroups") nL <- lavInspect(object, "nlevels") l.names <- o.names <- list() if (nG == 1L && nL == 1L) { ## single block l.names <- list(lavNames(object, "lv")) o.names <- list(lavNames(object, "ov")) } else if (nG == 1L && nL > 1L) { ## multilevel for (BB in 1:nL) { l.names <- c(l.names, list(lavNames(object, "lv", block = BB))) o.names <- c(o.names, list(lavNames(object, "ov", block = BB))) } } else if (nG > 1L && nL == 1L) { ## multigroup for (BB in 1:nG) { l.names <- c(l.names, list(lavNames(object, "lv", block = BB))) o.names <- c(o.names, list(lavNames(object, "ov", block = BB))) } } else { ## multilevel + multigroup for (BB in 1:(nG*nL)) { #FIXME: lavInspect(object, "nblocks") l.names <- c(l.names, list(lavNames(object, "lv", block = BB))) o.names <- c(o.names, list(lavNames(object, "ov", block = BB))) } } ## extract factor scores + covariance matrix fsArgs <- list(...) fsArgs$type <- "lv" fsArgs$assemble <- FALSE # assemble after drawing append.data <- fsArgs$append.data if (is.null(append.data)) append.data <- FALSE # default in lavPredict() only.L2 <- fsArgs$level == 2L if (length(only.L2) == 0L) only.L2 <- FALSE if (only.L2) fsArgs$append.data <- append.data <- FALSE #FIXME: how will Yves handle lavPredict(fit, append=T, level=2)? bothLevels <- nL > 1L && is.null(fsArgs$level) fsArgs$object <- object fsArgs$acov <- "standard" #FIXME: update if other options become available FS <- do.call(lavPredict, fsArgs) #FIXME: breaks when multigroup MLSEM: https://github.com/yrosseel/lavaan/issues/157 ## also draw Level 2, if multilevel and no specific level requested if (bothLevels) { fsArgs$level <- 2L fsArgs$append.data <- FALSE #FIXME: how will Yves handle lavPredict(fit, append=T, level=2)? FS2 <- do.call(lavPredict, fsArgs) } ## draw plausible values, if factor scores exist if (nG == 1L) { if (ncol(FS) == 0L) { PV <- FS } else { ACOV <- attr(FS, "acov")[[1]] v.idx <- if (only.L2) 2L else 1L PV <- apply(FS[ , l.names[[v.idx]], drop = FALSE], 1, function(mu) { mnormt::rmnorm(n = 1, mean = mu, varcov = ACOV) }) if (is.null(dim(PV))) { PV <- as.matrix(PV) colnames(PV) <- l.names[[v.idx]] } else PV <- t(PV) if (append.data) { PV <- cbind(FS[ , o.names[[v.idx]], drop = FALSE], PV) } } ## add Level 2 if multilevel and no specific level requested if (bothLevels) { if (ncol(FS2) == 0L) { PV2 <- FS2 } else { ACOV2 <- attr(FS2, "acov")[[1]] #FIXME: how will Yves handle lavPredict(fit, append=T, level=2)? PV2 <- apply(FS2, 1, function(mu) { out <- mnormt::rmnorm(n = 1, mean = mu, varcov = ACOV2) }) if (is.null(dim(PV2))) { PV2 <- as.matrix(PV2) colnames(PV2) <- l.names[[2]] } else PV2 <- t(PV2) } } } else { ACOV <- list() PV <- list() for (gg in 1:nG) { if (ncol(FS[[gg]]) == 0L) { PV[[gg]] <- FS[[gg]] } else { ACOV[[gg]] <- attr(FS, "acov")[[gg]] v.idx <- if (only.L2) (2L + (gg - 1L)*nL) else (1L + (gg - 1L)*nL) PV[[gg]] <- apply(FS[[gg]][ , l.names[[v.idx]], drop = FALSE], 1, function(mu) { mnormt::rmnorm(n = 1, mean = mu, varcov = ACOV[[gg]]) }) if (is.null(dim(PV[[gg]]))) { PV[[gg]] <- as.matrix(PV[[gg]]) colnames(PV[[gg]]) <- l.names[[v.idx]] } else PV[[gg]] <- t(PV[[gg]]) } if (append.data) { PV[[gg]] <- cbind(FS[[gg]][ , o.names[[v.idx]], drop = FALSE], PV[[gg]]) } } ## add Level 2 if multilevel and no specific level requested if (bothLevels) { ACOV2 <- list() PV2 <- list() for (gg in 1:nG) { if (ncol(FS2[[gg]]) == 0L) { PV2[[gg]] <- FS2[[gg]] } else { ACOV2[[gg]] <- attr(FS2, "acov")[[gg]] #FIXME: how will Yves handle lavPredict(fit, append=T, level=2)? PV2[[gg]] <- apply(FS2[[gg]], 1, function(mu) { mnormt::rmnorm(n = 1, mean = mu, varcov = ACOV2[[gg]]) }) if (is.null(dim(PV2[[gg]]))) { PV2[[gg]] <- as.matrix(PV2[[gg]]) colnames(PV2[[gg]]) <- colnames(FS2[[gg]]) } else PV2[[gg]] <- t(PV2[[gg]]) } } } } ## save as data.frame if (nG > 1L) { temp <- lapply(1:nG, function(gg) { dd <- data.frame(PV[[gg]]) ## add groups if multiple dd[ , group] <- group.label[gg] dd <- dd[ , c(group, setdiff(names(dd), group)), drop = FALSE ] ## attach row indices from original data for optional merging if (only.L2) { dd[ , cluster] <- lavInspect(object, "cluster.id")[[gg]] dd <- dd[ , c(cluster, setdiff(names(dd), cluster)), drop = FALSE ] } else { dd <- cbind(case.idx = lavInspect(object, "case.idx")[[gg]], dd) } ## attach cluster IDs, if multilevel and no level requested if (bothLevels) { dd[ , cluster] <- lavInspect(object, "cluster.label")[[gg]] d2 <- data.frame(PV2[[gg]]) d2[ , group] <- group.label[gg] d2[ , cluster] <- lavInspect(object, "cluster.id")[[gg]] dd <- merge(dd, d2, by = c(group, cluster), all = TRUE) } dd }) PV <- do.call(rbind, temp) } else { PV <- data.frame(PV) ## attach row indices from original data for optional merging if (only.L2) { PV[ , cluster] <- lavInspect(object, "cluster.id") PV <- PV[ , c(cluster, setdiff(names(PV), cluster)), drop = FALSE ] } else { PV <- cbind(case.idx = lavInspect(object, "case.idx"), PV) } ## attach cluster IDs, if multilevel and no level requested if (bothLevels) { PV[ , cluster] <- lavInspect(object, "cluster.label") PV2 <- data.frame(PV2) PV2[ , cluster] <- lavInspect(object, "cluster.id") PV <- merge(PV, PV2, by = cluster, all = TRUE) } } PV } ## draw plausible values from a lavaan.mi object ##' @importFrom lavaan lavInspect lavPredict plaus.mi <- function(object, seeds = 1:5, omit.imps = c("no.conv","no.se"), ...) { stopifnot(inherits(object, "lavaan.mi")) if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } m <- sum(useImps) useImps <- which(useImps) ## check if model has converged if (m == 0L) stop("No models converged. Score tests unavailable.") oldCall <- object@lavListCall if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L message("Unable to pass lavaan::lavPredict() arguments ", "when parallel='snow'. Switching to parallel='no'.", " Unless using Windows, parallel='multicore' should work.") } } ## call lavaanList() again to run lavTestScore() on each imputation oldCall$dataList <- object@DataList[useImps] oldCall$FUN <- function(obj) lapply(seeds, plaus.lavaan, object = obj, ...) FIT <- eval(as.call(oldCall)) ## check if there are any results noFS <- sapply(FIT@funList, is.null) if (all(noFS)) stop("No success drawing plausible values for any imputations.") do.call(c, FIT@funList) # concatenate lists } ## draw 1 set of plausible values from a blavaan object ##' @importFrom lavaan lavNames lavInspect plaus.blavaan <- function(object, nDraws = 20L, seed = 12345, ...) { stopifnot(inherits(object, "blavaan")) if (!"package:blavaan" %in% search()) attachNamespace("blavaan") # cluster <- lavInspect(object, "cluster") group <- lavInspect(object, "group") group.label <- lavInspect(object, "group.label") nG <- lavInspect(object, "ngroups") # nL <- lavInspect(object, "nlevels") case.idx <- lavInspect(object, "case.idx") ## plausible values of what? (could be latent item responses) dots <- list(...) if (is.null(dots$type)) dots$type <- "lv" # default to factor scores dots$object <- object ## stack factor scores from each chain (one row per PV) FS <- do.call(blavaan::blavPredict, dots) #NOTE: might be latent responses ## only save nDraws from posterior if (nDraws >= length(FS)) { ## why would anyone want this many? Or sample so few during estimation? message('nDraws cannot exceed number of iterations in `object=`. \nSet to ', 'nDraws = blavInspect(object, "niter") * blavInspect(bfitc, "n.chains")') nDraws <- length(FS) } set.seed(seed) idx.sample <- ceiling(1:nDraws * length(FS)/nDraws) #FIXME: if Ed accepts pull request, format will be the same as c("yhat","ypred") if (dots$type == "lv" && utils::compareVersion(utils::packageDescription('blavaan')$Version, '0.4-2.949') >= 0L) { ## column names contain indices to store PVs in matrix eta.idx <- colnames(FS) ## N and latent variable names, to know dimensions of PV N <- lavInspect(object, "ntotal") etas <- lavNames(object, "lv") #FIXME: assumes same model in both groups PV <- list() ## loop over nDraws rows, assign columns to eta matrix, save in PV list set.seed(seed) idx.sample <- ceiling(1:nDraws * length(FS)/nDraws) for (i in idx.sample) { eta <- matrix(NA, nrow = N, ncol = length(etas), dimnames = list(NULL, etas)) for (j in eta.idx) eval(parse(text = paste(j, "<-", FS[i, j]) )) PV[[i]] <- data.frame(eta) ## add case indices, and groups (if applicable) if (nG == 1L) PV[[i]]$case.idx <- case.idx else { PV[[i]]$case.idx <- do.call(c, case.idx) PV[[i]][ , group] <- rep(group.label, times = lavInspect(object, "nobs")) } } } else { ## latent responses, already a list PV <- list() for (i in idx.sample) { ## convert matrix to data.frame PV[[i]] <- data.frame(FS[[i]]) ## add case indices, and groups (if applicable) if (nG == 1L) PV[[i]]$case.idx <- case.idx else { PV[[i]]$case.idx <- do.call(c, case.idx) PV[[i]][ , group] <- rep(group.label, times = lavInspect(object, "nobs")) } } } #else stop('Not implemented for blavPredict(object, type="', dots$type,'")') PV } ## ------ ## Checks ## ------ # HS.model <- ' visual =~ x1 + x2 + x3 # textual =~ x4 + x5 + x6 # speed =~ x7 + x8 + x9 ' # # fit1 <- cfa(HS.model, data = HolzingerSwineford1939) # fs1 <- plausibleValues(fit1, nDraws = 3, append.data = T) # lapply(fs1, head) # # # # step1 <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", # group.equal = c("loadings","intercepts")) # PV.list <- plausibleValues(step1, append.data = T) # lapply(PV.list[1:3], head) # # # model <- ' # level: 1 # fw =~ y1 + y2 + y3 # fw ~ x1 + x2 + x3 # level: 2 # fb =~ y1 + y2 + y3 # fb ~ w1 + w2 # ' # msem <- sem(model, data = Demo.twolevel, cluster = "cluster") # mlPVs <- plausibleValues(msem, nDraws = 3, append.data = T) # both levels by default # lapply(mlPVs, head, n = 10) # ## only Level 1 # mlPV1 <- plausibleValues(msem, nDraws = 3, level = 1, append.data = T) # lapply(mlPV1, head) # ## only Level 2 # mlPV2 <- plausibleValues(msem, nDraws = 3, level = 2, append.data = T) # lapply(mlPV2, head) # # # # data(Demo.twolevel) # Demo.twolevel$g <- ifelse(Demo.twolevel$cluster %% 2L, "foo", "bar") # arbitrary groups # table(Demo.twolevel$g) # model2 <- ' group: foo # level: within # fw =~ y1 + L2*y2 + L3*y3 # fw ~ x1 + x2 + x3 # level: between # fb =~ y1 + L2*y2 + L3*y3 # fb ~ w1 + w2 # # group: bar # # level: within # fw =~ y1 + L2*y2 + L3*y3 # fw ~ x1 + x2 + x3 # level: between # fb =~ y1 + L2*y2 + L3*y3 # fb ~ w1 + w2 # ' # msem2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") # ml2PVs <- plausibleValues(msem2, nDraws = 3, append.data = T) # both levels by default # lapply(ml2PVs, head, n = 10) # ## only Level 1 # ml2PV1 <- plausibleValues(msem2, nDraws = 3, level = 1, append.data = T) # lapply(ml2PV1, head) # ## only Level 2 # ml2PV2 <- plausibleValues(msem2, nDraws = 3, level = 2, append.data = T) # lapply(ml2PV2, head) ## ordered-categorical data # data(datCat) # # modc <- ' ## Set thresholds equal across groups # ## thresholds at Time 1 # u1 | c(tau1.1, tau1.1)*t1 + c(tau1.2, tau1.2)*t2 + c(tau1.3, tau1.3)*t3 + c(tau1.4, tau1.4)*t4 # u2 | c(tau2.1, tau2.1)*t1 + c(tau2.2, tau2.2)*t2 + c(tau2.3, tau2.3)*t3 + c(tau2.4, tau2.4)*t4 # u3 | c(tau3.1, tau3.1)*t1 + c(tau3.2, tau3.2)*t2 + c(tau3.3, tau3.3)*t3 + c(tau3.4, tau3.4)*t4 # u4 | c(tau4.1, tau4.1)*t1 + c(tau4.2, tau4.2)*t2 + c(tau4.3, tau4.3)*t3 + c(tau4.4, tau4.4)*t4 # ## thresholds at Time 2 equal to Time 1 # u5 | c(tau1.1, tau1.1)*t1 + c(tau1.2, tau1.2)*t2 + c(tau1.3, tau1.3)*t3 + c(tau1.4, tau1.4)*t4 # u6 | c(tau2.1, tau2.1)*t1 + c(tau2.2, tau2.2)*t2 + c(tau2.3, tau2.3)*t3 + c(tau2.4, tau2.4)*t4 # u7 | c(tau3.1, tau3.1)*t1 + c(tau3.2, tau3.2)*t2 + c(tau3.3, tau3.3)*t3 + c(tau3.4, tau3.4)*t4 # u8 | c(tau4.1, tau4.1)*t1 + c(tau4.2, tau4.2)*t2 + c(tau4.3, tau4.3)*t3 + c(tau4.4, tau4.4)*t4 # ## define latent responses as single-indicator factors (resid. var = 0) # y1 =~ 1*u1 ; u1 ~~ c(0, 0)*u1 # y2 =~ 1*u2 ; u2 ~~ c(0, 0)*u2 # y3 =~ 1*u3 ; u3 ~~ c(0, 0)*u3 # y4 =~ 1*u4 ; u4 ~~ c(0, 0)*u4 # y5 =~ 1*u5 ; u5 ~~ c(0, 0)*u5 # y6 =~ 1*u6 ; u6 ~~ c(0, 0)*u6 # y7 =~ 1*u7 ; u7 ~~ c(0, 0)*u7 # y8 =~ 1*u8 ; u8 ~~ c(0, 0)*u8 # ## only fix mean=0 in first group/occasion # y1 + y2 + y3 + y4 ~ c( 0, NA)*1 # y5 + y6 + y7 + y8 ~ c(NA, NA)*1 # ## only fix variance=1 in first groop/occasion # y1 ~~ c( 1, NA)*y1 # y2 ~~ c( 1, NA)*y2 # y3 ~~ c( 1, NA)*y3 # y4 ~~ c( 1, NA)*y4 # y5 ~~ c(NA, NA)*y5 # y6 ~~ c(NA, NA)*y6 # y7 ~~ c(NA, NA)*y7 # y8 ~~ c(NA, NA)*y8 # ## estimate all covariances # y1 ~~ y2 + y3 + y4 + y5 + y6 + y7 + y8 # y2 ~~ y3 + y4 + y5 + y6 + y7 + y8 # y3 ~~ y4 + y5 + y6 + y7 + y8 # y4 ~~ y5 + y6 + y7 + y8 # y5 ~~ y6 + y7 + y8 # y6 ~~ y7 + y8 # y7 ~~ y8 # ' # ## fit in lavaan for sanity check # fitc <- lavaan(modc, data = datCat, group = "g", parameterization = "theta") # summary(fitc) # # ## impose 5% MCAR # set.seed(123) # for (i in 1:8) datCat[sample(1:nrow(datCat), size = .05*nrow(datCat)), i] <- NA # # ## try with pairwise deletion # fitcm <- lavaan(modc, data = datCat, group = "g", parameterization = "theta", # missing = "pairwise") # summary(fitcm) # # ## try blavaan # data(datCat) # doesn't yet work with missing ordinal data # bfitc <- blavaan(modc, data = datCat, group = "g", ordered = TRUE, # why is this needed when they are already ordered? # n.chains = 2, burnin = 500, sample = 101, seed = 123, # bcontrol = list(cores = 2), # save.lvs = TRUE) # summary(bfitc) # LIRs <- blavPredict(bfitc, type = "ypred") # yhats <- blavPredict(bfitc, type = "yhat") # same when resid. var = 0? # fscores <- blavPredict(bfitc, type = "lv") # same as LIRs? # # # length(LIRs) # list: 1 N*p matrix per chain # length(yhats) # list: 1 N*p matrix per chain # length(fscores) # matrix: 1 row per chain, 1 column per [N, fs] # ## all are basically interchangeable # ch <- 2 # cor(cbind(yhats = as.numeric(yhats[[ch]]), # LIRs = as.numeric(LIRs[[ch]]), # fscores = fscores[ch,])) # ## compare means (by group) # aggregate(yhats[[ch]], by = datCat["g"], FUN = mean) # aggregate( LIRs[[ch]], by = datCat["g"], FUN = mean) # aggregate(matrix(fscores[ch,], ncol = 8), by = datCat["g"], FUN = mean) # ## compare to lavaan # do.call(rbind, sapply(lavInspect(fitc, "est"), # function(i) i$alpha[,1], simplify = FALSE)) # # # # ## now a CFA (so there are latent item responses and common factors) # mod <- ' FU1 =~ u1 + u2 + u3 + u4 # FU2 =~ u5 + u6 + u7 + u8 ' # fit <- cfa(mod, data = datCat, std.lv = TRUE) # bfit <- bcfa(mod, data = datCat, std.lv = TRUE, ordered = TRUE, # n.chains = 2, burnin = 100, sample = 101, seed = 123, # save.lvs = TRUE) # summary(bfit) # fscores <- blavPredict(bfit, type = "lv") # LIRs <- blavPredict(bfit, type = "ypred") # FS <- plausibleValues(bfitc) # LIRs <- plausibleValues(bfitc, type = "ypred") semTools/R/htmt.R0000644000176200001440000001453114632150323013362 0ustar liggesusers### Ylenio Longo & Terrence D. Jorgensen ### Last updated: 31 January 2023 ##' Assessing Discriminant Validity using Heterotrait--Monotrait Ratio ##' ##' This function assesses discriminant validity through the ##' heterotrait-monotrait ratio (HTMT) of the correlations (Henseler, Ringlet & ##' Sarstedt, 2015). Specifically, it assesses the arithmetic (Henseler et al., ##' ) or geometric (Roemer et al., 2021) mean correlation ##' among indicators across constructs (i.e. heterotrait--heteromethod ##' correlations) relative to the geometric-mean correlation among indicators ##' within the same construct (i.e. monotrait--heteromethod correlations). ##' The resulting HTMT(2) values are interpreted as estimates of inter-construct ##' correlations. Absolute values of the correlations are recommended to ##' calculate the HTMT matrix, and are required to calculate HTMT2. Correlations ##' are estimated using the [lavaan::lavCor()] function. ##' ##' ##' @importFrom stats cov2cor ##' ##' @param model lavaan [lavaan::model.syntax()] of a confirmatory factor ##' analysis model where at least two factors are required for indicators ##' measuring the same construct. ##' @param data A `data.frame` or data `matrix` ##' @param sample.cov A covariance or correlation matrix can be used, instead of ##' `data=`, to estimate the HTMT values. ##' @param missing If `"listwise"`, cases with missing values are removed listwise ##' from the data frame. If `"direct"` or `"ml"` or `"fiml"` and the estimator is ##' maximum likelihood, an EM algorithm is used to estimate the unrestricted ##' covariance matrix (and mean vector). If `"pairwise"`, pairwise deletion is ##' used. If `"default"`, the value is set depending on the estimator and the ##' mimic option (see details in [lavaan::lavCor()]). ##' @param ordered Character vector. Only used if object is a `data.frame`. ##' Treat these variables as ordered (ordinal) variables. Importantly, all ##' other variables will be treated as numeric (unless `is.ordered` in ##' `data=`). See also [lavaan::lavCor()]. ##' @param absolute `logical` indicating whether HTMT values should be ##' estimated based on absolute correlations (default is `TRUE`). This ##' is recommended for HTMT but required for HTMT2 (so silently ignored). ##' @param htmt2 `logical` indicating whether to use the geometric mean ##' (default, appropriate for congeneric indicators) or arithmetic mean ##' (which assumes tau-equivalence). ##' ##' @return A matrix showing HTMT(2) values (i.e., discriminant validity) ##' between each pair of factors. ##' ##' @author ##' Ylenio Longo (University of Nottingham; \email{yleniolongo@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Henseler, J., Ringle, C. M., & Sarstedt, M. (2015). A new criterion for ##' assessing discriminant validity in variance-based structural equation ##' modeling. *Journal of the Academy of Marketing Science, 43*(1), ##' 115--135. \doi{10.1007/s11747-014-0403-8} ##' ##' Roemer, E., Schuberth, F., & Henseler, J. (2021). HTMT2---An improved ##' criterion for assessing discriminant validity in structural equation ##' modeling. *Industrial Management & Data Systems, 121*(21), 2637--2650. ##' \doi{10.1108/IMDS-02-2021-0082} ##' ##' Voorhees, C. M., Brady, M. K., Calantone, R., & Ramirez, E. (2016). ##' Discriminant validity testing in marketing: An analysis, causes for ##' concern, and proposed remedies. ##' *Journal of the Academy of Marketing Science, 44*(1), 119--134. ##' \doi{10.1007/s11747-015-0455-4} ##' ##' @examples ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' dat <- HolzingerSwineford1939[, paste0("x", 1:9)] ##' htmt(HS.model, dat) ##' ##' ## save covariance matrix ##' HS.cov <- cov(HolzingerSwineford1939[, paste0("x", 1:9)]) ##' ## HTMT using arithmetic mean ##' htmt(HS.model, sample.cov = HS.cov, htmt2 = FALSE) ##' ##' @export htmt <- function(model, data = NULL, sample.cov = NULL, missing = "listwise", ordered = NULL, absolute = TRUE, htmt2 = TRUE) { model <- lavaan::lavaanify(model) model <- model[model$op %in% "=~", ] factors <- unique(model$lhs) nf <- length(factors) var <- list() for (i in 1:nf) { var[[i]] <- model$rhs[which(model$lhs %in% factors[i])] } varnames <- c(unlist(var)) if(!is.null(data)) { # if data if(any(! varnames %in% colnames(data))) { absent.vars <- which(! varnames %in% colnames(data)) stop("Missing observed variables in the dataset: ", paste(varnames[absent.vars], collapse = " ")) } data <- data[ , c(varnames)] R <- lavaan::lavCor(data, missing = missing, ordered = ordered) rownames(R) <- names(data) colnames(R) <- names(data) } else { if (any(! varnames %in% colnames(sample.cov))) { absent.vars <- which(! varnames %in% colnames(sample.cov)) stop("Missing observed variables in the covariance or correlation matrix: ", paste(varnames[absent.vars], collapse = " ")) } diagR <- diag(sample.cov) if (max(diagR) != 1 & min(diagR) != 1) { #if covariance matrix R <- cov2cor(sample.cov[varnames, varnames]) } else { # if correlation matrix R <- sample.cov[varnames, varnames] } } if (absolute || htmt2) { R <- abs(R) } diag(R) <- NA m.cor.w <- list() for (i in 1:nf) { if (htmt2) { m.cor.w[[i]] <- exp(mean(log(R[ var[[i]], var[[i]] ]), na.rm = TRUE)) } else m.cor.w[[i]] <- mean(R[ var[[i]], var[[i]] ], na.rm = TRUE) } m.cor.w <- as.numeric(m.cor.w) comb <- expand.grid(1:nf, 1:nf) g <- list() for (i in 1:nrow(comb)) { g[[i]] <- sqrt(m.cor.w[comb[i, 2]] * m.cor.w[comb[i, 1]]) } g <- as.numeric(g) paste(comb[, 2], comb[, 1]) m.cor.a <- list() for (i in 1:nrow(comb)) { if (htmt2) { m.cor.a[[i]] <- exp(mean(log(R[ var[[comb[i, 2]]], var[[comb[i, 1]]] ]), na.rm = TRUE)) } else m.cor.a[[i]] <- mean(R[ var[[ comb[i,2] ]], var[[ comb[i,1] ]] ], na.rm = TRUE) } m.cor.a <- as.numeric(m.cor.a) outhtmt <- m.cor.a / g res <- matrix(outhtmt, nrow = nf, ncol = nf, dimnames = list(factors)) colnames(res) <- factors class(res) <- c("lavaan.matrix.symmetric", "matrix") res } semTools/R/semTools.R0000644000176200001440000000517014632426776014234 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 10 June 2024 ### package documentation, along with convenience documentation (e.g., imports) ##' semTools: Useful Tools for Structural Equation Modeling ##' ##' The \pkg{semTools} package provides many miscellaneous functions that are ##' useful for statistical analysis involving SEM in R. Many functions extend ##' the funtionality of the \pkg{lavaan} package. Some sets of functions in ##' \pkg{semTools} correspond to the same theme. We call such a collection of ##' functions a *suite*. Our suites include: ##' \itemize{ ##' \item{Model Fit Evaluation: ##' [moreFitIndices()], ##' [nullRMSEA()], ##' [singleParamTest()], ##' [miPowerFit()], and ##' [chisqSmallN()]} ##' \item{Measurement Invariance: ##' [measEq.syntax()], ##' [partialInvariance()], ##' [partialInvarianceCat()], and ##' [permuteMeasEq()]} ##' \item{Power Analysis: ##' [SSpower()], ##' [findRMSEApower()], ##' [plotRMSEApower()], ##' [plotRMSEAdist()], ##' [findRMSEAsamplesize()], ##' [findRMSEApowernested()], ##' [plotRMSEApowernested()], and ##' [findRMSEAsamplesizenested()]} ##' \item{Missing Data Analysis: ## [runMI()], # DEPRECATE ##' [auxiliary()], ##' [twostage()], ##' [fmi()], ##' [bsBootMiss()], ##' [quark()], and ##' [combinequark()]} ##' \item{Latent Interactions: ##' [indProd()], ##' [orthogonalize()], ##' [probe2WayMC()], ##' [probe3WayMC()], ##' [probe2WayRC()], ##' [probe3WayRC()], and ##' [plotProbe()]} ##' \item{Exploratory Factor Analysis (EFA): ##' [efa.ekc()]} ##' \item{Reliability Estimation: ##' [compRelSEM()] and ##' [maximalRelia()] ##' (see also [AVE()])} ##' \item{Parceling: ##' [parcelAllocation()], ##' [PAVranking()], and ##' [poolMAlloc()]} ##' \item{Non-Normality: ##' [skew()], ##' [kurtosis()], ##' [mardiaSkew()], ##' [mardiaKurtosis()], and ##' [mvrnonnorm()]} ##' } ##' All users of R (or SEM) are invited to submit functions or ideas for ##' functions by contacting the maintainer, Terrence Jorgensen ##' (\email{TJorgensen314@gmail.com}). Contributors are encouraged to use ##' `Roxygen` comments to document their contributed code, which is ##' consistent with the rest of \pkg{semTools}. Read the vignette from the ##' \pkg{roxygen2} package for details: ##' `vignette("rd", package = "roxygen2")` ##' ##' @name semTools ##' @aliases semTools-package NULL ##' @importFrom methods setClass setMethod getMethod show is new slot as hasArg NULL ##' @importFrom graphics hist plot par abline lines legend NULL ##' @importFrom stats nobs residuals resid fitted fitted.values coef anova vcov NULL semTools/R/mvrnonnorm.R0000644000176200001440000001456614632143377014644 0ustar liggesusers### Yves Rosseel, Sunthud Pornprasertmanit, & Terrence D. Jorgensen ### Last updated: 10 June 2024 ##' Generate Non-normal Data using Vale and Maurelli (1983) method ##' ##' Generate Non-normal Data using Vale and Maurelli (1983) method. The function ##' is designed to be as similar as the popular `mvrnorm` function in the ##' `MASS` package. The codes are copied from `mvrnorm` function in ##' the `MASS` package for argument checking and `lavaan` package for ##' data generation using Vale and Maurelli (1983) method. ##' ##' ##' @importFrom stats cov2cor ##' ##' @param n Sample size ##' @param mu A mean vector. If elements are named, those will be used as ##' variable names in the returned data matrix. ##' @param Sigma A positive-definite symmetric matrix specifying the covariance ##' matrix of the variables. If rows or columns are named (and `mu` is ##' unnamed), those will be used as variable names in the returned data matrix. ##' @param skewness A vector of skewness of the variables ##' @param kurtosis A vector of excessive kurtosis of the variables ##' @param empirical deprecated, ignored. ##' @return A data matrix ##' @author The original function is the [lavaan::simulateData()] ##' function written by Yves Rosseel in the `lavaan` package. The function ##' is adjusted for a convenient usage by Sunthud Pornprasertmanit ##' (\email{psunthud@@gmail.com}). Terrence D. Jorgensen added the feature to ##' retain variable names from `mu` or `Sigma`. ##' ##' @references Vale, C. D. & Maurelli, V. A. (1983). Simulating multivariate ##' nonormal distributions. *Psychometrika, 48*(3), 465--471. ##' \doi{10.1007/BF02293687} ##' ##' @examples ##' ##' set.seed(123) ##' mvrnonnorm(20, c(1, 2), matrix(c(10, 2, 2, 5), 2, 2), ##' skewness = c(5, 2), kurtosis = c(3, 3)) ##' ## again, with variable names specified in mu ##' set.seed(123) ##' mvrnonnorm(20, c(a = 1, b = 2), matrix(c(10, 2, 2, 5), 2, 2), ##' skewness = c(5, 2), kurtosis = c(3, 3)) ##' ##' @export mvrnonnorm <- function(n, mu, Sigma, skewness = NULL, kurtosis = NULL, empirical = FALSE) { ## number of variables p <- length(mu) if (!all(dim(Sigma) == c(p, p))) stop("incompatible arguments") ## save variable names, if they exist varnames <- names(mu) if (is.null(varnames)) varnames <- rownames(Sigma) if (is.null(varnames)) varnames <- colnames(Sigma) ## check for NPD eS <- eigen(Sigma, symmetric = TRUE) ev <- eS$values if (!all(ev >= -1e-06 * abs(ev[1L]))) stop("'Sigma' is not positive definite") ## simulate X <- NULL if (is.null(skewness) && is.null(kurtosis)) { X <- mnormt::rmnorm(n = n, mean = mu, varcov = Sigma) } else { if (is.null(skewness)) skewness <- rep(0, p) if (is.null(kurtosis)) kurtosis <- rep(0, p) Z <- ValeMaurelli1983copied(n = n, COR = cov2cor(Sigma), skewness = skewness, kurtosis = kurtosis) TMP <- scale(Z, center = FALSE, scale = 1/sqrt(diag(Sigma)))[ , , drop = FALSE] X <- sweep(TMP, MARGIN = 2, STATS = mu, FUN = "+") } colnames(X) <- varnames X } ## ---------------- ## Hidden Functions ## ---------------- ## Copied from lavaan package ##' @importFrom stats nlminb ValeMaurelli1983copied <- function(n = 100L, COR, skewness, kurtosis, debug = FALSE) { fleishman1978_abcd <- function(skewness, kurtosis) { system.function <- function(x, skewness, kurtosis) { b.=x[1L]; c.=x[2L]; d.=x[3L] eq1 <- b.^2 + 6*b.*d. + 2*c.^2 + 15*d.^2 - 1 eq2 <- 2*c.*(b.^2 + 24*b.*d. + 105*d.^2 + 2) - skewness eq3 <- 24*(b.*d. + c.^2*(1 + b.^2 + 28*b.*d.) + d.^2*(12 + 48*b.*d. + 141*c.^2 + 225*d.^2)) - kurtosis eq <- c(eq1,eq2,eq3) sum(eq^2) ## SS } out <- nlminb(start = c(1, 0, 0), objective = system.function, scale = 10, control = list(trace = 0), skewness = skewness, kurtosis = kurtosis) if(out$convergence != 0) warning("no convergence") b. <- out$par[1L]; c. <- out$par[2L]; d. <- out$par[3L]; a. <- -c. c(a.,b.,c.,d.) } getICOV <- function(b1, c1, d1, b2, c2, d2, R) { objectiveFunction <- function(x, b1, c1, d1, b2, c2, d2, R) { rho=x[1L] eq <- rho*(b1*b2 + 3*b1*d2 + 3*d1*b2 + 9*d1*d2) + rho^2*(2*c1*c2) + rho^3*(6*d1*d2) - R eq^2 } #gradientFunction <- function(x, bcd1, bcd2, R) { # #} out <- nlminb(start=R, objective=objectiveFunction, scale=10, control=list(trace=0), b1=b1, c1=c1, d1=d1, b2=b2, c2=c2, d2=d2, R=R) if(out$convergence != 0) warning("no convergence") rho <- out$par[1L] rho } # number of variables nvar <- ncol(COR) # check skewness if(is.null(skewness)) { SK <- rep(0, nvar) } else if(length(skewness) == nvar) { SK <- skewness } else if(length(skewness) == 1L) { SK <- rep(skewness, nvar) } else { stop("skewness has wrong length") } if(is.null(kurtosis)) { KU <- rep(0, nvar) } else if(length(kurtosis) == nvar) { KU <- kurtosis } else if(length(kurtosis) == 1L) { KU <- rep(kurtosis, nvar) } else { stop("kurtosis has wrong length") } # create Fleishman table FTable <- matrix(0, nvar, 4L) for(i in 1:nvar) { FTable[i,] <- fleishman1978_abcd(skewness=SK[i], kurtosis=KU[i]) } # compute intermediate correlations between all pairs ICOR <- diag(nvar) for(j in 1:(nvar-1L)) { for(i in (j+1):nvar) { if(COR[i,j] == 0) next ICOR[i,j] <- ICOR[j,i] <- getICOV(FTable[i,2], FTable[i,3], FTable[i,4], FTable[j,2], FTable[j,3], FTable[j,4], R=COR[i,j]) } } if(debug) { cat("\nOriginal correlations (for Vale-Maurelli):\n") print(COR) cat("\nIntermediate correlations (for Vale-Maurelli):\n") print(ICOR) cat("\nEigen values ICOR:\n") print( eigen(ICOR)$values ) } # generate Z X <- Z <- mnormt::rmnorm(n = n, mean = rep(0,nvar), varcov = ICOR) # transform Z using Fleischman constants for(i in 1:nvar) { X[,i] <- FTable[i,1L] + FTable[i,2L]*Z[,i] + FTable[i,3L]*Z[,i]^2 + FTable[i,4L]*Z[,i]^3 } X } semTools/R/imposeStart.R0000644000176200001440000001044614632016456014731 0ustar liggesusers### Sunthud Pornprasertmanit ### Last updated: 2 April 2017 #' Specify starting values from a lavaan output #' #' This function will save the parameter estimates of a lavaan output and #' impose those parameter estimates as starting values for another analysis #' model. The free parameters with the same names or the same labels across two #' models will be imposed the new starting values. This function may help to #' increase the chance of convergence in a complex model (e.g., #' multitrait-multimethod model or complex longitudinal invariance model). #' #' #' @param out The `lavaan` output that users wish to use the parameter #' estimates as staring values for an analysis model #' @param expr The original code that users use to run a lavaan model #' @param silent Logical to print the parameter table with new starting values #' @return A fitted lavaan model #' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) #' @examples #' #' ## The following example show that the longitudinal weak invariance model #' ## using effect coding was not convergent with three time points but convergent #' ## with two time points. Thus, the parameter estimates from the model with #' ## two time points are used as starting values of the three time points. #' ## The model with new starting values is convergent properly. #' #' weak2time <- ' #' # Loadings #' f1t1 =~ LOAD1*y1t1 + LOAD2*y2t1 + LOAD3*y3t1 #' f1t2 =~ LOAD1*y1t2 + LOAD2*y2t2 + LOAD3*y3t2 #' #' # Factor Variances #' f1t1 ~~ f1t1 #' f1t2 ~~ f1t2 #' #' # Factor Covariances #' f1t1 ~~ f1t2 #' #' # Error Variances #' y1t1 ~~ y1t1 #' y2t1 ~~ y2t1 #' y3t1 ~~ y3t1 #' y1t2 ~~ y1t2 #' y2t2 ~~ y2t2 #' y3t2 ~~ y3t2 #' #' # Error Covariances #' y1t1 ~~ y1t2 #' y2t1 ~~ y2t2 #' y3t1 ~~ y3t2 #' #' # Factor Means #' f1t1 ~ NA*1 #' f1t2 ~ NA*1 #' #' # Measurement Intercepts #' y1t1 ~ INT1*1 #' y2t1 ~ INT2*1 #' y3t1 ~ INT3*1 #' y1t2 ~ INT4*1 #' y2t2 ~ INT5*1 #' y3t2 ~ INT6*1 #' #' # Constraints for Effect-coding Identification #' LOAD1 == 3 - LOAD2 - LOAD3 #' INT1 == 0 - INT2 - INT3 #' INT4 == 0 - INT5 - INT6 #' ' #' model2time <- lavaan(weak2time, data = exLong) #' #' weak3time <- ' #' # Loadings #' f1t1 =~ LOAD1*y1t1 + LOAD2*y2t1 + LOAD3*y3t1 #' f1t2 =~ LOAD1*y1t2 + LOAD2*y2t2 + LOAD3*y3t2 #' f1t3 =~ LOAD1*y1t3 + LOAD2*y2t3 + LOAD3*y3t3 #' #' # Factor Variances #' f1t1 ~~ f1t1 #' f1t2 ~~ f1t2 #' f1t3 ~~ f1t3 #' #' # Factor Covariances #' f1t1 ~~ f1t2 + f1t3 #' f1t2 ~~ f1t3 #' #' # Error Variances #' y1t1 ~~ y1t1 #' y2t1 ~~ y2t1 #' y3t1 ~~ y3t1 #' y1t2 ~~ y1t2 #' y2t2 ~~ y2t2 #' y3t2 ~~ y3t2 #' y1t3 ~~ y1t3 #' y2t3 ~~ y2t3 #' y3t3 ~~ y3t3 #' #' # Error Covariances #' y1t1 ~~ y1t2 #' y2t1 ~~ y2t2 #' y3t1 ~~ y3t2 #' y1t1 ~~ y1t3 #' y2t1 ~~ y2t3 #' y3t1 ~~ y3t3 #' y1t2 ~~ y1t3 #' y2t2 ~~ y2t3 #' y3t2 ~~ y3t3 #' #' # Factor Means #' f1t1 ~ NA*1 #' f1t2 ~ NA*1 #' f1t3 ~ NA*1 #' #' # Measurement Intercepts #' y1t1 ~ INT1*1 #' y2t1 ~ INT2*1 #' y3t1 ~ INT3*1 #' y1t2 ~ INT4*1 #' y2t2 ~ INT5*1 #' y3t2 ~ INT6*1 #' y1t3 ~ INT7*1 #' y2t3 ~ INT8*1 #' y3t3 ~ INT9*1 #' #' # Constraints for Effect-coding Identification #' LOAD1 == 3 - LOAD2 - LOAD3 #' INT1 == 0 - INT2 - INT3 #' INT4 == 0 - INT5 - INT6 #' INT7 == 0 - INT8 - INT9 #' ' #' ### The following command does not provide convergent result #' # model3time <- lavaan(weak3time, data = exLong) #' #' ### Use starting values from the model with two time points #' model3time <- imposeStart(model2time, lavaan(weak3time, data = exLong)) #' summary(model3time) #' #' @export imposeStart <- function(out, expr, silent = TRUE) { if(!is(out, "lavaan")) stop("The first argument of the function must be a lavaan output.") template2 <- template <- substitute(expr) template2$do.fit <- FALSE model <- eval(expr = template2, enclos = parent.frame()) ptmodel <- parTable(model) coefmodel <- lavaan::coef(model) coefout <- lavaan::coef(out) start <- coefout[match(names(coefmodel), names(coefout))] ptmodel$start[ptmodel$free != 0] <- start[ptmodel$free[ptmodel$free != 0]] ptmodel$est <- NULL ptmodel$se <- NULL if(!silent) { cat("########## Model with imposed starting values #########\n") print(ptmodel) } if("model" %in% names(template)) { template$model <- ptmodel } else { template[[2]] <- ptmodel } eval(expr = template, enclos = parent.frame()) } semTools/R/auxiliary.R0000644000176200001440000002740614753073437014440 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 February 2025 ##' Implement Saturated Correlates with FIML ##' ##' Automatically add auxiliary variables to a lavaan model when using full ##' information maximum likelihood (FIML) to handle missing data ##' ##' These functions are wrappers around the corresponding lavaan functions. ##' You can use them the same way you use [lavaan::lavaan()], but you ##' *must* pass your full `data.frame` to the `data` argument. ##' Because the saturated-correlates approaches (Enders, 2008) treats exogenous ##' variables as random, `fixed.x` must be set to `FALSE`. Because FIML ##' requires continuous data (although nonnormality corrections can still be ##' requested), no variables in the model nor auxiliary variables specified in ##' `aux` can be declared as `ordered`. ##' ##' @aliases auxiliary lavaan.auxiliary cfa.auxiliary sem.auxiliary growth.auxiliary ##' @importFrom lavaan lavInspect parTable lavNames ##' @importFrom stats cov quantile ##' ##' @param model The analysis model can be specified with 1 of 2 objects: ##' \enumerate{ ##' \item lavaan [lavaan::model.syntax()] specifying a hypothesized ##' model *without* mention of auxiliary variables in `aux` ##' \item a parameter table, as returned by [lavaan::parTable()], ##' specifying the target model *without* auxiliary variables. ##' This option requires these columns (and silently ignores all others): ##' `c("lhs","op","rhs","user","group","free","label","plabel","start")` ##' } ##' @param data `data.frame` that includes auxiliary variables as well as ##' any observed variables in the `model` ##' @param aux `character`. Names of auxiliary variables to add to `model` ##' @param fun `character`. Name of a specific lavaan function used to fit ##' `model` to `data` (i.e., `"lavaan"`, `"cfa"`, ##' `"sem"`, or `"growth"`). Only required for `auxiliary`. ##' @param ... Additional arguments to pass to `fun=`. ##' @param envir Passed to [do.call()]. ##' @param return.syntax `logical` indicating whether to return a ##' `character` string of [lavaan::model.syntax()] that can be ##' added to a target `model=` that is also a `character` string. ##' This can be advantageous, for example, to use add saturated correlates to ##' a \pkg{blavaan} model. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Enders, C. K. (2008). A note on the use of missing auxiliary variables in ##' full information maximum likelihood-based structural equation models. ##' *Structural Equation Modeling, 15*(3), 434--448. ##' \doi{10.1080/10705510802154307} ##' ##' @return a fitted [lavaan::lavaan-class] object. Additional ##' information is stored as a `list` in the `@@external` slot: ##' \itemize{ ##' \item `baseline.model`. a fitted [lavaan::lavaan-class] ##' object. Results of fitting an appropriate independence model for ##' the calculation of incremental fit indices (e.g., CFI, TLI) in ##' which the auxiliary variables remain saturated, so only the target ##' variables are constrained to be orthogonal. See Examples for how ##' to send this baseline model to [lavaan::fitMeasures()]. ##' \item `aux`. The character vector of auxiliary variable names. ##' \item `baseline.syntax`. A character vector generated within the ##' `auxiliary` function, specifying the `baseline.model` ##' syntax. ##' } ##' ##' @examples ##' dat1 <- lavaan::HolzingerSwineford1939 ##' set.seed(12345) ##' dat1$z <- rnorm(nrow(dat1)) ##' dat1$x5 <- ifelse(dat1$z < quantile(dat1$z, .3), NA, dat1$x5) ##' dat1$x9 <- ifelse(dat1$z > quantile(dat1$z, .8), NA, dat1$x9) ##' ##' targetModel <- " ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' " ##' ##' ## works just like cfa(), but with an extra "aux" argument ##' fitaux1 <- cfa.auxiliary(targetModel, data = dat1, aux = "z", ##' missing = "fiml", estimator = "mlr") ##' ##' ## with multiple auxiliary variables and multiple groups ##' fitaux2 <- cfa.auxiliary(targetModel, data = dat1, aux = c("z","ageyr","grade"), ##' group = "school", group.equal = "loadings") ##' ##' ## calculate correct incremental fit indices (e.g., CFI, TLI) ##' fitMeasures(fitaux2, fit.measures = c("cfi","tli")) ##' ## NOTE: lavaan will use the internally stored baseline model, which ##' ## is the independence model plus saturated auxiliary parameters ##' lavInspect(fitaux2@external$baseline.model, "free") ##' ##' ##' @export auxiliary <- function(model, data, aux, fun, ..., envir = getNamespace("lavaan"), return.syntax = FALSE) { lavArgs <- list(...) lavArgs$data <- substitute(data) lavArgs$fixed.x <- FALSE if (fun %in% c("lavaan","cfa","sem","growth")) { #TODO: allow fun = "efa"? lavArgs$missing <- "fiml" lavArgs$meanstructure <- TRUE } lavArgs$ordered <- NULL if (missing(aux)) stop("Please provide a character vector with names of auxiliary variables") if (missing(data)) stop("Please provide a data.frame that includes modeled and auxiliary variables") if (fun %in% c("lavaan","cfa","sem","growth") && !all(sapply(data[aux], is.numeric))) stop("missing = 'FIML' is unavailable for categorical data") PTcols <- c("lhs","op","rhs","user","block","group","free","label","plabel","start") #TODO: add any? if fun %in% c("blavaan","bcfa","bsem","bgrowth") ## check parameter table, or create one from syntax if (is.list(model)) { if (any(model$exo == 1)) stop("All exogenous variables (covariates) must be treated as endogenous", " by the 'auxiliary' function. Please set 'fixed.x = FALSE'") if (!is.null(lavArgs$group.equal)) warning("The 'group.equal' argument is ignored when 'model' is a parameter table.") if (is.null(model$start)) { startArgs <- lavArgs startArgs$model <- model startArgs$do.fit <- FALSE model$start <- parTable(do.call(fun, startArgs, envir = envir))$start } missingCols <- setdiff(PTcols, names(model)) if (length(missingCols)) stop("If the 'model' argument is a parameter table", " it must also include these columns: \n", paste(missingCols, collapse = ", ")) PT <- as.data.frame(model, stringsAsFactors = FALSE)[PTcols] } else if (is.character(model)) { ptArgs <- lavArgs ptArgs$model <- model ptArgs$do.fit <- FALSE #FIXME: does this work with blavaan? PT <- parTable(do.call(fun, ptArgs, envir = envir))[PTcols] } else stop("The 'model' argument must be a character vector of", " lavaan syntax or a parameter table") ## separately store rows with constraints or user-defined parameters conRows <- PT$op %in% c("==","<",">",":=") if (any(conRows)) { CON <- PT[ conRows, ] PT <- PT[ !conRows, ] } else CON <- data.frame(NULL) ## variable names varnames <- lavNames(PT, type = "ov") if (length(intersect(varnames, aux))) stop('modeled variable declared as auxiliary') ## specify a saturated model for auxiliaries covstruc <- outer(aux, aux, function(x, y) paste(x, "~~", y)) satMod <- c(covstruc[lower.tri(covstruc, diag = TRUE)], paste(aux, "~ 1"), # among auxiliaries outer(aux, varnames, function(x, y) paste(x, "~~", y))) # between aux and targets if (return.syntax) return(satMod) satPT <- lavaan::lavaanify(satMod, ngroups = max(PT$group))[c("lhs","op","rhs", "user","block","group")] ## after omitting duplicates, check number of added parameters, add columns mergedPT <- lavaan::lav_partable_merge(PT, satPT, remove.duplicated = TRUE, warn = FALSE) nAuxPar <- nrow(mergedPT) - nrow(PT) newRows <- 1L:nAuxPar + nrow(PT) #TODO: mergedPT$user[newRows] <- 2L (list as constraints to omit printing?) or new code (9L)? mergedPT$free[newRows] <- 1L:nAuxPar + max(PT$free) mergedPT$plabel[newRows] <- paste0(".p", 1L:nAuxPar + nrow(PT), ".") ## calculate sample moments as starting values (recycle over groups) # if (is.null(lavArgs$group)) { # auxCov <- cov(data[aux], use = "pairwise.complete.obs") # auxM <- colMeans(data[aux], na.rm = TRUE) # auxTarget <- cov(data[c(aux, varnames)], # use = "pairwise.complete.obs")[aux, varnames] # ## match order of parameters in syntax above # mergedPT$start[newRows] <- c(auxCov[lower.tri(auxCov, diag = TRUE)], # auxM, as.numeric(auxTarget)) # } else { # auxCovs <- list() # auxMs <- list() # auxTargets <- list() # startVals <- numeric(0) # for (g in unique(data[ , lavArgs$group])) { # auxCovs[[g]] <- cov(data[data[ , lavArgs$group] == g, aux], # use = "pairwise.complete.obs") # auxMs[[g]] <- colMeans(data[data[ , lavArgs$group] == g, aux], na.rm = TRUE) # auxTargets[[g]] <- cov(data[data[ , lavArgs$group] == g, c(aux, varnames)], # use = "pairwise.complete.obs")[aux, varnames] # startVals <- c(startVals, auxCovs[[g]][lower.tri(auxCovs[[g]], diag = TRUE)], # auxMs[[g]], as.numeric(auxTargets[[g]])) # } # ## match order of parameters in syntax above # mergedPT$start[newRows] <- startVals # } lavArgs$model <- lavaan::lav_partable_complete(rbind(mergedPT, CON)) #FIXME for blavaan result <- do.call(fun, lavArgs, envir = envir) if (fun %in% c("lavaan","cfa","sem","growth")) { ## specify, fit, and attach an appropriate independence model baseArgs <- list() baseArgs$model <- lavaan::lav_partable_complete(satPT) baseArgs$data <- data baseArgs$group <- lavArgs$group baseArgs$group.label <- lavArgs$group.label baseArgs$missing <- "fiml" baseArgs$cluster <- lavArgs$cluster baseArgs$sample.cov.rescale <- lavArgs$sample.cov.rescale baseArgs$estimator <- lavArgs$estimator baseArgs$information <- lavArgs$information baseArgs$se <- lavArgs$se baseArgs$test <- lavArgs$test baseArgs$bootstrap <- lavArgs$bootstrap baseArgs$control <- lavArgs$control baseArgs$optim.method <- lavArgs$optim.method result@external$baseline.model <- do.call("lavaan", baseArgs, envir = envir) result@external$aux <- aux result@external$baseline.syntax <- satMod } # else something similar for blavaan? Better to fit manually for blavFitIndices result } ##' @rdname auxiliary ##' @aliases lavaan.auxiliary ##' @export lavaan.auxiliary <- function(model, data, aux, ..., envir = getNamespace("lavaan")) { mc <- match.call(expand.dots = TRUE) mc$fun <- "lavaan" mc[[1L]] <- quote(semTools::auxiliary) eval(mc, parent.frame()) } ##' @rdname auxiliary ##' @aliases cfa.auxiliary ##' @export cfa.auxiliary <- function(model, data, aux, ..., envir = getNamespace("lavaan")) { mc <- match.call(expand.dots = TRUE) mc$fun <- "cfa" mc[[1L]] <- quote(semTools::auxiliary) eval(mc, parent.frame()) } ##' @rdname auxiliary ##' @aliases sem.auxiliary ##' @export sem.auxiliary <- function(model, data, aux, ..., envir = getNamespace("lavaan")) { mc <- match.call(expand.dots = TRUE) mc$fun <- "sem" mc[[1L]] <- quote(semTools::auxiliary) eval(mc, parent.frame()) } ##' @rdname auxiliary ##' @aliases growth.auxiliary ##' @export growth.auxiliary <- function(model, data, aux, ..., envir = getNamespace("lavaan")) { mc <- match.call(expand.dots = TRUE) mc$fun <- "growth" mc[[1L]] <- quote(semTools::auxiliary) eval(mc, parent.frame()) } semTools/R/kd.R0000644000176200001440000001010114632016456013001 0ustar liggesusers### Edgar Merkle ### Last updated: 10 January 2021 ### Kaiser-Dickman (1962) algorithm for generating sample data ### based on the input covmat, which is a covariance matrix. ##' Generate data via the Kaiser-Dickman (1962) algorithm. ##' ##' Given a covariance matrix and sample size, generate raw data that correspond ##' to the covariance matrix. Data can be generated to match the covariance ##' matrix exactly, or to be a sample from the population covariance matrix. ##' ##' By default, R's `cov()` function divides by `n`-1. The data ##' generated by this algorithm result in a covariance matrix that matches ##' `covmat`, but you must divide by `n` instead of `n`-1. ##' ##' ##' @importFrom stats cov2cor rnorm ##' ##' @param covmat a symmetric, positive definite covariance matrix ##' @param n the sample size for the data that will be generated ##' @param type type of data generation. `exact` generates data that ##' exactly correspond to `covmat`. `sample` treats `covmat` as ##' a poulation covariance matrix, generating a sample of size `n`. ##' ##' @return `kd` returns a data matrix of dimension `n` by ##' `nrow(covmat)`. ##' ##' @author Ed Merkle (University of Missouri; \email{merklee@@missouri.edu}) ##' ##' @references Kaiser, H. F. and Dickman, K. (1962). Sample and population ##' score matrices and sample correlation matrices from an arbitrary population ##' correlation matrix. *Psychometrika, 27*(2), 179--182. ##' \doi{10.1007/BF02289635} ##' ##' @examples ##' ##' #### First Example ##' ##' ## Get data ##' dat <- HolzingerSwineford1939[ , 7:15] ##' hs.n <- nrow(dat) ##' ##' ## Covariance matrix divided by n ##' hscov <- ((hs.n-1)/hs.n) * cov(dat) ##' ##' ## Generate new, raw data corresponding to hscov ##' newdat <- kd(hscov, hs.n) ##' ##' ## Difference between new covariance matrix and hscov is minimal ##' newcov <- (hs.n-1)/hs.n * cov(newdat) ##' summary(as.numeric(hscov - newcov)) ##' ##' ## Generate sample data, treating hscov as population matrix ##' newdat2 <- kd(hscov, hs.n, type = "sample") ##' ##' #### Another example ##' ##' ## Define a covariance matrix ##' covmat <- matrix(0, 3, 3) ##' diag(covmat) <- 1.5 ##' covmat[2:3,1] <- c(1.3, 1.7) ##' covmat[3,2] <- 2.1 ##' covmat <- covmat + t(covmat) ##' ##' ## Generate data of size 300 that have this covariance matrix ##' rawdat <- kd(covmat, 300) ##' ##' ## Covariances are exact if we compute sample covariance matrix by ##' ## dividing by n (vs by n - 1) ##' summary(as.numeric((299/300)*cov(rawdat) - covmat)) ##' ##' ## Generate data of size 300 where covmat is the population covariance matrix ##' rawdat2 <- kd(covmat, 300) ##' ##' @export kd <- function(covmat, n, type=c("exact","sample")) { type <- match.arg(type) ## Check to ensure that covmat is a valid covariance matrix. if (nrow(covmat) != ncol(covmat)) stop("non-square matrix supplied") symmetric <- isSymmetric.matrix(covmat) if (!symmetric) stop("non-symmetric matrix supplied") pd <- all(eigen(covmat, only.values = TRUE)$values > 0) if (!pd) stop("covariance matrix is not positive definite") p <- nrow(covmat) ## Algorithm works on a correlation matrix mv.vars <- matrix(0, nrow(covmat), nrow(covmat)) diag(mv.vars) <- sqrt(diag(covmat)) cormat <- cov2cor(covmat) ## Generate standard normal data and mean center each variable Xscore <- matrix(rnorm(p*n), p, n) Xsub0 <- t(apply(Xscore, 1, scale, scale = FALSE)) ## Correlation matrix factored via Cholesky decomposition: Fcomp <- t(chol(cormat)) ## Equation 2 from K&D: Zhat <- Fcomp %*% Xscore ## Equation 3 from K&D: Xsub0.prod <- Xsub0 %*% t(Xsub0) ## Get singular value decomp of Xsub0.prod Xsub0.svd <- svd(Xsub0.prod) M.sqrt <- matrix(0, p, p) diag(M.sqrt) <- 1 / sqrt(Xsub0.svd$d) ## Equation 5 from K&D: Z <- Fcomp %*% M.sqrt %*% t(Xsub0.svd$u) %*% Xsub0 Z <- Z * sqrt(n) dat <- Z if (type == "sample") { dat <- Zhat } ## Scale data to correspond to covmat dat <- t(dat) %*% mv.vars ## convert to data.frame, use any existing names from covmat dat <- data.frame(dat) if(!is.null(colnames(covmat))) names(dat) <- colnames(covmat) dat } semTools/R/measurementInvarianceCat.R0000644000176200001440000002723714764267172017413 0ustar liggesusers### Sunthud Pornprasertmanit, Yves Rosseel, & Terrence D. Jorgensen ### Last updated: 12 March 2025 ### automate measurement invariance tests for categorical indicators ##' Measurement Invariance Tests for Categorical Items ##' ##' Testing measurement invariance across groups using a typical sequence of ##' model comparison tests. ##' ##' Theta parameterization is used to represent SEM for categorical items. That ##' is, residual variances are modeled instead of the total variance of ##' underlying normal variate for each item. Five models can be tested based on ##' different constraints across groups. ##' \enumerate{ ##' \item Model 1: configural invariance. The same factor structure is imposed ##' on all groups. ##' \item Model 2: weak invariance. The factor loadings are constrained to be ##' equal across groups. ##' \item Model 3: strong invariance. The factor loadings and thresholds are ##' constrained to be equal across groups. ##' \item Model 4: strict invariance. The factor loadings, thresholds and ##' residual variances are constrained to be equal across groups. ##' For categorical variables, all residual variances are fixed as 1. ##' \item Model 5: The factor loadings, threshoulds, residual variances and ##' means are constrained to be equal across groups. ##' } ##' ##' However, if all items have two items (dichotomous), scalar invariance and ##' weak invariance cannot be separated because thresholds need to be equal ##' across groups for scale identification. Users can specify `strict` ##' option to include the strict invariance model for the invariance testing. ##' See the further details of scale identification and different ##' parameterization in Millsap and Yun-Tein (2004). ##' ##' @importFrom lavaan lavInspect parTable ##' ##' @param ... The same arguments as for any lavaan model. See ##' [lavaan::cfa()] for more information. ##' @param std.lv If `TRUE`, the fixed-factor method of scale ##' identification is used. If `FALSE`, the first variable for each ##' factor is used as marker variable. ##' @param strict If `TRUE`, the sequence requires `strict' invariance. ##' See details for more information. ##' @param quiet If `FALSE` (default), a summary is printed out containing ##' an overview of the different models that are fitted, together with some ##' model comparison tests. If `TRUE`, no summary is printed. ##' @param fit.measures Fit measures used to calculate the differences between ##' nested models. ##' @param baseline.model custom baseline model passed to ##' [lavaan::fitMeasures()] ##' @param method The method used to calculate likelihood ratio test. See ##' [lavaan::lavTestLRT()] for available options ##' ##' @return Invisibly, all model fits in the sequence are returned as a list. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) ##' ##' @references Millsap, R. E., & Yun-Tein, J. (2004). Assessing factorial ##' invariance in ordered-categorical measures. *Multivariate Behavioral ##' Research, 39*(3), 479--515. \doi{10.1207/S15327906MBR3903_4} ##' ##' @examples ##' ##' \donttest{ ##' syntax <- ' f1 =~ u1 + u2 + u3 + u4' ##' ##' measurementInvarianceCat(model = syntax, data = datCat, group = "g", ##' parameterization = "theta", estimator = "wlsmv", ##' ordered = c("u1", "u2", "u3", "u4")) ##' } ##' ##' @name measurementInvarianceCat-deprecated ##' @usage ##' measurementInvarianceCat(..., std.lv = FALSE, strict = FALSE, ##' quiet = FALSE, fit.measures = "default", ##' baseline.model = NULL, method = "default") ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' ##' @export measurementInvarianceCat <- function(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "default") { .Deprecated(msg = c("The measurementInvarianceCat function is deprecated, and", " it will cease to be included in future versions of ", "semTools. See help('semTools-deprecated) for details.")) List <- list(...) if (is.null(List$model)) stop('all lavaan() and lavOptions() arguments must ', 'named, including the "model=" argument.') lavaancfa <- function(...) { lavaan::cfa(...) } lavaanlavaan <- function(...) { lavaan::lavaan(...) } if (!is.null(List$parameterization) && tolower(List$parameterization) != "theta") warning("The parameterization is set to 'theta' by default.") List$parameterization <- "theta" # Find the number of groups if (is.null(List$group)) stop("Please specify the group variable") # Get the lavaan parameter table template <- do.call(lavaancfa, c(List, do.fit = FALSE)) lavaanParTable <- parTable(template) # Find the number of groups ngroups <- max(lavaanParTable$group) # Check whether all variables are categorical sampstat <- lavInspect(template, "samp")[[1]] meanname <- names(sampstat$mean) thname <- names(sampstat$th) if (any(is.na(charmatch(meanname, thname)))) stop("Some variables in your model are not identified as categorical.") varList <- lavaanParTable$rhs[lavaanParTable$op == "=~"] facName <- lavaanParTable$lhs[(lavaanParTable$op == "=~") & (lavaanParTable$rhs %in% varList)] if (length(unique(sapply(facName, function(x) length(x)))) > 1) stop("The numbers of variables in each element are not equal.") varList <- unique(varList) facName <- unique(facName) # Check whether the factor configuration is the same across gorups groupParTable <- split(lavaanParTable, lavaanParTable$group) group1pt <- groupParTable[[1]] groupParTable <- lapply(groupParTable, "[", c("lhs", "op", "rhs")) if (!multipleAllEqualList(lapply(groupParTable, function(x) sapply(x, "[", x$op == "=~")))) stop("Factor configuration is not the same across groups") # Extract the number of thresholds numThreshold <- table(sapply(group1pt, "[", group1pt$op == "|")[,"lhs"]) # Find the indicators of each factor group1facload <- sapply(group1pt, "[", group1pt$op == "=~") factorRep <- split(group1facload[,"rhs"], group1facload[,"lhs"]) # Find marker variables marker <- rep(NA, length(factorRep)) numThresholdMarker <- rep(NA, length(factorRep)) for (i in seq_along(factorRep)) { temp <- sapply(group1pt, "[", group1pt$rhs %in% factorRep[[i]] & group1pt$op == "=~" & group1pt$lhs == names(factorRep)[i]) marker[i] <- temp[!is.na(temp[,"ustart"]), "rhs"] numThresholdMarker[i] <- numThreshold[marker[i]] } numThresholdFactorRep <- lapply(factorRep, function(x) numThreshold[x]) constraintSecondThreshold <- unlist(lapply(numThresholdFactorRep, function(x) names(which(x > 1)[1]))) constraintSecondThreshold <- constraintSecondThreshold[!is.na(constraintSecondThreshold)] # Find the marker variable of each facto for (i in names(numThreshold)) { lavaanParTable <- constrainParTable(lavaanParTable, i, "|", "t1", 1:ngroups) } if (length(constraintSecondThreshold) > 0) { for (i in constraintSecondThreshold) { lavaanParTable <- constrainParTable(lavaanParTable, i, "|", "t2", 1:ngroups) } } # Group 1 for (i in facName) { lavaanParTable <- fixParTable(lavaanParTable, i, "~1", "", 1, 0) # Fix factor means as 0 if (std.lv) { lavaanParTable <- fixParTable(lavaanParTable, i, "~~", i, 1, 1) } else { lavaanParTable <- freeParTable(lavaanParTable, i, "~~", i, 1, NA) # Free factor variances } # Assuming that all factor covariances are freeParTable } for (i in varList) { lavaanParTable <- fixParTable(lavaanParTable, i, "~~", i, 1, 1) } # Other groups for (k in 2:ngroups) { for (i in facName) { lavaanParTable <- freeParTable(lavaanParTable, i, "~1", "", k, NA) if (std.lv) { lavaanParTable <- fixParTable(lavaanParTable, i, "~~", i, k, 1) } else { lavaanParTable <- freeParTable(lavaanParTable, i, "~~", i, k, NA) } } for (i in varList) { lavaanParTable <- freeParTable(lavaanParTable, i, "~~", i, k, NA) } # Fix the indicator variances of marker variables with two categories as 1 for (i in seq_along(marker)) { if (numThresholdMarker[i] == 1) lavaanParTable <- fixParTable(lavaanParTable, marker[i], "~~", marker[i], k, 1) } } if (std.lv) { for (i in seq_along(factorRep)) { lavaanParTable <- freeParTable(lavaanParTable, names(factorRep)[i], "=~", marker[i], 1:ngroups, NA) } } # Fit configural invariance ListConfigural <- List ListConfigural$model <- lavaanParTable fitConfigural <- try(do.call(lavaanlavaan, ListConfigural), silent = TRUE) # Create the parameter table for metric invariance ptMetric <- lavaanParTable for (i in seq_along(factorRep)) { varwithin <- factorRep[[i]] if (!std.lv) { varwithin <- setdiff(varwithin, marker[i]) } for (j in seq_along(varwithin)) { ptMetric <- constrainParTable(ptMetric, names(factorRep)[i], "=~", varwithin[j], 1:ngroups) } } if (std.lv) { for (k in 2:ngroups) { for (i in facName) { ptMetric <- freeParTable(ptMetric, i, "~~", i, k, NA) } } } ListMetric <- List ListMetric$model <- ptMetric fitMetric <- try(do.call(lavaanlavaan, ListMetric), silent = TRUE) ptMeans <- ptStrict <- ptMetric nonMarker <- setdiff(names(numThreshold), marker) nonDichoMarker <- numThreshold[which(numThreshold[nonMarker] > 1)] scalar <- length(nonDichoMarker) > 0 if (scalar) { ptScalar <- ptMetric for (i in seq_along(numThreshold)) { thresholdName <- paste0("t", 1:numThreshold[i]) for(j in seq_along(thresholdName)) { ptScalar <- constrainParTable(ptScalar, names(numThreshold)[i], "|", thresholdName[j], 1:ngroups) } } ListScalar <- List ListScalar$model <- ptScalar fitScalar <- try(do.call(lavaanlavaan, ListScalar), silent = TRUE) ptMeans <- ptStrict <- ptScalar } else fitScalar <- NULL fitStrict <- NULL # Create the parameter table for strict invariance if specified if (strict) { if (scalar) ptStrict <- ptScalar for (k in 2:ngroups) { # Constrain measurement error variances for (i in varList) { ptStrict <- fixParTable(ptStrict, i, "~~", i, k, 1) } } ListStrict <- List ListStrict$model <- ptStrict fitStrict <- try(do.call(lavaanlavaan, ListStrict), silent = TRUE) ptMeans <- ptStrict } # Create the parameter table for mean equality # Constrain factor means to be equal for (k in 2:ngroups) { ptMeans <- fixParTable(ptMeans, facName, "~1", "", k, ustart = 0) } ListMeans <- List ListMeans$model <- ptMeans fitMeans <- try(do.call(lavaanlavaan, ListMeans), silent = TRUE) FIT <- invisible(list(fit.configural = fitConfigural, fit.loadings = fitMetric, fit.thresholds = fitScalar, fit.residuals = fitStrict, fit.means = fitMeans)) FIT <- FIT[!sapply(FIT, is.null)] if (!quiet) { printInvarianceResult(FIT, fit.measures, baseline.model, method) } invisible(FIT) } ## ---------------- ## Hidden Functions ## ---------------- multipleAllEqual <- function(...) { obj <- list(...) multipleAllEqualList(obj) } multipleAllEqualList <- function(obj) { for (i in 2:length(obj)) { for (j in 1:(i - 1)) { temp <- isTRUE(all.equal(obj[[i]], obj[[j]])) if (!temp) return(FALSE) } } return(TRUE) } multipleAnyEqual <- function(...) { obj <- list(...) multipleAnyEqualList(obj) } multipleAnyEqualList <- function(obj) { for (i in 2:length(obj)) { for (j in 1:(i - 1)) { temp <- isTRUE(all.equal(obj[[i]], obj[[j]])) if (temp) return(TRUE) } } return(FALSE) } semTools/R/probeInteraction.R0000644000176200001440000024546114753073565015745 0ustar liggesusers### Sunthud Pornprasertmanit & Terrence D. Jorgensen ### Last updated: 12 February 2025 ## -------- ## 2-way MC ## -------- ##' Probing two-way interaction on the no-centered or mean-centered latent ##' interaction ##' ##' Probing interaction for simple intercept and simple slope for the ##' no-centered or mean-centered latent two-way interaction ##' ##' Before using this function, researchers need to make the products of the ##' indicators between the first-order factors using mean centering (Marsh, Wen, ##' & Hau, 2004). Note that the double-mean centering may not be appropriate for ##' probing interaction if researchers are interested in simple intercepts. The ##' mean or double-mean centering can be done by the [indProd()] ##' function. The indicator products can be made for all possible combination or ##' matched-pair approach (Marsh et al., 2004). Next, the hypothesized model ##' with the regression with latent interaction will be used to fit all original ##' indicators and the product terms. See the example for how to fit the product ##' term below. Once the lavaan result is obtained, this function will be used ##' to probe the interaction. ##' ##' Let that the latent interaction model regressing the dependent variable ##' (\eqn{Y}) on the independent variable (\eqn{X}) and the moderator (\eqn{Z}) ##' be \deqn{ Y = b_0 + b_1X + b_2Z + b_3XZ + r, } where \eqn{b_0} is the ##' estimated intercept or the expected value of \eqn{Y} when both \eqn{X} and ##' \eqn{Z} are 0, \eqn{b_1} is the effect of \eqn{X} when \eqn{Z} is 0, ##' \eqn{b_2} is the effect of \eqn{Z} when \eqn{X} is 0, \eqn{b_3} is the ##' interaction effect between \eqn{X} and \eqn{Z}, and \eqn{r} is the residual ##' term. ##' ##' To probe a two-way interaction, the simple intercept of the independent ##' variable at each value of the moderator (Aiken & West, 1991; Cohen, Cohen, ##' West, & Aiken, 2003; Preacher, Curran, & Bauer, 2006) can be obtained by ##' \deqn{ b_{0|X = 0, Z} = b_0 + b_2 Z. } ##' ##' The simple slope of the independent varaible at each value of the moderator ##' can be obtained by ##' \deqn{ b_{X|Z} = b_1 + b_3 Z. } ##' ##' The variance of the simple intercept formula is ##' \deqn{ Var\left(b_{0|X = 0, Z}\right) = ##' Var\left(b_0\right) + 2Z \times Cov\left(b_0, b_2\right) + ##' Z^2 \times Var\left(b_2\right) }, ##' where \eqn{Var} denotes the variance of a parameter ##' estimate and \eqn{Cov} denotes the covariance of two parameter estimates. ##' ##' The variance of the simple slope formula is ##' \deqn{ Var\left(b_{X|Z}\right) = Var\left(b_1\right) + 2Z \times ##' Cov\left(b_1, b_3\right) + Z^2 \times Var\left(b_3\right) } ##' ##' Wald *z* statistic is used for test statistic (even for objects of ##' class [lavaan.mi::lavaan.mi-class]). ##' ##' ##' @importFrom lavaan lavInspect parTable ##' @importFrom stats pnorm ##' @importFrom methods getMethod ##' ##' @param fit A fitted [lavaan::lavaan-class] or ##' [lavaan.mi::lavaan.mi-class] object with a latent 2-way interaction. ##' @param nameX `character` vector of all 3 factor names used as the ##' predictors. The lower-order factors must be listed first, and the final ##' name must be the latent interaction factor. ##' @param nameY The name of factor that is used as the dependent variable. ##' @param modVar The name of factor that is used as a moderator. The effect of ##' the other independent factor will be probed at each value of the ##' moderator variable listed in `valProbe`. ##' @param valProbe The values of the moderator that will be used to probe the ##' effect of the focal predictor. ##' @param group In multigroup models, the label of the group for which the ##' results will be returned. Must correspond to one of ##' `lavInspect(fit, "group.label")`, or an integer ##' corresponding to which of those group labels. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Ignored unless `fit` is of ##' class [lavaan.mi::lavaan.mi-class]. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return A list with two elements: ##' \enumerate{ ##' \item `SimpleIntercept`: The simple intercepts given each value of the ##' moderator. ##' \item `SimpleSlope`: The simple slopes given each value of the moderator. ##' } ##' In each element, the first column represents the values of the moderator ##' specified in the `valProbe` argument. The second column is the simple ##' intercept or simple slope. The third column is the *SE* of the simple ##' intercept or simple slope. The fourth column is the Wald (*z*) ##' statistic, and the fifth column is the associated *p* value testing ##' the null hypothesis that each simple intercept or slope is 0. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' \item [probe3WayMC()] For probing the three-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe2WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [probe3WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [plotProbe()] Plot the simple intercepts and slopes of the ##' latent interaction. ##' } ##' ##' @references ##' ##' Tutorial: ##' ##' Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting ##' latent variable interactions using the `semTools` package. ##' *Psych, 3*(3), 322--335. \doi{10.3390/psych3030024} ##' ##' Background literature: ##' ##' Aiken, L. S., & West, S. G. (1991). *Multiple regression: Testing ##' and interpreting interactions*. Newbury Park, CA: Sage. ##' ##' Cohen, J., Cohen, P., West, S. G., & Aiken, L. S. (2003). *Applied ##' multiple regression/correlation analysis for the behavioral sciences* ##' (3rd ed.). New York, NY: Routledge. ##' ##' Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of ##' latent interactions: Evaluation of alternative estimation strategies and ##' indicator construction. *Psychological Methods, 9*(3), 275--300. ##' \doi{10.1037/1082-989X.9.3.275} ##' ##' Preacher, K. J., Curran, P. J., & Bauer, D. J. (2006). Computational tools ##' for probing interactions in multiple linear regression, multilevel modeling, ##' and latent curve analysis. *Journal of Educational and Behavioral ##' Statistics, 31*(4), 437--448. \doi{10.3102/10769986031004437} ##' ##' @examples ##' ##' dat2wayMC <- indProd(dat2way, 1:3, 4:6) # double mean centered by default ##' ##' model1 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f3 =~ x7 + x8 + x9 ##' f3 ~ f1 + f2 + f12 ##' f12 ~~ 0*f1 + 0*f2 # not necessary, but implied by double mean centering ##' " ##' ##' fitMC2way <- sem(model1, data = dat2wayMC, meanstructure = TRUE) ##' summary(fitMC2way) ##' ##' probe2WayMC(fitMC2way, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1)) ##' ##' ##' ## can probe multigroup models, one group at a time ##' dat2wayMC$g <- 1:2 ##' ##' model2 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f3 =~ x7 + x8 + x9 ##' f3 ~ c(b1.g1, b1.g2)*f1 + c(b2.g1, b2.g2)*f2 + c(b12.g1, b12.g2)*f12 ##' f12 ~~ 0*f1 + 0*f2 ##' " ##' fit2 <- sem(model2, data = dat2wayMC, group = "g") ##' probe2WayMC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1)) # group = 1 by default ##' probe2WayMC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1), group = 2) ##' ##' @export probe2WayMC <- function(fit, nameX, nameY, modVar, valProbe, group = 1L, omit.imps = c("no.conv","no.se")) { ## TDJ: verify class if (inherits(fit, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(fit@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(fit@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(fit@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(fit@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(fit@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) } else if (!inherits(fit, "lavaan")) { stop('"fit" must inherit from lavaan or lavaan.mi class', call. = FALSE) } meanstruc <- lavInspect(fit, "options")$meanstructure # Check whether modVar is correct if (is.character(modVar)) modVar <- match(modVar, nameX) if (is.na(modVar) || !(modVar %in% 1:2)) stop("The moderator name is not in the name of independent factors or not 1 or 2.") ## TDJ: If multigroup, check group %in% group.label nG <- lavInspect(fit, "ngroups") if (nG > 1L) { group.label <- lavInspect(fit, "group.label") ## assign numeric to character if (is.numeric(group)) { if (group %in% 1:nG) { group <- group.label[group] } else group <- as.character(group) } else group <- as.character(group) ## check that character is a group if (!as.character(group) %in% group.label) stop('"group" must be a character string naming a group of interest, or ', 'an integer corresponding to a group in lavInspect(fit, "group.label")') group.number <- which(group.label == group) } else group.number <- 1L ## Get the parameter estimates for that group if (nG > 1L) { if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est")[[group]] if (!meanstruc) { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } else if (inherits(fit, "lavaan.mi")) { est <- list() GLIST <- fit@coefList[useImps] est$beta <- Reduce("+", lapply(GLIST, function(i) i[[group]]$beta)) / m if (meanstruc) { est$alpha <- Reduce("+", lapply(GLIST, function(i) i[[group]]$alpha)) / m } else { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } } else { ## single-group model if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est") if (!meanstruc) { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } else if (inherits(fit, "lavaan.mi")) { est <- list() est$beta <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "beta")) / m if (meanstruc) { est$alpha <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "alpha")) / m } else { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } } ## extract relevant slopes betaNC <- matrix(est$beta[nameY, nameX], ncol = 1, dimnames = list(nameX, nameY)) if (modVar == 1) betaNC <- betaNC[c(2, 1, 3)] ## Extract all sampling (co)variances if (inherits(fit, "lavaan")) { varEst <- lavaan::vcov(fit) } else if (inherits(fit, "lavaan.mi")) { varEst <- getMethod(f = "vcov", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(fit, omit.imps = omit.imps) } ## for indexing the sampling (co)variances PT <- parTable(fit) ## index slopes in varEst slope.idx <- which(PT$lhs == nameY & PT$op == "~" & PT$rhs %in% nameX & PT$group == group.number) ## check for user-defined labels; otherwise, set defaults slope.label <- PT$label[slope.idx] if (any(slope.label == "")) for (i in which(slope.label == "")) { slope.label[i] <- paste0(nameY, "~", nameX[i], ifelse(nG > 1L && group.number > 1L, no = "", yes = paste0(".g", group.number))) } if (modVar == 1) slope.label <- slope.label[c(3, 2, 4)] ## index intercept in varEst if (meanstruc) { int.idx <- PT$label[PT$lhs == nameY & PT$op == "~1" & PT$group == group.number] if (int.idx == "") { ## no custom label, use default int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## check whether it is actually estimated (appears in $alpha and varEst) estimateIntcept <- int.idx %in% rownames(varEst) } else { estimateIntcept <- FALSE ## use default label int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## if intercept is not estimated, add a row/column with zero sampling variance if (!estimateIntcept) { dn <- c(rownames(varEst), int.idx) varEst <- rbind(cbind(varEst, 0), 0) dimnames(varEst) <- list(dn, dn) } ## save all indices in a vector targetcol <- c(int.idx, slope.label) ## collect relevant estimates and variances to probe the interaction usedBeta <- rbind(est$alpha[nameY,], betaNC) # point estimates usedVar <- varEst[targetcol, targetcol] # sampling (co)variances ## function to calculate p values for Wald z tests pvalue <- function(x) (1 - pnorm(abs(x))) * 2 ## Calculate simple intercepts simpleIntcept <- usedBeta[1] + usedBeta[3] * valProbe varIntcept <- usedVar[1, 1] + 2 * valProbe * usedVar[1, 3] + (valProbe^2) * usedVar[3, 3] zIntcept <- simpleIntcept / sqrt(varIntcept) pIntcept <- pvalue(zIntcept) resultIntcept <- data.frame(valProbe, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultIntcept) <- c("lavaan.data.frame","data.frame") ## Calculate simple slopes simpleSlope <- usedBeta[2] + usedBeta[4] * valProbe varSlope <- usedVar[2, 2] + 2 * valProbe * usedVar[2, 4] + (valProbe^2) * usedVar[4, 4] zSlope <- simpleSlope / sqrt(varSlope) pSlope <- pvalue(zSlope) resultSlope <- data.frame(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultSlope) <- c("lavaan.data.frame","data.frame") list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope) } ## -------- ## 2-way RC ## -------- ##' Probing two-way interaction on the residual-centered latent interaction ##' ##' Probing interaction for simple intercept and simple slope for the ##' residual-centered latent two-way interaction (Geldhof et al., 2013) ##' ##' Before using this function, researchers need to make the products of the ##' indicators between the first-order factors and residualize the products by ##' the original indicators (Lance, 1988; Little, Bovaird, & Widaman, 2006). The ##' process can be automated by the [indProd()] function. Note that ##' the indicator products can be made for all possible combination or ##' matched-pair approach (Marsh et al., 2004). Next, the hypothesized model ##' with the regression with latent interaction will be used to fit all original ##' indicators and the product terms. To use this function the model must be fit ##' with a mean structure. See the example for how to fit the product term ##' below. Once the lavaan result is obtained, this function will be used to ##' probe the interaction. ##' ##' The probing process on residual-centered latent interaction is based on ##' transforming the residual-centered result into the no-centered result. See ##' Geldhof et al. (2013) for further details. Note that this approach is based ##' on a strong assumption that the first-order latent variables are normally ##' distributed. The probing process is applied after the no-centered result ##' (parameter estimates and their covariance matrix among parameter estimates) ##' has been computed. See the [probe2WayMC()] for further details. ##' ##' ##' @importFrom lavaan lavInspect parTable ##' @importFrom stats pnorm ##' @importFrom methods getMethod ##' ##' @param fit A fitted [lavaan::lavaan-class] or ##' [lavaan.mi::lavaan.mi-class] object with a latent 2-way interaction. ##' @param nameX `character` vector of all 3 factor names used as the ##' predictors. The lower-order factors must be listed first, and the final ##' name must be the latent interaction factor. ##' @param nameY The name of factor that is used as the dependent variable. ##' @param modVar The name of factor that is used as a moderator. The effect of ##' the other independent factor will be probed at each value of the ##' moderator variable listed in `valProbe`. ##' @param valProbe The values of the moderator that will be used to probe the ##' effect of the focal predictor. ##' @param group In multigroup models, the label of the group for which the ##' results will be returned. Must correspond to one of ##' `lavInspect(fit, "group.label")`, or an integer ##' corresponding to which of those group labels. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Ignored unless `fit` is of ##' class [lavaan.mi::lavaan.mi-class]. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return A list with two elements: ##' \enumerate{ ##' \item `SimpleIntercept`: The simple intercepts given each value of the ##' moderator. ##' \item `SimpleSlope`: The simple slopes given each value of the moderator. ##' } ##' In each element, the first column represents the values of the moderators ##' specified in the `valProbe` argument. The second column is the simple ##' intercept or simple slope. The third column is the standard error of the ##' simple intercept or slope. The fourth column is the Wald (*z*) ##' statistic, and the fifth column is the associated *p* value testing ##' the null hypothesis that each simple intercept or slope is 0. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' \item [probe2WayMC()] For probing the two-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe3WayMC()] For probing the three-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe3WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [plotProbe()] Plot the simple intercepts and slopes of the ##' latent interaction. ##' } ##' @references ##' ##' Tutorial: ##' ##' Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting ##' latent variable interactions using the `semTools` package. ##' *Psych, 3*(3), 322--335. \doi{10.3390/psych3030024} ##' ##' Background literature: ##' ##' Lance, C. E. (1988). Residual centering, exploratory and confirmatory ##' moderator analysis, and decomposition of effects in path models containing ##' interactions. *Applied Psychological Measurement, 12*(2), 163--175. ##' \doi{10.1177/014662168801200205} ##' ##' Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of ##' orthogonalizing powered and product terms: Implications for modeling ##' interactions. *Structural Equation Modeling, 13*(4), 497--519. ##' \doi{10.1207/s15328007sem1304_1} ##' ##' Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of ##' latent interactions: Evaluation of alternative estimation strategies and ##' indicator construction. *Psychological Methods, 9*(3), 275--300. ##' \doi{10.1037/1082-989X.9.3.275} ##' ##' Geldhof, G. J., Pornprasertmanit, S., Schoemann, A. M., & Little, T. D. ##' (2013). Orthogonalizing through residual centering: Extended applications ##' and caveats. *Educational and Psychological Measurement, 73*(1), 27--46. ##' \doi{10.1177/0013164412445473} ##' ##' @examples ##' ##' dat2wayRC <- orthogonalize(dat2way, 1:3, 4:6) ##' ##' model1 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f3 =~ x7 + x8 + x9 ##' f3 ~ f1 + f2 + f12 ##' f12 ~~ 0*f1 + 0*f2 ##' x1 + x4 + x1.x4 + x7 ~ 0*1 # identify latent means ##' f1 + f2 + f12 + f3 ~ NA*1 ##' " ##' ##' fitRC2way <- sem(model1, data = dat2wayRC, meanstructure = TRUE) ##' summary(fitRC2way) ##' ##' probe2WayRC(fitRC2way, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1)) ##' ##' ##' ## can probe multigroup models, one group at a time ##' dat2wayRC$g <- 1:2 ##' ##' model2 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f3 =~ x7 + x8 + x9 ##' f3 ~ c(b1.g1, b1.g2)*f1 + c(b2.g1, b2.g2)*f2 + c(b12.g1, b12.g2)*f12 ##' f12 ~~ 0*f1 + 0*f2 ##' x1 + x4 + x1.x4 + x7 ~ 0*1 # identify latent means ##' f1 + f2 + f12 ~ NA*1 ##' f3 ~ NA*1 + c(b0.g1, b0.g2)*1 ##' " ##' fit2 <- sem(model2, data = dat2wayRC, group = "g") ##' probe2WayRC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1)) # group = 1 by default ##' probe2WayRC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", ##' modVar = "f2", valProbe = c(-1, 0, 1), group = 2) ##' ##' @export probe2WayRC <- function(fit, nameX, nameY, modVar, valProbe, group = 1L, omit.imps = c("no.conv","no.se")) { ## TDJ: verify class if (inherits(fit, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(fit@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(fit@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(fit@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(fit@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(fit@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) } else if (!inherits(fit, "lavaan")) { stop('"fit" must inherit from lavaan or lavaan.mi class', call. = FALSE) } if (!lavInspect(fit, "options")$meanstructure) stop('This function requires the model to be fit with a mean structure.', call. = FALSE) # Check whether modVar is correct if (is.character(modVar)) modVar <- match(modVar, nameX) if (is.na(modVar) || !(modVar %in% 1:2)) stop("The moderator name is not in the name of independent factors or not 1 or 2.") ## TDJ: If multigroup, check group %in% group.label nG <- lavInspect(fit, "ngroups") if (nG > 1L) { group.label <- lavInspect(fit, "group.label") ## assign numeric to character if (is.numeric(group)) { if (group %in% 1:nG) { group <- group.label[group] } else group <- as.character(group) } else group <- as.character(group) ## check that character is a group if (!as.character(group) %in% group.label) stop('"group" must be a character string naming a group of interest, or ', 'an integer corresponding to a group in lavInspect(fit, "group.label")') group.number <- which(group.label == group) } else group.number <- 1L ## Get the parameter estimates for that group if (nG > 1L) { if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est")[[group]] } else if (inherits(fit, "lavaan.mi")) { est <- list() GLIST <- fit@coefList[useImps] est$beta <- Reduce("+", lapply(GLIST, function(i) i[[group]]$beta)) / m est$alpha <- Reduce("+", lapply(GLIST, function(i) i[[group]]$alpha)) / m est$psi <- Reduce("+", lapply(GLIST, function(i) i[[group]]$psi)) / m } } else { ## single-group model if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est") } else if (inherits(fit, "lavaan.mi")) { est <- list() est$beta <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "beta")) / m est$alpha <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "alpha")) / m est$psi <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "psi")) / m } } # Find the mean and covariance matrix of independent factors varX <- est$psi[ nameX, nameX] meanX <- est$alpha[nameX, , drop = FALSE] # Find the intercept, regression coefficients, and residual variance of residual-centered regression intceptRC <- est$alpha[nameY,] resVarRC <- est$psi[ nameY, nameY] betaRC <- t(est$beta[ nameY, nameX, drop = FALSE]) # Find the number of observations numobs <- lavInspect(fit, "nobs")[group.number] # Compute SSRC meanXwith1 <- rbind(1, meanX) varXwith0 <- cbind(0, rbind(0, varX)) SSRC <- numobs * (varXwith0 + (meanXwith1 %*% t(meanXwith1))) # Compute Mean(Y) and Var(Y) betaRCWithIntcept <- rbind(intceptRC, betaRC) meanY <- t(meanXwith1) %*% betaRCWithIntcept varY <- (t(betaRCWithIntcept) %*% SSRC %*% betaRCWithIntcept)/numobs - meanY^2 + resVarRC # Compute Cov(Y, X) covY <- as.matrix((varX %*% betaRC)[1:2,]) # Compute E(XZ) meanX[3] <- meanX[1] * meanX[2] + varX[1, 2] # Compute Var(XZ) varX[3, 3] <- meanX[1]^2 * varX[2, 2] + meanX[2]^2 * varX[1, 1] + 2 * meanX[1] * meanX[2] * varX[1, 2] + varX[1, 1] * varX[2, 2] + varX[1, 2]^2 # Compute Cov(X, XZ), Cov(Z, XZ) varX[1, 3] <- varX[3, 1] <- meanX[1] * varX[1, 2] + meanX[2] * varX[1, 1] varX[2, 3] <- varX[3, 2] <- meanX[1] * varX[2, 2] + meanX[2] * varX[1, 2] # Compute Cov(Y, XZ) and regression coefficients of no-centering betaNC <- solve(varX[1:2,1:2], covY - rbind(varX[1,3] * betaRC[3,1], varX[2, 3] * betaRC[3,1])) betaNC <- rbind(betaNC, betaRC[3, 1]) covY <- rbind(covY, (varX %*% betaNC)[3, 1]) # Aggregate the non-centering sufficient statistics (Just show how to do but not necessary) fullCov <- rbind(cbind(varX, covY), c(covY, varY)) fullMean <- rbind(meanX, meanY) # Compute the intercept of no-centering intceptNC <- meanY - t(betaNC) %*% meanX # Compute SSNC betaNCWithIntcept <- rbind(intceptNC, betaNC) meanXwith1 <- rbind(1, meanX) varXwith0 <- rbind(0, cbind(0, varX)) SSNC <- numobs * (varXwith0 + (meanXwith1 %*% t(meanXwith1))) # Compute residual variance on non-centering resVarNC <- varY - (t(betaNCWithIntcept) %*% SSNC %*% betaNCWithIntcept)/numobs + meanY^2 ## function to calculate p values for Wald z tests pvalue <- function(x) (1 - pnorm(abs(x))) * 2 ## Extract all sampling (co)variances if (inherits(fit, "lavaan")) { varEst <- lavaan::vcov(fit) } else if (inherits(fit, "lavaan.mi")) { varEst <- getMethod(f = "vcov", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(fit, omit.imps = omit.imps) } ## for indexing sampling (co)variances PT <- parTable(fit) int.idx <- PT$label[PT$lhs == nameY & PT$op == "~1" & PT$group == group.number] if (int.idx == "") { ## no custom label, use default int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## check intercept is actually estimated (thus, has sampling variance) estimateIntcept <- int.idx %in% rownames(varEst) ## if intercept is not estimated, add a row/column with zero sampling variance if (!estimateIntcept) { dn <- c(rownames(varEst), int.idx) varEst <- rbind(cbind(varEst, 0), 0) dimnames(varEst) <- list(dn, dn) } ## index slopes in varEst slope.idx <- which(PT$lhs == nameY & PT$op == "~" & PT$rhs %in% nameX & PT$group == group.number) ## check for user-defined labels; otherwise, set defaults slope.label <- PT$label[slope.idx] if (any(slope.label == "")) for (i in which(slope.label == "")) { slope.label[i] <- paste0(nameY, "~", nameX[i], ifelse(nG > 1L && group.number > 1L, no = "", yes = paste0(".g", group.number))) } ## save all indices in a vector targetcol <- c(int.idx, slope.label) varEstSlopeRC <- varEst[targetcol, targetcol] ## collect relevant estimates and variances to probe the interaction usedVar <- as.numeric(resVarNC/resVarRC) * (varEstSlopeRC %*% SSRC %*% solve(SSNC)) usedBeta <- betaNCWithIntcept # Change the order of usedVar and usedBeta if the moderator variable is listed first if (modVar == 1) { usedVar <- usedVar[c(1, 3, 2, 4), c(1, 3, 2, 4)] usedBeta <- usedBeta[c(1, 3, 2, 4)] } ## Calculate simple intercepts simpleIntcept <- usedBeta[1] + usedBeta[3] * valProbe varIntcept <- usedVar[1, 1] + 2 * valProbe * usedVar[1, 3] + (valProbe^2) * usedVar[3, 3] zIntcept <- simpleIntcept/sqrt(varIntcept) pIntcept <- pvalue(zIntcept) resultIntcept <- data.frame(valProbe, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultIntcept) <- c("lavaan.data.frame","data.frame") ## Calculate simple slopes simpleSlope <- usedBeta[2] + usedBeta[4] * valProbe varSlope <- usedVar[2, 2] + 2 * valProbe * usedVar[2, 4] + (valProbe^2) * usedVar[4, 4] zSlope <- simpleSlope/sqrt(varSlope) pSlope <- pvalue(zSlope) resultSlope <- data.frame(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultSlope) <- c("lavaan.data.frame","data.frame") list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope) } ## -------- ## 3-way MC ## -------- ##' Probing three-way interaction on the no-centered or mean-centered latent ##' interaction ##' ##' Probing interaction for simple intercept and simple slope for the ##' no-centered or mean-centered latent two-way interaction ##' ##' Before using this function, researchers need to make the products of the ##' indicators between the first-order factors using mean centering (Marsh, Wen, ##' & Hau, 2004). Note that the double-mean centering may not be appropriate for ##' probing interaction if researchers are interested in simple intercepts. The ##' mean or double-mean centering can be done by the [indProd()] ##' function. The indicator products can be made for all possible combination or ##' matched-pair approach (Marsh et al., 2004). Next, the hypothesized model ##' with the regression with latent interaction will be used to fit all original ##' indicators and the product terms. See the example for how to fit the product ##' term below. Once the lavaan result is obtained, this function will be used ##' to probe the interaction. ##' ##' Let that the latent interaction model regressing the dependent variable ##' (\eqn{Y}) on the independent variable (\eqn{X}) and two moderators (\eqn{Z} ##' and \eqn{W}) be \deqn{ Y = b_0 + b_1X + b_2Z + b_3W + b_4XZ + b_5XW + b_6ZW ##' + b_7XZW + r, } where \eqn{b_0} is the estimated intercept or the expected ##' value of \eqn{Y} when \eqn{X}, \eqn{Z}, and \eqn{W} are 0, \eqn{b_1} is the ##' effect of \eqn{X} when \eqn{Z} and \eqn{W} are 0, \eqn{b_2} is the effect of ##' \eqn{Z} when \eqn{X} and \eqn{W} is 0, \eqn{b_3} is the effect of \eqn{W} ##' when \eqn{X} and \eqn{Z} are 0, \eqn{b_4} is the interaction effect between ##' \eqn{X} and \eqn{Z} when \eqn{W} is 0, \eqn{b_5} is the interaction effect ##' between \eqn{X} and \eqn{W} when \eqn{Z} is 0, \eqn{b_6} is the interaction ##' effect between \eqn{Z} and \eqn{W} when \eqn{X} is 0, \eqn{b_7} is the ##' three-way interaction effect between \eqn{X}, \eqn{Z}, and \eqn{W}, and ##' \eqn{r} is the residual term. ##' ##' To probe a three-way interaction, the simple intercept of the independent ##' variable at the specific values of the moderators (Aiken & West, 1991) can ##' be obtained by ##' \deqn{ b_{0|X = 0, Z, W} = b_0 + b_2Z + b_3W + b_6ZW. } ##' The simple slope of the independent variable at the specific values of the ##' moderators can be obtained by ##' \deqn{ b_{X|Z, W} = b_1 + b_3Z + b_4W + b_7ZW.} ##' The variance of the simple intercept formula is ##' \deqn{ Var\left(b_{0|X = 0, Z, W}\right) = ##' Var\left(b_0\right) + Z^2Var\left(b_2\right) + W^2Var\left(b_3\right) + ##' Z^2W^2Var\left(b_6\right)} ##' \deqn{+ 2ZCov\left(b_0, b_2\right) + 2WCov\left(b_0, b_3\right) + ##' 2ZWCov\left(b_0, b_6\right) + 2ZWCov\left(b_2, b_3\right) + ##' 2Z^2WCov\left(b_2, b_6\right) + 2ZW^2Cov\left(b_3, b_6\right), } ##' where \eqn{Var} denotes the variance of a parameter estimate and \eqn{Cov} ##' denotes the covariance of two parameter estimates. ##' ##' The variance of the simple slope formula is ##' \deqn{ Var\left(b_{X|Z, W}\right) = ##' Var\left(b_1\right) + Z^2Var\left(b_4\right) + W^2Var\left(b_5\right) ##' + Z^2W^2Var\left(b_7\right) } ##' \deqn{+ 2ZCov\left(b_1, b_4\right) + 2WCov\left(b_1, b_5\right) + ##' 2ZWCov\left(b_1, b_7\right) + 2ZWCov\left(b_4, b_5\right) + ##' 2Z^2WCov\left(b_4, b_7\right) + 2ZW^2Cov\left(b_5, b_7\right). } ##' ##' Wald *z* statistics are calculated (even for objects of class ##' [lavaan.mi::lavaan.mi-class]) to test null hypotheses that simple ##' intercepts or slopes are 0. ##' ##' ##' @importFrom lavaan lavInspect parTable ##' @importFrom stats pnorm ##' @importFrom methods getMethod ##' ##' @param fit A fitted [lavaan::lavaan-class] or ##' [lavaan.mi::lavaan.mi-class] object with a latent 2-way interaction. ##' @param nameX `character` vector of all 7 factor names used as the ##' predictors. The 3 lower-order factors must be listed first, followed by ##' the 3 second-order factors (specifically, the 4th element must be the ##' interaction between the factors listed first and second, the 5th element ##' must be the interaction between the factors listed first and third, and ##' the 6th element must be the interaction between the factors listed second ##' and third). The final name will be the factor representing the 3-way ##' interaction. ##' @param nameY The name of factor that is used as the dependent variable. ##' @param modVar The name of two factors that are used as the moderators. The ##' effect of the independent factor will be probed at each combination of ##' the moderator variables' chosen values. ##' @param valProbe1 The values of the first moderator that will be used to ##' probe the effect of the independent factor. ##' @param valProbe2 The values of the second moderator that will be used to ##' probe the effect of the independent factor. ##' @param group In multigroup models, the label of the group for which the ##' results will be returned. Must correspond to one of ##' `lavInspect(fit, "group.label")`. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Ignored unless `fit` is of ##' class [lavaan.mi::lavaan.mi-class]. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return A list with two elements: ##' \enumerate{ ##' \item `SimpleIntercept`: The model-implied intercepts given each ##' combination of moderator values. ##' \item `SimpleSlope`: The model-implied slopes given each combination ##' of moderator values. ##' } ##' In each element, the first column represents values of the first moderator ##' specified in the `valProbe1` argument. The second column represents ##' values of the second moderator specified in the `valProbe2` argument. ##' The third column is the simple intercept or simple slope. The fourth column ##' is the standard error of the simple intercept or simple slope. The fifth ##' column is the Wald (*z*) statistic, and the sixth column is its ##' associated *p* value to test the null hypothesis that each simple ##' intercept or simple slope equals 0. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' \item [probe2WayMC()] For probing the two-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe2WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [probe3WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [plotProbe()] Plot the simple intercepts and slopes of the ##' latent interaction. ##' } ##' ##' @references ##' Tutorial: ##' ##' Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting ##' latent variable interactions using the `semTools` package. ##' *Psych, 3*(3), 322--335. \doi{10.3390/psych3030024} ##' ##' Background literature: ##' ##' Aiken, L. S., & West, S. G. (1991). *Multiple regression: Testing ##' and interpreting interactions*. Newbury Park, CA: Sage. ##' ##' Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of ##' latent interactions: Evaluation of alternative estimation strategies and ##' indicator construction. *Psychological Methods, 9*(3), 275--300. ##' \doi{10.1037/1082-989X.9.3.275} ##' ##' @examples ##' ##' dat3wayMC <- indProd(dat3way, 1:3, 4:6, 7:9) ##' ##' model3 <- " ## define latent variables ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f3 =~ x7 + x8 + x9 ##' ## 2-way interactions ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f13 =~ x1.x7 + x2.x8 + x3.x9 ##' f23 =~ x4.x7 + x5.x8 + x6.x9 ##' ## 3-way interaction ##' f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 ##' ## outcome variable ##' f4 =~ x10 + x11 + x12 ##' ##' ## latent regression model ##' f4 ~ b1*f1 + b2*f2 + b3*f3 + b12*f12 + b13*f13 + b23*f23 + b123*f123 ##' ##' ## orthogonal terms among predictors ##' ## (not necessary, but implied by double mean centering) ##' f1 ~~ 0*f12 + 0*f13 + 0*f123 ##' f2 ~~ 0*f12 + 0*f23 + 0*f123 ##' f3 ~~ 0*f13 + 0*f23 + 0*f123 ##' f12 + f13 + f23 ~~ 0*f123 ##' " ##' ##' fitMC3way <- sem(model3, data = dat3wayMC, meanstructure = TRUE) ##' summary(fitMC3way) ##' ##' probe3WayMC(fitMC3way, nameX = c("f1" ,"f2" ,"f3", ##' "f12","f13","f23", # this order matters! ##' "f123"), # 3-way interaction ##' nameY = "f4", modVar = c("f1", "f2"), ##' valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) ##' ##' @export probe3WayMC <- function(fit, nameX, nameY, modVar, valProbe1, valProbe2, group = 1L, omit.imps = c("no.conv","no.se")) { ## TDJ: verify class if (inherits(fit, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(fit@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(fit@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(fit@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(fit@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(fit@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) } else if (!inherits(fit, "lavaan")) { stop('"fit" must inherit from lavaan or lavaan.mi class', call. = FALSE) } meanstruc <- lavInspect(fit, "options")$meanstructure # Check whether modVar is correct if (is.character(modVar)) modVar <- match(modVar, nameX) if ((NA %in% modVar) || !(do.call("&", as.list(modVar %in% 1:3)))) stop("The moderator name is not in the list of independent factors and is not 1, 2 or 3.") ## TDJ: If multigroup, check group %in% group.label nG <- lavInspect(fit, "ngroups") if (nG > 1L) { group.label <- lavInspect(fit, "group.label") ## assign numeric to character if (is.numeric(group)) { if (group %in% 1:nG) { group <- group.label[group] } else group <- as.character(group) } else group <- as.character(group) ## check that character is a group if (!as.character(group) %in% group.label) stop('"group" must be a character string naming a group of interest, or ', 'an integer corresponding to a group in lavInspect(fit, "group.label")') group.number <- which(group.label == group) } else group.number <- 1L ## Get the parameter estimates for that group if (nG > 1L) { if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est")[[group]] if (!meanstruc) { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } else if (inherits(fit, "lavaan.mi")) { est <- list() GLIST <- fit@coefList[useImps] est$beta <- Reduce("+", lapply(GLIST, function(i) i[[group]]$beta)) / m if (meanstruc) { est$alpha <- Reduce("+", lapply(GLIST, function(i) i[[group]]$alpha)) / m } else { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } } else { ## single-group model if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est") if (!meanstruc) { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } else if (inherits(fit, "lavaan.mi")) { est <- list() est$beta <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "beta")) / m if (meanstruc) { est$alpha <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "alpha")) / m } else { est$alpha <- matrix(0, 1, 1, dimnames = list(nameY, "intercept")) } } } ## extract relevant slopes betaNC <- matrix(est$beta[nameY, nameX], ncol = 1, dimnames = list(nameX, nameY)) ## Extract all sampling (co)variances if (inherits(fit, "lavaan")) { varEst <- lavaan::vcov(fit) } else if (inherits(fit, "lavaan.mi")) { varEst <- getMethod(f = "vcov", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(fit, omit.imps = omit.imps) } ## for indexing the sampling (co)variances PT <- parTable(fit) ## index slopes in varEst slope.idx <- which(PT$lhs == nameY & PT$op == "~" & PT$rhs %in% nameX & PT$group == group.number) ## check for user-defined labels; otherwise, set defaults slope.label <- PT$label[slope.idx] if (any(slope.label == "")) for (i in which(slope.label == "")) { slope.label[i] <- paste0(nameY, "~", nameX[i], ifelse(nG > 1L && group.number > 1L, no = "", yes = paste0(".g", group.number))) } ## index intercept in varEst if (meanstruc) { int.idx <- PT$label[PT$lhs == nameY & PT$op == "~1" & PT$group == group.number] if (int.idx == "") { ## no custom label, use default int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## check whether it is actually estimated (appears in $alpha and varEst) estimateIntcept <- int.idx %in% rownames(varEst) } else { estimateIntcept <- FALSE ## use default label int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## if intercept is not estimated, add a row/column with zero sampling variance if (!estimateIntcept) { dn <- c(rownames(varEst), int.idx) varEst <- rbind(cbind(varEst, 0), 0) dimnames(varEst) <- list(dn, dn) } ## save all indices in a vector targetcol <- c(int.idx, slope.label) ## collect relevant estimates and variances to probe the interaction usedBeta <- rbind(est$alpha[nameY,], betaNC) # point estimates usedVar <- varEst[targetcol, targetcol] # sampling (co)variances ## In case a moderator is listed first, find the order to rearrange ord <- c(setdiff(1:3, modVar), modVar) ord <- c(ord, 7 - rev(ord)) usedBeta <- usedBeta[c(1, ord+1, 8)] usedVar <- usedVar[ c(1, ord+1, 8), c(1, ord+1, 8)] ## set all combinations of moderator values val <- expand.grid(valProbe1, valProbe2) ## function to calculate p values for Wald z tests pvalue <- function(x) (1 - pnorm(abs(x))) * 2 ## Calculate simple intercepts simpleIntcept <- usedBeta[1] + usedBeta[3] * val[,1] + usedBeta[4] * val[,2] + usedBeta[7] * val[,1] * val[,2] varIntcept <- usedVar[1, 1] + val[,1]^2 * usedVar[3, 3] + val[,2]^2 * usedVar[4, 4] + val[,1]^2 * val[,2]^2 * usedVar[7, 7] + 2 * val[,1] * usedVar[1, 3] + 2 * val[,2] * usedVar[1, 4] + 2 * val[,1] * val[,2] * usedVar[1, 7] + 2 * val[,1] * val[,2] * usedVar[3, 4] + 2 * val[,1]^2 * val[,2] * usedVar[3, 7] + 2* val[,1] * val[,2]^2 * usedVar[4, 7] zIntcept <- simpleIntcept / sqrt(varIntcept) pIntcept <- pvalue(zIntcept) resultIntcept <- cbind(val, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultIntcept) <- c("lavaan.data.frame","data.frame") ## Calculate simple slopes simpleSlope <- usedBeta[2] + usedBeta[5] * val[,1] + usedBeta[6] * val[,2] + usedBeta[8] * val[,1] * val[,2] varSlope <- usedVar[2, 2] + val[,1]^2 * usedVar[5, 5] + val[,2]^2 * usedVar[6, 6] + val[,1]^2 * val[,2]^2 * usedVar[8, 8] + 2 * val[,1] * usedVar[2, 5] + 2 * val[,2] * usedVar[2, 6] + 2 * val[,1] * val[,2] * usedVar[2, 8] + 2 * val[,1] * val[,2] * usedVar[5, 6] + 2 * val[,1]^2 * val[,2] * usedVar[5, 8] + 2 * val[,1] * val[,2]^2 * usedVar[6, 8] zSlope <- simpleSlope / sqrt(varSlope) pSlope <- pvalue(zSlope) resultSlope <- cbind(val, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultSlope) <- c("lavaan.data.frame","data.frame") list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope) } ## -------- ## 3-way RC ## -------- ##' Probing three-way interaction on the residual-centered latent interaction ##' ##' Probing interaction for simple intercept and simple slope for the ##' residual-centered latent three-way interaction (Geldhof et al., 2013) ##' ##' Before using this function, researchers need to make the products of the ##' indicators between the first-order factors and residualize the products by ##' the original indicators (Lance, 1988; Little, Bovaird, & Widaman, 2006). The ##' process can be automated by the [indProd()] function. Note that ##' the indicator products can be made for all possible combination or ##' matched-pair approach (Marsh et al., 2004). Next, the hypothesized model ##' with the regression with latent interaction will be used to fit all original ##' indicators and the product terms (Geldhof et al., 2013). To use this ##' function the model must be fit with a mean structure. See the example for ##' how to fit the product term below. Once the lavaan result is obtained, this ##' function will be used to probe the interaction. ##' ##' The probing process on residual-centered latent interaction is based on ##' transforming the residual-centered result into the no-centered result. See ##' Geldhof et al. (2013) for further details. Note that this approach based on ##' a strong assumption that the first-order latent variables are normally ##' distributed. The probing process is applied after the no-centered result ##' (parameter estimates and their covariance matrix among parameter estimates) ##' has been computed. See the [probe3WayMC()] for further details. ##' ##' ##' @importFrom lavaan lavInspect parTable ##' @importFrom stats pnorm ##' @importFrom methods getMethod ##' ##' @param fit A fitted [lavaan::lavaan-class] or ##' [lavaan.mi::lavaan.mi-class] object with a latent 2-way interaction. ##' @param nameX `character` vector of all 7 factor names used as the ##' predictors. The 3 lower-order factors must be listed first, followed by ##' the 3 second-order factors (specifically, the 4th element must be the ##' interaction between the factors listed first and second, the 5th element ##' must be the interaction between the factors listed first and third, and ##' the 6th element must be the interaction between the factors listed second ##' and third). The final name will be the factor representing the 3-way ##' interaction. ##' @param nameY The name of factor that is used as the dependent variable. ##' @param modVar The name of two factors that are used as the moderators. The ##' effect of the independent factor on each combination of the moderator ##' variable values will be probed. ##' @param valProbe1 The values of the first moderator that will be used to ##' probe the effect of the independent factor. ##' @param valProbe2 The values of the second moderator that will be used to ##' probe the effect of the independent factor. ##' @param group In multigroup models, the label of the group for which the ##' results will be returned. Must correspond to one of ##' `lavInspect(fit, "group.label")`. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Ignored unless `fit` is of ##' class [lavaan.mi::lavaan.mi-class]. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. ##' ##' @return A list with two elements: ##' \enumerate{ ##' \item `SimpleIntercept`: The model-implied intercepts given each ##' combination of moderator values. ##' \item `SimpleSlope`: The model-implied slopes given each combination ##' of moderator values. ##' } ##' In each element, the first column represents values of the first moderator ##' specified in the `valProbe1` argument. The second column represents ##' values of the second moderator specified in the `valProbe2` argument. ##' The third column is the simple intercept or simple slope. The fourth column ##' is the *SE* of the simple intercept or simple slope. The fifth column ##' is the Wald (*z*) statistic, and the sixth column is its associated ##' *p* value to test the null hypothesis that each simple intercept or ##' simple slope equals 0. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' \item [probe2WayMC()] For probing the two-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe3WayMC()] For probing the three-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe2WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [plotProbe()] Plot the simple intercepts and slopes of the ##' latent interaction. ##' } ##' ##' @references ##' Tutorial: ##' ##' Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting ##' latent variable interactions using the `semTools` package. ##' *Psych, 3*(3), 322--335. \doi{10.3390/psych3030024} ##' ##' Background literature: ##' ##' Geldhof, G. J., Pornprasertmanit, S., Schoemann, A., & Little, ##' T. D. (2013). Orthogonalizing through residual centering: Extended ##' applications and caveats. *Educational and Psychological Measurement, ##' 73*(1), 27--46. \doi{10.1177/0013164412445473} ##' ##' Lance, C. E. (1988). Residual centering, exploratory and confirmatory ##' moderator analysis, and decomposition of effects in path models containing ##' interactions. *Applied Psychological Measurement, 12*(2), 163--175. ##' \doi{10.1177/014662168801200205} ##' ##' Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of ##' orthogonalizing powered and product terms: Implications for modeling ##' interactions. *Structural Equation Modeling, 13*(4), 497--519. ##' \doi{10.1207/s15328007sem1304_1} ##' ##' Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of ##' latent interactions: Evaluation of alternative estimation strategies and ##' indicator construction. *Psychological Methods, 9*(3), 275--300. ##' \doi{10.1037/1082-989X.9.3.275} ##' ##' Pornprasertmanit, S., Schoemann, A. M., Geldhof, G. J., & Little, T. D. ##' (submitted). *Probing latent interaction estimated with a residual ##' centering approach.* ##' ##' @examples ##' ##' dat3wayRC <- orthogonalize(dat3way, 1:3, 4:6, 7:9) ##' ##' model3 <- " ## define latent variables ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f3 =~ x7 + x8 + x9 ##' ## 2-way interactions ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f13 =~ x1.x7 + x2.x8 + x3.x9 ##' f23 =~ x4.x7 + x5.x8 + x6.x9 ##' ## 3-way interaction ##' f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 ##' ## outcome variable ##' f4 =~ x10 + x11 + x12 ##' ##' ## latent regression model ##' f4 ~ b1*f1 + b2*f2 + b3*f3 + b12*f12 + b13*f13 + b23*f23 + b123*f123 ##' ##' ## orthogonal terms among predictors ##' f1 ~~ 0*f12 + 0*f13 + 0*f123 ##' f2 ~~ 0*f12 + 0*f23 + 0*f123 ##' f3 ~~ 0*f13 + 0*f23 + 0*f123 ##' f12 + f13 + f23 ~~ 0*f123 ##' ##' ## identify latent means ##' x1 + x4 + x7 + x1.x4 + x1.x7 + x4.x7 + x1.x4.x7 + x10 ~ 0*1 ##' f1 + f2 + f3 + f12 + f13 + f23 + f123 + f4 ~ NA*1 ##' " ##' ##' fitRC3way <- sem(model3, data = dat3wayRC, meanstructure = TRUE) ##' summary(fitRC3way) ##' ##' probe3WayMC(fitRC3way, nameX = c("f1" ,"f2" ,"f3", ##' "f12","f13","f23", # this order matters! ##' "f123"), # 3-way interaction ##' nameY = "f4", modVar = c("f1", "f2"), ##' valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) ##' ##' @export probe3WayRC <- function(fit, nameX, nameY, modVar, valProbe1, valProbe2, group = 1L, omit.imps = c("no.conv","no.se")) { ## TDJ: verify class if (inherits(fit, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") useImps <- rep(TRUE, length(fit@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(fit@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(fit@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(fit@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(fit@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) } else if (!inherits(fit, "lavaan")) { stop('"fit" must inherit from lavaan or lavaan.mi class', call. = FALSE) } if (!lavInspect(fit, "options")$meanstructure) stop('This function requires the model to be fit with a mean structure.', call. = FALSE) # Check whether modVar is correct if (is.character(modVar)) modVar <- match(modVar, nameX) if ((NA %in% modVar) || !(do.call("&", as.list(modVar %in% 1:3)))) stop("The moderator name is not in the list of independent factors and is ", "not 1, 2 or 3.") # JG: Changed error ## TDJ: If multigroup, check group %in% group.label nG <- lavInspect(fit, "ngroups") if (nG > 1L) { group.label <- lavInspect(fit, "group.label") ## assign numeric to character if (is.numeric(group)) { if (group %in% 1:nG) { group <- group.label[group] } else group <- as.character(group) } else group <- as.character(group) ## check that character is a group if (!as.character(group) %in% group.label) stop('"group" must be a character string naming a group of interest, or ', 'an integer corresponding to a group in lavInspect(fit, "group.label")') group.number <- which(group.label == group) } else group.number <- 1L ## Get the parameter estimates for that group if (nG > 1L) { if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est")[[group]] } else if (inherits(fit, "lavaan.mi")) { est <- list() GLIST <- fit@coefList[useImps] est$beta <- Reduce("+", lapply(GLIST, function(i) i[[group]]$beta)) / m est$alpha <- Reduce("+", lapply(GLIST, function(i) i[[group]]$alpha)) / m est$psi <- Reduce("+", lapply(GLIST, function(i) i[[group]]$psi)) / m } } else { ## single-group model if (inherits(fit, "lavaan")) { est <- lavInspect(fit, "est") } else if (inherits(fit, "lavaan.mi")) { est <- list() est$beta <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "beta")) / m est$alpha <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "alpha")) / m est$psi <- Reduce("+", lapply(fit@coefList[useImps], "[[", i = "psi")) / m } } ## Find the mean and covariance matrix of predictors varX <- est$psi[ nameX, nameX] meanX <-est$alpha[nameX, , drop = FALSE] # Find the intercept, regression coefficients, and residual variance of residual-centered regression intceptRC <- est$alpha[nameY, , drop = FALSE] resVarRC <- est$psi[ nameY, nameY] if (resVarRC < 0) warning("The residual variance is negative. The model did not converge on a proper solution.") betaRC <- t(est$beta[nameY, nameX, drop = FALSE]) # Find the number of observations numobs <- lavInspect(fit, "nobs")[group.number] # Compute SSRC meanXwith1 <- rbind(1, meanX) varXwith0 <- cbind(0, rbind(0, varX)) SSRC <- numobs * (varXwith0 + (meanXwith1 %*% t(meanXwith1))) # Compute Mean(Y) and Var(Y) betaRCWithIntcept <- rbind(intceptRC, betaRC) meanY <- t(meanXwith1) %*% betaRCWithIntcept varY <- (t(betaRCWithIntcept) %*% SSRC %*% betaRCWithIntcept)/numobs - meanY^2 + resVarRC # Compute Cov(Y, X) covY <- as.matrix((varX %*% betaRC)[1:3,]) # Compute E(XZ), E(XW), E(ZW), E(XZW) meanX[4] <- expect2NormProd(meanX[c(1,2)], varX[c(1,2), c(1,2)]) meanX[5] <- expect2NormProd(meanX[c(1,3)], varX[c(1,3), c(1,3)]) meanX[6] <- expect2NormProd(meanX[c(2,3)], varX[c(2,3), c(2,3)]) meanX[7] <- expect3NormProd(meanX[1:3], varX[1:3, 1:3]) # Compute Var(XZ), Var(XW), Var(ZW), Var(XZW) varX[4, 4] <- var2NormProd(meanX[c(1,2)], varX[c(1,2), c(1,2)]) varX[5, 5] <- var2NormProd(meanX[c(1,3)], varX[c(1,3), c(1,3)]) varX[6, 6] <- var2NormProd(meanX[c(2,3)], varX[c(2,3), c(2,3)]) varX[7, 7] <- var3NormProd(meanX[1:3], varX[1:3, 1:3]) # Compute All covariances varX[4, 1] <- varX[1, 4] <- expect3NormProd(meanX[c(1, 2, 1)], varX[c(1, 2, 1),c(1, 2, 1)]) - expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) * meanX[1] varX[5, 1] <- varX[1, 5] <- expect3NormProd(meanX[c(1, 3, 1)], varX[c(1, 3, 1),c(1, 3, 1)]) - expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) * meanX[1] varX[6, 1] <- varX[1, 6] <- expect3NormProd(meanX[c(2, 3, 1)], varX[c(2, 3, 1),c(2, 3, 1)]) - expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) * meanX[1] varX[7, 1] <- varX[1, 7] <- expect4NormProd(meanX[c(1,2,3,1)], varX[c(1,2,3,1),c(1,2,3,1)]) - expect3NormProd(meanX[c(1,2,3)], varX[c(1,2,3),c(1,2,3)]) * meanX[1] varX[4, 2] <- varX[2, 4] <- expect3NormProd(meanX[c(1, 2, 2)], varX[c(1, 2, 2),c(1, 2, 2)]) - expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) * meanX[2] varX[5, 2] <- varX[2, 5] <- expect3NormProd(meanX[c(1, 3, 2)], varX[c(1, 3, 2),c(1, 3, 2)]) - expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) * meanX[2] varX[6, 2] <- varX[2, 6] <- expect3NormProd(meanX[c(2, 3, 2)], varX[c(2, 3, 2),c(2, 3, 2)]) - expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) * meanX[2] varX[7, 2] <- varX[2, 7] <- expect4NormProd(meanX[c(1,2,3,2)], varX[c(1,2,3,2),c(1,2,3,2)]) - expect3NormProd(meanX[c(1,2,3)], varX[c(1,2,3),c(1,2,3)]) * meanX[2] varX[4, 3] <- varX[3, 4] <- expect3NormProd(meanX[c(1, 2, 3)], varX[c(1, 2, 3),c(1, 2, 3)]) - expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) * meanX[3] varX[5, 3] <- varX[3, 5] <- expect3NormProd(meanX[c(1, 3, 3)], varX[c(1, 3, 3),c(1, 3, 3)]) - expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) * meanX[3] varX[6, 3] <- varX[3, 6] <- expect3NormProd(meanX[c(2, 3, 3)], varX[c(2, 3, 3),c(2, 3, 3)]) - expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) * meanX[3] varX[7, 3] <- varX[3, 7] <- expect4NormProd(meanX[c(1,2,3,3)], varX[c(1,2,3,3),c(1,2,3,3)]) - expect3NormProd(meanX[c(1,2,3)], varX[c(1,2,3),c(1,2,3)]) * meanX[3] varX[5, 4] <- varX[4, 5] <- expect4NormProd(meanX[c(1,3,1,2)], varX[c(1,3,1,2),c(1,3,1,2)]) - expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) * expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) varX[6, 4] <- varX[4, 6] <- expect4NormProd(meanX[c(2,3,1,2)], varX[c(2,3,1,2),c(2,3,1,2)]) - expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) * expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) varX[7, 4] <- varX[4, 7] <- expect5NormProd(meanX[c(1,2,3,1,2)], varX[c(1,2,3,1,2),c(1,2,3,1,2)]) - expect3NormProd(meanX[c(1, 2, 3)], varX[c(1, 2, 3),c(1, 2, 3)]) * expect2NormProd(meanX[c(1,2)], varX[c(1,2),c(1,2)]) varX[6, 5] <- varX[5, 6] <- expect4NormProd(meanX[c(2,3,1,3)], varX[c(2,3,1,3),c(2,3,1,3)]) - expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) * expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) varX[7, 5] <- varX[5, 7] <- expect5NormProd(meanX[c(1,2,3,1,3)], varX[c(1,2,3,1,3),c(1,2,3,1,3)]) - expect3NormProd(meanX[c(1, 2, 3)], varX[c(1, 2, 3),c(1, 2, 3)]) * expect2NormProd(meanX[c(1,3)], varX[c(1,3),c(1,3)]) varX[7, 6] <- varX[6, 7] <- expect5NormProd(meanX[c(1,2,3,2,3)], varX[c(1,2,3,2,3),c(1,2,3,2,3)]) - expect3NormProd(meanX[c(1, 2, 3)], varX[c(1, 2, 3),c(1, 2, 3)]) * expect2NormProd(meanX[c(2,3)], varX[c(2,3),c(2,3)]) # Find the meanX and varX without XZW meanXReducedWith1 <- rbind(1, as.matrix(meanX[1:6])) varXReducedWith0 <- cbind(0, rbind(0, varX[1:6, 1:6])) SSMCReduced <- numobs * (varXReducedWith0 + (meanXReducedWith1 %*% t(meanXReducedWith1))) # Find product of main and two-way onto three-way covXZWwith0 <- rbind(0, as.matrix(varX[7, 1:6])) meanXZWwith1 <- meanX[7] * meanXReducedWith1 SSXZW <- numobs * (covXZWwith0 + meanXZWwith1) # should the mean vector be squared (postmultiplied by its transpose)? # Compute a vector and b4, b5, b6 a <- solve(SSMCReduced) %*% as.matrix(SSXZW) betaTemp <- betaRC[4:6] - (as.numeric(betaRC[7]) * a[5:7]) betaTemp <- c(betaTemp, betaRC[7]) # Compute Cov(Y, XZ) and regression coefficients of no-centering betaNC <- solve(varX[1:3,1:3], as.matrix(covY) - (t(varX[4:7, 1:3]) %*% as.matrix(betaTemp))) betaNC <- rbind(as.matrix(betaNC), as.matrix(betaTemp)) covY <- rbind(covY, as.matrix((varX %*% betaNC)[4:7, 1])) # Aggregate the non-centering sufficient statistics (Just show how to do but not necessary) fullCov <- rbind(cbind(varX, covY), c(covY, varY)) fullMean <- rbind(meanX, meanY) # Compute the intercept of no-centering intceptNC <- meanY - t(betaNC) %*% meanX # Compute SSNC betaNCWithIntcept <- rbind(intceptNC, betaNC) meanXwith1 <- rbind(1, meanX) #JG: redundant varXwith0 <- rbind(0, cbind(0, varX)) #JG: redundant SSNC <- numobs * (varXwith0 + (meanXwith1 %*% t(meanXwith1))) # Compute residual variance on non-centering resVarNC <- varY - (t(betaNCWithIntcept) %*% SSNC %*% betaNCWithIntcept)/numobs + meanY^2 ## Extract all sampling (co)variances if (inherits(fit, "lavaan")) { varEst <- lavaan::vcov(fit) } else if (inherits(fit, "lavaan.mi")) { varEst <- getMethod(f = "vcov", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(fit, omit.imps = omit.imps) } ## for indexing sampling (co)variances PT <- parTable(fit) int.idx <- PT$label[PT$lhs == nameY & PT$op == "~1" & PT$group == group.number] if (int.idx == "") { ## no custom label, use default int.idx <- paste0(nameY, "~1") if (nG > 1L && group.number > 1L) { int.idx <- paste0(int.idx, ".g", group.number) } } ## check intercept is actually estimated (thus, has sampling variance) estimateIntcept <- int.idx %in% rownames(varEst) ## if intercept is not estimated, add a row/column with zero sampling variance if (!estimateIntcept) { dn <- c(rownames(varEst), int.idx) varEst <- rbind(cbind(varEst, 0), 0) dimnames(varEst) <- list(dn, dn) } ## index slopes in varEst slope.idx <- which(PT$lhs == nameY & PT$op == "~" & PT$rhs %in% nameX & PT$group == group.number) ## check for user-defined labels; otherwise, set defaults slope.label <- PT$label[slope.idx] if (any(slope.label == "")) for (i in which(slope.label == "")) { slope.label[i] <- paste0(nameY, "~", nameX[i], ifelse(nG > 1L && group.number > 1L, no = "", yes = paste0(".g", group.number))) } ## save all indices in a vector targetcol <- c(int.idx, slope.label) varEstSlopeRC <- varEst[targetcol, targetcol] ## collect relevant estimates and variances to probe the interaction usedVar <- as.numeric(resVarNC/resVarRC) * (varEstSlopeRC %*% SSRC %*% solve(SSNC)) usedBeta <- betaNCWithIntcept ## In case a moderator is listed first, find the order to rearrange ord <- c(setdiff(1:3, modVar), modVar) ord <- c(ord, 7 - rev(ord)) usedBeta <- usedBeta[c(1, ord+1, 8)] usedVar <- usedVar[ c(1, ord+1, 8), c(1, ord+1, 8)] ## set all combinations of moderator values val <- expand.grid(valProbe1, valProbe2) ## function to calculate p values for Wald z tests pvalue <- function(x) (1 - pnorm(abs(x))) * 2 ## Calculate simple intercepts simpleIntcept <- usedBeta[1] + usedBeta[3] * val[,1] + usedBeta[4] * val[,2] + usedBeta[7] * val[,1] * val[,2] varIntcept <- usedVar[1, 1] + val[,1]^2 * usedVar[3, 3] + val[,2]^2 * usedVar[4, 4] + val[,1]^2 * val[,2]^2 * usedVar[7, 7] + 2 * val[,1] * usedVar[1, 3] + 2 * val[,2] * usedVar[1, 4] + 2 * val[,1] * val[,2] * usedVar[1, 7] + 2 * val[,1] * val[,2] * usedVar[3, 4] + 2 * val[,1]^2 * val[,2] * usedVar[3, 7] + 2* val[,1] * val[,2]^2 * usedVar[4, 7] zIntcept <- simpleIntcept / sqrt(varIntcept) pIntcept <- pvalue(zIntcept) resultIntcept <- cbind(val, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultIntcept) <- c("lavaan.data.frame","data.frame") ## Calculate simple slopes simpleSlope <- usedBeta[2] + usedBeta[5] * val[,1] + usedBeta[6] * val[,2] + usedBeta[8] * val[,1] * val[,2] varSlope <- usedVar[2, 2] + val[,1]^2 * usedVar[5, 5] + val[,2]^2 * usedVar[6, 6] + val[,1]^2 * val[,2]^2 * usedVar[8, 8] + 2 * val[,1] * usedVar[2, 5] + 2 * val[,2] * usedVar[2, 6] + 2 * val[,1] * val[,2] * usedVar[2, 8] + 2 * val[,1] * val[,2] * usedVar[5, 6] + 2 * val[,1]^2 * val[,2] * usedVar[5, 8] + 2 * val[,1] * val[,2]^2 * usedVar[6, 8] zSlope <- simpleSlope / sqrt(varSlope) pSlope <- pvalue(zSlope) resultSlope <- cbind(val, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "est", "se", "z", "pvalue") class(resultSlope) <- c("lavaan.data.frame","data.frame") list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope) } ## ----------------- ## Plotting Function ## ----------------- ##' Plot a latent interaction ##' ##' This function will plot the line graphs representing the simple effect of ##' the independent variable given the values of the moderator. For multigroup ##' models, it will only generate a plot for 1 group, as specified in the ##' function used to obtain the first argument. ##' ##' @note ##' If the `object` does not contain simple intercepts (i.e., if the ##' `object$SimpleIntcept` element is `NULL`), then all simple ##' intercepts are arbitrarily set to zero in order to plot the simple slopes. ##' This may not be consistent with the fitted model, but was (up until version ##' 0.5-7) the default behavior when the y-intercept was fixed to 0. In this case, ##' although the relative steepness of simple slopes can still meaningfully be ##' compared, the relative vertical positions of lines at any point along the ##' *x*-axis should not be interpreted. ##' ##' @param object A `list`, typically the result of probing a latent 2-way ##' or 3-way interaction obtained from the [probe2WayMC()], ##' [probe2WayRC()], [probe3WayMC()], or ##' [probe3WayRC()] functions. ##' @param xlim The vector of two numbers: the minimum and maximum values of the ##' independent variable ##' @param xlab The label of the x-axis ##' @param ylab The label of the y-axis ##' @param legend `logical`. If `TRUE` (default), a legend is printed. ##' @param legendArgs `list` of arguments passed to [legend()] ##' function if `legend=TRUE`. ##' @param \dots Any additional argument for the [plot()] function ##' ##' @return None. This function will plot the simple main effect only. ##' ##' @author ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [indProd()] For creating the indicator products with no ##' centering, mean centering, double-mean centering, or residual centering. ##' \item [probe2WayMC()] For probing the two-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe3WayMC()] For probing the three-way latent interaction ##' when the results are obtained from mean-centering, or double-mean centering ##' \item [probe2WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' \item [probe3WayRC()] For probing the two-way latent interaction ##' when the results are obtained from residual-centering approach. ##' } ##' ##' @references ##' ##' Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting ##' latent variable interactions using the `semTools` package. ##' *Psych, 3*(3), 322--335. \doi{10.3390/psych3030024} ##' ##' @examples ##' ##' library(lavaan) ##' ##' dat2wayMC <- indProd(dat2way, 1:3, 4:6) ##' ##' model1 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f3 =~ x7 + x8 + x9 ##' f3 ~ f1 + f2 + f12 ##' f12 ~~ 0*f1 ##' f12 ~~ 0*f2 ##' x1 ~ 0*1 ##' x4 ~ 0*1 ##' x1.x4 ~ 0*1 ##' x7 ~ 0*1 ##' f1 ~ NA*1 ##' f2 ~ NA*1 ##' f12 ~ NA*1 ##' f3 ~ NA*1 ##' " ##' ##' fitMC2way <- sem(model1, data = dat2wayMC, meanstructure = TRUE) ##' result2wayMC <- probe2WayMC(fitMC2way, nameX = c("f1", "f2", "f12"), ##' nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) ##' plotProbe(result2wayMC, xlim = c(-2, 2)) ##' ##' ##' dat3wayMC <- indProd(dat3way, 1:3, 4:6, 7:9) ##' ##' model3 <- " ##' f1 =~ x1 + x2 + x3 ##' f2 =~ x4 + x5 + x6 ##' f3 =~ x7 + x8 + x9 ##' f12 =~ x1.x4 + x2.x5 + x3.x6 ##' f13 =~ x1.x7 + x2.x8 + x3.x9 ##' f23 =~ x4.x7 + x5.x8 + x6.x9 ##' f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 ##' f4 =~ x10 + x11 + x12 ##' f4 ~ f1 + f2 + f3 + f12 + f13 + f23 + f123 ##' f1 ~~ 0*f12 ##' f1 ~~ 0*f13 ##' f1 ~~ 0*f123 ##' f2 ~~ 0*f12 ##' f2 ~~ 0*f23 ##' f2 ~~ 0*f123 ##' f3 ~~ 0*f13 ##' f3 ~~ 0*f23 ##' f3 ~~ 0*f123 ##' f12 ~~ 0*f123 ##' f13 ~~ 0*f123 ##' f23 ~~ 0*f123 ##' x1 ~ 0*1 ##' x4 ~ 0*1 ##' x7 ~ 0*1 ##' x10 ~ 0*1 ##' x1.x4 ~ 0*1 ##' x1.x7 ~ 0*1 ##' x4.x7 ~ 0*1 ##' x1.x4.x7 ~ 0*1 ##' f1 ~ NA*1 ##' f2 ~ NA*1 ##' f3 ~ NA*1 ##' f12 ~ NA*1 ##' f13 ~ NA*1 ##' f23 ~ NA*1 ##' f123 ~ NA*1 ##' f4 ~ NA*1 ##' " ##' ##' fitMC3way <- sem(model3, data = dat3wayMC, std.lv = FALSE, ##' meanstructure = TRUE) ##' result3wayMC <- probe3WayMC(fitMC3way, nameX = c("f1", "f2", "f3", "f12", ##' "f13", "f23", "f123"), ##' nameY = "f4", modVar = c("f1", "f2"), ##' valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) ##' plotProbe(result3wayMC, xlim = c(-2, 2)) ##' ##' @export plotProbe <- function(object, xlim, xlab = "Indepedent Variable", ylab = "Dependent Variable", legend = TRUE, legendArgs = list(), ...) { if (length(xlim) != 2) stop("The x-limit should be specified as a numeric", " vector with the length of 2.") # Extract simple slope slope <- object$SimpleSlope # Check whether the object is the two-way or three-way interaction result numInt <- 2 if (ncol(slope) == 6) numInt <- 3 estSlope <- slope[, ncol(slope) - 3] # Get whether the simple slope is significant. If so, the resulting lines will be # shown as red. If not, the line will be black. estSlopeSig <- (slope[, ncol(slope)] < 0.05) + 1 # Extract simple intercept. If the simple intercept is not provided, the intercept # will be fixed as 0. estIntercept <- NULL if (is.null(object$SimpleIntcept)) { warning("Simple intercepts unavailable from object. All lines therefore ", "arbitrarily intersect at the origin. Relative vertical positions ", "of lines at any point on the x-axis are therefore arbitrary and ", "should not be interpreted. Only the relative steepness of simple ", "slopes can meaningfully be compared.") } else estIntercept <- object$SimpleIntcept[, ncol(slope) - 3] if (numInt == 2) { if (is.null(legendArgs$title)) legendArgs$title <- colnames(slope)[1] if (is.null(legendArgs$legend)) legendArgs$legend <- slope[, 1] plotSingleProbe(estSlope, estIntercept, xlim = xlim, xlab = xlab, ylab = ylab, colLine = estSlopeSig, legend = legend, legendArgs = legendArgs, ...) } else if (numInt == 3) { # Three-way interaction; separate lines for the first moderator, separate graphs # for the second moderator mod2 <- unique(slope[, 2]) mod1 <- unique(slope[, 1]) # Use multiple graphs in a figure if (length(mod2) == 2) { obj <- par(mfrow = c(1, 2)) } else if (length(mod2) == 3) { obj <- par(mfrow = c(1, 3)) } else if (length(mod2) > 3) { obj <- par(mfrow = c(2, ceiling(length(mod2)/2))) } else if (length(mod2) == 1) { # Intentionally leaving as blank } else stop("Some errors occur") for (i in 1:length(mod2)) { select <- slope[, 2] == mod2[i] if (is.null(legendArgs$title)) legendArgs$title <- colnames(slope)[1] if (is.null(legendArgs$legend)) legendArgs$legend <- mod1 plotSingleProbe(estSlope[select], estIntercept[select], xlim = xlim, xlab = xlab, ylab = ylab, colLine = estSlopeSig[select], main = paste(colnames(slope)[2], "=", mod2[i]), legend = legend, legendArgs = legendArgs, ...) } if (length(mod2) > 1) par(obj) } else { stop("Please make sure that the object argument is obtained from", " 'probe2wayMC', 'probe2wayRC', 'probe3wayMC', or 'probe3wayRC'.") } invisible(NULL) } ## ---------------- ## Hidden Functions ## ---------------- ## Find the expected value of the product of two normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates expect2NormProd <- function(m, s) return(prod(m) + s[1, 2]) ## Find the expected value of the product of three normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates expect3NormProd <- function(m, s) { return(prod(m) + m[3] * s[1, 2] + m[2] * s[1, 3] + m[1] * s[2, 3]) } ## Find the expected value of the product of four normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates expect4NormProd <- function(m, s) { first <- prod(m) com <- utils::combn(1:4, 2) forSecond <- function(draw, meanval, covval, index) { draw2 <- setdiff(index, draw) prod(meanval[draw2]) * covval[draw[1], draw[2]] } second <- sum(apply(com, 2, forSecond, meanval=m, covval=s, index=1:4)) com2 <- com[,1:3] #select only first three terms containing the first element only forThird <- function(draw, covval, index) { draw2 <- setdiff(index, draw) covval[draw[1], draw[2]] * covval[draw2[1], draw2[2]] } third <- sum(apply(com2, 2, forThird, covval=s, index=1:4)) return(first + second + third) } ## Find the expected value of the product of five normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates expect5NormProd <- function(m, s) { first <- prod(m) com <- utils::combn(1:5, 2) forSecond <- function(draw, meanval, covval, index) { draw2 <- setdiff(index, draw) prod(meanval[draw2]) * covval[draw[1], draw[2]] } second <- sum(apply(com, 2, forSecond, meanval=m, covval=s, index=1:5)) com2 <- utils::combn(1:5, 4) forThirdOuter <- function(index, m, s, indexall) { targetMean <- m[setdiff(indexall, index)] cominner <- utils::combn(index, 2)[,1:3] #select only first three terms containing the first element only forThirdInner <- function(draw, covval, index) { draw2 <- setdiff(index, draw) covval[draw[1], draw[2]] * covval[draw2[1], draw2[2]] } thirdInner <- targetMean * sum(apply(cominner, 2, forThirdInner, covval=s, index=index)) return(thirdInner) } third <- sum(apply(com2, 2, forThirdOuter, m=m, s=s, indexall=1:5)) return(first + second + third) } ## Find the variance of the product of two normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates var2NormProd <- function(m, s) { first <- m[2]^2 * s[1, 1] + m[1]^2 * s[2, 2] second <- 2 * m[1] * m[2] * s[1, 2] third <- s[1, 1] * s[2, 2] fourth <- s[1, 2]^2 return(first + second + third + fourth) } ## Find the variance of the product of three normal variates ## m = the mean of each normal variate ## s = the covariance matrix of all variates var3NormProd <- function(m, s) { com <- utils::combn(1:3, 2) forFirst <- function(draw, meanval, covval, index) { # draw = 2, 3; draw2 = 1 draw2 <- setdiff(index, draw) term1 <- meanval[draw[1]]^2 * meanval[draw[2]]^2 * covval[draw2, draw2] term2 <- 2 * meanval[draw2]^2 * meanval[draw[1]] * meanval[draw[2]] * covval[draw[1], draw[2]] term3 <- (meanval[draw2]^2 * covval[draw[1], draw[1]] * covval[draw[2], draw[2]]) + (meanval[draw2]^2 * covval[draw[1], draw[2]]^2) term4 <- 4 * meanval[draw[1]] * meanval[draw[2]] * covval[draw2, draw2] * covval[draw[1], draw[2]] term5 <- 6 * meanval[draw[1]] * meanval[draw[2]] * covval[draw2, draw[1]] * covval[draw2, draw[2]] term1 + term2 + term3 + term4 + term5 } first <- sum(apply(com, 2, forFirst, meanval=m, covval=s, index=1:3)) second <- prod(diag(s)) third <- 2 * s[3, 3] * s[1, 2]^2 + 2 * s[2, 2] * s[1, 3]^2 + 2 * s[1, 1] * s[2, 3]^2 fourth <- 8 * s[1, 2] * s[1, 3] * s[2, 3] return(first + second + third + fourth) } ## plotSingleProbe : plot the probing interaction result specific for only one moderator ## estSlope = slope of each line ## estIntercept = intercept of each line ## xlim = the minimum and maximum values of the independent variable (x-axis) ## xlab = the label for the independent variable ## ylab = the lable for the dependent variable ## main = the title of the graph ## colLine = the color of each line ## legend = whether to print a legend ## legendArgs = arguments to pass to legend() function plotSingleProbe <- function(estSlope, estIntercept = NULL, xlim, xlab = "Indepedent Variable", ylab = "Dependent Variable", main = NULL, colLine = "black", legend = TRUE, legendArgs = list(), ...) { if (is.null(estIntercept)) estIntercept <- rep(0, length(estSlope)) if (length(colLine) == 1) colLine <- rep(colLine, length(estSlope)) lower <- estIntercept + (xlim[1] * estSlope) upper <- estIntercept + (xlim[2] * estSlope) ylim <- c(min(c(lower, upper)), max(c(lower, upper))) plot(cbind(xlim, ylim), xlim = xlim, ylim = ylim, type = "n", xlab = xlab, ylab = ylab, main = main, ...) for (i in 1:length(estSlope)) { lines(cbind(xlim, c(lower[i], upper[i])), col = colLine[i], lwd = 1.5, lty = i) } if (legend) { positionX <- 0.25 if (all(estSlope > 0)) positionX <- 0.01 if (all(estSlope < 0)) positionX <- 0.50 if (is.null(legendArgs$x)) legendArgs$x <- positionX * (xlim[2] - xlim[1]) + xlim[1] if (is.null(legendArgs$y)) legendArgs$y <- 0.99 * (ylim[2] - ylim[1]) + ylim[1] if (is.null(legendArgs$col)) legendArgs$col <- colLine if (is.null(legendArgs$lty)) legendArgs$lty <- 1:length(estSlope) do.call(graphics::legend, legendArgs) } invisible(NULL) } semTools/R/runMI-modification.R0000644000176200001440000004725314764332565016132 0ustar liggesusers### Terrence D. Jorgensen & Yves Rosseel ### Last updated: 12 March 2025 ### adaptation of lavaan::modindices() for OLDlavaan.mi-class objects ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ##' Modification Indices for Multiple Imputations ##' ##' Modification indices (1-*df* Lagrange multiplier tests) from a ##' latent variable model fitted to multiple imputed data sets. Statistics ##' for releasing one or more fixed or constrained parameters in model can ##' be calculated by pooling the gradient and information matrices ##' across imputed data sets in a method proposed by Mansolf, Jorgensen, & ##' Enders (2020)---analogous to the "D1" Wald test proposed by Li, Meng, ##' Raghunathan, & Rubin (1991)---or by pooling the complete-data score-test ##' statistics across imputed data sets (i.e., "D2"; Li et al., 1991). ##' ## @aliases modificationIndices.mi modificationindices.mi modindices.mi ##' @importFrom lavaan lavInspect lavListInspect lavNames ##' @importFrom methods getMethod ##' @importFrom stats cov pchisq qchisq ##' ##' @param object An object of class [OLDlavaan.mi-class] ##' @param test `character` indicating which pooling method to use. ##' `"D1"` requests Mansolf, Jorgensen, & Enders' (2020) proposed ##' Wald-like test for pooling the gradient and information, which are then ##' used to calculate score-test statistics in the usual manner. `"D2"` ##' (default because it is less computationall intensive) requests to pool the ##' complete-data score-test statistics from each imputed data set, then pool ##' them across imputations, described by Li et al. (1991) and Enders (2010). ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. Specific imputation numbers can also be included in this ##' argument, in case users want to apply their own custom omission criteria ##' (or simulations can use different numbers of imputations without ##' redundantly refitting the model). ##' @param standardized `logical`. If `TRUE`, two extra columns ##' (`$sepc.lv` and `$sepc.all`) will contain standardized values ##' for the EPCs. In the first column (`$sepc.lv`), standardizization is ##' based on the variances of the (continuous) latent variables. In the second ##' column (`$sepc.all`), standardization is based on both the variances ##' of both (continuous) observed and latent variables. (Residual) covariances ##' are standardized using (residual) variances. ##' @param cov.std `logical`. `TRUE` if `test == "D2"`. ##' If `TRUE` (default), the (residual) ##' observed covariances are scaled by the square-root of the diagonal elements ##' of the \eqn{\Theta} matrix, and the (residual) latent covariances are ##' scaled by the square-root of the diagonal elements of the \eqn{\Psi} ##' matrix. If `FALSE`, the (residual) observed covariances are scaled by ##' the square-root of the diagonal elements of the model-implied covariance ##' matrix of observed variables (\eqn{\Sigma}), and the (residual) latent ##' covariances are scaled by the square-root of the diagonal elements of the ##' model-implied covariance matrix of the latent variables. ##' @param information `character` indicating the type of information ##' matrix to use (check [lavaan::lavInspect()] for available options). ##' `"expected"` information is the default, which provides better ##' control of Type I errors. ##' @param power `logical`. If `TRUE`, the (post-hoc) power is ##' computed for each modification index, using the values of `delta` ##' and `alpha`. ##' @param delta The value of the effect size, as used in the post-hoc power ##' computation, currently using the unstandardized metric of the `$epc` ##' column. ##' @param alpha The significance level used for deciding if the modification ##' index is statistically significant or not. ##' @param high.power If the computed power is higher than this cutoff value, ##' the power is considered 'high'. If not, the power is considered 'low'. ##' This affects the values in the `$decision` column in the output. ##' @param sort. `logical`. If `TRUE`, sort the output using the ##' values of the modification index values. Higher values appear first. ##' @param minimum.value `numeric`. Filter output and only show rows with a ##' modification index value equal or higher than this minimum value. ##' @param maximum.number `integer`. Filter output and only show the first ##' maximum number rows. Most useful when combined with the `sort.` option. ##' @param na.remove `logical`. If `TRUE` (default), filter output by ##' removing all rows with `NA` values for the modification indices. ##' @param op `character` string. Filter the output by selecting only those ##' rows with operator `op`. ##' ##' @note When `test = "D2"`, each (S)EPC will be pooled by taking its ##' average across imputations. When `test = "D1"`, EPCs will be ##' calculated in the standard way using the pooled gradient and information, ##' and SEPCs will be calculated by standardizing the EPCs using model-implied ##' (residual) variances. ##' ##' @return A `data.frame` containing modification indices and (S)EPCs. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' Adapted from \pkg{lavaan} source code, written by ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' `test = "D1"` method proposed by ##' Maxwell Mansolf (University of California, Los Angeles; ##' \email{mamansolf@@gmail.com}) ##' ##' @references ##' Enders, C. K. (2010). *Applied missing data analysis*. ##' New York, NY: Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data.*Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' Mansolf, M., Jorgensen, T. D., & Enders, C. K. (2020). A multiple ##' imputation score test for model modification in structural equation ##' models. *Psychological Methods, 25*(4), 393--411. ##' \doi{10.1037/met0000243} ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' ##' @name modindices.mi-deprecated ##' @usage ##' modindices.mi(object, test = c("D2","D1"), omit.imps = c("no.conv","no.se"), ##' standardized = TRUE, cov.std = TRUE, information = "expected", ##' power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, ##' sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), ##' na.remove = TRUE, op = NULL) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export modindices.mi <- function(object, test = c("D2","D1"), omit.imps = c("no.conv","no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", # power statistics? power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, # customize output sort. = FALSE, minimum.value = 0.0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) { .Deprecated(msg = c("\nThe runMI() and related lavaan.mi functions have been", " deprecated and will cease to be included in future ", "versions of semTools.\n\nSupport is still provided for ", "analyzing lavaan.mi-class objects (e.g., compRelSEM() ", "can estimate reliability using pooled results), which ", "can now be created using the lavaan.mi package.\n\nThe ", "deprecated runMI() function now creates an object of ", "class OLDlavaan.mi, which can be analyzed using the ", "deprecated functions in semTools, like lavTestLRT.mi(),", " that have been updated and improved in the lavaan.mi ", "package.\n\nFind more details help('semTools-deprecated)")) stopifnot(inherits(object, "OLDlavaan.mi")) useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) test <- tolower(test[1]) N <- lavListInspect(object, "ntotal") #FIXME: if (lavoptions$mimic == "EQS") N <- N - 1 # not in lavaan, why? # not ready for estimator = "PML" if (object@Options$estimator == "PML") { stop("Modification indices not yet implemented for estimator PML.") } # sanity check if (power) standardized <- TRUE ## use first available modification indices as template to store pooled results ngroups <- lavListInspect(object, "ngroups") nlevels <- lavListInspect(object, "nlevels") myCols <- c("lhs","op","rhs") if (ngroups > 1L) myCols <- c(myCols,"block","group") if (nlevels > 1L) myCols <- c(myCols,"block","level") myCols <- unique(myCols) for (i in useImps) { LIST <- object@miList[[i]][myCols] nR <- try(nrow(LIST), silent = TRUE) if (inherits(nR, "try-error") || is.null(nR)) { if (i == max(useImps)) { stop("No modification indices could be computed for any imputations.") } else next } else break } ## D2 pooling method if (test == "d2") { chiList <- lapply(object@miList[useImps], "[[", i = "mi") ## imputations in columns, parameters in rows pooledList <- apply(do.call(cbind, chiList), 1, function(x) { calculate.D2(x, DF = 1, asymptotic = TRUE) }) LIST$mi <- pooledList[1, ] # could be "F" or "chisq" ## diagnostics LIST$riv <- pooledList["ariv", ] LIST$fmi <- pooledList["fmi", ] ## also take average of epc & sepc.all epcList <- lapply(object@miList[useImps], "[[", i = "epc") LIST$epc <- rowMeans(do.call(cbind, epcList)) if (standardized) { sepcList <- lapply(object@miList[useImps], "[[", i = "sepc.lv") LIST$sepc.lv <- rowMeans(do.call(cbind, sepcList)) sepcList <- lapply(object@miList[useImps], "[[", i = "sepc.all") LIST$sepc.all <- rowMeans(do.call(cbind, sepcList)) fixed.x <- lavListInspect(object, "options")$fixed.x && length(lavNames(object, "ov.x")) if (fixed.x && "sepc.nox" %in% colnames(object@miList[useImps][[1]])) { sepcList <- lapply(object@miList[useImps], "[[", i = "sepc.nox") LIST$sepc.nox <- rowMeans(do.call(cbind, sepcList)) } } } else { scoreOut <- lavTestScore.mi(object, add = cbind(LIST, user = 10L, free = 1, start = 0), test = "d1", omit.imps = omit.imps, epc = TRUE, scale.W = FALSE, asymptotic = TRUE, information = information)$uni LIST$mi <- scoreOut$X2 LIST$riv <- scoreOut$riv LIST$fmi <- scoreOut$fmi LIST$epc <- scoreOut$epc #FIXME: use average across imputations? # standardize? if (standardized) { ## Need full parameter table for lavaan::standardizedSolution() ## Merge parameterEstimates() with modindices() oldPE <- getMethod("summary","OLDlavaan.mi")(object, se = FALSE, output = "data.frame", omit.imps = omit.imps) PE <- lavaan::lav_partable_merge(oldPE, cbind(LIST, est = 0), remove.duplicated = TRUE, warn = FALSE) ## merge EPCs, using parameter labels (unavailable for estimates) rownames(LIST) <- paste0(LIST$lhs, LIST$op, LIST$rhs, ".g", LIST$group) #FIXME: multilevel? rownames(PE) <- paste0(PE$lhs, PE$op, PE$rhs, ".g", PE$group) PE[rownames(LIST), "epc"] <- LIST$epc ## need "exo" column? PT <- parTable(object) if ("exo" %in% names(PT)) { rownames(PT) <- paste0(PT$lhs, PT$op, PT$rhs, ".g", PT$group) PE[rownames(PT), "exo"] <- PT$exo } else PE$exo <- 0L rownames(LIST) <- NULL rownames(PE) <- NULL EPC <- PE$epc if (cov.std) { # replace epc values for variances by est values var.idx <- which(PE$op == "~~" & PE$lhs == PE$rhs) EPC[ var.idx ] <- PE$est[ var.idx ] } # two problems: # - EPC of variances can be negative, and that is perfectly legal # - EPC (of variances) can be tiny (near-zero), and we should # not divide by tiny variables small.idx <- which(PE$op == "~~" & PE$lhs == PE$rhs & abs(EPC) < sqrt( .Machine$double.eps ) ) if (length(small.idx) > 0L) EPC[small.idx] <- as.numeric(NA) # get the sign EPC.sign <- sign(PE$epc) ## pooled estimates for standardizedSolution() pooledest <- getMethod("coef", "OLDlavaan.mi")(object, omit.imps = omit.imps) ## update @Model@GLIST for standardizedSolution(..., GLIST=) object@Model <- lavaan::lav_model_set_parameters(object@Model, x = pooledest) PE$sepc.lv <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.lv", cov.std = cov.std, partable = PE, GLIST = object@Model@GLIST, est = abs(EPC))$est.std PE$sepc.all <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.all", cov.std = cov.std, partable = PE, GLIST = object@Model@GLIST, est = abs(EPC))$est.std fixed.x <- lavListInspect(object, "options")$fixed.x && length(lavNames(object, "ov.x")) if (fixed.x) { PE$sepc.nox <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.nox", cov.std = cov.std, partable = PE, GLIST = object@Model@GLIST, est = abs(EPC))$est.std } if (length(small.idx) > 0L) { PE$sepc.lv[small.idx] <- 0 PE$sepc.all[small.idx] <- 0 if (fixed.x) PE$sepc.nox[small.idx] <- 0 } ## remove unnecessary columns, then merge if (is.null(LIST$block)) PE$block <- NULL PE$est <- NULL PE$mi <- NULL PE$epc <- NULL PE$exo <- NULL LIST <- merge(LIST, PE, sort = FALSE) class(LIST) <- c("lavaan.data.frame","data.frame") } } # power? if (power) { LIST$sepc.lv <- NULL LIST$delta <- delta # FIXME: this is using epc in unstandardized metric # this would be much more useful in standardized metric # we need a standardize.est.all.reverse function... LIST$ncp <- (LIST$mi / (LIST$epc*LIST$epc)) * (delta*delta) LIST$power <- 1 - pchisq(qchisq((1.0 - alpha), df=1), df=1, ncp=LIST$ncp) LIST$decision <- character( length(LIST$power) ) # five possibilities (Table 6 in Saris, Satorra, van der Veld, 2009) mi.significant <- ifelse( 1 - pchisq(LIST$mi, df=1) < alpha, TRUE, FALSE ) high.power <- LIST$power > high.power # FIXME: sepc.all or epc?? #epc.high <- LIST$sepc.all > LIST$delta epc.high <- LIST$epc > LIST$delta LIST$decision[ which(!mi.significant & !high.power)] <- "(i)" LIST$decision[ which( mi.significant & !high.power)] <- "**(m)**" LIST$decision[ which(!mi.significant & high.power)] <- "(nm)" LIST$decision[ which( mi.significant & high.power & !epc.high)] <- "epc:nm" LIST$decision[ which( mi.significant & high.power & epc.high)] <- "*epc:m*" #LIST$decision[ which(mi.significant & high.power) ] <- "epc" #LIST$decision[ which(mi.significant & !high.power) ] <- "***" #LIST$decision[ which(!mi.significant & !high.power) ] <- "(i)" } # sort? if (sort.) { LIST <- LIST[order(LIST$mi, decreasing = TRUE),] } if (minimum.value > 0.0) { LIST <- LIST[!is.na(LIST$mi) & LIST$mi > minimum.value,] } if (maximum.number < nrow(LIST)) { LIST <- LIST[seq_len(maximum.number),] } if (na.remove) { idx <- which(is.na(LIST$mi)) if (length(idx) > 0) LIST <- LIST[-idx,] } if (!is.null(op)) { idx <- LIST$op %in% op if (length(idx) > 0) LIST <- LIST[idx,] } # add header # TODO: small explanation of the columns in the header? # attr(LIST, "header") <- # c("modification indices for newly added parameters only; to\n", # "see the effects of releasing equality constraints, use the\n", # "lavTestScore() function") LIST } ##' @name modindices.mi-deprecated ##' @usage ##' modificationIndices.mi(object, test = c("D2","D1"), ##' omit.imps = c("no.conv","no.se"), ##' standardized = TRUE, cov.std = TRUE, ##' information = "expected", power = FALSE, delta = 0.1, ##' alpha = 0.05, high.power = 0.75, sort. = FALSE, ##' minimum.value = 0, maximum.number = nrow(LIST), ##' na.remove = TRUE, op = NULL) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export modificationIndices.mi <- modindices.mi ##' @name modindices.mi-deprecated ##' @usage ##' modificationindices.mi(object, test = c("D2","D1"), ##' omit.imps = c("no.conv","no.se"), ##' standardized = TRUE, cov.std = TRUE, ##' information = "expected", power = FALSE, delta = 0.1, ##' alpha = 0.05, high.power = 0.75, sort. = FALSE, ##' minimum.value = 0, maximum.number = nrow(LIST), ##' na.remove = TRUE, op = NULL) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export modificationindices.mi <- modindices.mi semTools/R/powerAnalysisNested.R0000644000176200001440000002023414632143377016421 0ustar liggesusers### Sunthud Pornprasertmanit, Bell Clinton, Pavel Panko ### Last updated: 10 January 2021 ##' Find power given a sample size in nested model comparison ##' ##' Find the sample size that the power in rejection the samples from the ##' alternative pair of RMSEA is just over the specified power. ##' ##' ##' @importFrom stats qchisq pchisq ##' ##' @param rmsea0A The \eqn{H_0} baseline RMSEA ##' @param rmsea0B The \eqn{H_0} alternative RMSEA (trivial misfit) ##' @param rmsea1A The \eqn{H_1} baseline RMSEA ##' @param rmsea1B The \eqn{H_1} alternative RMSEA (target misfit to be rejected) ##' @param dfA degree of freedom of the more-restricted model ##' @param dfB degree of freedom of the less-restricted model ##' @param n Sample size ##' @param alpha The alpha level ##' @param group The number of group in calculating RMSEA ##' ##' @author Bell Clinton ##' ##' Pavel Panko (Texas Tech University; \email{pavel.panko@@ttu.edu}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [plotRMSEApowernested()] to plot the statistical power for ##' nested model comparison based on population RMSEA given the sample size ##' \item [findRMSEAsamplesizenested()] to find the minium sample ##' size for a given statistical power in nested model comparison based on ##' population RMSEA ##' } ##' ##' @references ##' MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing ##' differences between nested covariance structure models: Power analysis and ##' null hypotheses. *Psychological Methods, 11*(1), 19--35. ##' \doi{10.1037/1082-989X.11.1.19} ##' ##' @examples ##' ##' findRMSEApowernested(rmsea0A = 0.06, rmsea0B = 0.05, rmsea1A = 0.08, ##' rmsea1B = 0.05, dfA = 22, dfB = 20, n = 200, ##' alpha = 0.05, group = 1) ##' ##' @export findRMSEApowernested <- function(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, n, alpha = 0.05, group = 1) { if(is.null(rmsea0A)) rmsea0A <- 0 if(is.null(rmsea0B)) rmsea0B <- 0 if(is.null(rmsea1B)) rmsea1B <- rmsea0B if(dfA <= dfB) stop("The degree of freedom of the more-restricted model (dfA) should be greater than the degree of freedom of the less-restricted model (dfB)") if(rmsea0A < rmsea0B) stop("In the null-hypothesis models, the RMSEA of the more-restricted model (rmsea0A) should have a higher than or equal to the RMSEA of the less-restricted model (rmsea0B).") if(rmsea1A < rmsea1B) stop("In the alternative-hypothesis models, the RMSEA of the more-restricted model (rmsea1A) should have a higher than or equal to the RMSEA of the less-restricted model (rmsea1B).") ddiff <- dfA-dfB f0a <- (dfA*rmsea0A^2)/group f0b <- (dfB*rmsea0B^2)/group f1a <- (dfA*rmsea1A^2)/group f1b <- (dfB*rmsea1B^2)/group ncp0 <- (n-1)*(f0a-f0b) ncp1 <- (n-1)*(f1a-f1b) cval <- qchisq(1-alpha,ddiff,ncp0) Power <- 1-pchisq(cval,ddiff,ncp1) Power } ##' Find sample size given a power in nested model comparison ##' ##' Find the sample size that the power in rejection the samples from the ##' alternative pair of RMSEA is just over the specified power. ##' ##' ##' @param rmsea0A The \eqn{H_0} baseline RMSEA ##' @param rmsea0B The \eqn{H_0} alternative RMSEA (trivial misfit) ##' @param rmsea1A The \eqn{H_1} baseline RMSEA ##' @param rmsea1B The \eqn{H_1} alternative RMSEA (target misfit to be rejected) ##' @param dfA degree of freedom of the more-restricted model. ##' @param dfB degree of freedom of the less-restricted model. ##' @param power The desired statistical power. ##' @param alpha The alpha level. ##' @param group The number of group in calculating RMSEA. ##' ##' @author Bell Clinton ##' ##' Pavel Panko (Texas Tech University; \email{pavel.panko@@ttu.edu}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [plotRMSEApowernested()] to plot the statistical power for ##' nested model comparison based on population RMSEA given the sample size ##' \item [findRMSEApowernested()] to find the power for a given ##' sample size in nested model comparison based on population RMSEA ##' } ##' ##' @references ##' MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing ##' differences between nested covariance structure models: Power analysis and ##' null hypotheses. *Psychological Methods, 11*(1), 19--35. ##' \doi{10.1037/1082-989X.11.1.19} ##' ##' @examples ##' ##' findRMSEAsamplesizenested(rmsea0A = 0, rmsea0B = 0, rmsea1A = 0.06, ##' rmsea1B = 0.05, dfA = 22, dfB = 20, power = 0.80, ##' alpha = .05, group = 1) ##' ##' @export findRMSEAsamplesizenested <- function(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, power = 0.80, alpha = .05, group = 1) { if(is.null(rmsea0A)) rmsea0A <- 0 if(is.null(rmsea0B)) rmsea0B <- 0 if(is.null(rmsea1B)) rmsea1B <- rmsea0B if(dfA <= dfB) stop("The degree of freedom of the more-restricted model (dfA) should be greater than the degree of freedom of the less-restricted model (dfB)") if(rmsea0A < rmsea0B) stop("In the null-hypothesis models, the RMSEA of the more-restricted model (rmsea0A) should have a higher than or equal to the RMSEA of the less-restricted model (rmsea0B).") if(rmsea1A < rmsea1B) stop("In the alternative-hypothesis models, the RMSEA of the more-restricted model (rmsea1A) should have a higher than or equal to the RMSEA of the less-restricted model (rmsea1B).") n <- 5:500 pow <- findRMSEApowernested(rmsea0A, rmsea0B, rmsea1A, rmsea1B, dfA, dfB, n, alpha, group = group) if(all(pow > power)) { return("Sample Size <= 5") } else if (all(power > pow)) { repeat { n <- n + 500 pow <- findRMSEApowernested(rmsea0A, rmsea0B, rmsea1A, rmsea1B, dfA, dfB, n, alpha, group = group) if(any(pow > power)) { index <- which(pow > power)[1] return(n[index]/group) } } } else { index <- which(pow > power)[1] return(n[index]/group) } } ##' Plot power of nested model RMSEA ##' ##' Plot power of nested model RMSEA over a range of possible sample sizes. ##' ##' ##' @param rmsea0A The \eqn{H_0} baseline RMSEA ##' @param rmsea0B The \eqn{H_0} alternative RMSEA (trivial misfit) ##' @param rmsea1A The \eqn{H_1} baseline RMSEA ##' @param rmsea1B The \eqn{H_1} alternative RMSEA (target misfit to be rejected) ##' @param dfA degree of freedom of the more-restricted model ##' @param dfB degree of freedom of the less-restricted model ##' @param nlow Lower bound of sample size ##' @param nhigh Upper bound of sample size ##' @param steps Step size ##' @param alpha The alpha level ##' @param group The number of group in calculating RMSEA ##' @param \dots The additional arguments for the plot function. ##' ##' @author Bell Clinton ##' ##' Pavel Panko (Texas Tech University; \email{pavel.panko@@ttu.edu}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [findRMSEApowernested()] to find the power for a given ##' sample size in nested model comparison based on population RMSEA ##' \item [findRMSEAsamplesizenested()] to find the minium sample ##' size for a given statistical power in nested model comparison based on ##' population RMSEA ##' } ##' ##' @references ##' MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing ##' differences between nested covariance structure models: Power analysis and ##' null hypotheses. *Psychological Methods, 11*(1), 19--35. ##' \doi{10.1037/1082-989X.11.1.19} ##' ##' @examples ##' ##' plotRMSEApowernested(rmsea0A = 0, rmsea0B = 0, rmsea1A = 0.06, ##' rmsea1B = 0.05, dfA = 22, dfB = 20, nlow = 50, ##' nhigh = 500, steps = 1, alpha = .05, group = 1) ##' ##' @export plotRMSEApowernested <- function(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, nlow, nhigh, steps = 1, alpha = .05, group = 1, ...){ nseq <- seq(nlow,nhigh, by=steps) pow1 <- findRMSEApowernested(rmsea0A = rmsea0A, rmsea0B = rmsea0B, rmsea1A = rmsea1A, rmsea1B = rmsea1B, dfA = dfA, dfB = dfB, n = nseq, alpha = alpha, group = group) plot(nseq, pow1, xlab="Sample Size", ylab="Power", main="Compute Power for Nested RMSEA", type="l", ...) } semTools/R/runMI-LRT.R0000644000176200001440000006443314764332523014117 0ustar liggesusers### Terrence D. Jorgensen & Yves Rosseel ### Last updated: 12 March 2025 ### Pooled likelihood ratio test for multiple imputations ### Borrowed source code from lavaan/R/lav_test_LRT.R ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ## ------------- ## Main function ## ------------- ##' Likelihood Ratio Test for Multiple Imputations ##' ##' Likelihood ratio test (LRT) for lavaan models fitted to multiple imputed ##' data sets. Statistics for comparing nested models can be calculated by ##' pooling the likelihood ratios across imputed data sets, as described by ##' Meng & Rubin (1992), or by pooling the LRT statistics from each imputation, ##' as described by Li, Meng, Raghunathan, & Rubin (1991). ##' ##' The Meng & Rubin (1992) method, also referred to as the `"D3"` ##' statistic, is only applicable when using a likelihood-based estimator. ##' Otherwise (e.g., DWLS for categorical outcomes), users are notified that ##' `test` was set to `"D2"`. ##' ##' `test = "Mplus"` implies `"D3"` and `asymptotic = TRUE` ##' (see Asparouhov & Muthen, 2010). ##' ##' Note that unlike [lavaan::lavTestLRT()], `lavTestLRT` can ##' only be used to compare a single pair of models, not a longer list of ##' models. To compare several nested models fitted to multiple imputations, ##' see examples on the [compareFit()] help page. ##' ## @aliases lavTestLRT.mi ##' @importFrom lavaan lavListInspect parTable lavTestLRT ##' @importFrom stats cov pchisq pf ##' ##' @param object,h1 An object of class [OLDlavaan.mi-class]. ##' `object` should be nested within (more constrained than) `h1`. ##' @param test `character` indicating which pooling method to use. ##' `"D3"`, `"mr"`, or `"meng.rubin"` (default) requests the ##' method described by Meng & Rubin (1992). `"D2"`, `"LMRR"`, ##' or `"Li.et.al"` requests the complete-data LRT statistic should be ##' calculated using each imputed data set, which will then be pooled across ##' imputations, as described in Li, Meng, Raghunathan, & Rubin (1991). ##' Find additional details in Enders (2010, chapter 8). ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. Specific imputation numbers can also be included in this ##' argument, in case users want to apply their own custom omission criteria ##' (or simulations can use different numbers of imputations without ##' redundantly refitting the model). ##' @param asymptotic `logical`. If `FALSE` (default), the pooled test ##' will be returned as an *F*-distributed statistic with numerator ##' (`df1`) and denominator (`df2`) degrees of freedom. ##' If `TRUE`, the pooled *F* statistic will be multiplied by its ##' `df1` on the assumption that its `df2` is sufficiently large ##' enough that the statistic will be asymptotically \eqn{\chi^2} distributed ##' with `df1`. ##' @param pool.robust `logical`. Ignored unless `test = "D2"` and a ##' robust test was requested. If `pool.robust = TRUE`, the robust test ##' statistic is pooled, whereas `pool.robust = FALSE` will pool ##' the naive test statistic (or difference statistic) and apply the average ##' scale/shift parameter to it (unavailable for mean- and variance-adjusted ##' difference statistics, so `pool.robust` will be set `TRUE`). ##' @param ... Additional arguments passed to [lavaan::lavTestLRT()], ##' only if `test = "D2"` and `pool.robust = TRUE` ##' ##' @return ##' A vector containing the LRT statistic (either an `F` or \eqn{\chi^2} ##' statistic, depending on the `asymptotic` argument), its degrees of ##' freedom (numerator and denominator, if `asymptotic = FALSE`), its ##' *p* value, and 2 missing-data diagnostics: the relative invrease ##' in variance (RIV, or average for multiparameter tests: ARIV) and the ##' fraction missing information (FMI = ARIV / (1 + ARIV)). Robust statistics ##' will also include the average (across imputations) scaling factor and ##' (if relevant) shift parameter(s), unless `pool.robust = TRUE`. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Enders, C. K. (2010). *Applied missing data analysis*. ##' New York, NY: Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data. *Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' Meng, X.-L., & Rubin, D. B. (1992). Performing likelihood ratio tests with ##' multiply-imputed data sets. *Biometrika, 79*(1), 103--111. ##' \doi{10.2307/2337151} ##' ##' Rubin, D. B. (1987). *Multiple imputation for nonresponse in surveys*. ##' New York, NY: Wiley. ##' ##' @seealso [lavaan::lavTestLRT()], [compareFit()] ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' ##' @name lavTestLRT.mi-deprecated ##' @usage ##' lavTestLRT.mi(object, h1 = NULL, test = c("D3","D2"), ##' omit.imps = c("no.conv","no.se"), ##' asymptotic = FALSE, pool.robust = FALSE, ...) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' ##' @export lavTestLRT.mi <- function(object, h1 = NULL, test = c("D3","D2"), omit.imps = c("no.conv","no.se"), asymptotic = FALSE, pool.robust = FALSE, ...) { .Deprecated(msg = c("\nThe runMI() and related lavaan.mi functions have been", " deprecated and will cease to be included in future ", "versions of semTools.\n\nSupport is still provided for ", "analyzing lavaan.mi-class objects (e.g., compRelSEM() ", "can estimate reliability using pooled results), which ", "can now be created using the lavaan.mi package.\n\nThe ", "deprecated runMI() function now creates an object of ", "class OLDlavaan.mi, which can be analyzed using the ", "deprecated functions in semTools, like lavTestLRT.mi(),", " that have been updated and improved in the lavaan.mi ", "package.\n\nFind more details help('semTools-deprecated)")) ## check class if (!inherits(object, "OLDlavaan.mi")) stop("object is not class 'OLDlavaan.mi'") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) DF0 <- object@testList[[ useImps[1] ]]$standard[["df"]] ## model comparison? if (!is.null(h1)) { if (!inherits(h1, "OLDlavaan.mi")) stop("h1 is not class 'OLDlavaan.mi'") if (!all(lavListInspect(object, "options")$test == lavListInspect(h1, "options")$test)) { stop('Different (sets of) test statistics were requested for the 2 models.') } useImps1 <- rep(TRUE, length(h1@DataList)) if ("no.conv" %in% omit.imps) useImps1 <- sapply(h1@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps1 <- useImps1 & sapply(h1@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(h1@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(h1@convergence, "[[", i = "Heywood.ov") useImps1 <- useImps1 & !(Heywood.lv | Heywood.ov) } m <- sum(useImps1) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps1 <- which(useImps1) h0.not.h1 <- setdiff(useImps, useImps1) if (length(h0.not.h1)) warn0 <- paste('\n\nFor the following imputations, ', '"object" converged but not "h1":', paste(h0.not.h1, collapse = ", "), '\n\n') h1.not.h0 <- setdiff(useImps1, useImps) if (length(h1.not.h0)) warn1 <- paste('\n\nFor the following imputations, ', '"h1" converged but not "object":', paste(h1.not.h0, collapse = ", "), '\n\n') if (length(c(h0.not.h1, h1.not.h0))) warning('The models being compared did not converge on the same set of ', 'imputations. ', if (length(h0.not.h1)) warn0 else '', if (length(h1.not.h0)) warn1 else '', 'Likelihood ratio test conducted using only the ', 'imputations for which both models converged.') useImps <- intersect(useImps, useImps1) m <- length(useImps) # yes, redefine if necessary if (m == 0L) stop('For no imputations did both models converge.') ## check DF DF1 <- h1@testList[[ useImps[1] ]]$standard[["df"]] if (DF0 == DF1) stop("models have equal degrees of freedom") if (DF0 < DF1) { H0 <- h1 h1 <- object object <- H0 H0 <- DF1 DF1 <- DF0 DF0 <- H0 } DF <- DF0 - DF1 } else DF <- DF0 ## only keep arguments relevant to pass to lavTestLRT (if D2) dots <- list(...)[names(formals(lavTestLRT))] ## check test-pooling options, for backward compatibility? test <- tolower(test[1]) if (test == "mplus") { test <- "D3" asymptotic <- TRUE } if (tolower(test) %in% c("mr","meng.rubin","likelihood","lrt","d3")) test <- "D3" if (tolower(test) %in% c("lmrr","li.et.al","pooled.wald","d2")) test <- "D2" if (test == "D3" && !lavListInspect(object, "options")$estimator %in% c("ML","PML","FML")) { message('"D3" only available using maximum likelihood estimation. ', 'Changed test to "D2".') test <- "D2" } ## check for robust test.names <- lavListInspect(object, "options")$test # lavaan 0.6-5: for now, we only acknowledge the first non-standard @test if (length(test.names) > 1L) { ## remove standard and any bootstrapped tests rm.idx <- which(test.names %in% c("standard","bootstrap","bollen.stine")) if (length(rm.idx) > 0L) { test.names <- test.names[-rm.idx] } ## only acknowledge the first scaled test statistic if (length(test.names) > 1L) { test.names <- test.names[1] } } robust <- any(test.names %in% c("satorra.bentler","yuan.bentler", "yuan.bentler.mplus","scaled.shifted", "mean.var.adjusted","satterthwaite")) if (!robust) pool.robust <- FALSE scaleshift <- any(test.names == "scaled.shifted") if (scaleshift && !is.null(h1)) { if (test == "D3" | !pool.robust) message("If test = 'scaled.shifted' (estimator = 'WLSMV' or 'MLMV'), ", "model comparison is only available by (re)setting test = 'D2' ", "and pool.robust = TRUE.\n", "Control more options by passing arguments to lavTestLRT() via ", "the '...' argument.\n") pool.robust <- TRUE test <- 'D2' } if (robust && !pool.robust && !asymptotic) { message('Robust correction can only be applied to pooled chi-squared ', 'statistic, not F statistic. "asymptotic" was switched to TRUE.') asymptotic <- TRUE } if (pool.robust && test == "D3") { message('pool.robust = TRUE is only applicable when test = "D2". ', 'Changed test to "D2".') test <- "D2" } ## calculate pooled test: if (robust && pool.robust) { ## pool both the naive and robust test statistics, return both to ## make output consistent across options out.naive <- D2.LRT(object, h1 = h1, useImps = useImps, asymptotic = asymptotic, pool.robust = FALSE) out.robust <- D2.LRT(object, h1 = h1, useImps = useImps, LRTargs = dots, asymptotic = asymptotic, pool.robust = TRUE) out <- c(out.naive, out.robust) } else if (test == "D2") { out <- D2.LRT(object, h1 = h1, useImps = useImps, asymptotic = asymptotic, pool.robust = pool.robust) } else if (test == "D3") { out <- D3.LRT(object, h1 = h1, useImps = useImps, asymptotic = asymptotic, omit.imps = omit.imps) } ## If test statistic is negative, return without any indices or robustness if (asymptotic) { if (out[["chisq"]] == 0) { message('Negative pooled test statistic was set to zero, so fit will ', 'appear to be arbitrarily perfect. ', if (robust) 'Robust corrections uninformative, not returned.', '\n') class(out) <- c("lavaan.vector","numeric") return(out) } } else { if (out[["F"]] == 0) { message('Negative pooled test statistic was set to zero, so fit will ', 'appear to be arbitrarily perfect.\n') class(out) <- c("lavaan.vector","numeric") return(out) } } ## If robust statistics were not pooled above, robustify naive statistics if (robust & !pool.robust) { out <- robustify(ChiSq = out, object = object, h1 = h1, useImps = useImps) if (scaleshift) { extraWarn <- ' and shift parameter' } else if (any(test.names == "mean.var.adjusted")) { extraWarn <- ' and degrees of freedom' } else extraWarn <- '' message('Robust corrections are made by pooling the naive chi-squared ', 'statistic across ', m, ' imputations for which the model ', 'converged, then applying the average (across imputations) scaling', ' factor', extraWarn, ' to that pooled value. \n', 'To instead pool the robust test statistics, set test = "D2" and ', 'pool.robust = TRUE. \n') } class(out) <- c("lavaan.vector","numeric") out } ## ---------------- ## Hidden Functions ## ---------------- ##' @importFrom lavaan lavListInspect parTable lavTestLRT D2.LRT <- function(object, h1 = NULL, useImps, asymptotic = FALSE, pool.robust = FALSE, LRTargs = list()) { warn <- lavListInspect(object, "options")$warn if (pool.robust && !is.null(h1)) { PT1 <- parTable(h1) op1 <- lavListInspect(h1, "options") oldCall <- object@lavListCall #re-run lavaanList() and save DIFFTEST if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L if (warn) warning("Unable to pass lavaan::lavTestLRT() arguments when ", "parallel = 'snow'. Switching to parallel = 'no'. ", "Unless using Windows, parallel = 'multicore' works.") } } ## call lavaanList() again to run lavTestLRT() on each imputation oldCall$FUN <- function(obj) { fit1 <- try(lavaan::lavaan(PT1, slotOptions = op1, slotData = obj@Data), silent = TRUE) if (inherits(fit1, "try-error")) { return("fit failed") } else { argList <- c(list(object = obj, fit1), LRTargs) } out <- try(do.call(lavTestLRT, argList), silent = TRUE) if (inherits(out, "try-error")) return("lavTestLRT() failed") c(chisq = out[2, "Chisq diff"], df = out[2, "Df diff"]) } FIT <- eval(as.call(oldCall)) ## check if there are any results noFit <- sapply(FIT@funList, function(x) x[1] == "fit failed") noLRT <- sapply(FIT@funList, function(x) x[1] == "lavTestLRT() failed") if (all(noFit | noLRT)) stop("No success using lavTestScore() on any imputations.") chiList <- sapply(FIT@funList[ intersect(which(!(noFit | noLRT)), useImps) ], "[[", i = "chisq") dfList <- sapply(FIT@funList[ intersect(which(!(noFit | noLRT)), useImps) ], "[[", i = "df") out <- calculate.D2(chiList, DF = mean(dfList), asymptotic) names(out) <- paste0(names(out), ".scaled") class(out) <- c("lavaan.vector","numeric") return(out) } ## else, return model fit OR naive difference test to be robustified test.names <- lavListInspect(object, "options")$test # lavaan 0.6-5: for now, we only acknowledge the first non-standard @test if (length(test.names) > 1L) { ## remove standard and any bootstrapped tests rm.idx <- which(test.names %in% c("standard","bootstrap","bollen.stine")) if (length(rm.idx) > 0L) { test.names <- test.names[-rm.idx] } ## only acknowledge the first scaled test statistic if (length(test.names) > 1L) { test.names <- test.names[1] } } ## pool Wald tests if (is.null(h1)) { test <- if (pool.robust) test.names[1] else "standard" DF <- mean(sapply(object@testList[useImps], function(x) x[[test]][["df"]] )) w <- sapply(object@testList[useImps], function(x) x[[test]][["stat"]]) } else { ## this will not get run if !pool.robust because logic catches that first DF0 <- mean(sapply(object@testList[useImps], function(x) x$standard[["df"]])) DF1 <- mean(sapply( h1@testList[useImps], function(x) x$standard[["df"]])) DF <- DF0 - DF1 w0 <- sapply(object@testList[useImps], function(x) x$standard[["stat"]]) w1 <- sapply( h1@testList[useImps], function(x) x$standard[["stat"]]) w <- w0 - w1 ## check DF if (DF < 0) { w <- -1*w DF <- -1*DF } } out <- calculate.D2(w, DF, asymptotic) ## add .scaled suffix if (pool.robust) names(out) <- paste0(names(out), ".scaled") ## for 1 model, add extra info (redundant if pool.robust) if (is.null(h1) & !pool.robust) { PT <- parTable(object) out <- c(out, npar = max(PT$free) - sum(PT$op == "=="), ntotal = lavListInspect(object, "ntotal")) } class(out) <- c("lavaan.vector","numeric") out } ##' @importFrom lavaan parTable lavaan lavListInspect ##' @importFrom methods getMethod getLLs <- function(object, useImps, saturated = FALSE, omit.imps = c("no.conv","no.se")) { ## FIXME: lavaanList does not return info when fixed because no convergence! dataList <- object@DataList[useImps] lavoptions <- lavListInspect(object, "options") group <- lavListInspect(object, "group") if (length(group) == 0L) group <- NULL cluster <- lavListInspect(object, "cluster") if (length(cluster) == 0L) cluster <- NULL if (saturated) { #FIXME: below is legacy code, no longer needed? # fit <- lavaan(parTable(object), data = dataList[[ useImps[1] ]], # slotOptions = lavoptions, group = group, cluster = cluster) # ## use saturated parameter table as new model # PT <- lavaan::lav_partable_unrestricted(fit) # ## fit saturated parameter table to each imputation, return estimates # satParams <- lapply(object@DataList[useImps], function(d) { # parTable(lavaan(model = PT, data = d, slotOptions = lavoptions, # group = group, cluster = cluster))$est # }) # ## fix them to pooled estimates # PT$ustart <- colMeans(do.call(rbind, satParams)) PT <- object@h1List[[ useImps[1] ]]$PT coefList <- lapply(object@h1List[useImps], function(x) x$PT$ustart) PT$ustart <- colMeans(do.call(rbind, coefList)) ## set all parameters fixed PT$free <- 0L PT$user <- 1L PT$start <- NULL PT$est <- NULL PT$se <- NULL } else { ## save parameter table as new model PT <- parTable(object) ## set all parameters fixed PT$free <- 0L PT$user <- 1L ## fix them to pooled estimates fixedValues <- getMethod("coef","OLDlavaan.mi")(object, type = "user", omit.imps = omit.imps) PT$ustart <- fixedValues PT$start <- NULL PT$est <- NULL PT$se <- NULL ## omit (in)equality constraints and user-defined parameters params <- !(PT$op %in% c("==","<",">",":=")) PT <- PT[params, ] } ## return log-likelihoods sapply(dataList, function(d) { lavaan::logLik(lavaan(PT, data = d, slotOptions = lavoptions, group = group, cluster = cluster)) }) #TODO: use "dry-run" trick from blavaan:::postpred() to save computing time } ##' @importFrom stats pf pchisq ##' @importFrom lavaan lavListInspect parTable D3.LRT <- function(object, h1 = NULL, useImps, asymptotic = FALSE, omit.imps = c("no.conv","no.se")) { ## NOTE: Need to pass omit.imps= to getLLs(), which calls coef() method N <- lavListInspect(object, "ntotal") m <- length(useImps) if (is.null(h1)) { DF <- object@testList[[ useImps[1] ]]$standard[["df"]] } else { DF1 <- h1@testList[[ useImps[1] ]]$standard[["df"]] DF0 <- object@testList[[ useImps[1] ]]$standard[["df"]] DF <- DF0 - DF1 if (DF < 0) stop('The "object" model must be nested within (i.e., have ', 'fewer degrees of freedom than) the "h1" model.') } ## calculate m log-likelihoods under pooled H0 estimates LL0 <- getLLs(object, useImps, omit.imps = omit.imps) ## calculate m log-likelihoods under pooled H1 estimates if (is.null(h1)) { LL1 <- getLLs(object, useImps, saturated = TRUE, omit.imps = omit.imps) } else { LL1 <- getLLs(h1, useImps, omit.imps = omit.imps) } #FIXME: check whether LL1 or LL0 returned errors? add try()? ## calculate average of m LRTs LRT_con <- mean(-2*(LL0 - LL1)) # getLLs() already applies [useImps] ## average chisq across imputations if (is.null(h1)) { LRT_bar <- mean(sapply(object@testList[useImps], function(x) x$standard$stat)) } else { LRT_bar <- mean(sapply(object@testList[useImps], function(x) x$standard$stat) - sapply(h1@testList[useImps], function(x) x$standard$stat)) } ## calculate average relative increase in variance a <- DF*(m - 1) ariv <- ((m + 1) / a) * (LRT_bar - LRT_con) test.stat <- LRT_con / (DF*(1 + ariv)) if (is.na(test.stat)) stop('D3 test statistic could not be calculated. ', 'Try the D2 pooling method.') #FIXME: check whether model-implied Sigma is NPD if (test.stat < 0) { message('Negative test statistic set to zero \n') test.stat <- 0 } if (asymptotic) { out <- c("chisq" = test.stat * DF, df = DF, pvalue = pchisq(test.stat * DF, df = DF, lower.tail = FALSE), ariv = ariv, fmi = ariv / (1 + ariv)) } else { ## F statistic if (a > 4) { v4 <- 4 + (a - 4) * (1 + (1 - (2 / a))*(1 / ariv))^2 # Enders (eq. 8.34) } else { v4 <- a*(1 + 1/DF)*(1 + 1/ariv)^2 / 2 # Enders (eq. 8.35) # v4 <- (DF + 1)*(m - 1)*(1 + (1 / ariv))^2 / 2 # Grund et al. (eq. 9) } out <- c("F" = test.stat, df1 = DF, df2 = v4, pvalue = pf(test.stat, df1 = DF, df2 = v4, lower.tail = FALSE), ariv = ariv, fmi = ariv / (1 + ariv)) } ## add log-likelihood and AIC/BIC for target model if (is.null(h1)) { PT <- parTable(object) npar <- max(PT$free) - sum(PT$op == "==") out <- c(out, npar = npar, ntotal = N, logl = mean(LL0), unrestricted.logl = mean(LL1), aic = -2*mean(LL0) + 2*npar, bic = -2*mean(LL0) + npar*log(N), bic2 = -2*mean(LL0) + npar*log((N + 2) / 24)) ## NOTE: Mplus reports the average of m likelihoods evaluated at the ## m point estimates, not evaluated at the pooled point estimates. ## Mplus also uses those to calcluate AIC and BIC. } class(out) <- c("lavaan.vector","numeric") out } ##' @importFrom stats pchisq ##' @importFrom lavaan lavListInspect robustify <- function(ChiSq, object, h1 = NULL, baseline = FALSE, useImps) { test.names <- lavListInspect(object, "options")$test # lavaan 0.6-5: for now, we only acknowledge the first non-standard @test if (length(test.names) > 1L) { ## remove standard and any bootstrapped tests rm.idx <- which(test.names %in% c("standard","bootstrap","bollen.stine")) if (length(rm.idx) > 0L) { test.names <- test.names[-rm.idx] } ## only acknowledge the first scaled test statistic if (length(test.names) > 1L) { test.names <- test.names[1] } } scaleshift <- any(test.names %in% "scaled.shifted") if (baseline) { TEST <- lapply(object@baselineList[useImps], "[[", i = "test") } else TEST <- object@testList[useImps] d0 <- mean(sapply(TEST, function(x) x[[ test.names[1] ]][["df"]])) c0 <- mean(sapply(TEST, function(x) x[[ test.names[1] ]][["scaling.factor"]])) if (!is.null(h1)) { d1 <- mean(sapply(h1@testList[useImps], function(x) x[[ test.names[1] ]][["df"]])) c1 <- mean(sapply(h1@testList[useImps], function(x) x[[ test.names[1] ]][["scaling.factor"]])) delta_c <- (d0*c0 - d1*c1) / (d0 - d1) ChiSq["chisq.scaled"] <- ChiSq[["chisq"]] / delta_c ChiSq["df.scaled"] <- d0 - d1 ChiSq["pvalue.scaled"] <- pchisq(ChiSq[["chisq.scaled"]], df = ChiSq[["df.scaled"]], lower.tail = FALSE) ChiSq["chisq.scaling.factor"] <- delta_c } else { ChiSq["chisq.scaled"] <- ChiSq[["chisq"]] / c0 ChiSq["df.scaled"] <- d0 if (scaleshift) { ## add average shift parameter (or average of sums, if nG > 1) shift <- mean(sapply(TEST, function(x) sum(x[[ test.names[1] ]][["shift.parameter"]]) )) ChiSq["chisq.scaled"] <- ChiSq[["chisq.scaled"]] + shift ChiSq["pvalue.scaled"] <- pchisq(ChiSq[["chisq.scaled"]], df = ChiSq[["df.scaled"]], lower.tail = FALSE) ChiSq["chisq.scaling.factor"] <- c0 ChiSq["chisq.shift.parameters"] <- shift } else { ChiSq["pvalue.scaled"] <- pchisq(ChiSq[["chisq.scaled"]], df = ChiSq[["df.scaled"]], lower.tail = FALSE) ChiSq["chisq.scaling.factor"] <- c0 } } ChiSq } semTools/R/fmi.R0000644000176200001440000003052314764331327013173 0ustar liggesusers### Mauricio Garnier Villarreal & Terrence D. Jorgensen ### Last updated: 12 March 2025 ### This function estimates the Fraction of Missing Information for means and ### (co)variances of each variable in a partially observed data set or from ### a list of multiple imputed data sets ##' Fraction of Missing Information. ##' ##' This function estimates the Fraction of Missing Information (FMI) for ##' summary statistics of each variable, using either an incomplete data set or ##' a list of imputed data sets. ##' ##' The function estimates a saturated model with [lavaan::lavaan()] for a ##' single incomplete data set using FIML, or with [lavaan.mi::lavaan.mi()] ##' for a list of imputed data sets. If method = `"saturated"`, FMI will be ##' estiamted for all summary statistics, which could take a lot of time with ##' big data sets. If method = `"null"`, FMI will only be estimated for ##' univariate statistics (e.g., means, variances, thresholds). The saturated ##' model gives more reliable estimates, so it could also help to request a ##' subset of variables from a large data set. ##' ##' ##' @importFrom lavaan lavListInspect lavInspect ##' ##' @param data Either a single `data.frame` with incomplete observations, ##' or a `list` of imputed data sets. ##' @param method character. If `"saturated"` or `"sat"` (default), ##' the model used to estimate FMI is a freely estimated covariance matrix and ##' mean vector for numeric variables, and/or polychoric correlations and ##' thresholds for ordered categorical variables, for each group (if ##' applicable). If `"null"`, only means and variances are estimated for ##' numeric variables, and/or thresholds for ordered categorical variables ##' (i.e., covariances and/or polychoric/polyserial correlations are ##' constrained to zero). See **Details** for more information. ##' @param group `character`. The optional name of a grouping variable, to ##' request FMI in each group. ##' @param ords Optional `character` vector naming ordered-categorical ##' variables, if they are not already stored as class `ordered` in `data`. ##' @param varnames Optional `character` vector of variable names, to calculate ##' FMI for a subset of variables in `data`. By default, all numeric and ##' `ordered=` variables will be included, unless `data=` is a single ##' incomplete `data.frame`, in which case only numeric variables can be ##' used with FIML estimation. Other variable types will be removed. ##' @param exclude Optional `character` vector naming variables to exclude from ##' the analysis. ##' @param return.fit logical. If `TRUE`, the fitted [lavaan::lavaan-class] or ##' [lavaan.mi::lavaan.mi-class] model is returned, so FMI can be found from ##' `summary(..., fmi=TRUE)`. ##' ##' @return `fmi()` returns a list with at least 2 of the following: ##' ##' \item{Covariances}{A list of symmetric matrices: (1) the estimated/pooled ##' covariance matrix, or a list of group-specific matrices (if applicable) ##' and (2) a matrix of FMI, or a list of group-specific matrices (if ##' applicable). Only available if `method = "saturated"`. When ##' `method="cor"`, this element is replaced by `Correlations`.} ##' \item{Variances}{The estimated/pooled variance for each numeric variable. ##' Only available if `method = "null"` (otherwise, it is on the diagonal ##' of Covariances).} ##' \item{Means}{The estimated/pooled mean for each numeric variable.} ##' \item{Thresholds}{The estimated/pooled threshold(s) for each ##' ordered-categorical variable.} ##' ##' @author ##' Mauricio Garnier Villarreal (Vrije Universiteit Amsterdam; \email{m.garniervillarreal@@vu.nl}) ##' ##' Terrence Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Rubin, D. B. (1987). *Multiple imputation for nonresponse in surveys*. ##' New York, NY: Wiley. ##' ##' Savalei, V. & Rhemtulla, M. (2012). On obtaining estimates of the fraction ##' of missing information from full information maximum likelihood. ##' *Structural Equation Modeling, 19*(3), 477--494. ##' \doi{10.1080/10705511.2012.687669} ##' ##' Wagner, J. (2010). The fraction of missing information as a tool for ##' monitoring the quality of survey data. *Public Opinion Quarterly, ##' 74*(2), 223--243. \doi{10.1093/poq/nfq007} ##' ##' @examples ##' ##' HSMiss <- HolzingerSwineford1939[ , c(paste("x", 1:9, sep = ""), ##' "ageyr","agemo","school")] ##' set.seed(12345) ##' HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) ##' age <- HSMiss$ageyr + HSMiss$agemo/12 ##' HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) ##' ##' ## calculate FMI (using FIML, provide partially observed data set) ##' (out1 <- fmi(HSMiss, exclude = "school")) ##' (out2 <- fmi(HSMiss, exclude = "school", method = "null")) ##' (out3 <- fmi(HSMiss, varnames = c("x5","x6","x7","x8","x9"))) ##' (out4 <- fmi(HSMiss, method = "cor", group = "school")) # correlations by group ##' ##' ## significance tests in lavaan(.mi) object ##' out5 <- fmi(HSMiss, method = "cor", return.fit = TRUE) ##' summary(out5) # factor loading == SD, covariance = correlation ##' ##' if(requireNamespace("lavaan.mi")){ ##' ## ordered-categorical data ##' data(binHS5imps, package = "lavaan.mi") ##' ##' ## calculate FMI, using list of imputed data sets ##' fmi(binHS5imps, group = "school") ##' } ##' ##' @export fmi <- function(data, method = "saturated", group = NULL, ords = NULL, varnames = NULL, exclude = NULL, return.fit = FALSE) { fiml <- is.data.frame(data) ## check for single data set or list of imputed data sets data1 <- if (fiml) data else data[[1]] ## select user-specified variables vars <- if (is.character(varnames)) varnames else colnames(data1) ## remove grouping variable and user-specified exclusions, if applicable vars <- setdiff(vars, c(group, exclude)) ## check classes ordvars <- vars[sapply(data1[vars], is.ordered)] if (!is.null(ords)) ordvars <- c(ordvars, ords) numvars <- vars[sapply(data1[vars], is.numeric)] vars <- union(numvars, ordvars) numvars <- setdiff(vars, ordvars) if (fiml) { #TODO: enable estimator = "PML" # pass missing= option as another fmi() argument? if (length(ordvars)) message(c("By providing a single data set, only the ", "FIML option is available to calculate FMI,", " which requires continuous variables. The ", "following variables were removed: ", paste(ordvars, collapse = ", "))) if (!length(numvars)) stop("No numeric variables were provided.") vars <- numvars } ## construct model if (method == "saturated" | method == "sat") { covstruc <- outer(vars, vars, function(x, y) paste(x, "~~", y)) diag(covstruc)[which(vars %in% ordvars)] <- "" model <- covstruc[lower.tri(covstruc, diag = TRUE)] } else if (method == "null") { covstruc <- outer(vars, vars, function(x, y) paste(x, "~~", y)) diag(covstruc)[which(vars %in% ordvars)] <- "" model <- diag(covstruc) } else if (method == "cor") { # phantoms <- paste0(".", vars, ".") model <- c(paste0(".", vars, ". =~ ", ifelse(vars %in% ordvars, "1*", "NA*"), vars), # loadings = SDs (fixed to 1 when ordinal) paste0(vars, " ~~ 0*", vars)) # "residual" variances = 0 } else stop('Invalid method= argument: "', method, '"') if (length(numvars)) model <- c(model, paste(numvars, "~ 1")) ## fit model if (fiml) { if (method == "cor") { fit <- lavaan::cfa(model, data = data, missing = "fiml", group = group, std.lv = TRUE) } else { fit <- lavaan::lavaan(model, data = data, missing = "fiml", group = group) } if (return.fit) return(fit) comb.results <- lavaan::parameterEstimates(fit, fmi = TRUE, zstat = FALSE, pvalue = FALSE, ci = FALSE) nG <- lavInspect(fit, "ngroups") if (nG == 1L) comb.results$group <- 1L group.label <- lavInspect(fit, "group.label") } else { ## list of imputations if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") if (method == "cor") { fit <- lavaan.mi::cfa.mi(model, data = data, group = group, ordered = ordvars, std.lv = TRUE) } else { fit <- lavaan.mi::lavaan.mi(model, data = data, group = group, ordered = ordvars, auto.th = TRUE) } if (return.fit) return(fit) comb.results <- lavaan.mi::parameterEstimates.mi(fit, fmi = TRUE, zstat = FALSE, pvalue = FALSE, ci = FALSE) nG <- lavListInspect(fit, "ngroups") if (nG == 1L) comb.results$group <- 1L group.label <- lavListInspect(fit, "group.label") #FIXME: also return RIV? Or make it an argument (FMI or RIV) comb.results$riv <- NULL } ## Variances from null model, if applicable if (method == "null") { if (length(numvars)) { Variances <- comb.results[comb.results$lhs == comb.results$rhs, c("lhs","group","est","fmi")] colnames(Variances)[c(1, 3)] <- c("variable","coef") if (nG > 1L) Variances$group <- group.label[Variances$group] class(Variances) <- c("lavaan.data.frame","data.frame") attr(Variances, "header") <- paste("Null-model estimates may not be as", "accurate as saturated-model estimates.") ## start list of results results <- list(Variances = Variances) } else results <- list() } else { ## covariances from saturated model, including polychorics (if applicable) if (fiml) { if (nG == 1L) { covmat <- lavInspect(fit, "est")[[ifelse(method == "cor", "psi", "theta")]] covmat <- list(covmat) } else { covmat <- sapply(lavInspect(fit, "est"), "[[", i = ifelse(method == "cor", "psi", "theta"), simplify = FALSE) } } else { useImps <- sapply(fit@convergence, "[[", "converged") m <- sum(useImps) if (nG == 1L) { CovList <- lapply(fit@coefList[useImps], function(x) x[[ifelse(method == "cor", "psi", "theta")]]) covmat <- list(Reduce("+", CovList) / m) } else { covmat <- list() for (i in group.label) { groupList <- lapply(fit@coefList[useImps],"[[", i) CovList <- lapply(groupList, function(x) x[[ifelse(method == "cor", "psi", "theta")]]) covmat[[i]] <- Reduce("+", CovList) / m } } } fmimat <- covmat covars <- comb.results[comb.results$op == "~~", c("lhs","rhs","group","est","fmi")] for (i in 1:nG) { theseCovars <- covars[covars$group == i,] if (method == "cor") { phantomRows <- !(theseCovars$lhs %in% vars) theseCovars <- theseCovars[phantomRows,] } fmimat[[i]][as.matrix(theseCovars[, 1:2])] <- theseCovars$fmi fmimat[[i]][as.matrix(theseCovars[, 2:1])] <- theseCovars$fmi if (method == "cor") { ## reset variable names dimnames(fmimat[[i]]) <- dimnames(covmat[[i]]) <- list(vars, vars) } } if (nG == 1L) { Covariances <- list(coef = covmat[[1]], fmi = fmimat[[1]]) } else Covariances <- list(coef = covmat, fmi = fmimat) ## start list of results results <- setNames(list(Covariances), nm = ifelse(method == "cor", "Correlations", "Covariances")) } ## Means, if applicable if (length(numvars)) { results$Means <- comb.results[comb.results$op == "~1" & comb.results$lhs %in% numvars, c("lhs","group","est","fmi")] colnames(results$Means)[c(1, 3)] <- c("variable","coef") if (nG > 1L) results$Means$group <- group.label[results$Means$group] class(results$Means) <- c("lavaan.data.frame","data.frame") } ## Thresholds, if applicable if (length(ordvars)) { results$Thresholds <- comb.results[comb.results$op == "|", c("lhs","rhs","group","est","fmi")] colnames(results$Thresholds)[c(1, 2, 4)] <- c("variable","threshold","coef") if (nG > 1L) results$Thresholds$group <- group.label[results$Thresholds$group] class(results$Thresholds) <- c("lavaan.data.frame","data.frame") } results } semTools/R/runMI-Wald.R0000644000176200001440000003075614764332711014345 0ustar liggesusers### Terrence D. Jorgensen & Yves Rosseel ### Last updated: 12 March 2025 ### Pooled Wald test for multiple imputations ### Borrowed source code from lavaan/R/lav_test_Wald.R ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ##' Wald Test for Multiple Imputations ##' ##' Wald test for testing a linear hypothesis about the parameters of lavaan ##' models fitted to multiple imputed data sets. Statistics for constraining ##' one or more free parameters in a model can be calculated from the pooled ##' point estimates and asymptotic covariance matrix of model parameters ##' using Rubin's (1987) rules, or by pooling the Wald test statistics ##' across imputed data sets (Li, Meng, Raghunathan, & Rubin, 1991). ##' ##' The constraints are specified using the `"=="` operator. ##' Both the left-hand side and the right-hand side of the equality can contain ##' a linear combination of model parameters, or a constant (like zero). ##' The model parameters must be specified by their user-specified labels from ##' the \code{link[lavaan]{model.syntax}}. Names of defined parameters ##' (using the ":=" operator) can be included too. ##' ## @aliases lavTestWald.mi ##' @importFrom lavaan parTable lavListInspect ##' @importFrom stats pchisq pf ##' @importFrom methods getMethod ##' ##' @param object An object of class [OLDlavaan.mi-class]. ##' @param constraints A `character` string (typically between single ##' quotes) containing one or more equality constraints. ##' See examples for more details ##' @param test `character` indicating which pooling method to use. ##' `"D1"` or `"Rubin"` (default) indicates Rubin's (1987) rules ##' will be applied to the point estimates and the asymptotic covariance ##' matrix of model parameters, and those pooled values will be used to ##' calculate the Wald test in the usual manner. `"D2"`, `"LMRR"`, ##' or `"Li.et.al"` indicate that the complete-data Wald test statistic ##' should be calculated using each imputed data set, which will then be ##' pooled across imputations, as described in Li, Meng, Raghunathan, & Rubin ##' (1991) and Enders (2010, chapter 8). ##' @param asymptotic `logical`. If `FALSE` (default), the pooled test ##' will be returned as an *F*-distributed statistic with numerator ##' (`df1`) and denominator (`df2`) degrees of freedom. ##' If `TRUE`, the pooled *F* statistic will be multiplied by its ##' `df1` on the assumption that its `df2` is sufficiently large ##' enough that the statistic will be asymptotically \eqn{\chi^2} distributed ##' with `df1`. ##' @param scale.W `logical`. If `FALSE`, the pooled ##' asymptotic covariance matrix of model parameters is calculated as the ##' weighted sum of the within-imputation and between-imputation components. ##' Otherwise, the pooled asymptotic covariance matrix of model parameters is ##' calculated by scaling the within-imputation component by the ##' average relative increase in variance (ARIV; see Enders, 2010, p. 235), ##' which is *only* consistent when requesting the *F* test (i.e., ##' `asymptotic = FALSE`. Ignored (irrelevant) if `test = "D2"`. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. Specific imputation numbers can also be included in this ##' argument, in case users want to apply their own custom omission criteria ##' (or simulations can use different numbers of imputations without ##' redundantly refitting the model). ##' @param verbose `logical`. If `TRUE`, print the restriction ##' matrix and the estimated restricted values. ##' @param warn `logical`. If `TRUE`, print warnings if they occur. ##' ##' @return ##' A vector containing the Wald test statistic (either an `F` or ##' \eqn{\chi^2} statistic, depending on the `asymptotic` argument), ##' the degrees of freedom (numerator and denominator, if ##' `asymptotic = FALSE`), and a *p* value. If ##' `asymptotic = FALSE`, the relative invrease in variance (RIV, or ##' average for multiparameter tests: ARIV) used to calculate the denominator ##' *df* is also returned as a missing-data diagnostic, along with the ##' fraction missing information (FMI = ARIV / (1 + ARIV)). ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' Adapted from \pkg{lavaan} source code, written by ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' @references ##' Enders, C. K. (2010). *Applied missing data analysis*. ##' New York, NY: Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data. *Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' Rubin, D. B. (1987). *Multiple imputation for nonresponse in surveys*. ##' New York, NY: Wiley. ##' ##' @seealso [lavaan::lavTestWald()] ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' ##' @name lavTestWald.mi-deprecated ##' @usage ##' lavTestWald.mi(object, constraints = NULL, test = c("D1","D2"), ##' asymptotic = FALSE, scale.W = !asymptotic, ##' omit.imps = c("no.conv","no.se"), ##' verbose = FALSE, warn = TRUE) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export lavTestWald.mi <- function(object, constraints = NULL, test = c("D1","D2"), asymptotic = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), verbose = FALSE, warn = TRUE) { .Deprecated(msg = c("\nThe runMI() and related lavaan.mi functions have been", " deprecated and will cease to be included in future ", "versions of semTools.\n\nSupport is still provided for ", "analyzing lavaan.mi-class objects (e.g., compRelSEM() ", "can estimate reliability using pooled results), which ", "can now be created using the lavaan.mi package.\n\nThe ", "deprecated runMI() function now creates an object of ", "class OLDlavaan.mi, which can be analyzed using the ", "deprecated functions in semTools, like lavTestLRT.mi(),", " that have been updated and improved in the lavaan.mi ", "package.\n\nFind more details help('semTools-deprecated)")) stopifnot(inherits(object, "OLDlavaan.mi")) useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) test <- tolower(test[1]) if (test %in% c("d2", "lmrr", "li.et.al")) test <- "D2" if (test %in% c("d1", "rubin")) test <- "D1" if (!test %in% c("D1","D2")) stop('Invalid choice of "test" argument.') message('\nWald test calculated using se = "', lavListInspect(object, "options")$se, '"\n') if (test == "D2") { oldCall <- object@lavListCall if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L if (warn) warning("Unable to pass lavaan::lavTestWald() arguments ", "when parallel='snow'. Switching to parallel='no'.", " Unless using Windows, parallel='multicore' works.") } } ## call lavaanList() again to run lavTestWald() on each imputation oldCall$FUN <- function(obj) { out <- try(lavaan::lavTestWald(object = obj, constraints = constraints, verbose = FALSE), silent = TRUE) if (inherits(out, "try-error")) return(NULL) do.call(c, out[1:2]) } FIT <- eval(as.call(oldCall)) ## check if there are any results noStats <- sapply(FIT@funList, is.null) if (all(noStats)) stop("No success using lavTestWald() on any imputations.") ## template to fill in pooled values ## at a minimum, pool the total score test chiList <- sapply(FIT@funList[ intersect(useImps, which(!noStats)) ], "[[", i = 1) DF <- FIT@funList[[ intersect(useImps, which(!noStats))[1] ]][[2]] out <- calculate.D2(chiList, DF = DF, asymptotic) class(out) <- c("lavaan.vector","numeric") return(out) } # else test == "D1", making 'scale.W=' relevant ## "borrowed" lavTestWald() if (is.null(constraints) || nchar(constraints) == 0L) stop("constraints are empty") # remove == constraints from parTable, save as list PT <- parTable(object) partable <- as.list(PT[PT$op != "==", ]) # parse constraints FLAT <- lavaan::lavParseModelString( constraints ) CON <- attr(FLAT, "constraints") LIST <- list() if (length(CON) > 0L) { lhs <- unlist(lapply(CON, "[[", i = "lhs")) op <- unlist(lapply(CON, "[[", i = "op")) rhs <- unlist(lapply(CON, "[[", i = "rhs")) LIST$lhs <- c(LIST$lhs, lhs) # FIXME: why concatenate with NULL? LIST$op <- c(LIST$op, op) LIST$rhs <- c(LIST$rhs, rhs) } else stop("no equality constraints found in constraints argument") # theta = free parameters only (equality-constrained allowed) theta <- getMethod("coef", "OLDlavaan.mi")(object, omit.imps = omit.imps) #object@optim$x # build constraint function ceq.function <- lavaan::lav_partable_constraints_ceq(partable = partable, con = LIST, debug = FALSE) # compute jacobian restrictions JAC <- try(lavaan::lav_func_jacobian_complex(func = ceq.function, x = theta), silent = TRUE) if (inherits(JAC, "try-error")) { # eg. pnorm() JAC <- lavaan::lav_func_jacobian_simple(func = ceq.function, x = theta) } if (verbose) {cat("Restriction matrix (jacobian):\n"); print(JAC); cat("\n")} # linear restriction theta.r <- ceq.function( theta ) if (verbose) {cat("Restricted theta values:\n"); print(theta.r); cat("\n")} # get VCOV VCOV <- getMethod("vcov","OLDlavaan.mi")(object, scale.W = scale.W, omit.imps = omit.imps) # restricted vcov info.r <- JAC %*% VCOV %*% t(JAC) # Wald test statistic test.stat <- as.numeric(t(theta.r) %*% solve( info.r ) %*% theta.r) # number of constraints (k in Enders (2010, p. 235) eqs. 8.23-25) DF <- nrow(JAC) if (asymptotic) { out <- c("chisq" = test.stat, df = DF, pvalue = pchisq(test.stat, df = DF, lower.tail = FALSE)) } else { W <- getMethod("vcov", "OLDlavaan.mi")(object, type = "within", omit.imps = omit.imps) B <- getMethod("vcov", "OLDlavaan.mi")(object, type = "between", omit.imps = omit.imps) #FIXME: only valid for linear constraints? ## restricted B & W components of VCOV W.r <- JAC %*% W %*% t(JAC) B.r <- JAC %*% B %*% t(JAC) ## relative increase in variance due to missing data W.inv <- MASS::ginv(W.r) ariv <- (1 + 1/m) * sum(diag(B.r %*% W.inv)) / DF ## calculate denominator DF for F statistic a <- DF*(m - 1) if (a > 4) { v2 <- 4 + (a - 4) * (1 + (1 - 2/a)*(1 / ariv))^2 # Enders (eq. 8.24) } else { v2 <- a*(1 + 1/DF) * (1 + 1/ariv)^2 / 2 # Enders (eq. 8.25) } out <- c("F" = test.stat / DF, df1 = DF, df2 = v2, pvalue = pf(test.stat / DF, df1 = DF, df2 = v2, lower.tail = FALSE), ariv = ariv, fmi = ariv / (1 + ariv)) } class(out) <- c("lavaan.vector","numeric") out } semTools/R/monteCarloCI.R0000644000176200001440000003666414764333616014756 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ## from http://www.da.ugent.be/cvs/pages/en/Presentations/Presentation%20Yves%20Rosseel.pdf # dd <- read.table("http://www.statmodel.com/examples/shortform/4cat%20m.dat", # col.names = c("intention", "intervention", "ciguse", "w")) # myData <- do.call(rbind, lapply(1:nrow(dd), function(RR) { # data.frame(rep(1, dd$w[RR]) %*% as.matrix(dd[RR, 1:3])) # })) # model <- ' # ciguse ~ c*intervention + b*intention # intention ~ a*intervention # # label threshold for ciguse # ciguse | b0*t1 # # biased SEs # naive.indirect := a*b # naive.direct := c # # correct # probit11 := (-b0+c+b*a)/sqrt(b^2+1) # probit10 := (-b0+c )/sqrt(b^2+1) # probit00 := (-b0 )/sqrt(b^2+1) # indirect := pnorm(probit11) - pnorm(probit10) # direct := pnorm(probit10) - pnorm(probit00) # OR.indirect := (pnorm(probit11)/(1-pnorm(probit11))) / (pnorm(probit10)/(1-pnorm(probit10))) # OR.direct := (pnorm(probit10)/(1-pnorm(probit10))) / (pnorm(probit00)/(1-pnorm(probit00))) # ' # fit <- sem(model, data = myData, ordered = c("ciguse","intention")) # summary(fit, ci = TRUE) ##' Monte Carlo Confidence Intervals to Test Functions of Parameter Estimates ##' ##' Robust confidence intervals for functions of parameter estimates, ##' based on empirical sampling distributions of estimated model parameters. ##' ##' This function implements the Monte Carlo method of obtaining an empirical ##' sampling distribution of estimated model parameters, as described by ##' MacKinnon et al. (2004) for testing indirect effects in mediation models. ##' This is essentially a parametric bootstrap method, which (re)samples ##' parameters (rather than raw data) from a multivariate-normal distribution ##' with mean vector equal to estimates in `coef()` and covariance matrix ##' equal to the asymptotic covariance matrix `vcov()` of estimated parameters. ##' ##' The easiest way to use the function is to fit a SEM to data with ##' [lavaan::lavaan()], using the `:=` operator in the ##' [lavaan::model.syntax()] to specify user-defined parameters. ##' All information is then available in the resulting ##' [lavaan::lavaan-class] object. Alternatively (especially when using ##' external SEM software to fit the model), the expression(s) can be explicitly ##' passed to the function, along with the vector of estimated model parameters ##' and their associated asymptotic sampling covariance matrix (ACOV). ##' For further information on the Monte Carlo method, see MacKinnon et al. ##' (2004) and Preacher & Selig (2012). ##' ##' The asymptotic covariance matrix can be obtained easily from many popular ##' SEM software packages. ##' \itemize{ ##' \item{LISREL: Including the EC option on the OU line will print the ACM ##' to a seperate file. The file contains the lower triangular elements of ##' the ACM in free format and scientific notation.} ##' \item{M*plus*: Include the command TECH3; in the OUTPUT section. ##' The ACM will be printed in the output.} ##' \item{`lavaan`: Use the [vcov()] method on the fitted [lavaan::lavaan-class] ##' object to return the ACM.} ##' } ##' ##' ##' @importFrom stats quantile ##' @importFrom methods getMethod ##' @importFrom lavaan parTable lavInspect ##' ##' @param object A object of class [lavaan::lavaan-class] in which ##' functions of parameters have already been defined using the `:=` ##' operator in `lavaan`'s [lavaan::model.syntax()]. When ##' `NULL`, users must specify `expr`, `coefs`, and `ACM`. ##' @param expr Optional `character` vector specifying functions of model ##' parameters (e.g., an indirect effect). Ideally, the vector should have ##' names, which is necessary if any user-defined parameters refer to other ##' user-defined parameters defined earlier in the vector (order matters!). ##' All parameters appearing in the vector must be provided in `coefs`, ##' or defined (as functions of `coefs`) earlier in `expr`. If ##' `length(expr) > 1L`, `nRep` samples will be drawn ##' simultaneously from a single multivariate distribution; thus, ##' `ACM` must include all parameters in `coefs`. ##' @param coefs `numeric` vector of parameter estimates used in ##' `expr`. Ignored when `object` is used. ##' @param ACM Symmetric `matrix` representing the asymptotic sampling ##' covariance matrix (ACOV) of the parameter estimates in `coefs`. ##' Ignored when `object` is used. Information on how to obtain the ACOV ##' in popular SEM software is described in **Details**. ##' @param nRep `integer`. The number of samples to draw, to obtain an ##' empirical sampling distribution of model parameters. Many thousand are ##' recommended to minimize Monte Carlo error of the estimated CIs. ##' @param standardized `logical` indicating whether to obtain CIs for the ##' fully standardized (`"std.all"`) estimates, using their asymptotic ##' sampling covariance matrix. ##' @param fast `logical` indicating whether to use a fast algorithm that ##' assumes all functions of parameters (in `object` or `expr`) use ##' standard operations. Set to `FALSE` if using (e.g.) [c()] ##' to concatenate parameters in the definition, which would have unintended ##' consequences when vectorizing functions in `expr` across sampled ##' parameters. ##' @param level `numeric` confidence level, between 0--1 ##' @param na.rm `logical` passed to [stats::quantile()] ##' @param append.samples `logical` indicating whether to return the ##' simulated empirical sampling distribution of parameters (in `coefs`) ##' and functions (in `expr`) in a `list` with the results. This ##' could be useful to calculate more precise highest-density intervals (see ##' examples). ##' @param plot `logical` indicating whether to plot the empirical sampling ##' distribution of each function in `expr` ##' @param ask whether to prompt user before printing each plot ##' @param \dots arguments passed to [graphics::hist()] when ##' `plot = TRUE`. ##' ##' @return A `lavaan.data.frame` (to use lavaan's `print` method) ##' with point estimates and confidence limits of each requested function of ##' parameters in `expr` is returned. If `append.samples = TRUE`, ##' output will be a `list` with the same `$Results` along with a ##' second `data.frame` with the `$Samples` (in rows) of each ##' parameter (in columns), and an additional column for each requested ##' function of those parameters. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' MacKinnon, D. P., Lockwood, C. M., & Williams, J. (2004). Confidence limits ##' for the indirect effect: Distribution of the product and resampling methods. ##' *Multivariate Behavioral Research, 39*(1) 99--128. ##' \doi{10.1207/s15327906mbr3901_4} ##' ##' Preacher, K. J., & Selig, J. P. (2010, July). Monte Carlo method ##' for assessing multilevel mediation: An interactive tool for creating ##' confidence intervals for indirect effects in 1-1-1 multilevel models. ##' Computer software available from . ##' ##' Preacher, K. J., & Selig, J. P. (2012). Advantages of Monte Carlo confidence ##' intervals for indirect effects. *Communication Methods and Measures, 6*(2), ##' 77--98. \doi{10.1080/19312458.2012.679848} ##' ##' Selig, J. P., & Preacher, K. J. (2008, June). Monte Carlo method for ##' assessing mediation: An interactive tool for creating confidence intervals ##' for indirect effects. Computer software available from ##' . ##' ##' @aliases monteCarloCI monteCarloMed ##' ##' @examples ##' ##' ## From the mediation tutorial: ##' ## http://lavaan.ugent.be/tutorial/mediation.html ##' ##' set.seed(1234) ##' X <- rnorm(100) ##' M <- 0.5*X + rnorm(100) ##' Y <- 0.7*M + rnorm(100) ##' dat <- data.frame(X = X, Y = Y, M = M) ##' ##' mod <- ' # direct effect ##' Y ~ c*X ##' # mediator ##' M ~ a*X ##' Y ~ b*M ##' # indirect effect (a*b) ##' ind := a*b ##' # total effect ##' total := ind + c ##' ' ##' fit <- sem(mod, data = dat) ##' summary(fit, ci = TRUE) # print delta-method CIs ##' ##' ## Automatically extract information from lavaan object ##' set.seed(1234) ##' monteCarloCI(fit) # CIs more robust than delta method in smaller samples ##' ##' ## delta method for standardized solution ##' standardizedSolution(fit) ##' ## compare to Monte Carlo CIs: ##' set.seed(1234) ##' monteCarloCI(fit, standardized = TRUE) ##' ##' \donttest{ ##' ## save samples to calculate more precise intervals: ##' set.seed(1234) ##' foo <- monteCarloCI(fit, append.samples = TRUE) ##' # library(HDInterval) # not a dependency; must be installed ##' # hdi(foo$Samples) ##' } ##' ## Parameters can also be obtained from an external analysis ##' myParams <- c("a","b","c") ##' (coefs <- coef(fit)[myParams]) # names must match those in the "expression" ##' ## Asymptotic covariance matrix from an external analysis ##' (AsyCovMat <- vcov(fit)[myParams, myParams]) ##' ## Compute CI, include a plot ##' set.seed(1234) ##' monteCarloCI(expr = c(ind = 'a*b', total = 'ind + c', ##' ## other arbitrary functions are also possible ##' meaningless = 'sqrt(a)^b / log(abs(c))'), ##' coefs = coefs, ACM = AsyCovMat, ##' plot = TRUE, ask = TRUE) # print a plot for each ##' ##' @export monteCarloCI <- function(object = NULL, expr, coefs, ACM, nRep = 2e4, standardized = FALSE, fast = TRUE, level = 0.95, na.rm = TRUE, append.samples = FALSE, plot = FALSE, ask = getOption("device.ask.default"), ...) { if (inherits(object, c("lavaan","lavaan.mi"))) { ## extract user-defined parameters from parTable (order of user-defined PT <- parTable(object) # parameters must be correct for model to be fitted) ## create expression vector expr <- PT$rhs[PT$op == ":="] names(expr) <- PT$lhs[PT$op == ":="] if (length(expr) == 0L) stop('No user-defined parameters found.') } ## provide names if there are none if (is.null(names(expr))) names(expr) <- expr ## Get names and the number of unique variables in the expression funcVars <- unique(do.call("c", lapply(paste("~", expr), function(x) { all.vars(stats::as.formula(x)) }))) ## isolate names of model parameters (not user-defined), which get sampled if (inherits(object, "lavaan")) { if (standardized) { STD <- lavaan::standardizedSolution(object) coefRows <- !(STD$op %in% c(":=","==","<",">","<=",">=")) coefs <- STD$est.std[coefRows] names(coefs) <- lavaan::lav_partable_labels(STD[coefRows, ]) } else coefs <- lavaan::coef(object) } else if (inherits(object, "lavaan.mi")) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") if (standardized) { ## only available after this lavaan version: if ( utils::packageDescription("lavaan", fields = "Version") < "0.6-19" || (utils::packageDescription("lavaan", fields = "Version") > "0.6-19" && utils::packageDescription("lavaan", fields = "Version") < "0.6-19.2148") ) { stop("standardized=TRUE for a lavaan.mi-class object requires lavaan ", "version >= 0.6-19 from CRAN, or development version >= ", "0.6-19.2148 from GitHub") } STD <- lavaan.mi::standardizedSolution.mi(object) coefRows <- !(STD$op %in% c(":=","==","<",">","<=",">=")) coefs <- STD$est.std[coefRows] names(coefs) <- lavaan::lav_partable_labels(STD[coefRows, ]) } else coefs <- getMethod(f = "coef", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(object) } sampVars <- intersect(names(coefs), funcVars) ## If a lavaan(.mi) object is provided, extract coefs and ACM if (inherits(object, "lavaan")) { coefs <- coefs[sampVars] if (standardized) { ACM <- lavInspect(object, "vcov.std.all")[sampVars, sampVars] } else { ACM <- lavaan::vcov(object)[sampVars, sampVars] } } else if (inherits(object, "lavaan.mi")) { coefs <- coefs[sampVars] if (standardized) { ACM <- lavaan.mi::standardizedSolution.mi(object, return.vcov = TRUE, type = "std.all")[sampVars, sampVars] } else { ACM <- getMethod(f = "vcov", signature = "lavaan.mi", where = getNamespace("lavaan.mi"))(object)[sampVars, sampVars] } } ## Apply the expression(s) to POINT ESTIMATES estList <- as.list(coefs) for (i in seq_along(expr)) { estList[names(expr[i])] <- eval(parse(text = expr[i]), envir = estList) } EST <- data.frame(est = do.call("c", estList[names(expr)])) ## old, buggy code (see issue #142) # estList <- within(as.list(coefs), expr = { # for (i in seq_along(expr)) assign(names(expr[i]), eval(parse(text = expr[i]))) # })[names(expr)] # EST <- data.frame(est = do.call("c", estList)) rownames(EST) <- names(expr) if (standardized && inherits(object, "lavaan")) colnames(EST) <- "est.std" ## Matrix of sampled values # dat <- samples <- data.frame(mnormt::rmnorm(n = nRep, mean = coefs, varcov = ACM)) ## Apply the expression(s) to VECTORS of ESTIMATES if (fast) { for (i in seq_along(expr)) { samples[names(expr[i])] <- eval(parse(text = expr[i]), envir = samples) } ## old, buggy code (see issue #142) # samples <- within(dat, expr = { # for (i in seq_along(expr)) assign(names(expr[i]), eval(parse(text = expr[i]))) # })[c(sampVars, names(expr))] } else { ## SLOWER: only necessary if expr creates objects using (e.g.) c(), which ## would concatenate parameters ACROSS samples as well as WITHIN datList <- lapply(1:nRep, function(Rep) { samples[Rep,] # dat[Rep,] }) samples <- do.call(rbind, lapply(datList, function(Rep) { for (i in seq_along(expr)) { Rep[names(expr[i])] <- eval(parse(text = expr[i]), envir = Rep) } ## old, buggy code (see issue #142) # within(Rep, expr = { # for (i in seq_along(expr)) assign(names(expr[i]), eval(parse(text = expr[i]))) # }) Rep })) # [c(sampVars, names(expr))] } ## Get the CI(s) halfAlpha <- (1-level)/2 Limits <- lapply(samples[names(expr)], quantile, na.rm = na.rm, probs = c(halfAlpha, 1 - halfAlpha)) CIs <- data.frame(do.call("rbind", Limits)) rownames(CIs) <- names(expr) colnames(CIs) <- c("ci.lower","ci.upper") ## Switch for outputting a plot if (plot) { if (length(expr) > 1L && ask) { opar <- grDevices::devAskNewPage() grDevices::devAskNewPage(ask = TRUE) } for (i in seq_along(expr)) { histArgs <- list(...) histArgs$x <- samples[[ names(expr)[i] ]] if (is.null(histArgs$breaks)) histArgs$breaks <- "FD" if (is.null(histArgs$xlab)) histArgs$xlab <- paste0(level*100, '% Confidence Interval') if (is.null(histArgs$main)) histArgs$main <- paste('Distribution of', names(expr)[i]) do.call("hist", histArgs) abline(v = EST[i,1], lwd = 3) abline(v = CIs[i,1:2], lwd = 2, lty = "dashed") } if (length(expr) > 1L && ask) grDevices::devAskNewPage(ask = opar) } ## Always return point and interval estimates out <- cbind(EST, CIs) class(out) <- c("lavaan.data.frame","data.frame") ## also simulated values? (e.g., to calculate highest-density intervals) if (append.samples) return(list(Results = out, Samples = samples)) out } #FIXME: Remove after a few version updates monteCarloMed <- function(...) { .Defunct("monteCarloCI", msg = "monteCarloMed() has been replaced by monteCarloCI()") } semTools/R/powerAnalysisRMSEA.R0000644000176200001440000003764614632143377016065 0ustar liggesusers### Sunthud Pornprasertmanit, Alexander M. Schoemann, Kristopher J. Preacher, Donna Coffman ### Last updated: 22 April 2022 ##' Plot power curves for RMSEA ##' ##' Plots power of RMSEA over a range of sample sizes ##' ##' This function creates plot of power for RMSEA against a range of sample ##' sizes. The plot places sample size on the horizontal axis and power on the ##' vertical axis. The user should indicate the lower and upper values for ##' sample size and the sample size between each estimate ("step size") We ##' strongly urge the user to read the sources below (see References) before ##' proceeding. A web version of this function is available at: ##' . This function is also ##' implemented in the web application "power4SEM": ##' ##' ##' ##' @importFrom stats qchisq pchisq ##' ##' @param rmsea0 Null RMSEA ##' @param rmseaA Alternative RMSEA ##' @param df Model degrees of freedom ##' @param nlow Lower sample size ##' @param nhigh Upper sample size ##' @param steps Increase in sample size for each iteration. Smaller values of ##' steps will lead to more precise plots. However, smaller step sizes means a ##' longer run time. ##' @param alpha Alpha level used in power calculations ##' @param group The number of group that is used to calculate RMSEA. ##' @param \dots The additional arguments for the plot function. ##' ##' @return Plot of power for RMSEA against a range of sample sizes ##' ##' @author ##' Alexander M. Schoemann (East Carolina University; \email{schoemanna@@ecu.edu}) ##' ##' Kristopher J. Preacher (Vanderbilt University; \email{kris.preacher@@vanderbilt.edu}) ##' ##' Donna L. Coffman (Pennsylvania State University; \email{dlc30@@psu.edu}) ##' ##' @seealso \itemize{ ##' \item [plotRMSEAdist()] to visualize the RMSEA distributions ##' \item [findRMSEApower()] to find the statistical power based on ##' population RMSEA given a sample size ##' \item [findRMSEAsamplesize()] to find the minium sample size for ##' a given statistical power based on population RMSEA ##' } ##' ##' @references ##' MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing ##' differences between nested covariance structure models: Power analysis and ##' null hypotheses. *Psychological Methods, 11*(1), 19--35. ##' \doi{10.1037/1082-989X.11.1.19} ##' ##' MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis ##' and determination of sample size for covariance structure modeling. ##' *Psychological Methods, 1*(2), 130--149. \doi{10.1037/1082-989X.1.2.130} ##' ##' MacCallum, R. C., Lee, T., & Browne, M. W. (2010). The issue of isopower in ##' power analysis for tests of structural equation models. *Structural ##' Equation Modeling, 17*(1), 23--41. \doi{10.1080/10705510903438906} ##' ##' Preacher, K. J., Cai, L., & MacCallum, R. C. (2007). Alternatives to ##' traditional model comparison strategies for covariance structure models. In ##' T. D. Little, J. A. Bovaird, & N. A. Card (Eds.), *Modeling contextual ##' effects in longitudinal studies* (pp. 33--62). Mahwah, NJ: Lawrence Erlbaum ##' Associates. ##' ##' Steiger, J. H. (1998). A note on multiple sample extensions of the RMSEA fit ##' index. *Structural Equation Modeling, 5*(4), 411--419. ##' \doi{10.1080/10705519809540115} ##' ##' Steiger, J. H., & Lind, J. C. (1980, June). *Statistically based tests ##' for the number of factors.* Paper presented at the annual meeting of the ##' Psychometric Society, Iowa City, IA. ##' ##' Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. ##' (2021). Analytical power calculations for structural equation modeling: ##' A tutorial and Shiny app. *Behavior Research Methods, 53*, 1385--1406. ##' \doi{10.3758/s13428-020-01479-0} ##' ##' @examples ##' ##' plotRMSEApower(rmsea0 = .025, rmseaA = .075, df = 23, ##' nlow = 100, nhigh = 500, steps = 10) ##' ##' @export plotRMSEApower <- function(rmsea0, rmseaA, df, nlow, nhigh, steps = 1, alpha = .05, group = 1, ...) { pow1 <- 0 nseq <- seq(nlow,nhigh, by=steps) for(i in nseq){ ncp0 <- ((i-1)*df*rmsea0^2)/group ncpa <- ((i-1)*df*rmseaA^2)/group #Compute power if(rmsea0 < rmseaA) { cval <- qchisq(alpha,df,ncp=ncp0,lower.tail=FALSE) pow <- pchisq(cval,df,ncp=ncpa,lower.tail=FALSE) } if(rmsea0 > rmseaA) { cval <- qchisq(1-alpha, df, ncp=ncp0, lower.tail=FALSE) pow <- 1-pchisq(cval,df,ncp=ncpa,lower.tail=FALSE) } pow1<-c(pow1, pow) } pow1 <- pow1[-1] plot(nseq,pow1,xlab="Sample Size",ylab="Power",main="Compute Power for RMSEA",type="l", ...) } ##' Plot the sampling distributions of RMSEA ##' ##' Plots the sampling distributions of RMSEA based on the noncentral chi-square ##' distributions ##' ##' This function creates overlappling plots of the sampling distribution of ##' RMSEA based on noncentral \eqn{\chi^2} distribution (MacCallum, Browne, & ##' Suguwara, 1996). First, the noncentrality parameter (\eqn{\lambda}) is ##' calculated from RMSEA (Steiger, 1998; Dudgeon, 2004) by \deqn{\lambda = (N - ##' 1)d\varepsilon^2 / K,} where \eqn{N} is sample size, \eqn{d} is the model ##' degree of freedom, \eqn{K} is the number of group, and \eqn{\varepsilon} is ##' the population RMSEA. Next, the noncentral \eqn{\chi^2} distribution with a ##' specified *df* and noncentrality parameter is plotted. Thus, ##' the x-axis represents the sample \eqn{\chi^2} value. The sample \eqn{\chi^2} ##' value can be transformed to the sample RMSEA scale (\eqn{\hat{\varepsilon}}) ##' by \deqn{\hat{\varepsilon} = \sqrt{K}\sqrt{\frac{\chi^2 - d}{(N - 1)d}},} ##' where \eqn{\chi^2} is the \eqn{\chi^2} value obtained from the noncentral ##' \eqn{\chi^2} distribution. ##' ##' ##' @importFrom stats qchisq ##' ##' @param rmsea The vector of RMSEA values to be plotted ##' @param n Sample size of a dataset ##' @param df Model degrees of freedom ##' @param ptile The percentile rank of the distribution of the first RMSEA that ##' users wish to plot a vertical line in the resulting graph ##' @param caption The name vector of each element of `rmsea` ##' @param rmseaScale If `TRUE`, the RMSEA scale is used in the x-axis. If ##' `FALSE`, the chi-square scale is used in the x-axis. ##' @param group The number of group that is used to calculate RMSEA. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [plotRMSEApower()] to plot the statistical power ##' based on population RMSEA given the sample size ##' \item [findRMSEApower()] to find the statistical power based on ##' population RMSEA given a sample size ##' \item [findRMSEAsamplesize()] to find the minium sample size for ##' a given statistical power based on population RMSEA ##' } ##' ##' @references ##' Dudgeon, P. (2004). A note on extending Steiger's (1998) ##' multiple sample RMSEA adjustment to other noncentrality parameter-based ##' statistic. *Structural Equation Modeling, 11*(3), 305--319. ##' \doi{10.1207/s15328007sem1103_1} ##' ##' MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis ##' and determination of sample size for covariance structure modeling. ##' *Psychological Methods, 1*(2), 130--149. \doi{10.1037/1082-989X.1.2.130} ##' ##' Steiger, J. H. (1998). A note on multiple sample extensions of the RMSEA fit ##' index. *Structural Equation Modeling, 5*(4), 411--419. ##' \doi{10.1080/10705519809540115} ##' ##' @examples ##' ##' plotRMSEAdist(c(.05, .08), n = 200, df = 20, ptile = .95, rmseaScale = TRUE) ##' plotRMSEAdist(c(.05, .01), n = 200, df = 20, ptile = .05, rmseaScale = FALSE) ##' ##' @export plotRMSEAdist <- function(rmsea, n, df, ptile = NULL, caption = NULL, rmseaScale = TRUE, group = 1) { graph <- cbind(rmsea, df) ncp <- apply(graph, MARGIN = 1, FUN = function(x, n, group) ((n - 1) * x[2] * (x[1]^2))/group, n = n, group = group) graph <- cbind(graph, ncp) dens <- lapply(as.list(data.frame(t(graph))), function(x) findDensity("chisq", df = x[2], ncp=x[3])) if (rmseaScale) dens <- lapply(dens, function(x, df, n, group) { x[,1] <- (x[,1] - df)/(n-1); x[(x[,1] < 0),1] <- 0; x[,1] <- sqrt(group) * sqrt(x[,1]/df); return(x) }, df=df, n=n, group=group) cutoff <- NULL if (!is.null(ptile)) { cutoff <- qchisq(ptile, df = graph[1, 2], ncp = graph[1, 3]) if (rmseaScale) cutoff <- sqrt(group) * sqrt((cutoff - df)/(df * (n - 1))) } if (is.null(caption)) caption <- sapply(graph[,1], function(x) paste("Population RMSEA = ", format(x, digits = 3), sep = "")) plotOverlapDensity(dens, cutoff, caption, ylab = "Density", xlab = ifelse(rmseaScale, "RMSEA", "Chi-Square")) equal0 <- sapply(dens, function(x) x[,1] == 0) if (any(equal0)) warning("The density at RMSEA = 0 cannot be trusted", " because the plots are truncated.") } ##' Find the statistical power based on population RMSEA ##' ##' Find the proportion of the samples from the sampling distribution of RMSEA ##' in the alternative hypothesis rejected by the cutoff dervied from the ##' sampling distribution of RMSEA in the null hypothesis. This function can be ##' applied for both test of close fit and test of not-close fit (MacCallum, ##' Browne, & Suguwara, 1996) ##' ##' This function find the proportion of sampling distribution derived from the ##' alternative RMSEA that is in the critical region derived from the sampling ##' distribution of the null RMSEA. If `rmseaA` is greater than ##' `rmsea0`, the test of close fit is used and the critical region is in ##' the right hand side of the null sampling distribution. On the other hand, if ##' `rmseaA` is less than `rmsea0`, the test of not-close fit is used ##' and the critical region is in the left hand side of the null sampling ##' distribution (MacCallum, Browne, & Suguwara, 1996). ##' ##' There is also a Shiny app called "power4SEM" that provides a graphical user ##' interface for this functionality (Jak et al., in press). It can be accessed ##' at . ##' ##' ##' @importFrom stats qchisq pchisq ##' ##' @param rmsea0 Null RMSEA ##' @param rmseaA Alternative RMSEA ##' @param df Model degrees of freedom ##' @param n Sample size of a dataset ##' @param alpha Alpha level used in power calculations ##' @param group The number of group that is used to calculate RMSEA. ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' @seealso \itemize{ ##' \item [plotRMSEApower()] to plot the statistical power based on ##' population RMSEA given the sample size ##' \item [plotRMSEAdist()] to visualize the RMSEA distributions ##' \item [findRMSEAsamplesize()] to find the minium sample size for ##' a given statistical power based on population RMSEA ##' } ##' ##' @references ##' MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis ##' and determination of sample size for covariance structure modeling. ##' *Psychological Methods, 1*(2), 130--149. \doi{10.1037/1082-989X.1.2.130} ##' ##' Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. ##' (2021). Analytical power calculations for structural equation modeling: ##' A tutorial and Shiny app. *Behavior Research Methods, 53*, 1385--1406. ##' \doi{10.3758/s13428-020-01479-0} ##' ##' @examples ##' ##' findRMSEApower(rmsea0 = .05, rmseaA = .08, df = 20, n = 200) ##' ##' @export findRMSEApower <- function(rmsea0, rmseaA, df, n, alpha = .05, group = 1) { ncp0 <- ((n-1)*df*rmsea0^2)/group ncpa <- ((n-1)*df*rmseaA^2)/group if (rmsea0 power)) { return("Sample Size <= 5") } else if (all(power > pow)) { repeat { n <- n + 500 pow <- findRMSEApower(rmsea0, rmseaA, df, n, alpha, group=group) if(any(pow > power)) { index <- which(pow > power)[1] return(n[index]/group) } } } else { index <- which(pow > power)[1] return(n[index]/group) } } ## ---------------- ## Hidden Functions ## ---------------- ## findDensity ## Find the x and y coordinate of a distribution in order to plot a density of a distribution ## dist: target distribution in text, such as "chisq" ## ...: Additional argument of the distribution ## Return the data frame with x and y coordinates for plotting density findDensity <- function(dist, ...) { FUN <- list() FUN[[1]] <- get(paste("q", dist, sep="")) FUN[[2]] <- c(0.001, 0.999) FUN <- c(FUN, ...) bound <- eval(as.call(FUN)) val <- seq(bound[1], bound[2], length.out=1000) FUN[[1]] <- get(paste("d", dist, sep="")) FUN[[2]] <- val height <- eval(as.call(FUN)) return(cbind(val, height)) } ##Example Code ##findDensity("chisq", df=10) ## plotOverlapDensity ## Plot the overlapping distributions using density ## dat: A list of data frame where each data frame has the x coordinate as the variable 1 and y coordinate as the variable 2 ## vline: Vertical line in the graph ## caption: The name of each density line ## ...: Additional argument of the plot function plotOverlapDensity <- function(dat, vline = NULL, caption = NULL, ...) { if (!is.list(dat)) { temp <- list() temp[[1]] <- dat dat <- temp } stack <- do.call(rbind, dat) lim <- apply(stack, 2, function(x) c(min(x), max(x))) plot(stack, xlim = lim[,1], ylim = lim[,2], type = "n", ...) for (i in 1:length(dat)) lines(dat[[i]], col = i, lwd = 1.5) for (i in 1:length(vline)) abline(v = vline[i], lwd = 1.5) if (!is.null(caption)) legend(0.50 * (lim[2,1] - lim[1,1]) + lim[1,1], 0.99 * (lim[2,2] - lim[1,2]) + lim[1,2], caption, col=1:length(dat), lty=1) } semTools/R/EmpKaiser.R0000644000176200001440000001365314632144122014272 0ustar liggesusers### Ylenio Longo ### Last updated: 10 January 2021 ##' Empirical Kaiser criterion ##' ##' Identify the number of factors to extract based on the Empirical Kaiser ##' Criterion (EKC). The analysis can be run on a `data.frame` or data ##' `matrix` (`data`), or on a correlation or covariance matrix ##' (`sample.cov`) and the sample size (`sample.nobs`). A ##' `data.frame` is returned with two columns: the eigenvalues from your ##' data or covariance matrix and the reference eigenvalues. The number of ##' factors suggested by the Empirical Kaiser Criterion (i.e. the sample ##' eigenvalues greater than the reference eigenvalues), and the number of ##' factors suggested by the original Kaiser Criterion ##' (i.e. sample eigenvalues > 1) is printed above the output. ##' ##' ##' @importFrom stats cov cov2cor ##' ##' @param data A `data.frame` or data `matrix` containing columns of ##' variables to be factor-analyzed. ##' @param sample.cov A covariance or correlation matrix can be used, instead of ##' `data`, to estimate the eigenvalues. ##' @param sample.nobs Number of observations (i.e. sample size) if ##' `is.null(data)` and `sample.cov=` is used. ##' @param missing If `"listwise"`, incomplete cases are removed listwise from ##' the `data.frame`. If `"direct"` or `"ml"` or `"fiml"` and the `estimator=` ##' is maximum likelihood, an EM algorithm is used to estimate an unrestricted ##' covariance matrix (and mean vector). If `"pairwise"`, pairwise deletion is ##' used. If `"default"``, the value is set depending on the estimator and the ##' mimic option (see [lavaan::lavCor()] for details). ##' @param ordered `character` vector. Only used if object is a `data.frame`. ##' Treat these variables as `ordered=` (ordinal) variables. Importantly, all ##' other variables will be treated as numeric (unless `is.ordered == TRUE` in ##' `data`). (see also [lavCor][lavaan::lavCor]) ##' @param plot logical. Whether to print a scree plot comparing the sample ##' eigenvalues with the reference eigenvalues. ##' @return A `data.frame` showing the sample and reference eigenvalues. ##' ##' The number of factors suggested by the Empirical Kaiser Criterion (i.e. the ##' sample eigenvalues greater than the reference eigenvalues) is returned as an ##' attribute (see **Examples**). ##' ##' The number of factors suggested by the original Kaiser Criterion (i.e. ##' sample eigenvalues > 1) is also printed as a header to the `data.frame` ##' ##' @author Ylenio Longo (University of Nottingham; ##' \email{yleniolongo@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @references Braeken, J., & van Assen, M. A. L. M. (2017). An empirical ##' Kaiser criterion. *Psychological Methods, 22*(3), 450--466. ##' \doi{10.1037/met0000074} ##' ##' @examples ##' ##' ## Simulate data with 3 factors ##' model <- ' ##' f1 =~ .3*x1 + .5*x2 + .4*x3 ##' f2 =~ .3*x4 + .5*x5 + .4*x6 ##' f3 =~ .3*x7 + .5*x8 + .4*x9 ##' ' ##' dat <- simulateData(model, seed = 123) ##' ## save summary statistics ##' myCovMat <- cov(dat) ##' myCorMat <- cor(dat) ##' N <- nrow(dat) ##' ##' ## Run the EKC function ##' (out <- efa.ekc(dat)) ##' ##' ## To extract the recommended number of factors using the EKC: ##' attr(out, "nfactors") ##' ##' ## If you do not have raw data, you can use summary statistics ##' (x1 <- efa.ekc(sample.cov = myCovMat, sample.nobs = N, plot = FALSE)) ##' (x2 <- efa.ekc(sample.cov = myCorMat, sample.nobs = N, plot = FALSE)) ##' ##' @export efa.ekc <- function(data = NULL, sample.cov = NULL, sample.nobs = NULL, missing = "default", ordered = NULL, plot = TRUE) { ## if data if (!is.null(data)) { data <- as.data.frame(data) R <- lavaan::lavCor(data, missing = missing, ordered = ordered) #correlations j <- dim(data)[2] #number of variables n <- dim(data)[1] #sample size } else { ## if covariance matrix if (max(diag(sample.cov)) != 1 & min(diag(sample.cov)) != 1) { R <- cov2cor(sample.cov) j <- dim(R)[2] #number of variables n <- sample.nobs #sample size } else { ## if correlation matrix R <- sample.cov j <- dim(R)[2] #number of variables n <- sample.nobs #sample size } } g <- j/n #gamma: var / sample l <- (1 + sqrt(g))^2 #1st reference eigenvalue e <- eigen(R)$values #eigenvalues v <- cumsum(e) #Define cumulatively summed eigenvalue vector v1 <- v[1:j - 1] #omit last element v2 <- c(0, v1) #put a zero upfront w <- sort(1:j, decreasing = TRUE) #eigenvalue order vector ref <- (((j - v2)/w) * l) #EKC reference eigenvalues # results Eigenvalues <- data.frame(Sample = e, Ref = ref) #sample and reference eigenvalues rownames(Eigenvalues) <- 1:j class(Eigenvalues) <- c("lavaan.data.frame","data.frame") ## add no. factors to extract as attribute, using each criterion nfactors_EKC <- which(!(Eigenvalues[, 1] > Eigenvalues[, 2]))[1] - 1 # EKC nfactors_KC <- which(!(Eigenvalues[, 1] > 1))[1] - 1 # Kaiser Criterion attr(Eigenvalues, "header") <- paste(" Empirical Kaiser Criterion suggests", nfactors_EKC, "factors.\n", "Traditional Kaiser Criterion suggests", nfactors_KC, "factors.") attr(Eigenvalues, "nfactors") <- nfactors_EKC if (plot) { plot(Eigenvalues[, 1], type = "b", pch = 20, cex = 0.9, col = "black", main = "Empirical Kaiser Criterion\nScree Plot", ylab = "Eigenvalues", ylim = c(min(Eigenvalues), max(ceiling(Eigenvalues))), xlab = "Factor Number", xlim = c(1, j)) lines(Eigenvalues[, 2], lty = "dashed", col = "blue") legend("topright", c(" Data", " Empirical\n Reference", " Kaiser Criterion"), col = c("black","blue","gray"), bty = "n", pch = c(20, NA, NA), lty = c("solid","dashed","solid"), merge = TRUE) abline(h = 1, col = "gray") # Kaiser Criterion } return(Eigenvalues) } semTools/R/runMI-methods.R0000644000176200001440000020305414764332442015113 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 February 2025 ### Class and Methods for OLDlavaan.mi object, returned by runMI() ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ##' Class for a lavaan Model Fitted to Multiple Imputations ##' ##' This class extends the [lavaan::lavaanList-class] class, created by ##' fitting a lavaan model to a list of data sets. In this case, the list of ##' data sets are multiple imputations of missing data. ##' ##' ##' @name OLDlavaan.mi-class ##' @importClassesFrom lavaan lavaanList ##' @aliases OLDlavaan.mi-class show,OLDlavaan.mi-method summary,OLDlavaan.mi-method ##' fitMeasures,OLDlavaan.mi-method fitmeasures,OLDlavaan.mi-method ##' anova,OLDlavaan.mi-method nobs,OLDlavaan.mi-method coef,OLDlavaan.mi-method ##' vcov,OLDlavaan.mi-method fitted,OLDlavaan.mi-method fitted.values,OLDlavaan.mi-method ##' residuals,OLDlavaan.mi-method resid,OLDlavaan.mi-method ##' @docType class ##' ##' @slot coefList `list` of estimated coefficients in matrix format (one ##' per imputation) as output by `lavInspect(fit, "est")` ##' @slot phiList `list` of model-implied latent-variable covariance ##' matrices (one per imputation) as output by ##' `lavInspect(fit, "cov.lv")` ##' @slot miList `list` of modification indices output by ##' [lavaan::modindices()] ##' @slot seed `integer` seed set before running imputations ##' @slot lavListCall call to [lavaan::lavaanList()] used to fit the ##' model to the list of imputed data sets in `@@DataList`, stored as a ##' `list` of arguments ##' @slot imputeCall call to imputation function (if used), stored as a ##' `list` of arguments ##' @slot convergence `list` of `logical` vectors indicating whether, ##' for each imputed data set, (1) the model converged on a solution, (2) ##' *SE*s could be calculated, (3) the (residual) covariance matrix of ##' latent variables (\eqn{\Psi}) is non-positive-definite, and (4) the ##' residual covariance matrix of observed variables (\eqn{\Theta}) is ##' non-positive-definite. ##' @slot lavaanList_slots All remaining slots are from ##' [lavaan::lavaanList-class], but [runMI()] only populates a ##' subset of the `list` slots, two of them with custom information: ##' @slot DataList The `list` of imputed data sets ##' @slot SampleStatsList List of output from ##' `lavInspect(fit, "sampstat")` applied to each fitted ##' model ##' @slot ParTableList See [lavaan::lavaanList-class] ##' @slot vcovList See [lavaan::lavaanList-class] ##' @slot testList See [lavaan::lavaanList-class] ##' @slot h1List See [lavaan::lavaanList-class]. An additional element is ##' added to the `list`: `$PT` is the "saturated" model's parameter ##' table, returned by [lavaan::lav_partable_unrestricted()]. ##' @slot baselineList See [lavaan::lavaanList-class] ##' ##' @param object An object of class `OLDlavaan.mi` ##' @param se,ci,level,standardized,rsquare,header,output See ##' [lavaan::parameterEstimates()]. The `output=` argument ##' can also be passed to [lavaan::fitMeasures()]. ##' @param fmi `logical` indicating whether to include the Fraction Missing ##' Information (FMI) for parameter estimates in the `summary` ##' output (see **Value** section). ##' @param asymptotic `logical`. If `FALSE` (typically a default, but ##' see **Value** section for details using various methods), pooled ##' tests (of fit or pooled estimates) will be *F* or *t* ##' statistics with associated degrees of freedom (*df*). If ##' `TRUE`, the (denominator) *df* are assumed to be ##' sufficiently large for a *t* statistic to follow a normal ##' distribution, so it is printed as a *z* statisic; likewise, ##' *F* times its numerator *df* is printed, assumed to follow ##' a \eqn{\chi^2} distribution. ##' @param scale.W `logical`. If `TRUE` (default), the `vcov` ##' method will calculate the pooled covariance matrix by scaling the ##' within-imputation component by the ARIV (see Enders, 2010, p. 235, ##' for definition and formula). Otherwise, the pooled matrix is ##' calculated as the weighted sum of the within-imputation and ##' between-imputation components (see Enders, 2010, ch. 8, for details). ##' This in turn affects how the `summary()` method calculates its ##' pooled standard errors, as well as [lavTestWald.mi()]. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. NPD solutions are not excluded by default because ##' they are likely to occur due to sampling error, especially in small ##' samples. However, gross model misspecification could also cause ##' NPD solutions, users can compare pooled results with and without ##' this setting as a sensitivity analysis to see whether some ##' imputations warrant further investigation. Specific imputation ##' numbers can also be included in this argument, in case users want to ##' apply their own custom omission criteria (or simulations can use ##' different numbers of imputations without redundantly refitting the ##' model). ##' @param labels `logical` indicating whether the `coef` output ##' should include parameter labels. Default is `TRUE`. ##' @param total `logical` (default: `TRUE`) indicating whether the ##' `nobs` method should return the total sample size or (if ##' `FALSE`) a vector of group sample sizes. ##' @param type The meaning of this argument varies depending on which method it ##' it used for. Find detailed descriptions in the **Value** section ##' under `coef`, `vcov`, and `residuals`. ##' @param fit.measures,baseline.model See [lavaan::fitMeasures()]. ##' `summary(object, fit.measures = TRUE)` will print (but not ##' return) a table of fit measures to the console. ##' @param ... Additional arguments passed to [lavTestLRT.mi()], or ##' subsequently to [lavaan::lavTestLRT()]. ##' ##' @return ##' ##' \item{coef}{`signature(object = "OLDlavaan.mi", type = "free", ##' labels = TRUE, omit.imps = c("no.conv","no.se"))`: ##' See [lavaan::lavaan-class]. Returns the pooled point estimates (i.e., ##' averaged across imputed data sets; see Rubin, 1987).} ##' ##' \item{vcov}{`signature(object = "OLDlavaan.mi", scale.W = TRUE, ##' omit.imps = c("no.conv","no.se"), ##' type = c("pooled","between","within","ariv"))`: By default, returns the ##' pooled covariance matrix of parameter estimates (`type = "pooled"`), ##' the within-imputations covariance matrix (`type = "within"`), the ##' between-imputations covariance matrix (`type = "between"`), or the ##' average relative increase in variance (`type = "ariv"`) due to ##' missing data.} ##' ##' \item{fitted.values}{`signature(object = "OLDlavaan.mi", ##' omit.imps = c("no.conv","no.se"))`: See [lavaan::lavaan-class]. ##' Returns model-implied moments, evaluated at the pooled point estimates.} ##' \item{fitted}{alias for `fitted.values`} ##' ##' \item{residuals}{`signature(object = "OLDlavaan.mi", ##' type = c("raw","cor"), omit.imps = c("no.conv","no.se"))`: ##' See [lavaan::lavaan-class]. By default (`type = "raw"`), returns ##' the difference between the model-implied moments from `fitted.values` ##' and the pooled observed moments (i.e., averaged across imputed data sets). ##' Standardized residuals are also available, using Bollen's ##' (`type = "cor"` or `"cor.bollen"`) or Bentler's ##' (`type = "cor.bentler"`) formulas.} ##' \item{resid}{alias for `residuals`} ##' ##' \item{nobs}{`signature(object = "OLDlavaan.mi", total = TRUE)`: either ##' the total (default) sample size or a vector of group sample sizes ##' (`total = FALSE`).} ##' ##' \item{anova}{`signature(object = "OLDlavaan.mi", ...)`: ##' Returns a test of model fit for a single model (`object`) or test(s) ##' of the difference(s) in fit between nested models passed via `...`. ##' See [lavTestLRT.mi()] and [compareFit()] for details.} ##' ##' \item{fitMeasures}{`signature(object = "OLDlavaan.mi", ##' fit.measures = "all", baseline.model = NULL, output = "vector", ##' omit.imps = c("no.conv","no.se"), ...)`: See lavaan's ##' [lavaan::fitMeasures()] for details. Pass additional arguments ##' to [lavTestLRT.mi()] via `...`.} ##' \item{fitmeasures}{alias for `fitMeasures`.} ##' ##' \item{show}{`signature(object = "OLDlavaan.mi")`: returns a message about ##' convergence rates and estimation problems (if applicable) across imputed ##' data sets.} ##' ##' \item{summary}{`signature(object = "OLDlavaan.mi", se = TRUE, ci = FALSE, ##' level = .95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, ##' scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), asymptotic = FALSE, ##' header = TRUE, output = "text", fit.measures = FALSE, ...)`: ##' See [lavaan::parameterEstimates()] for details. ##' By default, `summary()` returns pooled point and *SE* ##' estimates, along with *t* test statistics and their associated ##' *df* and *p* values. If `ci = TRUE`, confidence intervals ##' are returned with the specified confidence `level` (default 95\% CI). ##' If `asymptotic = TRUE`, *z* instead of *t* tests are ##' returned. `standardized` solution(s) can also be requested by name ##' (`"std.lv"` or `"std.all"`) or both are returned with `TRUE`. ##' *R*-squared for endogenous variables can be requested, as well as the ##' Fraction Missing Information (FMI) for parameter estimates. By default, the ##' output will appear like `lavaan`'s `summary()` output, but if ##' `output == "data.frame"`, the returned `data.frame` will resemble ##' the `parameterEstimates()` output. The `scale.W` argument is ##' passed to `vcov` (see description above). ##' Setting `fit.measures=TRUE` will additionally print fit measures to ##' the console, but they will not be returned; additional arguments may be ##' passed via `...` to [lavaan::fitMeasures()] and ##' subsequently to [lavTestLRT.mi()].} ##' ##' @section Objects from the Class: See the [runMI()] function for details. ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Asparouhov, T., & Muthen, B. (2010). *Chi-square statistics ##' with multiple imputation*. Technical Report. Retrieved from ##' ##' ##' Enders, C. K. (2010). *Applied missing data analysis*. New York, NY: ##' Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data. *Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' Meng, X.-L., & Rubin, D. B. (1992). Performing likelihood ratio tests with ##' multiply-imputed data sets. *Biometrika, 79*(1), 103--111. ##' \doi{10.2307/2337151} ##' ##' Rubin, D. B. (1987). *Multiple imputation for nonresponse in surveys*. ##' New York, NY: Wiley. ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' setClass("OLDlavaan.mi", contains = "lavaanList", slots = c(coefList = "list", # coefficients in matrix format phiList = "list", # list of model-implied latent covariance matrices miList = "list", # modification indices seed = "integer", # seed set before running imputations lavListCall = "list", # store actual call to lavaanList imputeCall = "list", # store call from imputation, if used convergence = "list")) # also check SEs and Heywood cases ##' @name OLDlavaan.mi-class ##' @aliases show,OLDlavaan.mi-method ##' @export setMethod("show", "OLDlavaan.mi", function(object) { nData <- object@meta$ndat useImps <- sapply(object@convergence, "[[", i = "converged") nConverged <- sum(useImps) SE <- sapply(object@convergence, "[[", "SE") SE[is.na(SE)] <- FALSE Heywood.ov <- sapply(object@convergence, "[[", "Heywood.ov") Heywood.ov[is.na(Heywood.ov)] <- FALSE Heywood.lv <- sapply(object@convergence, "[[", "Heywood.lv") Heywood.lv[is.na(Heywood.lv)] <- FALSE cat('OLDlavaan.mi object based on ', nData, ' imputed data sets. \n', 'See class?OLDlavaan.mi help page for available methods. \n\n', 'Convergence information:\n', 'The model converged on ', nConverged, ' imputed data sets \n\n', sep = "") if (!all(SE)) cat('Standard errors could not be computed for data set(s)', paste(which(!SE), collapse = ", "), '\nTry fitting the', 'model to the individual data set(s) to diagnose', 'problems. If they cannot be fixed, try inspecting the', 'imputations. It may be necessary to reimpute the data', 'with some restrictions imposed. \n\n') if (any(Heywood.ov | Heywood.lv)) cat('Heywood cases detected for data set(s)', paste(which(Heywood.ov | Heywood.lv), collapse = ", "), '\nThese are not necessarily a cause for concern, unless a pooled', 'estimate is also a Heywood case. \n\n') object }) ##' @importFrom stats pt qt pnorm qnorm ##' @importFrom lavaan lavListInspect parTable lavNames ##' @importFrom methods getMethod summary_OLDlavaan.mi <- function(object, se = TRUE, ci = FALSE, level = .95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), asymptotic = FALSE, header = TRUE, output = "text", fit.measures = FALSE, ...) { useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) lavoptions <- lavListInspect(object, "options") ## extract parameter table with attributes for printing PT <- parTable(object) myCols <- c("lhs","op","rhs","exo") if (lavListInspect(object, "ngroups") > 1L) myCols <- c(myCols,"block","group") if (lavListInspect(object, "nlevels") > 1L) myCols <- c(myCols,"block","level") PE <- PT[ , unique(myCols)] free <- PT$free > 0L | PT$op == ":=" STDs <- !(PT$op %in% c("==","<",">")) # which rows can be standardized PE$est <- getMethod("coef","OLDlavaan.mi")(object, type = "all", omit.imps = omit.imps) if (lavoptions$se == "none") { warning('pooled variances and tests unavailable when se="none" is requested') se <- FALSE } if (!se) fmi <- FALSE messPool <- paste0("Rubin's (1987) rules were used to pool point", if (se) " and SE", " estimates across ", m, " imputed data sets", if (se & !asymptotic) ", and to calculate degrees of", if (se & !asymptotic) " freedom for each parameter's t", if (se & !asymptotic) " test and CI.", "\n") if (se) { VCOV <- getMethod("vcov","OLDlavaan.mi")(object, scale.W = scale.W, omit.imps = omit.imps) PE$se <- lavaan::lav_model_vcov_se(object@Model, VCOV = VCOV, lavpartable = object@ParTable) W <- rowMeans(sapply(object@ParTableList[useImps], "[[", i = "se")^2) B <- apply(sapply(object@ParTableList[useImps], "[[", i = "est"), 1, var) Bm <- B + B/m Tot <- W + Bm if (asymptotic) { PE$z[free] <- PE$est[free] / PE$se[free] PE$pvalue <- pnorm(-abs(PE$z))*2 crit <- qnorm(1 - (1 - level) / 2) } else { PE$t[free] <- PE$est[free] / PE$se[free] ## calculate df for t test ## can't do finite-sample correction because Wald z tests have no df ## (see Enders, 2010, p. 231, eq. 8.13 & 8.14) PE$df[free] <- (m - 1) * (1 + W[free] / Bm[free])^2 ## if DF are obscenely large, set them to infinity for pretty printing PE$df <- ifelse(PE$df > 9999, Inf, PE$df) PE$pvalue <- pt(-abs(PE$t), df = PE$df)*2 crit <- qt(1 - (1 - level) / 2, df = PE$df) } if (ci) { PE$ci.lower <- PE$est - crit * PE$se PE$ci.upper <- PE$est + crit * PE$se PE$ci.lower[!free] <- PE$ci.upper[!free] <- PE$est[!free] } } if (is.logical(standardized)) { if (standardized) { standardized <- c("std.lv","std.all") if (length(lavNames(object, "ov.x")) && lavoptions$fixed.x) { standardized <- c(standardized, "std.nox") } } else standardized <- NULL } else standardized <- tolower(as.character(standardized)) if (length(standardized) || rsquare) { ## pooled estimates for standardizedSolution() est <- getMethod("coef", "OLDlavaan.mi")(object, omit.imps = omit.imps) ## updates @Model@GLIST for standardizedSolution(..., GLIST=) object@Model <- lavaan::lav_model_set_parameters(object@Model, x = est) } if ("std.lv" %in% standardized) { PE$std.lv[STDs] <- lavaan::standardizedSolution(object, se = FALSE, type = "std.lv", GLIST = object@Model@GLIST, est = PE$est)$est.std } if ("std.all" %in% standardized) { PE$std.all[STDs] <- lavaan::standardizedSolution(object, se = FALSE, type = "std.all", GLIST = object@Model@GLIST, est = PE$est)$est.std } if ("std.nox" %in% standardized) { PE$std.nox[STDs] <- lavaan::standardizedSolution(object, se = FALSE, type = "std.nox", GLIST = object@Model@GLIST, est = PE$est)$est.std } if (fmi) { PE$fmi[free] <- Bm[free] / Tot[free] PE$riv[free] <- Bm[free] / W[free] # (Enders, 2010, p. 226, eq. 8.10) # == PE$riv[free] <- PE$fmi1[free] / (1 - PE$fmi1[free]) messRIV <- paste("The RIV will exceed 1 whenever between-imputation", "variance exceeds within-imputation variance", "(when FMI(1) > 50%).\n\n") } ## fancy or not? if (output == "text") { PE$label <- PT$label #FIXME: no longer needed? PE$exo <- 0L class(PE) <- c("lavaan.parameterEstimates","lavaan.data.frame","data.frame") attr(PE, "categorical") <- lavoptions$categorical attr(PE, "parameterization") <- lavoptions$parameterization attr(PE, "information") <- lavoptions$information[1] attr(PE, "information.meat") <- lavoptions$information.meat attr(PE, "se") <- lavoptions$se attr(PE, "group.label") <- lavListInspect(object, "group.label") attr(PE, "level.label") <- c("within", lavListInspect(object, "cluster")) attr(PE, "bootstrap") <- lavoptions$bootstrap attr(PE, "bootstrap.successful") <- 0L #FIXME: assumes none. Implement Wei & Fan's mixing method? attr(PE, "missing") <- lavoptions$missing attr(PE, "observed.information") <- lavoptions$observed.information[1] attr(PE, "h1.information") <- lavoptions$h1.information[1] attr(PE, "h1.information.meat") <- lavoptions$h1.information.meat attr(PE, "header") <- header # FIXME: lavaan may add more!! if (fmi) cat("\n", messRIV, sep = "") } else { PE$exo <- NULL class(PE) <- c("lavaan.data.frame","data.frame") } ## requested R-squared? endoNames <- c(lavNames(object, "ov.nox"), lavNames(object, "lv.nox")) if (rsquare & length(endoNames)) { isEndo <- sapply(PE$lhs, function(x) x %in% endoNames) rsqPE <- PE[PE$lhs == PE$rhs & PE$op == "~~" & isEndo, ] rsqPE$op <- "r2" for (i in which(!sapply(colnames(PE), function(x) x %in% c("lhs","op","rhs","block", "level","group","est","exo")))) { rsqPE[ , i] <- NA } STD <- lavaan::standardizedSolution(object, se = FALSE, type = "std.all", GLIST = object@Model@GLIST, est = PE$est) isEndoSTD <- sapply(STD$lhs, function(x) x %in% endoNames) std.all <- STD$est.std[STD$lhs == STD$rhs & STD$op == "~~" & isEndoSTD] rsqPE$est <- ifelse(std.all < 0, NA, 1 - std.all) # negative variances if (output == "text") rsqPE$label <- "" PE <- rbind(PE, rsqPE) } if (output == "data.frame") PE <- PE[!(PE$op %in% c("==","<",">")), ] rownames(PE) <- NULL if (output == "text") { getMethod("show", "OLDlavaan.mi")(object) cat(messPool) } if (fit.measures) { indices <- c("chisq","df","pvalue","cfi","tli","rmsea","srmr") FITS <- suppressWarnings(fitMeasures(object, fit.measures = indices, output = "text", ...)) try(print(FITS, add.h0 = TRUE), silent = TRUE) } PE } ##' @name OLDlavaan.mi-class ##' @aliases summary,OLDlavaan.mi-method ##' @export setMethod("summary", "OLDlavaan.mi", summary_OLDlavaan.mi) ##' @name OLDlavaan.mi-class ##' @aliases nobs,OLDlavaan.mi-method ##' @importFrom lavaan lavListInspect ##' @export setMethod("nobs", "OLDlavaan.mi", function(object, total = TRUE) { if (total) return(lavListInspect(object, "ntotal")) #FIXME: cluster N for multilevel? N <- lavListInspect(object, "norig") if (length(N) > 1L) names(N) <- lavListInspect(object, "group.label") N }) ##' @importFrom lavaan parTable coef_OLDlavaan.mi <- function(object, type = "free", labels = TRUE, omit.imps = c("no.conv","no.se")) { useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) PT <- parTable(object) if (type == "user" || type == "all") { type <- "user" idx <- 1:length(PT$lhs) } else if (type == "free") { ## FIXME: duplicated leftover from old way of handling EQ constraints? idx <- which(PT$free > 0L & !duplicated(PT$free)) } ## extract coefficients for converged models coefList <- lapply(object@ParTableList[useImps], "[[", i = "est") out <- colMeans(do.call(rbind, coefList))[idx] ## attach names, set class if (labels) names(out) <- lavaan::lav_partable_labels(PT, type = type) class(out) <- c("lavaan.vector","numeric") out } ##' @name OLDlavaan.mi-class ##' @aliases coef,OLDlavaan.mi-method ##' @export setMethod("coef", "OLDlavaan.mi", coef_OLDlavaan.mi) ##' @importFrom stats cov ##' @importFrom lavaan lavListInspect parTable vcov_OLDlavaan.mi <- function(object, type = c("pooled","between","within","ariv"), scale.W = TRUE, omit.imps = c("no.conv","no.se")) { useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) if (lavListInspect(object, "options")$se == "none") { warning('requested se="none", so only between-imputation (co)variance can', ' be computed') type <- "between" } type <- tolower(type[1]) if (!(type %in% c("pooled","between","within","ariv"))) stop("'", type, "' is not a valid option for 'type'") PT <- parTable(object) ncon <- sum(PT$op == "==") npar <- max(PT$free) - ncon coefList <- lapply(object@ParTableList[useImps], "[[", i = "est") B <- cov(do.call(rbind, coefList)[ , PT$free > 0L & !duplicated(PT$free)]) class(B) <- c("lavaan.matrix.symmetric","matrix") rownames(B) <- colnames(B) <- lavaan::lav_partable_labels(PT, type = "free") if (type == "between") return(B) W <- Reduce("+", lapply(object@vcovList[useImps], function(x) x$vcov)) / m class(W) <- c("lavaan.matrix.symmetric","matrix") dimnames(W) <- dimnames(B) if (type == "within") return(W) ## check whether equality constraints prevent inversion of W if (scale.W || type == "ariv") { inv.W <- if (ncon == 0) try(solve(W), silent = TRUE) else MASS::ginv(W) if (inherits(inv.W, "try-error")) { if (ncon == 0) { warning("Could not invert within-imputation covariance matrix. ", "Generalized inverse used instead.\nIt may be ", "safer to set `scale.W = FALSE' (and `asymptotic = TRUE').") } inv.W <- MASS::ginv(W) } ## relative increase in variance due to missing data r <- (1 + 1/m)/npar * sum(diag(B %*% inv.W)) # Enders (2010, p. 235) eqs. 8.20-21 if (type == "ariv") return(r) Total <- (1 + r) * W # FIXME: asked Yves for a hack, says it can't be inverted back to infoMat } else { ## less reliable, but constraints prevent inversion of W Total <- W + B + (1/m)*B ## Enders (2010, p. 235) eq. 8.19 } ## return pooled variance Total } ##' @name OLDlavaan.mi-class ##' @aliases vcov,OLDlavaan.mi-method ##' @export setMethod("vcov", "OLDlavaan.mi", vcov_OLDlavaan.mi) ##' @importFrom lavaan lavListInspect lavTestLRT anova_OLDlavaan.mi <- function(object, ...) { ## save model names objname <- deparse(substitute(object)) dotnames <- as.character(sapply(substitute(list(...))[-1], deparse)) ## check class if (!inherits(object, "OLDlavaan.mi")) stop("object is not class 'OLDlavaan.mi'") ## check for additional arguments dots <- list(...) if (length(dots)) { ## separate OLDlavaan.mi objects from other lavTestLRT.mi() arguments idx.mi <- which(sapply(dots, inherits, what = "OLDlavaan.mi")) if (length(idx.mi)) { mods <- dots[idx.mi] dots <- dots[-idx.mi] ## save names for mods, so compareFit() doesn't break modnames <- dotnames[idx.mi] nonames <- which(names(mods) == "") names(mods)[nonames] <- modnames[nonames] } else { mods <- NULL modnames <- NULL } LRT.names <- intersect(names(dots), union(names(formals(lavTestLRT)), names(formals(lavTestLRT.mi)))) dots <- if (length(LRT.names)) dots[LRT.names] else NULL if (!is.null(dots$h1)) { #FIXME: this shouldn't be necessary: mods <- c(mods, list(h1 = dots$h1)) dots$h1 <- NULL } } else mods <- NULL ## run compareFit if length(idx.mi) > 1L if (length(mods) == 0L) { argList <- c(list(object = object), dots) results <- do.call(lavTestLRT.mi, argList) } else if (length(mods) == 1L) { argList <- c(list(object = object, h1 = mods[[1]]), dots) results <- do.call(lavTestLRT.mi, argList) } else if (length(mods) > 1L) { modList <- c(list(object), mods) names(modList) <- c(objname, modnames) argList <- c(modList, list(argsLRT = dots, indices = FALSE)) results <- do.call(compareFit, argList)@nested class(results) <- c("lavaan.data.frame","data.frame") attr(results, "header") <- "Nested Model Comparisons:" } results } ##' @name OLDlavaan.mi-class ##' @aliases anova,OLDlavaan.mi-method ##' @export setMethod("anova", "OLDlavaan.mi", anova_OLDlavaan.mi) ##' @importFrom lavaan lavListInspect lavNames ##' @importFrom methods getMethod ## utility function called within fitMeasures.mi() getSRMR <- function(object, type = "cor.bentler", level = "within", include.mean = TRUE, omit.imps = c("no.conv","no.se")) { conditional.x <- lavListInspect(object, "options")$conditional.x include.mean <- include.mean && lavListInspect(object, "meanstructure") include.diag <- type %in% c("cor.bentler","raw") mplus <- type == "mplus" if (mplus) type <- "cor.bollen" ## how many blocks to loop over nG <- lavListInspect(object, "ngroups") nlevels <- lavListInspect(object, "nlevels") ## save relevant sample sizes if (nlevels > 1L && level != "within") { n.per.group <- lavListInspect(object, "nclusters") #FIXME: only works for 2 levels N <- sum(n.per.group) } else { n.per.group <- lavListInspect(object, "nobs") N <- lavListInspect(object, "ntotal") } ## grab residuals R <- getMethod("resid", "OLDlavaan.mi")(object, type = type, omit.imps = omit.imps) if (mplus) Rd <- getMethod("resid", "OLDlavaan.mi")(object, type = "cor.bentler", omit.imps = omit.imps) ## restructure, if necessary if (nG == 1L) { loopBlocks <- 1L ## extract relevant level if (nlevels > 1L) { R <- R[[level]] if (mplus) Rd <- Rd[[level]] } ## to loop over blocks R <- list(R) if (mplus) Rd <- list(Rd) ## multiple groups AND multilevel } else if (nlevels > 1L) { loopBlocks <- 2*(1:nG) if (level == "within") loopBlocks <- loopBlocks - 1L R <- R[loopBlocks] if (mplus) Rd <- Rd[loopBlocks] } else loopBlocks <- 1:nG # no restructure necessary for multigroup 1-level models ## store vector of squared residuals RR <- vector("list", nG) for (b in loopBlocks) { index <- if (conditional.x) "res.cov" else "cov" RR[[b]] <- R[[b]][[index]][lower.tri(R[[b]][[index]], diag = FALSE)]^2 ## only capture means/variances of numeric modeled variables (not conditional.x) vv <- intersect(lavNames(object, type = "ov.num", block = b), lavNames(object, type = "ov.model", block = b)) if (include.diag) RR[[b]] <- c(RR[[b]], diag(R[[b]][[index]])[vv]^2) if (mplus) RR[[b]] <- c(RR[[b]], diag(Rd[[b]][[index]])[vv]^2) if (include.mean) { index <- if (conditional.x) "res.int" else "mean" RR[[b]] <- c(RR[[b]], R[[b]][[index]][vv]^2) } } ## take weighted average of group means as.numeric( (n.per.group %*% sqrt(sapply(RR, mean))) / N ) } ##' @importFrom lavaan lavNames lavListInspect ##' @importFrom stats pchisq uniroot fitMeasures_OLDlavaan.mi <- function(object, fit.measures = "all", baseline.model = NULL, output = "vector", omit.imps = c("no.conv","no.se"), ...) { useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) lavoptions <- lavListInspect(object, "options") fit.measures <- tolower(fit.measures) if (length(fit.measures) == 0L) fit.measures <- "all" ## narrow down fit indices incremental <- c("cfi","tli","nnfi","rfi","nfi","pnfi","ifi","rni") if ("all" %in% fit.measures) { indices <- c("chisq","df","pvalue","scaling", incremental, "rmsea","rmr","mfi","gammahat") } else { indices <- grep(pattern = paste(c("chisq","df","pvalue","scaling", incremental, "mfi","rmsea", "gammahat","rmr"), collapse = "|"), x = fit.measures, ignore.case = TRUE, value = TRUE) } ## CHI-SQUARED-BASED FIT INDICES notest <- length(lavoptions$test) == 1L && lavoptions$test == "none" if (notest || any(!grepl(pattern = "rmr", x = indices))) { ## check for additional arguments dots <- list(...) if (length(dots)) { LRT.names <- intersect(names(dots), union(names(formals(lavTestLRT)), names(formals(lavTestLRT.mi)))) dots <- if (length(LRT.names)) dots[LRT.names] else list(asymptotic = TRUE) } else dots <- list(asymptotic = TRUE) ## check test options (adapted from lavTestLRT.mi, limits duplicate warnings) test <- dots$test if (is.null(test)) { test <- "d3" # default } else test <- tolower(test[1]) if (tolower(test) %in% c("mr","meng.rubin","likelihood","lrt","mplus","d3")) test <- "D3" if (tolower(test) %in% c("lmrr","li.et.al","pooled.wald","d2")) test <- "D2" if (test == "D3" && !lavoptions$estimator %in% c("ML","PML","FML")) { message('"D3" only available using maximum likelihood estimation. ', 'Changed test to "D2".') test <- "D2" } ## check for robust test.names <- lavoptions$test # lavaan 0.6-5: for now, we only acknowledge the first non-standard @test if (length(test.names) > 1L) { ## remove standard and any bootstrapped tests rm.idx <- which(test.names %in% c("standard","bootstrap","bollen.stine")) if (length(rm.idx) > 0L) { test.names <- test.names[-rm.idx] } ## only acknowledge the first scaled test statistic if (length(test.names) > 1L) { test.names <- test.names[1] } } robust <- any(test.names %in% c("satorra.bentler","yuan.bentler", "yuan.bentler.mplus","scaled.shifted", "mean.var.adjusted","satterthwaite")) if (robust) { ## assign pool.robust option to object if (is.null(dots$pool.robust)) { pool.robust <- formals(lavTestLRT.mi)$pool.robust # default value } else { pool.robust <- dots$pool.robust # user-specified value } } else dots$pool.robust <- pool.robust <- FALSE scaleshift <- any(test.names == "scaled.shifted") if (scaleshift) { if (test == "D3") { message("If test = 'scaled.shifted' (estimator = 'WLSMV' or 'MLMV'), ", "model evaluation is only available by (re)setting .", "test = 'D2'.\nControl more options by passing arguments to ", "lavTestLRT() via the '...' argument.\n") test <- 'D2' } } if (pool.robust && test == "D3") { message('pool.robust = TRUE is only applicable when test = "D2". ', 'Changed test to "D2".') test <- "D2" } dots$test <- test ## pooled test statistic(s) argList <- c(list(object = object), dots) argList$asymptotic <- TRUE # in case it wasn't set in list(...) argList$omit.imps <- omit.imps out <- do.call(lavTestLRT.mi, argList) ## check for scaled test statistic (if not, set robust=FALSE) if (robust && is.na(out["chisq.scaled"])) robust <- FALSE ## fit baseline model if necessary if (any(indices %in% incremental)) { if (inherits(baseline.model, "OLDlavaan.mi")) { baseFit <- baseline.model } else if (inherits(object@external$baseline.model, "OLDlavaan.mi")) { baseFit <- object@external$baseline.model ## MUST fit PTb for "D3" likelihoods, but for "D2" use @baselineList } else if (test == "D2") { ## length(baseImps) == m, not just length(useImps) baseImps <- object@meta$baseline.ok if (!all(baseImps[useImps])) warning('The default independence model ', 'did not converge for data set(s): ', which(!baseImps)) ## only use imputations that converged for both baseImps <- intersect(useImps, which(baseImps)) w <- sapply(object@baselineList[baseImps], function(x) x$test$standard[["stat"]]) if (is.list(w)) { #TODO: figure out why this happens! w <- unlist(w) DF <- mean(unlist(sapply(object@baselineList[baseImps], function(x) x$test$standard[["df"]]))) } else { DF <- mean(sapply(object@baselineList[baseImps], function(x) x$test$standard[["df"]])) } baseOut <- calculate.D2(w, DF, asymptotic = TRUE) if (robust) { if (pool.robust) { w.r <- sapply(object@baselineList[baseImps], function(x) x$test[[ test.names[1] ]][["stat"]]) if (is.list(w.r)) { w.r <- unlist(w.r) DF.r <- mean(unlist(sapply(object@baselineList[baseImps], function(x) x$test[[ test.names[1] ]][["df"]]))) } else { DF.r <- mean(sapply(object@baselineList[baseImps], function(x) x$test[[ test.names[1] ]][["df"]])) } base.robust <- calculate.D2(w.r, DF.r, asymptotic = TRUE) names(base.robust) <- paste0(names(base.robust), ".scaled") baseOut <- c(baseOut, base.robust) } else { baseOut <- robustify(ChiSq = baseOut, object = object, baseline = TRUE, useImps = baseImps) } } baseFit <- NULL # for later checking, to avoid unnecessary calls } else { PTb <- object@baselineList[[ useImps[1] ]]$partable PTb[c("est","se")] <- NULL # FIXME: shouldn't need this line, but lav_partable_merge() fails when # lavaan:::lav_object_extended() returns a NULL slot instead of "plabel" PTb$plabel <- paste0(".p", PTb$id, ".") group <- lavListInspect(object, "group") if (length(group) == 0L) group <- NULL cluster <- lavListInspect(object, "cluster") if (length(cluster) == 0L) cluster <- NULL baseFit <- runMI(model = PTb, data = object@DataList[useImps], group = group, cluster = cluster, test = lavoptions$test, estimator = lavoptions$estimator, fixed.x = lavoptions$fixed.x, se = "none", # to save time conditional.x = lavoptions$conditional.x, ordered = lavListInspect(object, "ordered"), parameterization = lavoptions$parameterization) } if (!is.null(baseFit)) { ## length(baseImps) is only as long as length(useImps), not the original m baseImps <- sapply(baseFit@convergence, "[[", i = "converged") if (!all(baseImps)) warning('baseline.model did not converge for data set(s): ', useImps[!baseImps]) argList <- c(list(object = baseFit), dots) argList$asymptotic <- TRUE # in case it wasn't set in list(...) argList$omit.imps <- setdiff(omit.imps, "no.se") # se="none" in baseFit baseOut <- do.call(lavTestLRT.mi, argList) } # else { already used "D2" with @baselineList info to make baseOut } } X2 <- out[["chisq"]] DF <- out[["df"]] if (robust) { X2.sc <- out[["chisq.scaled"]] DF.sc <- out[["df.scaled"]] ## for mean.var.adjusted, mean DF across imputations if (!pool.robust) ch <- out[["chisq.scaling.factor"]] ## mean c_hat across imputations if (X2 < .Machine$double.eps && DF == 0) ch <- 0 ## for RMSEA if ("rmsea" %in% indices) { d <- mean(sapply(object@testList[useImps], function(x) sum(x[[ test.names[1] ]][["trace.UGamma"]]))) if (is.na(d) || d == 0) d <- NA # FIXME: only relevant when mean.var.adjusted? } } ## for CFI, TLI, etc. if (any(indices %in% incremental)) { bX2 <- baseOut[["chisq"]] bDF <- baseOut[["df"]] out <- c(out, baseline.chisq = bX2, baseline.df = bDF, baseline.pvalue = baseOut[["pvalue"]]) if (robust) { out["baseline.chisq.scaled"] <- bX2.sc <- baseOut[["chisq.scaled"]] out["baseline.df.scaled"] <- bDF.sc <- baseOut[["df.scaled"]] out["baseline.pvalue.scaled"] <- baseOut[["pvalue.scaled"]] if (!pool.robust) { cb <- baseOut[["chisq.scaling.factor"]] out["baseline.chisq.scaling.factor"] <- cb if (scaleshift) out["baseline.chisq.shift.parameters"] <- baseOut[["chisq.shift.parameters"]] } } } if ("cfi" %in% indices) { t1 <- max(X2 - DF, 0) t2 <- max(X2 - DF, bX2 - bDF, 0) out["cfi"] <- if(t1 == 0 && t2 == 0) 1 else 1 - t1/t2 if (robust) { ## scaled t1 <- max(X2.sc - DF.sc, 0) t2 <- max(X2.sc - DF.sc, bX2.sc - bDF.sc, 0) if (is.na(t1) || is.na(t2)) { out["cfi.scaled"] <- NA } else if (t1 == 0 && t2 == 0) { out["cfi.scaled"] <- 1 } else out["cfi.scaled"] <- 1 - t1/t2 ## Brosseau-Liard & Savalei MBR 2014, equation 15 if (!pool.robust & test.names[1] %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) { t1 <- max(X2 - ch*DF, 0) t2 <- max(X2 - ch*DF, bX2 - cb*bDF, 0) if (is.na(t1) || is.na(t2)) { out["cfi.robust"] <- NA } else if (t1 == 0 && t2 == 0) { out["cfi.robust"] <- 1 } else out["cfi.robust"] <- 1 - t1/t2 } } } if ("rni" %in% indices) { t1 <- X2 - DF t2 <- bX2 - bDF out["rni"] <- if (t2 == 0) NA else 1 - t1/t2 if (robust) { ## scaled t1 <- X2.sc - DF.sc t2 <- bX2.sc - bDF.sc if (is.na(t1) || is.na(t2)) { out["rni.scaled"] <- NA } else if (t2 == 0) { out["rni.scaled"] <- NA } else out["rni.scaled"] <- 1 - t1/t2 ## Brosseau-Liard & Savalei MBR 2014, equation 15 if (!pool.robust & test.names[1] %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) { t1 <- X2 - ch*DF t2 <- bX2 - cb*bDF if (is.na(t1) || is.na(t2)) { out["rni.robust"] <- NA } else if (t1 == 0 && t2 == 0) { out["rni.robust"] <- NA } else out["rni.robust"] <- 1 - t1/t2 } } } if (any(indices %in% c("tli","nnfi"))) { t1 <- (X2 - DF)*bDF t2 <- (bX2 - bDF)*DF out["tli"] <- out["nnfi"] <- if (DF > 0) 1 - t1/t2 else 1 if (robust) { ## scaled t1 <- (X2.sc - DF.sc)*bDF.sc t2 <- (bX2.sc - bDF.sc)*DF.sc if (is.na(t1) || is.na(t2)) { out["tli.scaled"] <- out["nnfi.scaled"] <- NA } else if (DF > 0 && t2 != 0) { out["tli.scaled"] <- out["nnfi.scaled"] <- 1 - t1/t2 } else { out["tli.scaled"] <- out["nnfi.scaled"] <- 1 } ## Brosseau-Liard & Savalei MBR 2014, equation 15 if (!pool.robust & test.names[1] %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) { t1 <- (X2 - ch*DF)*bDF t2 <- (bX2 - cb*bDF)*DF if (is.na(t1) || is.na(t2)) { out["tli.robust"] <- out["nnfi.robust"] <- NA } else if (t1 == 0 && t2 == 0) { out["tli.robust"] <- out["nnfi.robust"] <- 1 - t1/t2 } else out["tli.robust"] <- out["nnfi.robust"] <- 1 } } } if ("rfi" %in% indices) { if (DF > 0) { t2 <- bX2 / bDF t1 <- t2 - X2/DF out["rfi"] <- if (t1 < 0 || t2 < 0) 1 else t1/t2 } else out["rfi"] <- 1 if (robust) { if (DF > 0) { t2 <- bX2.sc / bDF.sc t1 <- t2 - X2.sc/DF.sc out["rfi.scaled"] <- if (t1 < 0 || t2 < 0) 1 else t1/t2 } else out["rfi.scaled"] <- 1 } } if ("nfi" %in% indices) { if (DF > 0) { t1 <- bX2 - X2 t2 <- bX2 out["nfi"] <- t1 / t2 } else out["nfi"] <- 1 if (robust) out["nfi.scaled"] <- (bX2.sc - X2.sc) / bX2.sc } if ("pnfi" %in% indices) { t1 <- bX2 - X2 t2 <- bX2 out["pnfi"] <- (DF / bDF) * t1/t2 if (robust) { t1 <- bX2.sc - X2.sc t2 <- bX2.sc out["pnfi.scaled"] <- (DF / bDF) * t1/t2 } } if ("ifi" %in% indices) { t1 <- bX2 - X2 t2 <- bX2 - DF out["ifi"] <- if (t2 < 0) 1 else t1/t2 if (robust) { t1 <- bX2.sc - X2.sc t2 <- bX2.sc - DF.sc if (is.na(t2)) { out["ifi.scaled"] <- NA } else if (t2 < 0) { out["ifi.scaled"] <- 1 } else out["ifi.scaled"] <- t1/t2 } } N <- lavListInspect(object, "ntotal") Ns <- lavListInspect(object, "nobs") # N per group nG <- lavListInspect(object, "ngroups") nVars <- length(lavNames(object)) if (!(lavoptions$likelihood == "normal" | lavoptions$estimator %in% c("ML","PML","FML"))) { N <- N - nG Ns <- Ns - 1 } if ("mfi" %in% indices) { out["mfi"] <- exp(-0.5 * (X2 - DF) / N) } if ("rmsea" %in% indices) { N.RMSEA <- max(N, X2*4) # FIXME: good strategy?? if (is.na(X2) || is.na(DF)) { out["rmsea"] <- as.numeric(NA) } else if (DF > 0) { getLambda <- function(lambda, chi, df, p) pchisq(chi, df, ncp=lambda) - p out["rmsea"] <- sqrt( max(0, (X2/N)/DF - 1/N) ) * sqrt(nG) ## lower confidence limit if (getLambda(0, X2, DF, .95) < 0.0) out["rmsea.ci.lower"] <- 0 else { lambda.l <- try(uniroot(f = getLambda, chi = X2, df = DF, p = .95, lower = 0, upper = X2)$root, silent = TRUE) if (inherits(lambda.l, "try-error")) lambda.l <- NA out["rmsea.ci.lower"] <- sqrt( lambda.l/(N*DF) ) * sqrt(nG) } ## upper confidence limit if (getLambda(N.RMSEA, X2, DF, .05) > 0 || getLambda(0, X2, DF, .05) < 0) { out["rmsea.ci.upper"] <- 0 } else { lambda.u <- try(uniroot(f = getLambda, chi = X2, df = DF, p = .05, lower = 0, upper = N.RMSEA)$root, silent = TRUE) if (inherits(lambda.u, "try-error")) lambda.u <- NA out["rmsea.ci.upper"] <- sqrt( lambda.u/(N*DF) ) * sqrt(nG) } ## p value out["rmsea.pvalue"] <- pchisq(X2, DF, ncp = N*DF*0.05^2/nG, lower.tail = FALSE) ## Scaled versions (naive and robust) if (robust & !scaleshift) { ## naive out["rmsea.scaled"] <- sqrt( max(0, (X2/N)/d - 1/N) ) * sqrt(nG) ## lower confidence limit if (DF < 1 || d < 1 || getLambda(0, X2, d, .95) < 0.0) { out["rmsea.ci.lower.scaled"] <- 0 } else { lambda.l <- try(uniroot(f = getLambda, chi = X2, df = d, p = .95, lower = 0, upper = X2)$root, silent = TRUE) if (inherits(lambda.l, "try-error")) lambda.l <- NA out["rmsea.ci.lower.scaled"] <- sqrt( lambda.l/(N*DF) ) * sqrt(nG) } ## upper confidence limit if (DF < 1|| d < 1 || getLambda(0, X2, d, .95) < 0.0 || getLambda(N.RMSEA, X2, d, .05) > 0.0) { out["rmsea.ci.upper.scaled"] <- 0 } else { lambda.u <- try(uniroot(f = getLambda, chi = X2, df = d, p = .05, lower = 0, upper = N.RMSEA)$root, silent = TRUE) if (inherits(lambda.u, "try-error")) lambda.u <- NA out["rmsea.ci.upper.scaled"] <- sqrt( lambda.u/(N*DF) ) * sqrt(nG) } ## p value out["rmsea.pvalue.scaled"] <- pchisq(X2, d, ncp = N*d*0.05^2/nG, lower.tail = FALSE) if (!pool.robust & test.names[1] %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) { ## robust out["rmsea.robust"] <- sqrt( max(0, (X2/N)/DF - ch/N ) ) * sqrt(nG) ## lower confidence limit if (DF.sc < 1 | getLambda(0, X2.sc, DF.sc, .95) < 0.0) { out["rmsea.ci.lower.robust"] <- 0 } else { lambda.l <- try(uniroot(f = getLambda, chi = X2.sc, df = DF.sc, p = .95, lower = 0, upper = X2.sc)$root, silent = TRUE) if (inherits(lambda.l, "try-error")) lambda.l <- NA out["rmsea.ci.lower.robust"] <- sqrt( (ch*lambda.l)/(N*DF.sc) ) * sqrt(nG) } ## upper confidence limit if (DF.sc < 1 | getLambda(N.RMSEA, X2.sc, DF.sc, .05) > 0.0) { out["rmsea.ci.upper.robust"] <- 0 } else { lambda.u <- try(uniroot(f = getLambda, chi = X2.sc, df = DF.sc, p = .05, lower = 0, upper = N.RMSEA)$root, silent = TRUE) if (inherits(lambda.u, "try-error")) lambda.u <- NA out["rmsea.ci.upper.robust"] <- sqrt( (ch*lambda.u)/(N*DF.sc) ) * sqrt(nG) } ## p value ########## To be discovered? } } else if (robust & scaleshift) { ## naive only out["rmsea.scaled"] <- sqrt( max(0, (X2.sc/N)/DF - 1/N) ) * sqrt(nG) ## lower confidence limit if (DF < 1 | getLambda(0, X2.sc, DF, .95) < 0.0) { out["rmsea.ci.lower.scaled"] <- 0 } else { lambda.l <- try(uniroot(f = getLambda, chi = X2.sc, df = DF, p = .95, lower = 0, upper = X2.sc)$root, silent = TRUE) if (inherits(lambda.l, "try-error")) lambda.l <- NA out["rmsea.ci.lower.scaled"] <- sqrt( lambda.l/(N*DF) ) * sqrt(nG) } ## upper confidence limit if (DF < 1 | getLambda(N.RMSEA, X2.sc, DF, .05) > 0.0) { out["rmsea.ci.upper.scaled"] <- 0 } else { lambda.u <- try(uniroot(f = getLambda, chi = X2.sc, df = DF, p = .05, lower = 0, upper = N.RMSEA)$root, silent = TRUE) if (inherits(lambda.u, "try-error")) lambda.u <- NA out["rmsea.ci.upper.scaled"] <- sqrt( lambda.u/(N*DF) ) * sqrt(nG) } ## p value out["rmsea.pvalue.scaled"] <- pchisq(X2.sc, DF, ncp = N*DF*0.05^2/nG, lower.tail = FALSE) } } } if ("gammahat" %in% indices) { out["gammaHat"] <- nVars / (nVars + 2*((X2 - DF) / N)) out["adjGammaHat"] <- 1 - (((nG * nVars * (nVars + 1)) / 2) / DF) * (1 - out["gammaHat"]) if (robust) { out["gammaHat.scaled"] <- nVars / (nVars + 2*((X2.sc - DF.sc) / N)) out["adjGammaHat.scaled"] <- 1 - (((nG * nVars * (nVars + 1)) / 2) / DF.sc) * (1 - out["gammaHat.scaled"]) } } ## END CHI-SQUARED-BASED FIT INDICES } else out <- numeric(0) ## RESIDUALS-BASED FIT INDICES if (any(grepl(pattern = "rmr", x = indices))) { if (lavListInspect(object, "nlevels") > 1L) { out["srmr"] <- NA # to preserve the order in lavaan output out["srmr_within"] <- getSRMR(object, type = "cor", include.mean = FALSE, level = "within", omit.imps = omit.imps) out["srmr_between"] <- getSRMR(object, type = "cor", include.mean = FALSE, level = lavListInspect(object, "cluster"), omit.imps = omit.imps) out["srmr"] <- out["srmr_within"] + out["srmr_between"] } else { out["rmr"] <- getSRMR(object, type = "raw", include.mean = TRUE, omit.imps = omit.imps) out["rmr_nomean"] <- getSRMR(object, type = "raw", include.mean = FALSE, omit.imps = omit.imps) out["srmr_bentler"] <- out["srmr"] <- getSRMR(object, type = "cor.bentler", include.mean = TRUE, omit.imps = omit.imps) out["srmr_bentler_nomean"] <- getSRMR(object, type = "cor.bentler", include.mean = FALSE, omit.imps = omit.imps) out["crmr"] <- getSRMR(object, type = "cor.bollen", include.mean = TRUE, omit.imps = omit.imps) out["crmr_nomean"] <- getSRMR(object, type = "cor.bollen", include.mean = FALSE, omit.imps = omit.imps) out["srmr_mplus"] <- getSRMR(object, type = "mplus", include.mean = TRUE, omit.imps = omit.imps) out["srmr_mplus_nomean"] <- getSRMR(object, type = "mplus", include.mean = FALSE, omit.imps = omit.imps) } ## END RESIDUALS-BASED FIT INDICES } ## return requested measures (loosely matched) if ("all" %in% fit.measures) { fits <- out } else { fits <- out[grepl(pattern = paste(fit.measures, collapse = "|"), x = names(out), ignore.case = TRUE)] fits <- fits[which(!is.na(names(fits)))] } class(fits) <- c("lavaan.vector","numeric") if (output == "text") class(fits) <- c("lavaan.fitMeasures", class(fits)) fits } ##' @name OLDlavaan.mi-class ##' @aliases fitMeasures,OLDlavaan.mi-method ##' @importFrom lavaan fitMeasures ##' @export setMethod("fitMeasures", "OLDlavaan.mi", fitMeasures_OLDlavaan.mi) ## lowercase 'm' ##' @name OLDlavaan.mi-class ##' @aliases fitmeasures,OLDlavaan.mi-method ##' @importFrom lavaan fitmeasures ##' @export setMethod("fitmeasures", "OLDlavaan.mi", fitMeasures_OLDlavaan.mi) ##' @importFrom lavaan lavListInspect lavNames ##' @importFrom methods getMethod fitted_OLDlavaan.mi <- function(object, omit.imps = c("no.conv","no.se")) { useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) ## how many blocks to loop over nG <- lavListInspect(object, "ngroups") nlevels <- lavListInspect(object, "nlevels") nBlocks <- nG * nlevels #FIXME: always? group.label <- if (nG > 1L) lavListInspect(object, "group.label") else NULL clus.label <- if (nlevels > 1L) c("within", lavListInspect(object, "cluster")) else NULL if (nBlocks > 1L) { block.label <- paste(rep(group.label, each = nlevels), clus.label, sep = if (nG > 1L && nlevels > 1L) "_" else "") } est <- getMethod("coef", "OLDlavaan.mi")(object, omit.imps = omit.imps) setpar <- lavaan::lav_model_set_parameters(object@Model, x = est) impMats <- lavaan::lav_model_implied(setpar) # if (lavListInspect(object, "categorical")) { # th.idx <- lavListInspect(object, "th.idx") # to select $(res.)th # if (nBlocks == 1L) th.idx <- list(th.idx) # to loop over # #FIXME when multilevel accepts categorical # } #TODO: adapt to multilevel, multigroup, or both ## loop over (blocks and) moments Implied <- vector("list", nBlocks) for (b in 1:nBlocks) { for (nm in names(impMats)) { ## skip any empty objects if (is.null(impMats[[nm]][[b]])) next Implied[[b]][[nm]] <- impMats[[nm]][[b]] ## assign names and classes if (nm %in% c("cov","res.cov")) { NAMES <- lavNames(object, type = "ov.model", block = b) dimnames(Implied[[b]][[nm]]) <- list(NAMES, NAMES) class(Implied[[b]][[nm]]) <- c("lavaan.matrix.symmetric","matrix") } else if (nm %in% c("mean","res.int")) { Implied[[b]][[nm]] <- as.numeric(Implied[[b]][[nm]]) # remove matrix names(Implied[[b]][[nm]]) <- lavNames(object, type = "ov.model", block = b) class(Implied[[b]][[nm]]) <- c("lavaan.vector","numeric") } else if (nm %in% c("th","res.th")) { #FIXME: When lavaan allows multilevel categorical, thresholds only ## apply once (not to each level, like for all groups). ## Will lavaan return a vector of zeros for all but "within"? ## If not, it will not exist for each block, so count over groups. Implied[[b]][[nm]] <- as.numeric(Implied[[b]][[nm]]) #[ th.idx[[b]] ] # remove matrix & numeric -means names(Implied[[b]][[nm]]) <- lavNames(object, type = "th", block = b) #FIXME? class(Implied[[b]][[nm]]) <- c("lavaan.vector","numeric") } else if (nm == "group.w") { ## Only for (D)WLS estimation, but when is it relevant? ## For now, assign no names/class ## The remaining only exist when conditional.x } else if (nm %in% c("slopes","res.slopes")) { dimnames(Implied[[b]][[nm]]) <- list(lavNames(object, type = "ov.nox", block = b), lavNames(object, type = "ov.x", block = b)) class(Implied[[b]][[nm]]) <- c("lavaan.matrix","matrix") } else if (nm == "cov.x") { NAMES <- lavNames(object, type = "ov.x", block = b) dimnames(Implied[[b]][[nm]]) <- list(NAMES, NAMES) class(Implied[[b]][[nm]]) <- c("lavaan.matrix.symmetric","matrix") } else if (nm == "mean.x") { Implied[[b]][[nm]] <- as.numeric(Implied[[b]][[nm]]) # remove matrix names(Implied[[b]][[nm]]) <- lavNames(object, type = "ov.x", block = b) class(Implied[[b]][[nm]]) <- c("lavaan.vector","numeric") } ## end loops } } ## drop list for 1 block, or add labels for multiple if (nBlocks == 1L) { Implied <- Implied[[1]] } else names(Implied) <- block.label Implied } ##' @name OLDlavaan.mi-class ##' @aliases fitted,OLDlavaan.mi-method ##' @export setMethod("fitted", "OLDlavaan.mi", fitted_OLDlavaan.mi) ##' @name OLDlavaan.mi-class ##' @aliases fitted.values,OLDlavaan.mi-method ##' @export setMethod("fitted.values", "OLDlavaan.mi", fitted_OLDlavaan.mi) ##' @importFrom lavaan lavListInspect ##' @importFrom methods getMethod ##' @importFrom stats cov2cor resid_OLDlavaan.mi <- function(object, type = c("raw","cor"), omit.imps = c("no.conv","no.se")) { ## @SampleStatsList is (for each imputation) output from: ## getSampStats <- function(obj) lavInspect(obj, "sampstat") useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) ## check type options type <- tolower(type[1]) if (type %in% c("raw","rmr")) { type = "raw" } else if (type %in% c("cor","cor.bollen","crmr")) { type <- "cor.bollen" } else if (type %in% c("cor.bentler","cor.eqs","srmr")) { type <- "cor.bentler" } else stop('type="', type, '" not supported for lavaan.mi objects') ## how many blocks to loop over nG <- lavListInspect(object, "ngroups") nlevels <- lavListInspect(object, "nlevels") nBlocks <- nG * nlevels #FIXME: always? group.label <- if (nG > 1L) lavListInspect(object, "group.label") else NULL clus.label <- if (nlevels > 1L) c("within", lavListInspect(object, "cluster")) else NULL if (nBlocks > 1L) { block.label <- paste(rep(group.label, each = nlevels), clus.label, sep = if (nG > 1L && nlevels > 1L) "_" else "") } if (lavListInspect(object, "categorical")) { th.idx <- lavListInspect(object, "th.idx") # to select $(res.)th if (nBlocks == 1L) th.idx <- list(th.idx) # to loop over #FIXME when multilevel accepts categorical } ## H0-model-implied moments, already pooled ## (moments-list nested in block-list) Implied <- getMethod("fitted", "OLDlavaan.mi")(object, omit.imps = omit.imps) if (nBlocks == 1L) Implied <- list(Implied) # store single block in a block-list ## template to store observed moments & residuals RES <- OBS <- vector("list", nBlocks) ## loop over (blocks and) moments for (b in 1:nBlocks) { for (nm in names(Implied[[b]])) { ## skip if Implied element is not part of the saturated list if (is.null(object@h1List[[ useImps[1] ]]$implied[[nm]][[b]])) next ## H1 (saturated model) implied moments ## (block-list nested in moments-list) momentList <- lapply(object@h1List[useImps], function(x) x$implied[[nm]][[b]]) OBS[[b]][[nm]] <- Reduce("+", momentList) / m #TODO: unnecessary calculation if standardized and nm %in% c("th","slopes") ## remove numeric -means from thresholds if (nm %in% c("th","res.th")) OBS[[b]][[nm]] <- as.numeric(OBS[[b]][[nm]])[ th.idx[[b]] ] ## calculate residuals if (type == "raw") { RES[[b]][[nm]] <- OBS[[b]][[nm]] - Implied[[b]][[nm]] class(RES[[b]][[nm]]) <- class(Implied[[b]][[nm]]) ## correlation residuals } else if (type == "cor.bollen") { if (nm %in% c("cov","res.cov")) { RES[[b]][[nm]] <- cov2cor(OBS[[b]][[nm]]) - cov2cor(Implied[[b]][[nm]]) class(RES[[b]][[nm]]) <- c("lavaan.matrix.symmetric","matrix") ## mean structure } else if (nm == "mean") { std.obs.M <- OBS[[b]][[nm]] / sqrt(diag(OBS[[b]]$cov)) std.mod.M <- Implied[[b]][[nm]] / sqrt(diag(Implied[[b]]$cov)) RES[[b]][[nm]] <- std.obs.M - std.mod.M class(RES[[b]][[nm]]) <- c("lavaan.vector","numeric") } else if (nm == "res.int") { std.obs.M <- OBS[[b]][[nm]] / sqrt(diag(OBS[[b]]$res.cov)) std.mod.M <- Implied[[b]][[nm]] / sqrt(diag(Implied[[b]]$res.cov)) RES[[b]][[nm]] <- std.obs.M - std.mod.M class(RES[[b]][[nm]]) <- c("lavaan.vector","numeric") ## thresholds, slopes, cov.x, mean.x } else { #FIXME: lavaan currently (0.6-4.1399) returns nothing next } ## standardized (by observed SDs) residuals } else if (type == "cor.bentler") { if (nm %in% c("cov","mean")) { SDs <- diag(sqrt(diag(OBS[[b]]$cov))) dimnames(SDs) <- dimnames(OBS[[b]][[nm]]) } else if (nm %in% c("res.cov","res.int")) { SDs <- diag(sqrt(diag(OBS[[b]]$res.cov))) dimnames(SDs) <- dimnames(OBS[[b]][[nm]]) } else { #FIXME: lavaan currently (0.6-4.1399) returns nothing for "th" or "slopes" next } if (nm %in% c("cov","res.cov")) { RES[[b]][[nm]] <- solve(SDs) %*% (OBS[[b]][[nm]] - Implied[[b]][[nm]]) %*% solve(SDs) class(RES[[b]][[nm]]) <- c("lavaan.matrix.symmetric","matrix") } else if (nm %in% c("mean","res.int")) { RES[[b]][[nm]] <- (OBS[[b]][[nm]] - Implied[[b]][[nm]]) / diag(SDs) class(RES[[b]][[nm]]) <- c("lavaan.vector","numeric") } } ## copy names from fitted() results if (is.null(dim(RES[[b]][[nm]]))) { names(RES[[b]][[nm]]) <- names(Implied[[b]][[nm]]) } else dimnames(RES[[b]][[nm]]) <- dimnames(Implied[[b]][[nm]]) ## end loop over moments } ## add type to beginning of each block's list RES[[b]] <- c(list(type = type), RES[[b]]) #TODO: Rename (res.)cov to (res.)cor? lavResiduals() does not } ## drop list for 1 block if (nBlocks == 1L) { RES <- RES[[1]] } else names(RES) <- block.label #FIXME: will lavaan do this in the future? RES } ##' @name OLDlavaan.mi-class ##' @aliases residuals,OLDlavaan.mi-method ##' @export setMethod("residuals", "OLDlavaan.mi", resid_OLDlavaan.mi) ##' @name OLDlavaan.mi-class ##' @aliases resid,OLDlavaan.mi-method ##' @export setMethod("resid", "OLDlavaan.mi", resid_OLDlavaan.mi) semTools/R/poolMAlloc.R0000644000176200001440000013623614764270100014460 0ustar liggesusers### Authors: ### Jason D. Rights (Vanderbilt University; jason.d.rights@vanderbilt.edu) ### - based on research from/with Sonya Sterba ### - adapted from OLD parcelAllocation() by Corbin Quick and Alexander Schoemann ### - additional "indices" argument added by Terrence D. Jorgensen ### Last updated: 12 March 2025 ##' Combine sampling variability with parcel-allocation variability by ##' pooling results across M parcel-allocations ##' ##' @description ##' This function employs an iterative algorithm to pick the number of random ##' item-to-parcel allocations needed to meet user-defined stability criteria ##' for a fitted structural equation model (SEM) (see **Details** below for ##' more information). Pooled point and standard-error estimates from this SEM ##' can be outputted at this final selected number of allocations (however, it ##' is more efficient to save the allocations and treat them as multiple ##' imputations using [lavaan.mi::lavaan.mi()]; see **See Also** for links with ##' examples). Additionally, new indices (see Sterba & Rights, 2016) are ##' outputted for assessing the relative contributions of parcel-allocation ##' variability vs. sampling variability in each estimate. At each iteration, ##' this function generates a given number of random item-to-parcel allocations, ##' fits a SEM to each allocation, pools estimates across allocations from that ##' iteration, and then assesses whether stopping criteria are met. If stopping ##' criteria are not met, the algorithm increments the number of allocations ##' used (generating all new allocations). ##' ##' @details ##' ##' This function implements an algorithm for choosing the number of allocations ##' (*M*; described in Sterba & Rights, 2016), pools point and ##' standard-error estimates across these *M* allocations, and produces ##' indices for assessing the relative contributions of parcel-allocation ##' variability vs. sampling variability in each estimate. ##' ##' To obtain pooled test statistics for model fit or model comparison, the ##' `list` or parcel allocations can be passed to [lavaan.mi::lavaan.mi()] ##' (find **Examples** on the help pages for [parcelAllocation()] ##' and [PAVranking()]). ##' ##' This function randomly generates a given number (`nAllocStart`) of ##' item-to-parcel allocations, fits a SEM to each allocation, and then ##' increments the number of allocations used (by `nAllocAdd`) until the ##' pooled point and standard-error estimates fulfill stopping criteria ##' (`stopProp` and `stopValue`, defined above). A summary of results ##' from the model that was fit to the *M* allocations are returned. ##' ##' Additionally, this function outputs the proportion of allocations with ##' solutions that converged (using a maximum likelihood estimator) as well as ##' the proportion of allocations with solutions that were converged and proper. ##' The converged and proper solutions among the final *M* allocations are ##' used in computing pooled results. ##' ##' Additionally, after each iteration of the algorithm, information useful in ##' monitoring the algorithm is outputted. The number of allocations used at ##' that iteration, the proportion of pooled parameter estimates meeting ##' stopping criteria at the previous iteration, the proportion of pooled ##' standard errors meeting stopping criteria at the previous iteration, and the ##' runtime of that iteration are outputted. When stopping criteria are ##' satisfied, the full set of results are outputted. ##' ##' For further details on the benefits of the random allocation of items to ##' parcels, see Sterba (2011) and Sterba & MacCallum (2010). ##' ##' @importFrom stats sd pnorm pt qt runif pchisq ##' @importFrom lavaan lavInspect ##' ##' @param nPerPar A list in which each element is a vector, corresponding to ##' each factor, indicating sizes of parcels. If variables are left out of ##' parceling, they should not be accounted for here (i.e., there should not ##' be parcels of size "1"). ##' @param facPlc A list of vectors, each corresponding to a factor, specifying ##' the item indicators of that factor (whether included in parceling or not). ##' Either variable names or column numbers. Variables not listed will not be ##' modeled or included in output datasets. ##' @param nAllocStart The number of random allocations of items to parcels to ##' generate in the first iteration of the algorithm. ##' @param nAllocAdd The number of allocations to add with each iteration of the ##' algorithm. Note that if only one iteration is desired, `nAllocAdd` can ##' be set to \eqn{0} and results will be output for `nAllocStart` ##' allocations only. ##' @param syntax lavaan syntax that defines the model. ##' @param dataset Item-level dataset ##' @param parceloutput Optional `character`. Path (folder/directory) where ##' *M* (the final selected number of allocations) parceled data sets will ##' be outputted from the iteration where the algorithm met stopping criteria. ##' Note for Windows users: file path must be specified using forward slashes ##' (`/`), not backslashes (`\\`). See [base::path.expand()] ##' for details. If `NULL` (default), nothing is saved to disk. ##' @param stopProp Value used in defining stopping criteria of the algorithm ##' (\eqn{\delta_a} in Sterba & Rights, 2016). This is the minimum proportion ##' of change (in any pooled parameter or pooled standard error estimate ##' listed in `selectParam`) that is allowable from one iteration of the ##' algorithm to the next. That is, change in pooled estimates and pooled ##' standard errors from one iteration to the next must all be less than ##' (`stopProp`) \eqn{\times} (value from former iteration). Note that ##' `stopValue` can override this criterion (see below). Also note that values ##' less than .01 are unlikely to lead to more substantively meaningful ##' precision. Also note that if only `stopValue` is a desired criterion, ##' `stopProp` can be set to 0. ##' @param stopValue Value used in defining stopping criteria of the algorithm ##' (\eqn{\delta_b} in Sterba & Rights, 2016). `stopValue` is a minimum ##' allowable amount of absolute change (in any pooled parameter or pooled ##' standard error estimate listed in `selectParam`) from one iteration of ##' the algorithm to the next. For a given pooled estimate or pooled standard ##' error, `stopValue` is only invoked as a stopping criteria when the ##' minimum change required by `stopProp` is less than `stopValue`. ##' Note that values less than .01 are unlikely to lead to more substantively ##' meaningful precision. Also note that if only `stopProp` is a desired ##' criterion, `stopValue` can be set to 0. ##' @param selectParam (Optional) A list of the pooled parameters to be used in ##' defining stopping criteria (i.e., `stopProp` and `stopValue`). ##' These parameters should appear in the order they are listed in the lavaan ##' syntax. By default, all pooled parameters are used. Note that ##' `selectParam` should only contain freely-estimated parameters. In one ##' example from Sterba & Rights (2016) `selectParam` included all free ##' parameters except item intercepts and in another example `selectParam` ##' included only structural parameters. ##' @param indices Optional `character` vector indicating the names of ##' available [lavaan::fitMeasures()] to be included in the output. ##' The first and second elements should be a chi-squared test statistic and ##' its associated degrees of freedom, both of which will be added if missing. ##' If `"default"`, the indices will be `c("chisq", "df", "cfi", "tli", ##' "rmsea","srmr")`. If a robust test statistic is requested (see ##' [lavaan::lavOptions()]), `c("chisq","df")` will be replaced ##' by `c("chisq.scaled","df.scaled")`. For the output to include both the ##' naive and robust test statistics, `indices` should include both, but ##' put the scaled test statistics first, as in `indices = ##' c("chisq.scaled", "df.scaled", "chisq", "df")` ##' @param double (Optional) If set to `TRUE`, requires stopping criteria ##' (`stopProp` and `stopValue`) to be met for all parameters (in ##' `selectParam`) for two consecutive iterations of the algorithm. By ##' default, this is set to `FALSE`, meaning stopping criteria need only be ##' met at one iteration of the algorithm. ##' @param names (Optional) A character vector containing the names of parceled ##' variables. ##' @param leaveout (Optional) A vector of variables to be left out of ##' randomized parceling. Either variable names or column numbers are allowed. ##' @param useTotalAlloc (Optional) If set to `TRUE`, function will output ##' a separate set of results that uses all allocations created by the ##' algorithm, rather than *M* allocations (see "Allocations needed for ##' stability" below). This distinction is further discussed in Sterba and ##' Rights (2016). ##' @param checkConv (Optional) If set to TRUE, function will output pooled ##' estimates and standard errors from 10 iterations post-convergence. ##' @param \dots Additional arguments to be passed to ##' [lavaan::lavaan()]. See also [lavaan::lavOptions()] ##' ##' @return ##' ##' \item{Estimates}{A table containing pooled results across *M* ##' allocations at the iteration where stopping criteria were met. Columns ##' correspond to individual parameter name, pooled estimate, pooled standard ##' error, *p* value for a *z* test of the parameter, normal-theory \eqn{95\%} ##' CI, *p* value for a *t* test of the parameter (using \eqn{df} described in ##' Sterba & Rights, 2016), and *t*-based \eqn{95\%} CI for the parameter.} ##' \item{Fit}{A table containing results related to model fit from the *M* ##' allocations at the iteration where stopping criteria were met. Columns ##' correspond to fit index names, the mean of each index across allocations, ##' the *SD* of each fit index across allocations, the minimum, maximum and ##' range of each fit index across allocations, and the percent of the *M* ##' allocations where the chi-square test of absolute fit was significant.} ##' \item{Proportions}{A table containing the proportion of the final *M* ##' allocations that (a) met the optimizer convergence criteria) and ##' (b) converged to proper solutions. Note that pooled estimates, pooled ##' standard errors, and other results are computed using only the converged, ##' proper allocations.} ##' \item{Stability}{The number of allocations (*M*) needed for stability, at ##' which point the algorithm's stopping criteria (defined above) were met.} ##' \item{Uncertainty}{Indices used to quantify uncertainty in estimates due to ##' sample vs. allocation variability. A table containing individual parameter ##' names, an estimate of the proportion of total variance of a pooled ##' parameter estimate that is attributable to parcel-allocation variability ##' (PPAV), and an estimate of the ratio of the between-allocation variance of ##' a pooled parameter estimate to the within-allocation variance (RPAV). ##' See Sterba & Rights (2016) for more detail.} ##' \item{Time}{The total runtime of the function, in minutes. Note that the ##' total runtime will be greater when the specified model encounters ##' convergence problems for some allocations, as is the case with the ##' [simParcel()] dataset used below.} ##' ##' ##' @author ##' Jason D. Rights (Vanderbilt University; \email{jason.d.rights@@vanderbilt.edu}) ##' ##' The author would also like to credit Corbin Quick and Alexander Schoemann ##' for providing the original [parcelAllocation()] function (prior to its ##' revision by Terrence D. Jorgensen) on which this function is based. ##' ##' @seealso ##' [lavaan.mi::lavaan.mi()] for treating allocations as multiple imputations ##' to pool results across allocations. See **Examples** on help pages for ##' [parcelAllocation()] (when fitting a single model) and [PAVranking()] ##' (when comparing 2 models). ##' ##' @references ##' ##' Sterba, S. K. (2011). Implications of parcel-allocation ##' variability for comparing fit of item-solutions and parcel-solutions. ##' *Structural Equation Modeling, 18*(4), 554--577. ##' \doi{10.1080/10705511.2011.607073} ##' ##' Sterba, S. K., & MacCallum, R. C. (2010). Variability in parameter estimates ##' and model fit across random allocations of items to parcels. ##' *Multivariate Behavioral Research, 45*(2), 322--358. ##' \doi{10.1080/00273171003680302} ##' ##' Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation ##' variability in practice: Combining sources of uncertainty and choosing the ##' number of allocations. *Multivariate Behavioral Research, 51*(2--3), ##' 296--313. \doi{10.1080/00273171.2016.1144502} ##' ##' Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model ##' selection: Parcel-allocation variability in model ranking. ##' *Psychological Methods, 22*(1), 47--68. \doi{10.1037/met0000067} ##' ##' @examples ##' ##' \donttest{ ##' ## lavaan syntax: A 2 Correlated ##' ## factor CFA model to be fit to parceled data ##' ##' parmodel <- ' ##' f1 =~ NA*p1f1 + p2f1 + p3f1 ##' f2 =~ NA*p1f2 + p2f2 + p3f2 ##' p1f1 ~ 1 ##' p2f1 ~ 1 ##' p3f1 ~ 1 ##' p1f2 ~ 1 ##' p2f2 ~ 1 ##' p3f2 ~ 1 ##' p1f1 ~~ p1f1 ##' p2f1 ~~ p2f1 ##' p3f1 ~~ p3f1 ##' p1f2 ~~ p1f2 ##' p2f2 ~~ p2f2 ##' p3f2 ~~ p3f2 ##' f1 ~~ 1*f1 ##' f2 ~~ 1*f2 ##' f1 ~~ f2 ##' ' ##' ##' ## specify items for each factor ##' f1name <- colnames(simParcel)[1:9] ##' f2name <- colnames(simParcel)[10:18] ##' ##' ## run function ##' poolMAlloc(nPerPar = list(c(3,3,3), c(3,3,3)), ##' facPlc = list(f1name, f2name), nAllocStart = 10, nAllocAdd = 10, ##' syntax = parmodel, dataset = simParcel, stopProp = .03, ##' stopValue = .03, selectParam = c(1:6, 13:18, 21), ##' names = list("p1f1","p2f1","p3f1","p1f2","p2f2","p3f2"), ##' double = FALSE, useTotalAlloc = FALSE) ##' } ##' ##' ## See examples on ?parcelAllocation and ?PAVranking for how to obtain ##' ## pooled test statistics and other pooled lavaan output. ##' ## Details provided in Sterba & Rights (2016). ##' ##' @export poolMAlloc <- function(nPerPar, facPlc, nAllocStart, nAllocAdd = 0, parceloutput = NULL, syntax, dataset, stopProp, stopValue, selectParam = NULL, indices = "default", double = FALSE, checkConv = FALSE, names = "default", leaveout = 0, useTotalAlloc = FALSE, ...) { message('Note that more options for pooled results are available using the ', 'lavaan.mi package (see Examples on ?parcelAllocation and ?PAVranking)') if (!is.null(parceloutput)) { if (!dir.exists(parceloutput)) stop('invalid directory:\n', paste(parceloutput), "\n\n") } StartTimeFull <- proc.time() if (is.character(dataset)) dataset <- utils::read.csv(dataset) if (indices[1] == "default") indices <- c("chisq", "df", "cfi", "tli", "rmsea","srmr") ## make sure chi-squared and df are the first and second elements requestedChiSq <- grep(pattern = "chisq", indices, value = TRUE) if (length(requestedChiSq) == 0L) { indices <- unique(c("chisq", indices)) } else { indices <- unique(c(requestedChiSq[1], indices)) } requestedDF <- grep(pattern = "df", indices, value = TRUE) if (length(requestedDF) == 0L) { indices <- unique(c(indices[1], "df", indices[-1])) } else { indices <- unique(c(indices[1], requestedDF[1], indices[-1])) } isProperSolution <- function(object) { lavpartable <- object@ParTable lavfit <- object@Fit lavdata <- object@Data lavmodel <- object@Model var.idx <- which(lavpartable$op == "~~" & lavpartable$lhs == lavpartable$rhs) if (length(var.idx) > 0L && any(lavfit@est[var.idx] < 0)) return(FALSE) if (length(lavaan::lavaanNames(lavpartable, type = "lv.regular")) > 0L) { ETA <- list(lavInspect(object, "cov.lv")) for (g in 1:lavdata@ngroups) { eigvals <- eigen(ETA[[g]], symmetric = TRUE, only.values = TRUE)$values if (any(eigvals < -1 * .Machine$double.eps^(3/4))) return(FALSE) } } THETA <- list(lavInspect(object, "theta")) for (g in 1:lavdata@ngroups) { num.idx <- lavmodel@num.idx[[g]] if (length(num.idx) > 0L) { eigvals <- eigen(THETA[[g]][unlist(num.idx), unlist(num.idx), drop = FALSE], symmetric = TRUE, only.values = TRUE)$values if (any(eigvals < -1 * .Machine$double.eps^(3/4))) return(FALSE) } } TRUE } nloop <- 0 nAllocStarttemp <- nAllocStart options(max.print = 1e+06) BreakCounter <- NA repeat { StartTime <- proc.time() nloop <- nloop + 1 if (double == TRUE & is.na(BreakCounter) == FALSE) BreakCounter <- BreakCounter + 1 if (checkConv == TRUE & is.na(BreakCounter) == FALSE) BreakCounter <- BreakCounter + 1 if (nloop > 1) { if (is.na(BreakCounter) == TRUE) { Parmn_revFinal <- Parmn_rev[[nloop - 1]] nConvergedOutput <- nConverged nConvergedProperOutput <- nConvergedProper PooledSEwithinvarFinal <- PooledSEwithinvar PooledSEbetweenvarFinal <- PooledSEbetweenvar PooledSEFinal <- PooledSE FitsumOutput <- Fitsum nAllocOutput <- nAllocStart - nAllocAdd AllocationsOutput <- Allocations #ParamFinal <- Param # defined, but never used } ParamPooledSE_temp <- ParamPooledSE ParamTest_temp <- ParamTest PooledSE_temp <- PooledSE ParamPoolSEdiffmin <- abs(ParamPooledSE_temp * stopProp) ParamPoolSEdiffmin[ParamPoolSEdiffmin < stopValue] <- stopValue ParamDiffMin <- abs(ParamTest * stopProp) ParamDiffMin[ParamDiffMin < stopValue] <- stopValue PooledSEmin <- abs(PooledSE * stopProp) PooledSEmin[PooledSEmin < stopValue] <- stopValue } dataset <- as.matrix(dataset) if (nAllocStart < 2) stop("Minimum of two allocations required.") if (is.list(facPlc)) { if (is.numeric(facPlc[[1]][1]) == FALSE) { facPlcb <- facPlc Namesv <- colnames(dataset) for (i in 1:length(facPlc)) { for (j in 1:length(facPlc[[i]])) { facPlcb[[i]][j] <- match(facPlc[[i]][j], Namesv) } facPlcb[[i]] <- as.numeric(facPlcb[[i]]) } facPlc <- facPlcb } facPlc2 <- rep(0, ncol(dataset)) for (i in 1:length(facPlc)) { for (j in 1:length(facPlc[[i]])) { facPlc2[facPlc[[i]][j]] <- i } } facPlc <- facPlc2 } if (leaveout != 0) { if (is.numeric(leaveout) == FALSE) { leaveoutb <- rep(0, length(leaveout)) Namesv <- colnames(dataset) for (i in 1:length(leaveout)) { leaveoutb[i] <- match(leaveout[i], Namesv) } leaveout <- as.numeric(leaveoutb) } k1 <- 0.001 for (i in 1:length(leaveout)) { facPlc[leaveout[i]] <- facPlc[leaveout[i]] + k1 k1 <- k1 + 0.001 } } if (0 %in% facPlc == TRUE) { Zfreq <- sum(facPlc == 0) for (i in 1:Zfreq) { Zplc <- match(0, facPlc) dataset <- dataset[, -Zplc] facPlc <- facPlc[-Zplc] } } if (is.list(nPerPar)) { nPerPar2 <- c() for (i in 1:length(nPerPar)) { Onesp <- sum(facPlc > i & facPlc < i + 1) nPerPar2 <- c(nPerPar2, nPerPar[i], rep(1, Onesp), recursive = TRUE) } nPerPar <- nPerPar2 } Npp <- c() for (i in 1:length(nPerPar)) { Npp <- c(Npp, rep(i, nPerPar[i])) } Locate <- sort(round(facPlc)) Maxv <- max(Locate) - 1 if (length(Locate) != length(Npp)) { stop("** ERROR! ** Parcels incorrectly specified. Check input!") } if (Maxv > 0) { for (i in 1:Maxv) { Mat <- match(i + 1, Locate) if (Npp[Mat] == Npp[Mat - 1]) { stop("** ERROR! ** Parcels incorrectly specified. Check input!") } } } Onevec <- facPlc - round(facPlc) NleaveA <- length(Onevec) - sum(Onevec == 0) NleaveP <- sum(nPerPar == 1) if (NleaveA < NleaveP) { warning("** WARNING! ** Single-variable parcels have been requested.", " Check input!") } if (NleaveA > NleaveP) warning("** WARNING! ** More non-parceled variables have been requested", " than provided for in parcel vector. Check input!") if (length(names) > 1) { if (length(names) != length(nPerPar)) { warning("** WARNING! ** Number of parcel names provided not equal to", " number of parcels requested. Check input!") } } Data <- c(1:ncol(dataset)) # Nfactors <- max(facPlc) # defined but never used Nindicators <- length(Data) Npar <- length(nPerPar) Rmize <- runif(Nindicators, 1, Nindicators) Data <- rbind(facPlc, Rmize, Data) Results <- matrix(numeric(0), nAllocStart, Nindicators) Pin <- nPerPar[1] for (i in 2:length(nPerPar)) { Pin <- c(Pin, nPerPar[i] + Pin[i - 1]) } for (i in 1:nAllocStart) { Data[2, ] <- runif(Nindicators, 1, Nindicators) Data <- Data[, order(Data[2, ])] Data <- Data[, order(Data[1, ])] Results[i, ] <- Data[3, ] } Alpha <- rbind(Results[1, ], dataset) Allocations <- list() for (i in 1:nAllocStart) { Ineff <- rep(NA, ncol(Results)) Ineff2 <- c(1:ncol(Results)) for (inefficient in 1:ncol(Results)) { Ineff[Results[i, inefficient]] <- Ineff2[inefficient] } Alpha[1, ] <- Ineff Beta <- Alpha[, order(Alpha[1, ])] Temp <- matrix(NA, nrow(dataset), Npar) TempAA <- if (length(1:Pin[1]) > 1) { Beta[2:nrow(Beta), 1:Pin[1]] } else cbind(Beta[2:nrow(Beta), 1:Pin[1]], Beta[2:nrow(Beta), 1:Pin[1]]) Temp[, 1] <- rowMeans(TempAA, na.rm = TRUE) for (al in 2:Npar) { Plc <- Pin[al - 1] + 1 TempBB <- if (length(Plc:Pin[al]) > 1) { Beta[2:nrow(Beta), Plc:Pin[al]] } else cbind(Beta[2:nrow(Beta), Plc:Pin[al]], Beta[2:nrow(Beta), Plc:Pin[al]]) Temp[, al] <- rowMeans(TempBB, na.rm = TRUE) } if (length(names) > 1) { colnames(Temp) <- names } Allocations[[i]] <- Temp } Param <- list() Fitind <- list() Converged <- list() ProperSolution <- list() ConvergedProper <- list() for (i in 1:(nAllocStart)) { data_parcel <- as.data.frame(Allocations[[i]], row.names = NULL, optional = FALSE) fit <- lavaan::sem(syntax, data = data_parcel, ...) ## if a robust estimator was requested, update fit indices accordingly requestedTest <- lavInspect(fit, "options")$test if (any(requestedTest %in% c("satorra.bentler","yuan.bentler", "yuan.bentler.mplus","scaled.shifted", "mean.var.adjusted","satterthwaite"))) { indices[1:2] <- c("chisq.scaled","df.scaled") } else indices[1:2] <- c("chisq","df") ## check convergence and solution if (lavInspect(fit, "converged") == TRUE) { Converged[[i]] <- 1 } else Converged[[i]] <- 0 Param[[i]] <- lavaan::parameterEstimates(fit)[, c("lhs", "op", "rhs", "est", "se", "z", "pvalue", "ci.lower", "ci.upper")] if (isProperSolution(fit) == TRUE & Converged[[i]] == 1) { ProperSolution[[i]] <- 1 } else ProperSolution[[i]] <- 0 if (any(is.na(Param[[i]][, 5] == TRUE))) ProperSolution[[i]] <- 0 if (Converged[[i]] == 1 & ProperSolution[[i]] == 1) { ConvergedProper[[i]] <- 1 } else ConvergedProper[[i]] <- 0 if (ConvergedProper[[i]] == 0) Param[[i]][, 4:9] <- matrix(data = NA, nrow(Param[[i]]), 6) if (ConvergedProper[[i]] == 1) { Fitind[[i]] <- lavaan::fitMeasures(fit, indices) if (!all(indices %in% names(Fitind[[i]]))) { invalidIndices <- setdiff(indices, names(Fitind[[i]])) Fitind[[i]][invalidIndices] <- NA } } else Fitind[[i]] <- rep(NA, length(indices)) } nConverged <- Reduce("+", Converged) nProperSolution <- Reduce("+", ProperSolution) nConvergedProper <- Reduce("+", ConvergedProper) if (nConvergedProper == 0) stop("All allocations failed to converge and/or", " yielded improper solutions for a given loop.") Parmn <- Param[[1]] if (is.null(selectParam)) selectParam <- 1:nrow(Parmn) ParSE <- matrix(NA, nrow(Parmn), nAllocStart) ParSEmn <- Parmn[, 5] Parsd <- matrix(NA, nrow(Parmn), nAllocStart) Fitmn <- Fitind[[1]] Fitsd <- matrix(NA, length(Fitmn), nAllocStart) Sigp <- matrix(NA, nrow(Parmn), nAllocStart) Fitind <- data.frame(Fitind) ParamSEsquared <- list() for (i in 1:nAllocStart) { ParamSEsquared[[i]] <- cbind(Param[[i]][, 5], Param[[i]][, 5]) if (any(is.na(ParamSEsquared[[i]]) == TRUE)) ParamSEsquared[[i]] <- 0 ParamSEsquared[[i]] <- apply(as.data.frame(ParamSEsquared[[i]]), 1, prod) Parsd[, i] <- Param[[i]][, 4] ParSE[, i] <- Param[[i]][, 5] Sigp[, ncol(Sigp) - i + 1] <- Param[[i]][, 7] Fitsd[, i] <- Fitind[[i]] } Sigp <- Sigp + 0.45 Sigp <- apply(Sigp, c(1, 2), round) Sigp <- 1 - as.vector(rowMeans(Sigp, na.rm = TRUE)) Parsum <- cbind(apply(Parsd, 1, mean, na.rm = TRUE), apply(Parsd, 1, sd, na.rm = TRUE), apply(Parsd, 1, max, na.rm = TRUE), apply(Parsd, 1, min, na.rm = TRUE), apply(Parsd, 1, max, na.rm = TRUE) - apply(Parsd, 1, min, na.rm = TRUE), Sigp) colnames(Parsum) <- c("Avg Est.", "S.D.", "MAX", "MIN", "Range", "% Sig") ParSEmn <- Parmn[, 1:3] ParSEfn <- cbind(ParSEmn, apply(ParSE, 1, mean, na.rm = TRUE), apply(ParSE, 1, sd, na.rm = TRUE), apply(ParSE, 1, max, na.rm = TRUE), apply(ParSE, 1, min, na.rm = TRUE), apply(ParSE, 1, max, na.rm = TRUE) - apply(ParSE, 1, min, na.rm = TRUE)) colnames(ParSEfn) <- c("lhs", "op", "rhs", "Avg SE", "S.D.", "MAX", "MIN", "Range") Fitsum <- cbind(apply(Fitsd, 1, mean, na.rm = TRUE), apply(Fitsd, 1, sd, na.rm = TRUE), apply(Fitsd, 1, max, na.rm = TRUE), apply(Fitsd, 1, min, na.rm = TRUE), apply(Fitsd, 1, max, na.rm = TRUE) - apply(Fitsd, 1, min, na.rm = TRUE)) rownames(Fitsum) <- indices Parmn[, 4:ncol(Parmn)] <- Parmn[, 4:ncol(Parmn)]/nConvergedProper Parmn <- Parmn[, 1:3] Parmn <- cbind(Parmn, Parsum) Fitmn <- Fitmn/nConvergedProper pChisq <- list() sigChisq <- list() for (i in 1:nAllocStart) { pChisq[[i]] <- (1 - pchisq(Fitsd[1, i], Fitsd[2, i])) if (is.na(pChisq[[i]]) == FALSE & pChisq[[i]] < 0.05) { sigChisq[[i]] <- 1 } else sigChisq[[i]] <- 0 } PerSigChisq <- (Reduce("+", sigChisq))/nConvergedProper * 100 PerSigChisq <- round(PerSigChisq, 4) PerSigChisqCol <- c(PerSigChisq, # however many indices != chisq(.scaled) rep("n/a", sum(!grepl(pattern = "chisq", x = indices)))) Fitsum <- data.frame(Fitsum, PerSigChisqCol, stringsAsFactors = FALSE) colnames(Fitsum) <- c("Avg Ind", "S.D.", "MAX", "MIN", "Range", "% Sig") PooledSEwithinvar <- Reduce("+", ParamSEsquared)/nConvergedProper PooledSEbetweenvar <- Parmn[, 5]^2 PooledSE <- sqrt(PooledSEwithinvar + PooledSEbetweenvar + PooledSEbetweenvar/nConvergedProper) ParamPooledSE <- c(Parmn[, 4], PooledSE) ParamTest <- Parmn[, 4] if (nloop > 1) { ParamPoolSEdiff <- abs(ParamPooledSE_temp - ParamPooledSE) Paramdiff <- abs(ParamTest_temp - ParamTest) PooledSEdiff <- abs(PooledSE - PooledSE_temp) ParamPoolSEdifftest <- ParamPoolSEdiff - ParamPoolSEdiffmin ParamPoolSEdifftest[ParamPoolSEdifftest <= 0] <- 0 ParamPoolSEdifftest[ParamPoolSEdifftest > 0] <- 1 Paramdifftest <- Paramdiff - ParamDiffMin Paramdifftest[Paramdifftest <= 0] <- 0 Paramdifftest[Paramdifftest > 0] <- 1 PooledSEdifftest <- PooledSEdiff - PooledSEmin PooledSEdifftest[PooledSEdifftest <= 0] <- 0 PooledSEdifftest[PooledSEdifftest > 0] <- 1 if (nloop == 2) { ParamPoolSEdifftesttable <- cbind(ParamPoolSEdifftest) Paramdifftesttable <- cbind(Paramdifftest) PooledSEdifftesttable <- cbind(PooledSEdifftest) } if (nloop > 2) { ParamPoolSEdifftesttable <- cbind(ParamPoolSEdifftesttable, ParamPoolSEdifftest) Paramdifftesttable <- cbind(Paramdifftesttable, Paramdifftest) PooledSEdifftesttable <- cbind(PooledSEdifftesttable, PooledSEdifftest) } PropStopParam <- 1 - (Reduce("+", Paramdifftesttable[selectParam, nloop - 1])/length(selectParam)) PropStopPooled <- 1 - (Reduce("+", PooledSEdifftesttable[selectParam, nloop - 1])/length(selectParam)) PropStopParamPooled <- 1 - (Reduce("+", ParamPoolSEdifftesttable[c(selectParam, selectParam + nrow(Parmn)), nloop - 1]) / (2 * length(selectParam))) if (checkConv == TRUE & is.na(BreakCounter) == TRUE) { print(nAllocStart) print("Proportion of pooled estimates meeting stop criteria:") print(PropStopParam) print("Proportion of pooled SE meeting stop criteria:") print(PropStopPooled) } if (checkConv == FALSE) { print(nAllocStart) print("Proportion of pooled estimates meeting stop criteria:") print(PropStopParam) print("Proportion of pooled SE meeting stop criteria:") print(PropStopPooled) } } nAllocStart <- nAllocStart + nAllocAdd StopTime <- proc.time() - StartTime print("Runtime:") print(StopTime) Parmn_rev <- list() Parmn_rev[[nloop]] <- cbind(Parmn[, 1:4], PooledSE) Parmn_rev[[nloop]][, 4:5] <- sapply(Parmn_rev[[nloop]][,4:5], as.numeric) colnames(Parmn_rev[[nloop]]) <- c("lhs", "op", "rhs","Estimate", "Pooled SE") if (nloop == 1) { Param_revTemp <- cbind(Parmn[, 1:3], Parmn_rev[[nloop]][,4]) Param_revTemp[, 4] <- as.numeric(Param_revTemp[,4]) Param_revTotal <- cbind(Param_revTemp) PooledSE_revTemp <- cbind(Parmn[, 1:3], Parmn_rev[[nloop]][,5]) PooledSE_revTemp[, 4] <- as.numeric(PooledSE_revTemp[,4]) PooledSE_revTotal <- cbind(PooledSE_revTemp) } if (nloop > 1) { Param_revTemp <- cbind(Parmn_rev[[nloop]][, 4]) Param_revTemp <- as.numeric(Param_revTemp) Param_revTotal <- cbind(Param_revTotal, Param_revTemp) PooledSE_revTemp <- cbind(Parmn_rev[[nloop]][, 5]) PooledSE_revTemp <- as.numeric(PooledSE_revTemp) PooledSE_revTotal <- cbind(PooledSE_revTotal, PooledSE_revTemp) } if (nloop == 1) { ParamTotal <- Param FitindTotal <- Fitind AllocationsTotal <- Allocations nAllocTotal <- nAllocStart - nAllocAdd nConvergedTotal <- nConverged nProperSolutionTotal <- nProperSolution nConvergedProperTotal <- nConvergedProper } if (nloop > 1) { ParamTotal <- c(ParamTotal, Param) FitindTotal <- c(FitindTotal, Fitind) AllocationsTotal <- c(AllocationsTotal, Allocations) nAllocTotal <- nAllocTotal + nAllocStart - nAllocAdd nConvergedTotal <- nConverged + nConvergedTotal nProperSolution <- nProperSolution + nProperSolutionTotal nConvergedProperTotal <- nConvergedProper + nConvergedProperTotal } if (nloop > 1 & double == TRUE & is.na(BreakCounter) == FALSE & BreakCounter == 2) { if (Reduce("+", ParamPoolSEdifftesttable[c(selectParam, selectParam + nrow(Parmn_rev[[nloop]])), nloop - 1]) == 0) break } if (nloop > 1 & double == TRUE) { if (Reduce("+", ParamPoolSEdifftesttable[c(selectParam, selectParam + nrow(Parmn_rev[[nloop]])), nloop - 1]) == 0) { BreakCounter <- 1 } else BreakCounter <- NA } if (nloop > 1 & checkConv == TRUE & is.na(BreakCounter) == TRUE) { if (Reduce("+", ParamPoolSEdifftesttable[c(selectParam, selectParam + nrow(Parmn_rev[[nloop]])), nloop - 1]) == 0) BreakCounter <- 0 } if (nloop > 1 & double == FALSE & checkConv == FALSE) { if (Reduce("+", ParamPoolSEdifftesttable[c(selectParam, selectParam + nrow(Parmn_rev[[nloop]])), nloop - 1]) == 0) break } if (nAllocAdd == 0) break if (checkConv == TRUE & is.na(BreakCounter) == FALSE & BreakCounter == 9) break } if (nAllocAdd == 0) { Parmn_revFinal <- Parmn_rev[[nloop]] nConvergedOutput <- nConverged nConvergedProperOutput <- nConvergedProper PooledSEwithinvarFinal <- PooledSEwithinvar PooledSEbetweenvarFinal <- PooledSEbetweenvar PooledSEFinal <- PooledSE FitsumOutput <- Fitsum nAllocOutput <- nAllocStart - nAllocAdd AllocationsOutput <- Allocations } if (!is.null(parceloutput)) { replist <- matrix(NA, nAllocOutput, 1) for (i in 1:(nAllocOutput)) { colnames(AllocationsOutput[[i]]) <- names utils::write.table(AllocationsOutput[[i]], file = paste(parceloutput, "/parcelruns", i, ".dat", sep = ""), row.names = FALSE, col.names = TRUE) replist[i, 1] <- paste("parcelruns", i, ".dat", sep = "") } utils:: write.table(replist, paste(parceloutput, "/parcelrunsreplist.dat", sep = ""), quote = FALSE, row.names = FALSE, col.names = FALSE) } if (useTotalAlloc == TRUE) { ParmnTotal <- ParamTotal[[1]] ParSETotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) ParSEmnTotal <- ParmnTotal[, 5] ParsdTotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) FitmnTotal <- FitindTotal[[1]] FitsdTotal <- matrix(NA, length(FitmnTotal), nAllocTotal) SigpTotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) FitindTotal <- data.frame(FitindTotal) ParamSEsquaredTotal <- list() for (i in 1:nAllocTotal) { ParamSEsquaredTotal[[i]] <- cbind(ParamTotal[[i]][,5], ParamTotal[[i]][, 5]) if (any(is.na(ParamSEsquaredTotal[[i]]) == TRUE)) ParamSEsquaredTotal[[i]] <- 0 ParamSEsquaredTotal[[i]] <- apply(as.data.frame(ParamSEsquaredTotal[[i]]),1, prod) ParsdTotal[, i] <- ParamTotal[[i]][, 4] ParSETotal[, i] <- ParamTotal[[i]][, 5] SigpTotal[, ncol(Sigp) - i + 1] <- ParamTotal[[i]][,7] FitsdTotal[, i] <- FitindTotal[[i]] } SigpTotal <- SigpTotal + 0.45 SigpTotal <- apply(SigpTotal, c(1, 2), round) SigpTotal <- 1 - as.vector(rowMeans(SigpTotal, na.rm = TRUE)) ParsumTotal <- cbind(apply(ParsdTotal, 1, mean, na.rm = TRUE), apply(ParsdTotal, 1, sd, na.rm = TRUE), apply(ParsdTotal, 1, max, na.rm = TRUE), apply(ParsdTotal, 1, min, na.rm = TRUE), apply(ParsdTotal, 1, max, na.rm = TRUE) - apply(ParsdTotal, 1, min, na.rm = TRUE), SigpTotal) colnames(ParsumTotal) <- c("Avg Est.", "S.D.", "MAX", "MIN", "Range", "% Sig") ParSEmnTotal <- ParmnTotal[, 1:3] ParSEfnTotal <- cbind(ParSEmnTotal, apply(ParSETotal, 1, mean, na.rm = TRUE), apply(ParSETotal, 1, sd, na.rm = TRUE), apply(ParSETotal, 1, max, na.rm = TRUE), apply(ParSETotal, 1, min, na.rm = TRUE), apply(ParSETotal, 1, max, na.rm = TRUE) - apply(ParSETotal, 1, min, na.rm = TRUE)) colnames(ParSEfnTotal) <- c("lhs", "op", "rhs", "Avg SE", "S.D.", "MAX", "MIN", "Range") FitsumTotal <- cbind(apply(FitsdTotal, 1, mean, na.rm = TRUE), apply(FitsdTotal, 1, sd, na.rm = TRUE), apply(FitsdTotal, 1, max, na.rm = TRUE), apply(FitsdTotal, 1, min, na.rm = TRUE), apply(FitsdTotal, 1, max, na.rm = TRUE) - apply(FitsdTotal, 1, min, na.rm = TRUE)) rownames(FitsumTotal) <- indices ParmnTotal[, 4:ncol(ParmnTotal)] <- ParmnTotal[,4:ncol(Parmn)]/nConvergedProperTotal ParmnTotal <- ParmnTotal[, 1:3] ParmnTotal <- cbind(ParmnTotal, ParsumTotal) FitmnTotal <- FitmnTotal/nConvergedProperTotal pChisqTotal <- list() sigChisqTotal <- list() for (i in 1:nAllocTotal) { pChisqTotal[[i]] <- (1 - pchisq(FitsdTotal[1,i], FitsdTotal[2, i])) if (is.na(pChisqTotal[[i]]) == FALSE & pChisqTotal[[i]] < 0.05) { sigChisqTotal[[i]] <- 1 } else sigChisqTotal[[i]] <- 0 } PerSigChisqTotal <- (Reduce("+", sigChisqTotal))/nConvergedProperTotal * 100 PerSigChisqTotal <- round(PerSigChisqTotal, 4) PerSigChisqColTotal <- c(PerSigChisqTotal, "n/a", "n/a", "n/a", "n/a") FitsumTotal <- data.frame(FitsumTotal, PerSigChisqColTotal, stringsAsFactors = FALSE) colnames(FitsumTotal) <- c("Avg Ind", "S.D.", "MAX", "MIN", "Range", "% Sig") PooledSEwithinvarTotal <- Reduce("+", ParamSEsquaredTotal)/nConvergedProperTotal PooledSEbetweenvarTotal <- ParmnTotal[, 5]^2 PooledSETotal <- sqrt(PooledSEwithinvarTotal + PooledSEbetweenvarTotal + PooledSEbetweenvarTotal/nConvergedProperTotal) ParamPooledSETotal <- c(ParmnTotal[, 4], PooledSETotal) ParamTestTotal <- ParmnTotal[, 4] Parmn_revTotal <- cbind(ParmnTotal[, 1:4], PooledSETotal) Parmn_revTotal[, 4:5] <- sapply(Parmn_revTotal[,4:5], as.numeric) colnames(Parmn_revTotal) <- c("lhs", "op", "rhs", "Estimate", "Pooled SE") df_tTotal <- (nConvergedProperTotal - 1) * (1 + (nConvergedProperTotal * PooledSEwithinvarTotal)/(nConvergedProperTotal * PooledSEbetweenvarTotal + PooledSEbetweenvarTotal))^2 crit_tTotal <- abs(qt(0.05/2, df_tTotal)) pval_zTotal <- 2 * (1 - pnorm(abs(Parmn_revTotal[, 4]/PooledSETotal))) pval_tTotal <- 2 * (1 - pt(abs(Parmn_revTotal[, 4]/PooledSETotal), df = df_tTotal)) CI95_Lower_zTotal <- Parmn_revTotal[, 4] - 1.959963985 * PooledSETotal CI95_Upper_zTotal <- Parmn_revTotal[, 4] + 1.959963985 * PooledSETotal CI95_Lower_tTotal <- Parmn_revTotal[, 4] - crit_tTotal * PooledSETotal CI95_Upper_tTotal <- Parmn_revTotal[, 4] + crit_tTotal * PooledSETotal Parmn_revTotal <- cbind(Parmn_revTotal, pval_zTotal, CI95_Lower_zTotal, CI95_Upper_zTotal, pval_tTotal, CI95_Lower_tTotal, CI95_Upper_tTotal) colnames(Parmn_revTotal) <- c("lhs", "op", "rhs", "Pooled Est", "Pooled SE", "pval_z", "CI95_LB_z", "CI95_UB_z", "pval_t", "CI95_LB_t", "CI95_UB_t") for (i in 1:nrow(Parmn_revTotal)) { if (Parmn_revTotal[i, 5] == 0) Parmn_revTotal[i, 6:11] <- NA } RPAVTotal <- (PooledSEbetweenvarTotal + (PooledSEbetweenvarTotal/(nConvergedProperTotal)))/PooledSEwithinvarTotal PPAVTotal <- (((nConvergedProperTotal + 1)/(nConvergedProperTotal)) * PooledSEbetweenvarTotal)/(PooledSEwithinvarTotal + (((nConvergedProperTotal + 1)/(nConvergedProperTotal)) * PooledSEbetweenvarTotal)) PAVtableTotal <- cbind(ParmnTotal[1:3], RPAVTotal, PPAVTotal) Parmn_revTotal[, 4:11] <- apply(Parmn_revTotal[, 4:11], 2, round, digits = 4) FitsumTotal[, 1:5] <- apply(FitsumTotal[, 1:5], 2, round, digits = 4) PAVtableTotal[, 4:5] <- apply(PAVtableTotal[, 4:5], 2, round, digits = 4) FitsumTotal[2, 2:5] <- c("n/a", "n/a", "n/a", "n/a") ConvergedProperSumTotal <- rbind((nConvergedTotal)/(nAllocTotal), (nConvergedProperTotal)/(nAllocTotal)) rownames(ConvergedProperSumTotal) <- c("Converged", "Converged and Proper") colnames(ConvergedProperSumTotal) <- "Proportion of Allocations" } if (nAllocAdd != 0) { if (nloop == 2) { PropParamMet <- matrix(data = 1, nrow(Parmn), 1) PropPooledSEMet <- matrix(data = 1, nrow(Parmn), 1) } if (nloop != 2) { PropParamMet <- (1 - apply(Paramdifftesttable[, 1:nloop - 1], 1, mean)) * 100 PropPooledSEMet <- (1 - apply(PooledSEdifftesttable[,1:nloop - 1], 1, mean)) * 100 } FirstParamMet <- apply(Paramdifftesttable == 0, 1, which.max) FirstPooledSEMet <- apply(PooledSEdifftesttable == 0, 1, which.max) } if (nAllocAdd == 0) { PropParamMet <- matrix(data = NA, nrow(Parmn), 1) PropPooledSEMet <- matrix(data = NA, nrow(Parmn), 1) FirstParamMet <- matrix(data = NA, nrow(Parmn), 1) FirstPooledSEMet <- matrix(data = NA, nrow(Parmn), 1) } PerLoops <- cbind(Parmn[, 1:3], PropParamMet, PropPooledSEMet) colnames(PerLoops) <- c("lhs", "op", "rhs", "Param Criteria Met", "PooledSE Criteria Met") FirstLoops <- cbind(Parmn[, 1:3], FirstParamMet, FirstPooledSEMet) colnames(FirstLoops) <- c("lhs", "op", "rhs", "Param Criteria Met", "PooledSE Criteria Met") NumbAllocations <- cbind(Parmn[, 1:3], (FirstParamMet - 1) * nAllocAdd + nAllocStarttemp, (FirstPooledSEMet - 1) * nAllocAdd + nAllocStarttemp) colnames(NumbAllocations) <- c("lhs", "op", "rhs", "Param Criteria Met", "PooledSE Criteria Met") if (nAllocAdd != 0) { for (i in 1:nrow(Parmn)) { if ((i %in% selectParam) == FALSE) PerLoops[i, 4:5] <- NA if ((i %in% selectParam) == FALSE) FirstLoops[i, 4:5] <- NA if ((i %in% selectParam) == FALSE) NumbAllocations[i, 4:5] <- NA } } df_t <- (nConvergedProperOutput - 1) * (1 + (nConvergedProperOutput * PooledSEwithinvarFinal) / (nConvergedProperOutput * PooledSEbetweenvarFinal + PooledSEbetweenvarFinal))^2 crit_t <- abs(qt(0.05/2, df_t)) pval_z <- 2 * (1 - pnorm(abs(Parmn_revFinal[, 4]/PooledSEFinal))) pval_t <- 2 * (1 - pt(abs(Parmn_revFinal[, 4]/PooledSEFinal), df = df_t)) CI95_Lower_z <- Parmn_revFinal[, 4] - 1.959963985 * PooledSEFinal CI95_Upper_z <- Parmn_revFinal[, 4] + 1.959963985 * PooledSEFinal CI95_Lower_t <- Parmn_revFinal[, 4] - crit_t * PooledSEFinal CI95_Upper_t <- Parmn_revFinal[, 4] + crit_t * PooledSEFinal Parmn_revFinal <- cbind(Parmn_revFinal, pval_z, CI95_Lower_z, CI95_Upper_z, pval_t, CI95_Lower_t, CI95_Upper_t) colnames(Parmn_revFinal) <- c("lhs", "op", "rhs", "Pooled Est", "Pooled SE", "pval_z", "CI95_LB_z", "CI95_UB_z", "pval_t", "CI95_LB_t", "CI95_UB_t") for (i in 1:nrow(Parmn_revFinal)) { if (Parmn_revFinal[i, 5] == 0 | is.na(Parmn_revFinal[i, 5]) == TRUE) Parmn_revFinal[i, 6:11] <- NA } RPAV <- (PooledSEbetweenvarFinal + (PooledSEbetweenvarFinal/(nConvergedProperOutput)))/PooledSEwithinvarFinal PPAV <- (((nConvergedProperOutput + 1)/(nConvergedProperOutput)) * PooledSEbetweenvarFinal)/(PooledSEwithinvarFinal + (((nConvergedProperOutput + 1)/(nConvergedProperOutput)) * PooledSEbetweenvarFinal)) PAVtable <- cbind(Parmn[1:3], RPAV, PPAV) colnames(Param_revTotal) <- c("lhs", "op", "rhs", c(1:nloop)) colnames(PooledSE_revTotal) <- c("lhs", "op", "rhs", c(1:nloop)) Param_revTotal[, 4:(nloop + 3)] <- sapply(Param_revTotal[, 4:(nloop + 3)], as.numeric) PooledSE_revTotal[, 4:(nloop + 3)] <- sapply(PooledSE_revTotal[, 4:(nloop + 3)], as.numeric) Parmn_revFinal[, 4:11] <- apply(Parmn_revFinal[, 4:11], 2, round, digits = 4) FitsumOutput[, 1:5] <- apply(FitsumOutput[, 1:5], 2, round, digits = 4) if (nAllocAdd != 0) Param_revTotal[, 4:(nloop + 3)] <- apply(Param_revTotal[, 4:(nloop + 3)], 2, round, digits = 8) if (nAllocAdd == 0) Param_revTotal[, 4] <- round(Param_revTotal[, 4], 8) if (nAllocAdd != 0) PooledSE_revTotal[, 4:(nloop + 3)] <- apply(PooledSE_revTotal[, 4:(nloop + 3)], 2, round, digits = 8) if (nAllocAdd == 0) PooledSE_revTotal[, 4] <- round(PooledSE_revTotal[, 4], 8) PAVtable[, 4:5] <- apply(PAVtable[, 4:5], 2, round, digits = 4) FitsumOutput[2, 2:5] <- c("n/a", "n/a", "n/a", "n/a") ConvergedProperSum <- rbind((nConvergedOutput)/(nAllocOutput), (nConvergedProperOutput)/(nAllocOutput)) rownames(ConvergedProperSum) <- c("Converged", "Converged and Proper") colnames(ConvergedProperSum) <- "Proportion of Allocations" StopTimeFull <- proc.time() - StartTimeFull if (useTotalAlloc == FALSE) { Output_mod <- list(Parmn_revFinal, FitsumOutput, ConvergedProperSum, nAllocOutput, PAVtable, StopTimeFull[[3]]/60) names(Output_mod) <- c("Estimates", "Fit", "Proportion of Converged and Proper Allocations", "Allocations needed for stability (M)", "Indices to quantify uncertainty in estimates due to sampling vs. allocation variability", "Total runtime (minutes)") } if (useTotalAlloc == TRUE) { Output_mod <- list(Parmn_revFinal, FitsumOutput, ConvergedProperSum, nAllocOutput, PAVtable, Parmn_revTotal, FitsumTotal, ConvergedProperSumTotal, nAllocTotal, PAVtableTotal, StopTimeFull[[3]]/60) names(Output_mod) <- c("Estimates (using M allocations)", "Fit (using M allocations)", "Proportion of Converged and Proper Allocations (using M allocations)", "Allocations needed for stability (M)", "Indices to quantify uncertainty in estimates due to sampling vs. allocation variability (using M allocations)", "Estimates (using all allocations)", "Fit (using all allocations)", "Proportion of Converged and Proper Allocations (using all allocations)", "Total Allocations used by algorithm", "Indices to quantify uncertainty in estimates due to sampling vs. allocation variability (using all allocations)", "Total runtime (minutes)") } if (exists("invalidIndices")) { if (length(invalidIndices)) message('\n\nInvalid fit indices requested: ', paste(invalidIndices, collapse = ", "), "\n\n") } return(Output_mod) } semTools/R/data.R0000644000176200001440000001122214632143376013323 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 4 April 2017 ### document example data sets #' Simulated Dataset to Demonstrate Two-way Latent Interaction #' #' A simulated data set with 2 independent factors and 1 dependent factor where #' each factor has three indicators #' #' #' @format A `data.frame` with 500 observations of 9 variables. #' \describe{ #' \item{x1}{The first indicator of the first independent factor} #' \item{x2}{The second indicator of the first independent factor} #' \item{x3}{The third indicator of the first independent factor} #' \item{x4}{The first indicator of the second independent factor} #' \item{x5}{The second indicator of the second independent factor} #' \item{x6}{The third indicator of the second independent factor} #' \item{x7}{The first indicator of the dependent factor} #' \item{x8}{The second indicator of the dependent factor} #' \item{x9}{The third indicator of the dependent factor} #' } #' @source Data were generated by the [MASS::mvrnorm()] function in #' the `MASS` package. #' @examples head(dat2way) "dat2way" #' Simulated Dataset to Demonstrate Three-way Latent Interaction #' #' A simulated data set with 3 independent factors and 1 dependent factor where #' each factor has three indicators #' #' #' @format A `data.frame` with 500 observations of 12 variables. #' \describe{ #' \item{x1}{The first indicator of the first independent factor} #' \item{x2}{The second indicator of the first independent factor} #' \item{x3}{The third indicator of the first independent factor} #' \item{x4}{The first indicator of the second independent factor} #' \item{x5}{The second indicator of the second independent factor} #' \item{x6}{The third indicator of the second independent factor} #' \item{x7}{The first indicator of the third independent factor} #' \item{x8}{The second indicator of the third independent factor} #' \item{x9}{The third indicator of the third independent factor} #' \item{x10}{The first indicator of the dependent factor} #' \item{x11}{The second indicator of the dependent factor} #' \item{x12}{The third indicator of the dependent factor} #' } #' @source Data were generated by the [MASS::mvrnorm()] function in #' the `MASS` package. #' @examples head(dat3way) "dat3way" #' Simulated Data set to Demonstrate Categorical Measurement Invariance #' #' A simulated data set with 2 factors with 4 indicators each separated into #' two groups #' #' #' @format A `data.frame` with 200 observations of 9 variables. #' \describe{ #' \item{g}{Sex of respondents} #' \item{u1}{Indicator 1} #' \item{u2}{Indicator 2} #' \item{u3}{Indicator 3} #' \item{u4}{Indicator 4} #' \item{u5}{Indicator 5} #' \item{u6}{Indicator 6} #' \item{u7}{Indicator 7} #' \item{u8}{Indicator 8} #' } #' @source Data were generated using the `lavaan` package. #' @examples head(datCat) "datCat" #' Simulated Data set to Demonstrate Longitudinal Measurement Invariance #' #' A simulated data set with 1 factors with 3 indicators in three timepoints #' #' #' @format A `data.frame` with 200 observations of 10 variables. #' \describe{ #' \item{sex}{Sex of respondents} #' \item{y1t1}{Indicator 1 in Time 1} #' \item{y2t1}{Indicator 2 in Time 1} #' \item{y3t1}{Indicator 3 in Time 1} #' \item{y1t2}{Indicator 1 in Time 2} #' \item{y2t2}{Indicator 2 in Time 2} #' \item{y3t2}{Indicator 3 in Time 2} #' \item{y1t3}{Indicator 1 in Time 3} #' \item{y2t3}{Indicator 2 in Time 3} #' \item{y3t3}{Indicator 3 in Time 3} #' } #' @source Data were generated using the `simsem` package. #' @examples head(exLong) "exLong" #' Simulated Data set to Demonstrate Random Allocations of Parcels #' #' A simulated data set with 2 factors with 9 indicators for each factor #' #' #' @format A `data.frame` with 800 observations of 18 variables. #' \describe{ #' \item{f1item1}{Item 1 loading on factor 1} #' \item{f1item2}{Item 2 loading on factor 1} #' \item{f1item3}{Item 3 loading on factor 1} #' \item{f1item4}{Item 4 loading on factor 1} #' \item{f1item5}{Item 5 loading on factor 1} #' \item{f1item6}{Item 6 loading on factor 1} #' \item{f1item7}{Item 7 loading on factor 1} #' \item{f1item8}{Item 8 loading on factor 1} #' \item{f1item9}{Item 9 loading on factor 1} #' \item{f2item1}{Item 1 loading on factor 2} #' \item{f2item2}{Item 2 loading on factor 2} #' \item{f2item3}{Item 3 loading on factor 2} #' \item{f2item4}{Item 4 loading on factor 2} #' \item{f2item5}{Item 5 loading on factor 2} #' \item{f2item6}{Item 6 loading on factor 2} #' \item{f2item7}{Item 7 loading on factor 2} #' \item{f2item8}{Item 8 loading on factor 2} #' \item{f2item9}{Item 9 loading on factor 2} #' } #' @source Data were generated using the `simsem` package. #' @examples head(simParcel) "simParcel" semTools/R/indProd.R0000644000176200001440000003402014764266564014025 0ustar liggesusers### Sunthud Pornprasertmanit and Alexander M. Schoemann ### Last updated: 12 March 2025 ### prepare product indicators for 2-way and 3-way interactions in SEM ##' Make products of indicators using no centering, mean centering, double-mean ##' centering, or residual centering ##' ##' The `indProd` function will make products of indicators using no ##' centering, mean centering, double-mean centering, or residual centering. The ##' `orthogonalize` function is the shortcut of the `indProd` function ##' to make the residual-centered indicators products. ##' ##' ##' @aliases indProd orthogonalize ##' @importFrom stats lm ##' ##' @param data The desired data to be transformed. ##' @param var1 Names or indices of the variables loaded on the first factor ##' @param var2 Names or indices of the variables loaded on the second factor ##' @param var3 Names or indices of the variables loaded on the third factor ##' (for three-way interaction) ##' @param match Specify `TRUE` to use match-paired approach (Marsh, Wen, & ##' Hau, 2004). If `FALSE`, the resulting products are all possible ##' products. ##' @param meanC Specify `TRUE` for mean centering the main effect ##' indicator before making the products ##' @param residualC Specify `TRUE` for residual centering the products by ##' the main effect indicators (Little, Bovaird, & Widaman, 2006). ##' @param doubleMC Specify `TRUE` for centering the resulting products ##' (Lin et. al., 2010) ##' @param namesProd The names of resulting products ##' @return The original data attached with the products. ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) Alexander ##' Schoemann (East Carolina University; \email{schoemanna@@ecu.edu}) ##' @seealso \itemize{ \item [probe2WayMC()] For probing the two-way ##' latent interaction when the results are obtained from mean-centering, or ##' double-mean centering. \item [probe3WayMC()] For probing the ##' three-way latent interaction when the results are obtained from ##' mean-centering, or double-mean centering. \item [probe2WayRC()] ##' For probing the two-way latent interaction when the results are obtained ##' from residual-centering approach. \item [probe3WayRC()] For ##' probing the two-way latent interaction when the results are obtained from ##' residual-centering approach. \item [plotProbe()] Plot the simple ##' intercepts and slopes of the latent interaction. } ##' @references Marsh, H. W., Wen, Z. & Hau, K. T. (2004). Structural equation ##' models of latent interactions: Evaluation of alternative estimation ##' strategies and indicator construction. *Psychological Methods, 9*(3), ##' 275--300. \doi{10.1037/1082-989X.9.3.275} ##' ##' Lin, G. C., Wen, Z., Marsh, H. W., & Lin, H. S. (2010). Structural equation ##' models of latent interactions: Clarification of orthogonalizing and ##' double-mean-centering strategies. *Structural Equation Modeling, 17*(3), ##' 374--391. \doi{10.1080/10705511.2010.488999} ##' ##' Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of ##' orthogonalizing powered and product terms: Implications for modeling ##' interactions among latent variables. *Structural Equation Modeling, ##' 13*(4), 497--519. \doi{10.1207/s15328007sem1304_1} ##' @examples ##' ##' ## Mean centering / two-way interaction / match-paired ##' dat <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6) ##' ##' ## Residual centering / two-way interaction / match-paired ##' dat2 <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6, match = FALSE, ##' meanC = FALSE, residualC = TRUE, doubleMC = FALSE) ##' ##' ## Double-mean centering / two-way interaction / match-paired ##' dat3 <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6, match = FALSE, ##' meanC = TRUE, residualC = FALSE, doubleMC = TRUE) ##' ##' ## Mean centering / three-way interaction / match-paired ##' dat4 <- indProd(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6) ##' ##' ## Residual centering / three-way interaction / match-paired ##' dat5 <- orthogonalize(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6, ##' match = FALSE) ##' ##' ## Double-mean centering / three-way interaction / match-paired ##' dat6 <- indProd(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6, ##' match = FALSE, meanC = TRUE, residualC = TRUE, ##' doubleMC = TRUE) ##' ##' ##' ## To add product-indicators to multiple-imputed data sets ##' \donttest{ ##' HSMiss <- HolzingerSwineford1939[ , c(paste0("x", 1:9), "ageyr","agemo")] ##' set.seed(12345) ##' HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) ##' age <- HSMiss$ageyr + HSMiss$agemo/12 ##' HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) ##' library(Amelia) ##' set.seed(12345) ##' HS.amelia <- amelia(HSMiss, m = 3, p2s = FALSE) ##' imps <- HS.amelia$imputations # extract a list of imputations ##' ## apply indProd() to the list of data.frames ##' imps2 <- lapply(imps, indProd, ##' var1 = c("x1","x2","x3"), var2 = c("x4","x5","x6")) ##' ## verify: ##' lapply(imps2, head) ##' } ##' ##' @export indProd <- function(data, var1, var2, var3 = NULL, match = TRUE, meanC = TRUE, residualC = FALSE, doubleMC = TRUE, namesProd = NULL) { # Get all variable names if (all(is.numeric(var1))) var1 <- colnames(data)[var1] if (all(is.numeric(var2))) var2 <- colnames(data)[var2] if (!is.null(var3) && all(is.numeric(var3))) var3 <- colnames(data)[var3] dat1 <- data[, var1] dat2 <- data[, var2] dat3 <- NULL if (!is.null(var3)) dat3 <- data[, var3] # Mean centering on the original indicators if (meanC) { dat1 <- scale(dat1, scale = FALSE) dat2 <- scale(dat2, scale = FALSE) if (!is.null(dat3)) dat3 <- scale(dat3, scale = FALSE) } if (match) { # Check whether the number of variables are equal across variable sets if (length(var1) != length(var2)) stop("If the match-paired approach is used, the number of", " variables in all sets must be equal.") if (!is.null(var3) && (length(var1) != length(var3))) stop("If the match-paired approach is used, the number of", " variables in all three sets must be equal.") datProd <- NULL if (is.null(var3)) { # Two-way interaction datProd <- dat1 * dat2 if (residualC) { notmissing <- which(!apply(datProd, 1, function(x) any(is.na(x)))) colnames(datProd) <- paste("interactionProduct", 1:ncol(datProd), sep = "") # Write the expression for linear model and residualize the products temp <- data.frame(datProd, dat1, dat2) express <- paste("cbind(", paste(colnames(datProd), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2)), collapse = " + "), sep = "") datProd[notmissing,] <- lm(express, data = temp)$residuals } } else { # Three-way interaction datProd2way <- cbind(dat1 * dat2, dat1 * dat3, dat2 * dat3) datProd3way <- dat1 * dat2 * dat3 if (residualC) { notmissing2way <- which(!apply(datProd2way, 1, function(x) any(is.na(x)))) colnames(datProd2way) <- paste("interaction2Product", 1:ncol(datProd2way), sep = "") # Write the expression for linear model and residualize the two-way products temp2 <- data.frame(datProd2way, dat1, dat2, dat3) express2 <- paste("cbind(", paste(colnames(datProd2way), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2), colnames(dat3)), collapse = " + "), sep = "") datProd2way[notmissing2way,] <- lm(express2, data = temp2)$residuals # Making all possible products to residualize the 3-way interaction datProd2wayFull <- matrix(0, nrow(data), 1) for (i in 1:length(var1)) datProd2wayFull <- data.frame(datProd2wayFull, matrix(rep(dat1[, i], length(var2)), ncol = length(var2)) * dat2) for (i in 1:length(var1)) datProd2wayFull <- data.frame(datProd2wayFull, matrix(rep(dat1[, i], length(var3)), ncol = length(var3)) * dat3) for (i in 1:length(var2)) datProd2wayFull <- data.frame(datProd2wayFull, matrix(rep(dat2[, i], length(var3)), ncol = length(var3)) * dat3) datProd2wayFull <- datProd2wayFull[, -1] colnames(datProd2wayFull) <- paste("interaction2Product", 1:ncol(datProd2wayFull), sep = "") notmissing3way <- which(!apply(datProd3way, 1, function(x) any(is.na(x)))) colnames(datProd3way) <- paste("interaction3Product", 1:ncol(datProd3way), sep = "") # Write the expression for linear model and residualize the three-way products temp3 <- data.frame(datProd3way, dat1, dat2, dat3, datProd2wayFull) express3 <- paste("cbind(", paste(colnames(datProd3way), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2), colnames(dat3), colnames(datProd2wayFull)), collapse = " + "), sep = "") datProd3way[notmissing3way,] <- lm(express3, data = temp3)$residuals } datProd <- cbind(datProd2way, datProd3way) } ## Mean-centering the final product if (doubleMC) datProd <- scale(datProd, scale = FALSE) ## Rename the obtained product terms if (is.null(namesProd)) { if (is.null(var3)) { colnames(datProd) <- paste(var1, var2, sep = ".") } else { colnames(datProd) <- c(paste(var1, var2, sep = "."), paste(var1, var3, sep = "."), paste(var2, var3, sep = "."), paste(var1, var2, var3, sep = ".")) } } else { colnames(datProd) <- namesProd } } else { datProd <- NULL if (is.null(var3)) { # Create all possible combinations of the products of indicators datProd <- matrix(0, nrow(data), 1) for (i in 1:length(var1)) datProd <- data.frame(datProd, matrix(rep(dat1[, i], length(var2)), ncol = length(var2)) * dat2) datProd <- datProd[, -1] if (residualC) { notmissing <- which(!apply(datProd, 1, function(x) any(is.na(x)))) colnames(datProd) <- paste("interactionProduct", 1:ncol(datProd), sep = "") # Write the expression for linear model and residualize the two-way products temp <- data.frame(datProd, dat1, dat2) express <- paste("cbind(", paste(colnames(datProd), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2)), collapse = " + "), sep = "") datProd[notmissing,] <- lm(express, data = temp)$residuals } } else { # Create all possible combinations of the products of indicators datProd2way <- matrix(0, nrow(data), 1) for (i in 1:length(var1)) datProd2way <- data.frame(datProd2way, matrix(rep(dat1[, i], length(var2)), ncol = length(var2)) * dat2) for (i in 1:length(var1)) datProd2way <- data.frame(datProd2way, matrix(rep(dat1[, i], length(var3)), ncol = length(var3)) * dat3) for (i in 1:length(var2)) datProd2way <- data.frame(datProd2way, matrix(rep(dat2[, i], length(var3)), ncol = length(var3)) * dat3) datProd3way <- matrix(0, nrow(data), 1) for (i in 1:length(var1)) { for(j in 1:length(var2)) { datProd3way <- data.frame(datProd3way, matrix(rep(dat1[, i], length(var3)), ncol = length(var3)) * matrix(rep(dat2[, j], length(var3)), ncol = length(var3)) * dat3) } } datProd2way <- datProd2way[, -1] datProd3way <- datProd3way[, -1] if (residualC) { notmissing2way <- which(!apply(datProd2way, 1, function(x) any(is.na(x)))) colnames(datProd2way) <- paste("interaction2Product", 1:ncol(datProd2way), sep = "") # Write the expression for linear model and residualize the two-way products temp2 <- data.frame(datProd2way, dat1, dat2, dat3) express2 <- paste("cbind(", paste(colnames(datProd2way), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2), colnames(dat3)), collapse = " + "), sep = "") datProd2way[notmissing2way,] <- lm(express2, data = temp2)$residuals notmissing3way <- which(!apply(datProd3way, 1, function(x) any(is.na(x)))) colnames(datProd3way) <- paste("interaction3Product", 1:ncol(datProd3way), sep = "") # Write the expression for linear model and residualize the three-way products temp3 <- data.frame(datProd3way, dat1, dat2, dat3, datProd2way) express3 <- paste("cbind(", paste(colnames(datProd3way), collapse = ", "), ") ~ ", paste(c(colnames(dat1), colnames(dat2), colnames(dat3), colnames(datProd2way)), collapse = " + "), sep = "") datProd3way[notmissing3way,] <- lm(express3, data = temp3)$residuals } datProd <- cbind(datProd2way, datProd3way) } ## Double-mean centering if (doubleMC) datProd <- scale(datProd, scale = FALSE) ## Name the resulting product terms if (is.null(namesProd)) { temp <- NULL if (is.null(var3)) { for (i in 1:length(var1)) temp <- c(temp, paste(var1[i], var2, sep = ".")) } else { for (i in 1:length(var1)) temp <- c(temp, paste(var1[i], var2, sep = ".")) for (i in 1:length(var1)) temp <- c(temp, paste(var1[i], var3, sep = ".")) for (i in 1:length(var2)) temp <- c(temp, paste(var2[i], var3, sep = ".")) for (i in 1:length(var1)) { for(j in 1:length(var2)) { temp <- c(temp, paste(var1[i], var2[j], var3, sep = ".")) } } } colnames(datProd) <- temp } else { colnames(datProd) <- namesProd } } ## Bind the products back to the original data data.frame(data, datProd) } ##' @rdname indProd ##' @export orthogonalize <- function(data, var1, var2, var3 = NULL, match = TRUE, namesProd = NULL) { indProd(data = data, var1 = var1, var2 = var2, var3 = var3, match = match, meanC = FALSE, residualC = TRUE, doubleMC = FALSE, namesProd = namesProd) } semTools/R/singleParamTest.R0000644000176200001440000002372314632143377015526 0ustar liggesusers### Sunthud Pornprasertmanit ### Last updated: 2 June 2022 ##' Single Parameter Test Divided from Nested Model Comparison ##' ##' In comparing two nested models, \eqn{\Delta\chi^2} test may indicate that ##' two models are different. However, like other omnibus tests, researchers do ##' not know which fixed parameters or constraints make these two models ##' different. This function will help researchers identify the significant ##' parameter. ##' ##' This function first identifies the differences between these two models. The ##' model with more free parameters is referred to as parent model and the model ##' with fewer free parameters is referred to as nested model. Two tests are ##' implemented here: ##' ##' \enumerate{ ##' \item `free`: The nested model is used as a template. Then, ##' one parameter indicating the differences between two models is freed. The new ##' model is compared with the nested model. This process is repeated for all ##' differences between two models. ##' \item`fix`: The parent model is used ##' as a template. Then, one parameter indicating the differences between two ##' models is fixed or constrained to be equal to other parameters. The new ##' model is then compared with the parent model. This process is repeated for ##' all differences between two models. ##' \item`mi`: No longer available ##' because the test of modification indices is not consistent. For example, if ##' two parameters are equality constrained, the modification index from the ##' first parameter is not equal to the second parameter. ##' } ##' ##' Note that this function does not adjust for the inflated Type I error rate ##' from multiple tests. ##' ##' @param model1 Model 1. ##' @param model2 Model 2. Note that two models must be nested models. Further, ##' the order of parameters in their parameter tables are the same. That is, ##' nested models with different scale identifications may not be able to test ##' by this function. ##' @param return.fit Return the submodels fitted by this function ##' @param method The method used to calculate likelihood ratio test. See ##' [lavaan::lavTestLRT()] for available options ##' @return If `return.fit = FALSE`, the result tables are provided. ##' \eqn{\chi^2} and *p* value are provided for all methods. Note that the ##' \eqn{\chi^2} is all based on 1 *df*. Expected parameter changes ##' and their standardized forms are also provided. ##' ##' If `return.fit = TRUE`, a list with two elements are provided. The ##' first element is the tabular result. The second element is the submodels ##' used in the `free` and `fix` methods. ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @examples ##' ##' library(lavaan) ##' ##' # Nested model comparison by hand ##' HS.model1 <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6' ##' HS.model2 <- ' visual =~ a*x1 + a*x2 + a*x3 ##' textual =~ b*x4 + b*x5 + b*x6' ##' ##' m1 <- cfa(HS.model1, data = HolzingerSwineford1939, std.lv = TRUE, ##' estimator = "MLR") ##' m2 <- cfa(HS.model2, data = HolzingerSwineford1939, std.lv = TRUE, ##' estimator = "MLR") ##' anova(m1, m2) ##' singleParamTest(m1, m2) ##' ##' ## Nested model comparison from the measurementInvariance function ##' HW.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' models <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, ##' group = "school") ##' singleParamTest(models[[1]], models[[2]]) ##' ##' ## Note that the comparison between metric (Model 2) and scalar invariance ##' ## (Model 3) cannot be done by this function because the metric invariance ##' ## model fixes factor means as 0 in Group 2 but the strong invariance model ##' ## frees the factor means in Group 2. Users may use this function to compare ##' ## scalar invariance (Model 3) to a homogeneous-means model. ##' ##' @export singleParamTest <- function(model1, model2, return.fit = FALSE, method = "satorra.bentler.2001") { # Check nested models without any swaps if(lavaan::fitMeasures(model1, "df")[[1]] > lavaan::fitMeasures(model2, "df")[[1]]) { fit0 <- model1 fit1 <- model2 } else { fit0 <- model2 fit1 <- model1 } # fit0 = Nested model, fit1 = Parent model pt1 <- parTable(fit1) pt0 <- parTable(fit0) namept1 <- paramNameFromPt(pt1) namept0 <- paramNameFromPt(pt0) # Two possible constraints: fixed parameters and equality constraints free1 <- (pt1$free != 0) & !(duplicated(pt1$free)) free0 <- (pt0$free != 0) & !(duplicated(pt0$free)) iscon1 <- pt1$op == "==" iscon0 <- pt0$op == "==" con1 <- list(id = integer(0), lhs = character(0), op = character(0), rhs = character(0)) con0 <- list(id = integer(0), lhs = character(0), op = character(0), rhs = character(0)) if(any(iscon1)) con1 <- list(id = pt1$id[iscon1], lhs = pt1$lhs[iscon1], op = pt1$op[iscon1], rhs = pt1$rhs[iscon1]) if(any(iscon0)) con0 <- list(id = pt0$id[iscon0], lhs = pt0$lhs[iscon0], op = pt0$op[iscon0], rhs = pt0$rhs[iscon0]) if(length(free1[!iscon1]) != length(free0[!iscon0])) stop("Parameter tables in two models do not have equal lengths. This function does not work.") if(!all(free1[free0])) stop("Model are not nested or are not arranged in the way that this function works.") if(sum(iscon1) > sum(iscon0)) stop("There are equality constraints in the model with less degrees of freedom that do not exist in the model with higher degrees of freedom. Thus, two models are not nested.") if(!all.equal(lapply(pt1[2:4], "[", !iscon1), lapply(pt0[2:4], "[", !iscon0))) stop("This function needs parameter tables of two models to have the same orders of the same parameters.") # Find fixed values or constraints difffree <- !free0[!iscon0] & free1[!iscon1] textcon1 <- paste0(con1$lhs, con1$op, con1$rhs) textcon0 <- paste0(con0$lhs, con0$op, con0$rhs) indexsamecon <- match(textcon1, textcon0) indexdiffcon <- setdiff(seq_along(textcon0), indexsamecon) diffcon <- lapply(con0, "[", indexdiffcon) fixval <- which(difffree) index <- c(fixval, diffcon$id) if(length(index) <= 0) stop("Two models are identical. No single parameter test can be done.") # Find nested model and release 1-by-1 freeCon <- matrix(NA, length(index), 2) colnames(freeCon) <- c("free.chi", "free.p") listFreeCon <- list() runnum <- 1 for(i in seq_along(fixval)) { temp <- freeParTable(pt0, pt0$lhs[fixval[i]], pt0$op[fixval[i]], pt0$rhs[fixval[i]], pt0$group[fixval[i]]) tryresult <- try(tempfit <- refit(temp, fit0), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit0, method = method), silent = TRUE) if(!is(compresult, "try-error")) freeCon[runnum,] <- unlist(modelcomp[2, c(5, 7)]) } listFreeCon <- c(listFreeCon, tryresult) runnum <- runnum + 1 } rownames(freeCon)[seq_along(fixval)] <- names(listFreeCon)[seq_along(fixval)] <- namept0[fixval] for(i in seq_along(diffcon$id)) { temp <- removeEqCon(pt0, diffcon$id[i]) tryresult <- try(tempfit <- refit(temp, fit0), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit0, method = method), silent = TRUE) if(!is(compresult, "try-error")) freeCon[runnum,] <- unlist(modelcomp[2, c(5, 7)]) } listFreeCon <- c(listFreeCon, tryresult) runnum <- runnum + 1 } poscon <- seq_along(diffcon$id) + length(fixval) rownames(freeCon)[poscon] <- names(listFreeCon)[poscon] <- namept0[diffcon$id] # Find parent model and constrain 1-by-1 fixCon <- matrix(NA, length(index), 2) colnames(fixCon) <- c("fix.chi", "fix.p") listFixCon <- list() runnum <- 1 for(i in seq_along(fixval)) { temp <- fixParTable(pt1, pt1$lhs[fixval[i]], pt1$op[fixval[i]], pt1$rhs[fixval[i]], pt1$group[fixval[i]], pt0$ustart[fixval[i]]) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[runnum,] <- unlist(modelcomp[2,c(5, 7)]) } listFixCon <- c(listFixCon, tryresult) runnum <- runnum + 1 } rownames(fixCon)[seq_along(fixval)] <- names(listFixCon)[seq_along(fixval)] <- namept0[fixval] for(i in seq_along(diffcon$id)) { temp <- patMerge(pt1, list(lhs = diffcon$lhs[i], op = diffcon$op[i], rhs = diffcon$rhs[i])) tryresult <- try(tempfit <- refit(temp, fit1), silent = TRUE) if(!is(tryresult, "try-error")) { compresult <- try(modelcomp <- lavaan::lavTestLRT(tempfit, fit1, method = method), silent = TRUE) if(!is(compresult, "try-error")) fixCon[runnum,] <- unlist(modelcomp[2, c(5, 7)]) } listFixCon <- c(listFixCon, tryresult) runnum <- runnum + 1 } poscon <- seq_along(diffcon$id) + length(fixval) rownames(fixCon)[poscon] <- names(listFixCon)[poscon] <- namept0[diffcon$id] result <- cbind(freeCon, fixCon) if(return.fit) { return(invisible(list(result = result, models = list(free = listFreeCon, fix = listFixCon)))) } else { return(result) } } ## ---------------- ## Hidden Functions ## ---------------- paramNameFromPt <- function(pt) { ngroups <- max(pt$group) result <- NULL if (ngroups == 1) { result <- paste0(pt$lhs, pt$op, pt$rhs) } else { grouplab <- paste0(".g", pt$group) grouplab[grouplab == ".g0" | grouplab == ".g1"] <- "" result <- paste0(pt$lhs, pt$op, pt$rhs, grouplab) } con <- pt$op == "==" pt$lhs[con] <- result[match(pt$lhs[con], pt$plabel)] pt$rhs[con] <- result[match(pt$rhs[con], pt$plabel)] result[con] <- paste(pt$lhs[con], pt$op[con], pt$rhs[con]) result } ##' @importFrom lavaan lavInspect refit <- function(pt, object, resetstart = TRUE) { if (resetstart && "start" %in% names(pt)) pt <- pt[-which("start" == names(pt))] previousCall <- lavInspect(object, "call") ## Why this? args <- previousCall[-1] args$model <- pt funcall <- as.character(previousCall[[1]]) do.call(funcall[length(funcall)], args) ## instead of this? # previousCall$model <- pt # eval(previousCall) } semTools/R/dataDiagnosis.R0000644000176200001440000002446414677254477015216 0ustar liggesusers### Sunthud Pornprasertmanit & Terrence D. Jorgensen ### Last updated: 2 October 2024 ### Higher-order moments. Initial version from the simsem package. ##' Finding skewness ##' ##' Finding skewness (\eqn{g_{1}}) of an object ##' ##' The skewness computed by default is \eqn{g_{1}}, the third standardized ##' moment of the empirical distribution of `object`. ##' The population parameter skewness \eqn{\gamma_{1}} formula is ##' ##' \deqn{\gamma_{1} = \frac{\mu_{3}}{\mu^{3/2}_{2}},} ##' ##' where \eqn{\mu_{i}} denotes the \eqn{i} order central moment. ##' ##' The skewness formula for sample statistic \eqn{g_{1}} is ##' ##' \deqn{g_{1} = \frac{k_{3}}{k^{2}_{2}},} ##' ##' where \eqn{k_{i}} are the \eqn{i} order *k*-statistic. ##' ##' The standard error of the skewness is ##' ##' \deqn{Var(\hat{g}_1) = \frac{6}{N}} ##' ##' where \eqn{N} is the sample size. ##' ##' ##' @importFrom stats pnorm ##' ##' @param object A vector used to find a skewness ##' @param population `TRUE` to compute the parameter formula. `FALSE` ##' to compute the sample statistic formula. ##' @return A value of a skewness with a test statistic if the population is ##' specified as `FALSE` ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso \itemize{ ##' \item [kurtosis()] Find the univariate excessive kurtosis ##' of a variable ##' \item [mardiaSkew()] Find Mardia's multivariate skewness ##' of a set of variables ##' \item [mardiaKurtosis()] Find the Mardia's multivariate ##' kurtosis of a set of variables ##' } ##' @references Weisstein, Eric W. (n.d.). *Skewness*. Retrived from ##' *MathWorld*--A Wolfram Web Resource: ##' ##' @examples ##' ##' skew(1:5) ##' ##' @export skew <- function(object, population = FALSE) { if(any(is.na(object))) { object <- object[!is.na(object)] warning("Missing observations are removed from a vector.") } if(population) { out <- centralMoment(object, 3) / (centralMoment(object, 2)^(3/2)) } else { est <- kStat(object, 3) / (kStat(object, 2)^(3/2)) se <- sqrt(6/length(object)) z <- est/se p <- (1 - pnorm(abs(z)))*2 out <- c("skew (g1)"=est, se=se, z=z, p=p) } class(out) <- c("lavaan.vector", "numeric") out } ##' Finding excessive kurtosis ##' ##' Finding excessive kurtosis (\eqn{g_{2}}) of an object ##' ##' The excessive kurtosis computed by default is \eqn{g_{2}}, the fourth ##' standardized moment of the empirical distribution of `object`. ##' The population parameter excessive kurtosis \eqn{\gamma_{2}} formula is ##' ##' \deqn{\gamma_{2} = \frac{\mu_{4}}{\mu^{2}_{2}} - 3,} ##' ##' where \eqn{\mu_{i}} denotes the \eqn{i} order central moment. ##' ##' The excessive kurtosis formula for sample statistic \eqn{g_{2}} is ##' ##' \deqn{g_{2} = \frac{k_{4}}{k^{2}_{2}} - 3,} ##' ##' where \eqn{k_{i}} are the \eqn{i} order *k*-statistic. ##' ##' The standard error of the excessive kurtosis is ##' ##' \deqn{Var(\hat{g}_{2}) = \frac{24}{N}} ##' ##' where \eqn{N} is the sample size. ##' ##' ##' @importFrom stats pnorm ##' ##' @param object A vector used to find a excessive kurtosis ##' @param population `TRUE` to compute the parameter formula. `FALSE` ##' to compute the sample statistic formula. ##' @return A value of an excessive kurtosis with a test statistic if the ##' population is specified as `FALSE` ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso \itemize{ ##' \item [skew()] Find the univariate skewness of a variable ##' \item [mardiaSkew()] Find the Mardia's multivariate ##' skewness of a set of variables ##' \item [mardiaKurtosis()] Find the Mardia's multivariate kurtosis ##' of a set of variables ##' } ##' @references Weisstein, Eric W. (n.d.). *Kurtosis.* Retrieved from ##' *MathWorld*--A Wolfram Web Resource: ##' ##' ##' @examples ##' ##' kurtosis(1:5) ##' ##' @export kurtosis <- function(object, population = FALSE) { if(any(is.na(object))) { object <- object[!is.na(object)] warning("Missing observations are removed from a vector.") } if(population) { out <- (centralMoment(object, 4) / (centralMoment(object, 2)^2)) - 3 } else { est <- kStat(object, 4) / (kStat(object, 2)^(2)) se <- sqrt(24/length(object)) z <- est/se p <- (1 - pnorm(abs(z)))*2 out <- c("Excess Kur (g2)"=est, se=se, z=z, p=p) } class(out) <- c("lavaan.vector", "numeric") out } ##' Finding Mardia's multivariate skewness ##' ##' Finding Mardia's multivariate skewness of multiple variables ##' ##' The Mardia's multivariate skewness formula (Mardia, 1970) is ##' \deqn{ b_{1, d} = \frac{1}{n^2}\sum^n_{i=1}\sum^n_{j=1}\left[ ##' \left(\bold{X}_i - \bold{\bar{X}} \right)^{'} \bold{S}^{-1} ##' \left(\bold{X}_j - \bold{\bar{X}} \right) \right]^3, } ##' where \eqn{d} is the number of variables, \eqn{X} is the target dataset ##' with multiple variables, \eqn{n} is the sample size, \eqn{\bold{S}} is ##' the sample covariance matrix of the target dataset, and \eqn{\bold{\bar{X}}} ##' is the mean vectors of the target dataset binded in \eqn{n} rows. ##' When the population multivariate skewness is normal, the ##' \eqn{\frac{n}{6}b_{1,d}} is asymptotically distributed as \eqn{\chi^2} ##' distribution with \eqn{d(d + 1)(d + 2)/6} degrees of freedom. ##' ##' ##' @importFrom stats cov pchisq ##' ##' @param dat The target matrix or data frame with multiple variables ##' @param use Missing data handling method from the [stats::cov()] ##' function. ##' @return A value of a Mardia's multivariate skewness with a test statistic ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso \itemize{ ##' \item [skew()] Find the univariate skewness of a variable ##' \item [kurtosis()] Find the univariate excessive ##' kurtosis of a variable ##' \item [mardiaKurtosis()] Find the Mardia's multivariate ##' kurtosis of a set of variables ##' } ##' @references Mardia, K. V. (1970). Measures of multivariate skewness and ##' kurtosis with applications. *Biometrika, 57*(3), 519--530. ##' \doi{10.2307/2334770} ##' @examples ##' ##' library(lavaan) ##' mardiaSkew(HolzingerSwineford1939[ , paste0("x", 1:9)]) ##' ##' @export mardiaSkew <- function(dat, use = "everything") { centeredDat <- scale(dat, center=TRUE, scale=FALSE) invS <- solve(cov(dat, use = use)) FUN <- function(vec1, vec2, invS) { as.numeric(t(as.matrix(vec1)) %*% invS %*% as.matrix(vec2)) } FUN2 <- function(vec1, listVec2, invS) { sapply(listVec2, FUN, vec1=vec1, invS=invS) } indivTerm <- sapply(as.list(data.frame(t(centeredDat))), FUN2, listVec2=as.list(data.frame(t(centeredDat))), invS=invS) b1d <- sum(indivTerm^3, na.rm = TRUE) / (nrow(dat)^2) d <- ncol(dat) chi <- nrow(dat) * b1d / 6 df <- d * (d + 1) * (d + 2) / 6 p <- pchisq(chi, df = df, lower.tail = FALSE) out <- c(b1d = b1d, chi = chi, df=df, p=p) class(out) <- c("lavaan.vector", "numeric") return(out) } ##' Finding Mardia's multivariate kurtosis ##' ##' Finding Mardia's multivariate kurtosis of multiple variables ##' ##' The Mardia's multivariate kurtosis formula (Mardia, 1970) is ##' \deqn{ b_{2, d} = \frac{1}{n}\sum^n_{i=1}\left[ \left(\bold{X}_i - ##' \bold{\bar{X}} \right)^{'} \bold{S}^{-1} \left(\bold{X}_i - ##' \bold{\bar{X}} \right) \right]^2, } ##' where \eqn{d} is the number of variables, \eqn{X} is the target ##' dataset with multiple variables, \eqn{n} is the sample size, \eqn{\bold{S}} ##' is the sample covariance matrix of the target dataset, and ##' \eqn{\bold{\bar{X}}} is the mean vectors of the target dataset binded in ##' \eqn{n} rows. When the population multivariate kurtosis is normal, the ##' \eqn{b_{2,d}} is asymptotically distributed as normal distribution with the ##' mean of \eqn{d(d + 2)} and variance of \eqn{8d(d + 2)/n}. ##' ##' ##' @importFrom stats cov pnorm ##' ##' @param dat The target matrix or data frame with multiple variables ##' @param use Missing data handling method from the [stats::cov()] ##' function. ##' @return A value of a Mardia's multivariate kurtosis with a test statistic ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' @seealso \itemize{ ##' \item [skew()] Find the univariate skewness of a variable ##' \item [kurtosis()] Find the univariate excessive kurtosis ##' of a variable ##' \item [mardiaSkew()] Find the Mardia's multivariate skewness ##' of a set of variables ##' } ##' @references Mardia, K. V. (1970). Measures of multivariate skewness and ##' kurtosis with applications. *Biometrika, 57*(3), 519--530. ##' \doi{10.2307/2334770} ##' @examples ##' ##' library(lavaan) ##' mardiaKurtosis(HolzingerSwineford1939[ , paste0("x", 1:9)]) ##' ##' @export mardiaKurtosis <- function(dat, use = "everything") { centeredDat <- scale(dat, center=TRUE, scale=FALSE) invS <- solve(cov(dat, use = use)) FUN <- function(vec, invS) { as.numeric(t(as.matrix(vec)) %*% invS %*% as.matrix(vec)) } indivTerm <- sapply(as.list(data.frame(t(centeredDat))), FUN, invS=invS) b2d <- sum(indivTerm^2, na.rm = TRUE) / nrow(dat) d <- ncol(dat) m <- d * (d + 2) v <- 8 * d * (d + 2) / nrow(dat) z <- (b2d - m)/sqrt(v) p <- pnorm(-abs(z)) * 2 out <- c(b2d = b2d, z = z, p=p) class(out) <- c("lavaan.vector", "numeric") return(out) } ## ---------------- ## Hidden Functions ## ---------------- ## centralMoment ## Calculate central moments of a variable ## Arguments: ## x: vector of a variable ## ord: order of the moment ## weight: weight variable centralMoment <- function(x, ord) { if(ord < 2) stop("Central moment can be calculated for order 2 or more in an integer.") wm <- mean(x) result <- sum((x - wm)^(ord))/length(x) return(result) } ## Example ## centralMoment(1:5, 2) ## kStat ## Calculate the k-statistic (i.e., unbiased estimator of a cumulant) of a variable ## Arguments: ## x: vector of a variable ## ord: order of the k-statistics kStat <- function(x, ord) { # Formula from mathworld wolfram n <- length(x) if(ord == 1) { return(mean(x)) } else if (ord == 2) { return(centralMoment(x, 2) * n / (n - 1)) } else if (ord == 3) { return(centralMoment(x, 3) * n^2 / ((n - 1) * (n - 2))) } else if (ord == 4) { num1 <- n^2 num2 <- (n + 1) * centralMoment(x, 4) num3 <- 3 * (n - 1) * centralMoment(x, 2)^2 denom <- (n - 1) * (n - 2) * (n - 3) return((num1 * (num2 - num3))/denom) } else { stop("Order can be 1, 2, 3, or 4 only.") } } ## Example ## kStat(1:5, 4) semTools/R/runMI.R0000644000176200001440000004761314764332732013463 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### runMI creates OLDlavaan.mi object, inherits from lavaanList class ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ## ------------- ## Main function ## ------------- ##' Fit a lavaan Model to Multiple Imputed Data Sets ##' ##' This function fits a lavaan model to a list of imputed data sets, and can ##' also implement multiple imputation for a single `data.frame` with ##' missing observations, using either the Amelia package or the mice package. ##' ##' ##' @aliases runMI-deprecated lavaan.mi-deprecated cfa.mi-deprecated sem.mi-deprecated growth.mi-deprecated ##' @importFrom lavaan lavInspect parTable ##' @importFrom methods getMethod ##' ##' @param model The analysis model can be specified using ##' [lavaan::model.syntax()] or a [lavaan::parTable()] ##' @param data A `data.frame` with missing observations, or a `list` ##' of imputed data sets (if data are imputed already). If `runMI()` has ##' already been called, then imputed data sets are stored in the ##' `@@DataList` slot, so `data=` can also be an `OLDlavaan.mi` object ##' from which the same imputed data will be used for additional analyses. ##' @param fun `character`. Name of a specific lavaan function used to fit ##' `model=` to `data=` (i.e., `"lavaan"`, `"cfa"`, `"sem"`, or `"growth"`). ##' Only required for `runMI()`. ##' @param \dots additional arguments to pass to [lavaan::lavaan()] or ##' [lavaan::lavaanList()]. See also [lavaan::lavOptions()]. ##' Note that `lavaanList` provides parallel computing options, as well as ##' a `FUN` argument so the user can extract custom output after the model ##' is fitted to each imputed data set (see **Examples**). TIP: If a ##' custom `FUN` is used *and* `parallel = "snow"` is requested, ##' the user-supplied function should explicitly call `library` or use ##' \code{\link[base]{::}} for any functions not part of the base distribution. ##' @param m `integer`. Request the number of imputations. Ignored if `data=` is ##' already a `list` of imputed data sets or an `OLDlavaan.mi` object. ##' @param miArgs Addition arguments for the multiple-imputation function ##' (`miPackage`). The arguments should be put in a list (see example ##' below). Ignored if `data=` is already a `list` of imputed data ##' sets or an `OLDlavaan.mi` object. ##' @param miPackage Package to be used for imputation. Currently these ##' functions only support `"Amelia"` or `"mice"` for imputation. ##' Ignored if `data` is already a `list` of imputed data sets or an ##' `OLDlavaan.mi` object. ##' @param seed `integer`. Random number seed to be set before imputing the ##' data. Ignored if `data` is already a `list` of imputed data sets ##' or an `OLDlavaan.mi` object. ##' ##' @return A [semTools::OLDlavaan.mi-class] object ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Enders, C. K. (2010). *Applied missing data analysis*. New ##' York, NY: Guilford. ##' ##' Rubin, D. B. (1987). *Multiple imputation for nonresponse in surveys*. ##' New York, NY: Wiley. ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' ##' @name runMI-deprecated ##' @usage ##' runMI(model, data, fun = "lavaan", ..., ##' m, miArgs = list(), miPackage = "Amelia", seed = 12345) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @section `runMI()` and the `lavaan.mi` class functionality: ##' The `runMI()` function and support for `lavaan.mi-class` objects became ##' such a large part of semTools that it made sense to move that functionality ##' to its own package. The \pkg{lavaan.mi} package is now available for users ##' to fit `lavaan` models to their multiply imputed data. The new package ##' already fixes many bugs and provides many new features that make the ##' semTools `OLDlavaan.mi-class` obsolete. Please immediately discontinue ##' your dependence on `semTools::runMI()` amd transition to the new ##' \pkg{lavaan.mi} package, which also provides a more similar user interface ##' as the \pkg{lavaan} package provides for a single `data=` set. The README ##' on provides a list of analogous ##' functionality in \pkg{lavaan} and \pkg{lavaan.mi}, and the NEWS file ##' documents new features and other differences from the deprecated ##' `semTools::runMI()` functionality. ##' ##' @export runMI <- function(model, data, fun = "lavaan", ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) { .Deprecated(msg = c("\nThe runMI() function and lavaan.mi-class have been ", "deprecated and will cease to be included in future ", "versions of semTools.\n\nSupport is still provided for ", "analyzing lavaan.mi-class objects (e.g., compRelSEM() ", "can estimate reliability using pooled results), which ", "can now be created using the lavaan.mi package.\n\nThe ", "deprecated runMI() function now creates an object of ", "class OLDlavaan.mi, which can be analyzed using the ", "deprecated functions in semTools, like lavTestLRT.mi(),", " that have been updated and improved in the lavaan.mi ", "package.\n\nFind more details help('semTools-deprecated)")) CALL <- match.call() dots <- list(...) ## check for (Bollen-Stine) bootstrap request if (all(!is.null(dots$test), tolower(dots$test) %in% c("boot","bootstrap","bollen.stine")) || all(!is.null(dots$se), tolower(dots$se) %in% c("boot","bootstrap"))) { stop('Bootstraping unavailable (and not recommended) in combination with ', 'multiple imputations. For robust confidence intervals of indirect', ' effects, see the ?semTools::monteCarloCI help page. To bootstrap ', 'within each imputation, users can pass a custom function to the ', 'FUN= argument (see ?lavaanList) to save bootstrap distributions in ', 'the @funList slot, then manually combine afterward.') } seed <- as.integer(seed[1]) ## Create (or acknowledge) list of imputed data sets imputedData <- NULL if (missing(data)) { #TODO: check for summary statistics #TODO: make lavaanList() accept lists of summary stats #TODO: Add argument to implement Li Cai's pool-polychorics first, pass # to lavaan for DWLS with pooled WLS.V= and NACOV=, return(lavaan). } else if (is.data.frame(data)) { if (miPackage[1] == "Amelia") { requireNamespace("Amelia") if (!"package:Amelia" %in% search()) attachNamespace("Amelia") imputeCall <- c(list(Amelia::amelia, x = data, m = m, p2s = 0), miArgs) set.seed(seed) imputedData <- unclass(eval(as.call(imputeCall))$imputations) } else if (miPackage[1] == "mice") { requireNamespace("mice") if (!"package:mice" %in% search()) attachNamespace("mice") imputeCall <- c(list(mice::mice, data = data, m = m, diagnostics = FALSE, printFlag = FALSE), miArgs) set.seed(seed) miceOut <- eval(as.call(imputeCall)) imputedData <- list() for (i in 1:m) { imputedData[[i]] <- mice::complete(data = miceOut, action = i, include = FALSE) } } else stop("Currently runMI only supports imputation by Amelia or mice") } else if (is.list(data)) { ## check possibility that it is a mids object (inherits from list) if (requireNamespace("mice", quietly = TRUE)) { if (mice::is.mids(data)) { m <- data$m imputedData <- list() for (i in 1:m) { imputedData[[i]] <- mice::complete(data, action = i, include = FALSE) } imputeCall <- list() } else { seed <- integer(length = 0) imputeCall <- list() imputedData <- data m <- length(data) class(imputedData) <- "list" # override inheritance (e.g., "mi" if Amelia) } } else { ## can't check for mice, so probably isn't mids seed <- integer(length = 0) imputeCall <- list() imputedData <- data m <- length(data) class(imputedData) <- "list" # override inheritance (e.g., "mi" if Amelia) } } else if (is(data, "OLDlavaan.mi")) { seed <- data@seed imputeCall <- data@imputeCall imputedData <- data@DataList m <- length(imputedData) } else stop("data is not a valid input type: a partially observed data.frame,", " a list of imputed data.frames, or previous OLDlavaan.mi object") ## Function to get custom output for OLDlavaan.mi object ## NOTE: Need "lavaan::" to allow for parallel computations .getOutput. <- function(obj) { converged <- lavaan::lavInspect(obj, "converged") if (converged) { se <- lavaan::parTable(obj)$se se.test <- all(!is.na(se)) & all(se >= 0) & any(se != 0) if (lavaan::lavInspect(obj, "ngroups") == 1L && lavaan::lavInspect(obj, "nlevels") == 1L) { Heywood.lv <- det(lavaan::lavInspect(obj, "cov.lv")) <= 0 Heywood.ov <- det(lavaan::lavInspect(obj, "theta")) <= 0 } else { Heywood.lv <- !all(sapply(lavaan::lavInspect(obj, "cov.lv"), det) > 0) Heywood.ov <- !all(sapply(lavaan::lavInspect(obj, "theta"), det) > 0) } } else { se.test <- Heywood.lv <- Heywood.ov <- NA } list(sampstat = lavaan::lavInspect(obj, "sampstat"), coefMats = lavaan::lavInspect(obj, "est"), satPT = data.frame(lavaan::lav_partable_unrestricted(obj), #FIXME: do starting values ALWAYS == estimates? stringsAsFactors = FALSE), modindices = try(lavaan::modindices(obj), silent = TRUE), cov.lv = lavaan::lavInspect(obj, "cov.lv"), #TODO: calculate from pooled estimates for reliability() converged = converged, SE = se.test, Heywood.lv = Heywood.lv, Heywood.ov = Heywood.ov) } ## fit model using lavaanList lavListCall <- list(lavaan::lavaanList, model = model, dataList = imputedData, cmd = fun) lavListCall <- c(lavListCall, dots) lavListCall$store.slots <- c("partable","vcov","test","h1","baseline") lavListCall$FUN <- if (is.null(dots$FUN)) .getOutput. else function(obj) { temp1 <- .getOutput.(obj) temp2 <- dots$FUN(obj) if (!is.list(temp2)) temp2 <- list(userFUN1 = temp2) if (is.null(names(temp2))) names(temp2) <- paste0("userFUN", 1:length(temp2)) duplicatedNames <- which(sapply(names(temp2), function(x) { x %in% c("sampstat","coefMats","satPT","modindices","converged", "SE","Heywood.lv","Heywood.ov","cov.lv") })) for (i in duplicatedNames) names(temp2)[i] <- paste0("userFUN", i) c(temp1, temp2) } fit <- eval(as.call(lavListCall)) ## Store custom @DataList and @SampleStatsList fit@SampleStatsList <- lapply(fit@funList, "[[", i = "sampstat") fit@DataList <- imputedData ## add parameter table to @h1List for (i in 1:m) fit@h1List[[i]] <- c(fit@h1List[[i]], list(PT = fit@funList[[i]]$satPT)) ## assign class and add new slots fit <- as(fit, "OLDlavaan.mi") fit@coefList <- lapply(fit@funList, "[[", i = "coefMats") fit@miList <- lapply(fit@funList, "[[", i = "modindices") fit@phiList <- lapply(fit@funList, "[[", i = "cov.lv") fit@seed <- seed fit@call <- CALL fit@lavListCall <- lavListCall fit@imputeCall <- imputeCall convList <- lapply(fit@funList, "[", i = c("converged","SE", "Heywood.lv","Heywood.ov")) nonConv <- which(sapply(convList, is.null)) if (length(nonConv)) for (i in nonConv) { convList[[i]] <- list(converged = FALSE, SE = NA, Heywood.lv = NA, Heywood.ov = NA) } fit@convergence <- lapply(convList, function(x) do.call(c, x)) conv <- which(sapply(fit@convergence, "[", i = "converged")) if (!length(conv)) warning('The model did not converge for any imputed data sets.') ## keep any remaining funList slots (if allowing users to supply custom FUN) funNames <- names(fit@funList[[1]]) keepIndex <- which(!sapply(funNames, function(x) { x %in% c("sampstat","coefMats","satPT","modindices","converged", "SE","Heywood.lv","Heywood.ov","cov.lv") })) if (length(keepIndex)) { fit@funList <- lapply(fit@funList, "[", i = keepIndex) if (length(keepIndex) > 1L) { keepNames <- funNames[keepIndex] noNames <- which(keepNames == "") for (i in seq_along(noNames)) keepNames[ noNames[i] ] <- paste0("userFUN", i) fit@funList <- lapply(fit@funList, "names<-", value = keepNames) } } else fit@funList <- list() NewStartVals <- try(getMethod("coef", "OLDlavaan.mi")(fit, type = "user", labels = FALSE), silent = TRUE) if (!inherits(NewStartVals, "try-error")) fit@ParTable$start <- NewStartVals fit } ##' @name runMI-deprecated ##' @usage ##' lavaan.mi(model, data, ..., ##' m, miArgs = list(), miPackage = "Amelia", seed = 12345) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export lavaan.mi <- function(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) { # runMI(model = model, data = data, fun = "lavaan", ..., # m = m, miArgs = miArgs, miPackage = miPackage, seed = seed) mc <- match.call(expand.dots = TRUE) mc$fun <- "lavaan" mc[[1L]] <- quote(semTools::runMI) eval(mc, parent.frame()) } ##' @name runMI-deprecated ##' @usage ##' cfa.mi(model, data, ..., ##' m, miArgs = list(), miPackage = "Amelia", seed = 12345) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export cfa.mi <- function(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) { # runMI(model = model, data = data, fun = "cfa", ..., # m = m, miArgs = miArgs, miPackage = miPackage, seed = seed) mc <- match.call(expand.dots = TRUE) mc$fun <- "cfa" mc[[1L]] <- quote(semTools::runMI) eval(mc, parent.frame()) } ##' @name runMI-deprecated ##' @usage ##' sem.mi(model, data, ..., ##' m, miArgs = list(), miPackage = "Amelia", seed = 12345) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export sem.mi <- function(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) { # runMI(model = model, data = data, fun = "sem", ..., # m = m, miArgs = miArgs, miPackage = miPackage, seed = seed) mc <- match.call(expand.dots = TRUE) mc$fun <- "sem" mc[[1L]] <- quote(semTools::runMI) eval(mc, parent.frame()) } ##' @name runMI-deprecated ##' @usage ##' growth.mi(model, data, ..., ##' m, miArgs = list(), miPackage = "Amelia", seed = 12345) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export growth.mi <- function(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) { # runMI(model = model, data = data, fun = "growth", ..., # m = m, miArgs = miArgs, miPackage = miPackage, seed = seed) mc <- match.call(expand.dots = TRUE) mc$fun <- "growth" mc[[1L]] <- quote(semTools::runMI) eval(mc, parent.frame()) } ## ----------------- ## Utility functions ## ----------------- ##' Calculate the "D2" statistic ##' ##' This is a utility function used to calculate the "D2" statistic for pooling ##' test statistics across multiple imputations. This function is called by ##' several functions used for [OLDlavaan.mi-class] objects, such as ##' [lavTestLRT.mi()], [lavTestWald.mi()], and ##' [lavTestScore.mi()]. But this function can be used for any general ##' scenario because it only requires a vector of \eqn{\chi^2} statistics (one ##' from each imputation) and the degrees of freedom for the test statistic. ##' See Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010, chapter 8) for ##' details about how it is calculated. ##' ##' @importFrom stats var pf pchisq ##' ##' @param w `numeric` vector of Wald \eqn{\chi^2} statistics. Can also ##' be Wald *z* statistics, which will be internally squared to make ##' \eqn{\chi^2} statistics with one *df* (must set `DF = 0L`). ##' @param DF degrees of freedom (*df*) of the \eqn{\chi^2} statistics. ##' If `DF = 0L` (default), `w` is assumed to contain *z* ##' statistics, which will be internally squared. ##' @param asymptotic `logical`. If `FALSE` (default), the pooled test ##' will be returned as an *F*-distributed statistic with numerator ##' (`df1`) and denominator (`df2`) degrees of freedom. ##' If `TRUE`, the pooled *F* statistic will be multiplied by its ##' `df1` on the assumption that its `df2` is sufficiently large ##' enough that the statistic will be asymptotically \eqn{\chi^2} distributed ##' with `df1`. ##' ##' @return A `numeric` vector containing the test statistic, *df*, ##' its *p* value, and 2 missing-data diagnostics: the relative invrease ##' in variance (RIV, or average for multiparameter tests: ARIV) and the ##' fraction missing information (FMI = ARIV / (1 + ARIV)). ##' ##' @seealso [lavTestLRT.mi()], [lavTestWald.mi()], [lavTestScore.mi()] ##' ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Enders, C. K. (2010). *Applied missing data analysis*. New ##' York, NY: Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data. *Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' @examples ##' ## generate a vector of chi-squared values, just for example ##' DF <- 3 # degrees of freedom ##' M <- 20 # number of imputations ##' CHI <- rchisq(M, DF) ##' ##' ## pool the "results" ##' calculate.D2(CHI, DF) # by default, an F statistic is returned ##' calculate.D2(CHI, DF, asymptotic = TRUE) # asymptotically chi-squared ##' ##' ## generate standard-normal values, for an example of Wald z tests ##' Z <- rnorm(M) ##' calculate.D2(Z) # default DF = 0 will square Z to make chisq(DF = 1) ##' ## F test is equivalent to a t test with the denominator DF ##' ##' @name calculate.D2-deprecated ##' @usage calculate.D2(w, DF = 0L, asymptotic = FALSE) ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' ##' @export calculate.D2 <- function(w, DF = 0L, asymptotic = FALSE) { .Deprecated(msg = c("\nThe calculate.D2() function has been deprecated from ", "semTools and moved to the new lavaan.mi package, along ", "with other multiple-imputation functionality related to", " runMI().\nSee help('semTools-deprecated)")) if (length(w) == 0L) return(NA) w <- as.numeric(w) DF <- as.numeric(DF) nImps <- sum(!is.na(w)) if (nImps == 0) return(NA) if (DF <= 0L) { ## assume they are Z scores w <- w^2 DF <- 1L } ## pool test statistics if (length(w) > 1L) { w_bar <- mean(w, na.rm = TRUE) ariv <- (1 + 1/nImps) * var(sqrt(w), na.rm = TRUE) test.stat <- (w_bar/DF - ((nImps + 1) * ariv / (nImps - 1))) / (1 + ariv) } else { warning('There was only 1 non-missing value to pool, leading to zero ', 'variance, so D2 cannot be calculated.') test.stat <- ariv <- NA } if (test.stat < 0) test.stat <- 0 if (asymptotic) { out <- c("chisq" = test.stat * DF, df = DF, pvalue = pchisq(test.stat * DF, df = DF, lower.tail = FALSE), ariv = ariv, fmi = ariv / (1 + ariv)) } else { v3 <- DF^(-3 / nImps) * (nImps - 1) * (1 + (1 / ariv))^2 out <- c("F" = test.stat, df1 = DF, df2 = v3, pvalue = pf(test.stat, df1 = DF, df2 = v3, lower.tail = FALSE), ariv = ariv, fmi = ariv / (1 + ariv)) } class(out) <- c("lavaan.vector","numeric") out } semTools/R/measurementInvariance.R0000644000176200001440000002770314753124717016754 0ustar liggesusers### Sunthud Pornprasertmanit, Yves Rosseel, and Terrence D. Jorgensen ### Last updated: 12 June 2024 ### DEPRECATED: 9 May 2022 ##' Measurement Invariance Tests ##' ##' Testing measurement invariance across groups using a typical sequence of ##' model comparison tests. ##' ##' If `strict = FALSE`, the following four models are tested in order: ##' \enumerate{ ##' \item Model 1: configural invariance. The same factor structure ##' is imposed on all groups. ##' \item Model 2: weak invariance. The factor loadings are constrained to ##' be equal across groups. ##' \item Model 3: strong invariance. The factor loadings and intercepts ##' are constrained to be equal across groups. ##' \item Model 4: The factor loadings, intercepts and means are constrained ##' to be equal across groups. ##' } ##' ##' Each time a more restricted model is fitted, a \eqn{\Delta\chi^2} test is ##' reported, comparing the current model with the previous one, and comparing ##' the current model to the baseline model (Model 1). In addition, the ##' difference in CFI is also reported (\eqn{\Delta}CFI). ##' ##' If `strict = TRUE`, the following five models are tested in order: ##' \enumerate{ ##' \item Model 1: configural invariance. The same factor structure ##' is imposed on all groups. ##' \item Model 2: weak invariance. The factor loadings are constrained to be ##' equal across groups. ##' \item Model 3: strong invariance. The factor loadings and intercepts are ##' constrained to be equal across groups. ##' \item Model 4: strict invariance. The factor loadings, intercepts and ##' residual variances are constrained to be equal across groups. ##' \item Model 5: The factor loadings, intercepts, residual variances and means ##' are constrained to be equal across groups. ##' } ##' ##' Note that if the \eqn{\chi^2} test statistic is scaled (e.g., a Satorra-Bentler ##' or Yuan-Bentler test statistic), a special version of the \eqn{\Delta\chi^2} ##' test is used as described in ##' ##' @importFrom lavaan parTable ##' ##' @param ... The same arguments as for any lavaan model. See ##' [lavaan::cfa()] for more information. ##' @param std.lv If `TRUE`, the fixed-factor method of scale ##' identification is used. If `FALSE`, the first variable for each factor ##' is used as marker variable. ##' @param strict If `TRUE`, the sequence requires `strict' invariance. ##' See details for more information. ##' @param quiet If `FALSE` (default), a summary is printed out containing ##' an overview of the different models that are fitted, together with some ##' model comparison tests. If `TRUE`, no summary is printed. ##' @param fit.measures Fit measures used to calculate the differences between ##' nested models. ##' @param baseline.model custom baseline model passed to ##' [lavaan::fitMeasures()] ##' @param method The method used to calculate likelihood ratio test. See ##' [lavaan::lavTestLRT()] for available options ##' ##' @return Invisibly, all model fits in the sequence are returned as a list. ##' ##' @author Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) ##' ##' @references ##' Vandenberg, R. J., and Lance, C. E. (2000). A review and synthesis of the ##' measurement invariance literature: Suggestions, practices, and ##' recommendations for organizational research. *Organizational ##' Research Methods, 3,* 4--70. ##' ##' @examples ##' ##' HW.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' measurementInvariance(model = HW.model, data = HolzingerSwineford1939, ##' group = "school", fit.measures = c("cfi","aic")) ##' ##' @name measurementInvariance-deprecated ##' @usage ##' measurementInvariance(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, ##' fit.measures = "default", baseline.model = NULL, ##' method = "satorra.bentler.2001") ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @section Previous measurement-invariance functions: ##' The `measurementInvariance`, `measurementInvarianceCat`, and ##' `longInvariance` functions will no longer be supported. Instead, use ##' the [measEq.syntax()] function, which is much more flexible and ##' supports a wider range of data (e.g., any mixture of `numeric` and ##' `ordered` indicators, any combination of multiple groups and repeated ##' measures, models fit to multiple imputations with [lavaan.mi::lavaan.mi()]). ##' ##' @export measurementInvariance <- function(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001") { .Deprecated(msg = c("The measurementInvariance function is deprecated, and", " it will cease to be included in future versions of ", "semTools. See help('semTools-deprecated) for details.")) lavaancfa <- function(...) { lavaan::cfa(...) } ## check for a group.equal argument in ... dotdotdot <- list(...) if (is.null(dotdotdot$model)) stop('all lavaan() and lavOptions() arguments must', ' named, including the "model=" argument.') if (!is.null(dotdotdot$group.equal)) stop("lavaan ERROR: group.equal argument should not be used") ## and a model if (names(dotdotdot)[1] == "") names(dotdotdot)[1] <- "model" res <- list() ## base-line model: configural invariance configural <- dotdotdot configural$group.equal <- "" template <- try(do.call(lavaancfa, configural), silent = TRUE) if (inherits(template, "try-error")) stop('Configural model did not converge.') pttemplate <- parTable(template) varnames <- unique(pttemplate$rhs[pttemplate$op == "=~"]) facnames <- unique(pttemplate$lhs[(pttemplate$op == "=~") & (pttemplate$rhs %in% varnames)]) ngroups <- max(pttemplate$group) if (ngroups <= 1) stop("Well, the number of groups is 1. Measurement", " invariance across 'groups' cannot be done.") if (std.lv) { for (i in facnames) { pttemplate <- fixParTable(pttemplate, i, "~~", i, 1:ngroups, 1) } fixloadings <- which(pttemplate$op == "=~" & pttemplate$free == 0) for (i in fixloadings) { pttemplate <- freeParTable(pttemplate, pttemplate$lhs[i], "=~", pttemplate$rhs[i], pttemplate$group[i]) } dotdotdot$model <- pttemplate res$fit.configural <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { res$fit.configural <- template } ## fix loadings across groups if (std.lv) { findloadings <- which(pttemplate$op == "=~" & pttemplate$free != 0 & pttemplate$group == 1) for (i in findloadings) { pttemplate <- constrainParTable(pttemplate, pttemplate$lhs[i], "=~", pttemplate$rhs[i], 1:ngroups) } for (i in facnames) { pttemplate <- freeParTable(pttemplate, i, "~~", i, 2:ngroups) } dotdotdot$model <- pttemplate res$fit.loadings <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { loadings <- dotdotdot loadings$group.equal <- c("loadings") res$fit.loadings <- try(do.call(lavaancfa, loadings), silent = TRUE) } ## fix loadings + intercepts across groups if (std.lv) { findintcepts <- which(pttemplate$op == "~1" & pttemplate$lhs %in% varnames & pttemplate$free != 0 & pttemplate$group == 1) for (i in findintcepts) { pttemplate <- constrainParTable(pttemplate, pttemplate$lhs[i], "~1", "", 1:ngroups) } for (i in facnames) { pttemplate <- freeParTable(pttemplate, i, "~1", "", 2:ngroups) } dotdotdot$model <- pttemplate res$fit.intercepts <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { intercepts <- dotdotdot intercepts$group.equal <- c("loadings", "intercepts") res$fit.intercepts <- try(do.call(lavaancfa, intercepts), silent = TRUE) } if (strict) { if (std.lv) { findresiduals <- which(pttemplate$op == "~~" & pttemplate$lhs %in% varnames & pttemplate$rhs == pttemplate$lhs & pttemplate$free != 0 & pttemplate$group == 1) for (i in findresiduals) { pttemplate <- constrainParTable(pttemplate, pttemplate$lhs[i], "~~", pttemplate$rhs[i], 1:ngroups) } dotdotdot$model <- pttemplate res$fit.residuals <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) for (i in facnames) { pttemplate <- fixParTable(pttemplate, i, "~1", "", 1:ngroups, 0) } dotdotdot$model <- pttemplate res$fit.means <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { # fix loadings + intercepts + residuals residuals <- dotdotdot residuals$group.equal <- c("loadings", "intercepts", "residuals") res$fit.residuals <- try(do.call(lavaancfa, residuals), silent = TRUE) # fix loadings + residuals + intercepts + means means <- dotdotdot means$group.equal <- c("loadings", "intercepts", "residuals", "means") res$fit.means <- try(do.call(lavaancfa, means), silent = TRUE) } } else { if (std.lv) { for (i in facnames) { pttemplate <- fixParTable(pttemplate, i, "~1", "", 1:ngroups, 0) } dotdotdot$model <- pttemplate res$fit.means <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { # fix loadings + intercepts + means means <- dotdotdot means$group.equal <- c("loadings", "intercepts", "means") res$fit.means <- try(do.call(lavaancfa, means), silent = TRUE) } } if (!quiet) printInvarianceResult(res, fit.measures, baseline.model, method) invisible(res) } ## ---------------- ## Hidden Functions ## ---------------- ##' @importFrom lavaan lavInspect ##' @importMethodsFrom lavaan fitMeasures printInvarianceResult <- function(FIT, fit.measures, baseline.model, method) { ## check whether models converged NAMES <- names(FIT) nonconv <- which(sapply(FIT, class) == "try-error") if (length(nonconv)) { message('The following model(s) did not converge: \n', paste(NAMES[nonconv], sep = "\n")) FIT <- FIT[-nonconv] NAMES <- NAMES[-nonconv] } names(FIT) <- NULL ## compare models lavaanLavTestLRT <- function(...) lavaan::lavTestLRT(...) TABLE <- do.call(lavaanLavTestLRT, c(FIT, list(model.names = NAMES, method = method))) if (length(fit.measures) == 1L && fit.measures == "default") { ## scaled test statistic? if (length(lavInspect(FIT[[1]], "test")) > 1L) { if (lavInspect(FIT[[1]], "test")[[2]]$test %in% c("satorra.bentler", "yuan.bentler")) { fit.measures <- c("cfi.robust", "rmsea.robust") } else fit.measures <- c("cfi.scaled", "rmsea.scaled") } else { fit.measures <- c("cfi", "rmsea") } } ## add some fit measures if (length(fit.measures)) { FM <- lapply(FIT, fitMeasures, fit.measures = fit.measures, baseline.model = baseline.model) FM.table1 <- sapply(fit.measures, function(x) sapply(FM, "[[", x)) if (length(FM) == 1L) { FM.table1 <- rbind( rep(as.numeric(NA), length(fit.measures)), FM.table1) } if (length(FM) > 1L) { FM.table2 <- rbind(as.numeric(NA), abs(apply(FM.table1, 2, diff))) colnames(FM.table2) <- paste(colnames(FM.table2), ".delta", sep = "") FM.TABLE <- as.data.frame(cbind(FM.table1, FM.table2)) } else { FM.TABLE <- as.data.frame(FM.table1) } rownames(FM.TABLE) <- rownames(TABLE) class(FM.TABLE) <- c("lavaan.data.frame", "data.frame") } cat("\n") cat("Measurement invariance models:\n\n") cat(paste(paste("Model", seq_along(FIT), ":", NAMES), collapse = "\n")) cat("\n\n") print(TABLE) if (length(fit.measures)) { cat("\n\n") cat("Fit measures:\n\n") print(FM.TABLE) cat("\n") return(list(anova = TABLE, fitMeasures = FM.TABLE)) } TABLE } semTools/R/fitIndices.R0000644000176200001440000007267614751404365014517 0ustar liggesusers### Title: Compute more fit indices ### Authors: Terrence D. Jorgensen, Sunthud Pornprasertmanit, ### Aaron Boulton, Ruben Arslan, Mauricio Garnier-Villarreal ### Last updated: 7 February 2025 ### Description: Calculations for promising alternative fit indices ##' Calculate more fit indices ##' ##' Calculate more fit indices that are not already provided in lavaan. ##' ##' See [nullRMSEA()] for the further details of the computation of ##' RMSEA of the null model. ##' ##' Gamma-Hat (`gammaHat`; West, Taylor, & Wu, 2012) is a global ##' goodness-of-fit index which can be computed (assuming equal number of ##' indicators across groups) by ##' ##' \deqn{ \hat{\Gamma} =\frac{p}{p + 2 \times \frac{\chi^{2}_{k} - df_{k}}{N}},} ##' ##' where \eqn{p} is the number of variables in the model, \eqn{\chi^{2}_{k}} is ##' the \eqn{\chi^2} test statistic value of the target model, \eqn{df_{k}} is ##' the degree of freedom when fitting the target model, and \eqn{N} is the ##' sample size (or sample size minus the number of groups if `mimic` is ##' set to `"EQS"`). ##' ##' Adjusted Gamma-Hat (`adjGammaHat`; West, Taylor, & Wu, 2012) is a ##' global fit index which can be computed by ##' ##' \deqn{ \hat{\Gamma}_\textrm{adj} = \left(1 - \frac{K \times p \times ##' (p + 1)}{2 \times df_{k}} \right) \times \left( 1 - \hat{\Gamma} \right),} ##' ##' where \eqn{K} is the number of groups (please refer to Dudgeon, 2004, for ##' the multiple-group adjustment for `adjGammaHat`). ##' ##' Note that if Satorra--Bentler's or Yuan--Bentler's method is used, the fit ##' indices using the scaled \eqn{\chi^2} values are also provided. ##' ##' The remaining indices are information criteria calculated using the ##' `object`'s \eqn{-2 \times} log-likelihood, abbreviated \eqn{-2LL}. ##' ##' Corrected Akaike Information Criterion (`aic.smallN`; Burnham & ##' Anderson, 2003) is a corrected version of AIC for small sample size, often ##' abbreviated AICc: ##' ##' \deqn{ \textrm{AIC}_{\textrm{small}-N} = AIC + \frac{2q(q + 1)}{N - q - 1},} ##' ##' where \eqn{AIC} is the original AIC: \eqn{-2LL + 2q} (where \eqn{q} ##' = the number of estimated parameters in the target model). Note that AICc is ##' a small-sample correction derived for univariate regression models, so it is ##' probably *not* appropriate for comparing SEMs. ##' ##' Corrected Bayesian Information Criterion (`bic.priorN`; Kuha, 2004) is ##' similar to BIC but explicitly specifying the sample size on which the prior ##' is based (\eqn{N_{prior}}) using the `nPrior` argument. ##' ##' \deqn{ \textrm{BIC}_{\textrm{prior}-N} = -2LL + q\log{( 1 + \frac{N}{N_{prior}} )}.} ##' ##' Bollen et al. (2012, 2014) discussed additional BICs that incorporate more ##' terms from a Taylor series expansion, which the standard BIC drops. The ##' "Scaled Unit-Information Prior" BIC is calculated depending on whether the ##' product of the vector of estimated model parameters (\eqn{\hat{\theta}}) and ##' the observed information matrix (FIM) exceeds the number of estimated model ##' parameters (Case 1) or not (Case 2), which is checked internally: ##' ##' \deqn{ \textrm{SPBIC}_{\textrm{Case 1}} = -2LL + q(1 - \frac{q}{\hat{\theta}^{'} \textrm{FIM} \hat{\theta}}), \textrm{ or}} ##' \deqn{ \textrm{SPBIC}_{\textrm{Case 2}} = -2LL + \hat{\theta}^{'} \textrm{FIM} \hat{\theta},} ##' ##' Note that this implementation of SPBIC is calculated on the assumption that ##' priors for all estimated parameters are centered at zero, which is ##' inappropriate for most SEMs (e.g., variances should not have priors centered ##' at the lowest possible value; Bollen, 2014, p. 6). ##' ##' Bollen et al. (2014, eq. 14) credit the HBIC to Haughton (1988): ##' ##' \deqn{ \textrm{HBIC} = -2LL + q\log{\frac{N}{2 \pi}}.} ##' ##' Bollen et al. (2012, p. 305) proposed the information matrix (\eqn{I})-based BIC by ##' adding another term: ##' ##' \deqn{ \textrm{IBIC} = -2LL + q\log{\frac{N}{2 \pi}} + \log{\det{\textrm{FIM}}},} ##' ##' or equivalently, using the inverse information (the asymptotic sampling ##' covariance matrix of estimated parameters: ACOV): ##' ##' \deqn{ \textrm{IBIC} = -2LL - q\log{2 \pi} - \log{\det{\textrm{ACOV}}}.} ##' ##' Stochastic information criterion (SIC; see Preacher, 2006, for details) is ##' similar to IBIC but does not include the \eqn{q\log{2 \pi}} term that is ##' also in HBIC. SIC and IBIC both account for model complexity in a model's ##' functional form, not merely the number of free parameters. The SIC can be ##' computed as: ##' ##' \deqn{ \textrm{SIC} = -2LL + q\log{N} + \log{\det{\textrm{FIM}}} = -2LL - \log{\det{\textrm{ACOV}}}.} ##' ##' Hannan--Quinn Information Criterion (HQC; Hannan & Quinn, 1979) is used for ##' model selection, similar to AIC or BIC. ##' ##' \deqn{ \textrm{HQC} = -2LL + 2q\log{(\log{N})},} ##' ##' Bozdogan Information Complexity (ICOMP) Criteria (Howe et al., 2011), ##' instead of penalizing the number of free parameters directly, ##' ICOMP penalizes the covariance complexity of the model. ##' ##' \deqn{ \textrm{ICOMP} = -2LL + s \times log(\frac{\bar{\lambda_a}}{\bar{\lambda_g}}) } ##' ##' ##' @importFrom lavaan lavInspect ##' ##' @param object The lavaan model object provided after running the `cfa`, ##' `sem`, `growth`, or `lavaan` functions. ##' @param fit.measures Additional fit measures to be calculated. All additional ##' fit measures are calculated by default ##' @param nPrior The sample size on which prior is based. This argument is used ##' to compute `bic.priorN`. ##' ##' @return A `numeric` `lavaan.vector` including any of the ##' following requested via `fit.measures=` ##' \enumerate{ ##' \item `gammaHat`: Gamma-Hat ##' \item `adjGammaHat`: Adjusted Gamma-Hat ##' \item `baseline.rmsea`: RMSEA of the default baseline (i.e., independence) model ##' \item `gammaHat.scaled`: Gamma-Hat using scaled \eqn{\chi^2} ##' \item `adjGammaHat.scaled`: Adjusted Gamma-Hat using scaled \eqn{\chi^2} ##' \item `baseline.rmsea.scaled`: RMSEA of the default baseline (i.e., ##' independence) model using scaled \eqn{\chi^2} ##' \item `aic.smallN`: Corrected (for small sample size) AIC ##' \item `bic.priorN`: BIC with specified prior sample size ##' \item `spbic`: Scaled Unit-Information Prior BIC (SPBIC) ##' \item `hbic`: Haughton's BIC (HBIC) ##' \item `ibic`: Information-matrix-based BIC (IBIC) ##' \item `sic`: Stochastic Information Criterion (SIC) ##' \item `hqc`: Hannan-Quinn Information Criterion (HQC) ##' \item `icomp`: Bozdogan Information Complexity (ICOMP) Criteria ##' } ##' ##' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' Aaron Boulton (University of Delaware) ##' ##' Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@@gmail.com}) ##' ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' Mauricio Garnier-Villarreal (Vrije Universiteit Amsterdam; \email{mgv@pm.me}) ##' ##' A great deal of feedback was provided by Kris Preacher regarding Bollen et ##' al.'s (2012, 2014) extensions of BIC. ##' ##' @seealso ##' \itemize{ ##' \item [miPowerFit()] For the modification indices and their ##' power approach for model fit evaluation ##' \item [nullRMSEA()] For RMSEA of the default independence model ##' } ##' ##' @references ##' ##' Bollen, K. A., Ray, S., Zavisca, J., & Harden, J. J. (2012). A comparison of ##' Bayes factor approximation methods including two new methods. ##' *Sociological Methods & Research, 41*(2), 294--324. ##' \doi{10.1177/0049124112452393} ##' ##' Bollen, K. A., Harden, J. J., Ray, S., & Zavisca, J. (2014). BIC and ##' alternative Bayesian information criteria in the selection of structural ##' equation models. *Structural Equation Modeling, 21*(1), 1--19. ##' \doi{10.1080/10705511.2014.856691} ##' ##' Burnham, K., & Anderson, D. (2003). *Model selection and ##' multimodel inference: A practical--theoretic approach*. New York, NY: ##' Springer--Verlag. ##' ##' Dudgeon, P. (2004). A note on extending Steiger's (1998) multiple sample ##' RMSEA adjustment to other noncentrality parameter-based statistic. ##' *Structural Equation Modeling, 11*(3), 305--319. ##' \doi{10.1207/s15328007sem1103_1} ##' ##' Howe, E. D., Bozdogan, H., & Katragadda, S. (2011). Structural equation ##' modeling (SEM) of categorical and mixed-data using the novel Gifi ##' transformations and information complexity (ICOMP) criterion. ##' *Istanbul University Journal of the School of Business Administration, 40*(1), 86--123. ##' ##' Kuha, J. (2004). AIC and BIC: Comparisons of assumptions and performance. ##' *Sociological Methods Research, 33*(2), 188--229. ##' \doi{10.1177/0049124103262065} ##' ##' Preacher, K. J. (2006). Quantifying parsimony in structural equation ##' modeling. *Multivariate Behavioral Research, 43*(3), 227--259. ##' \doi{10.1207/s15327906mbr4103_1} ##' ##' West, S. G., Taylor, A. B., & Wu, W. (2012). Model fit and model selection ##' in structural equation modeling. In R. H. Hoyle (Ed.), *Handbook of ##' structural equation modeling* (pp. 209--231). New York, NY: Guilford. ##' ##' ##' @examples ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit <- cfa(HS.model, data = HolzingerSwineford1939) ##' moreFitIndices(fit) ##' ##' fit2 <- cfa(HS.model, data = HolzingerSwineford1939, estimator = "mlr") ##' moreFitIndices(fit2) ##' ##' @export moreFitIndices <- function(object, fit.measures = "all", nPrior = 1) { ## check for validity of user-specified "fit.measures" argument fit.choices <- c("gammaHat","adjGammaHat","baseline.rmsea", "gammaHat.scaled","adjGammaHat.scaled","baseline.rmsea.scaled", "aic.smallN","bic.priorN","spbic","hbic","ibic","sic","hqc","icomp") flags <- setdiff(fit.measures, c("all", fit.choices)) if (length(flags)) stop(paste("Argument 'fit.measures' includes invalid options:", paste(flags, collapse = ", "), "Please choose 'all' or among the following:", paste(fit.choices, collapse = ", "), sep = "\n")) if ("all" %in% fit.measures) fit.measures <- fit.choices # Extract fit indices information from lavaan object fit <- lavInspect(object, "fit") # Get the number of variable p <- length(lavaan::lavNames(object, type = "ov", group = 1)) # Get the number of parameters nParam <- fit["npar"] # Find the number of groups ngroup <- lavInspect(object, "ngroups") # Get number of observations N <- n <- lavInspect(object, "ntotal") if (lavInspect(object, "options")$mimic == "EQS") n <- n - ngroup ## Calculate -2*log(likelihood) f <- -2 * fit["logl"] ## Compute fit indices result <- list() if (length(grep("gamma", fit.measures, ignore.case = TRUE))) { gammaHat <- p / (p + 2 * ((fit["chisq"] - fit["df"]) / n)) adjGammaHat <- 1 - (((ngroup * p * (p + 1)) / 2) / fit["df"]) * (1 - gammaHat) result["gammaHat"] <- gammaHat result["adjGammaHat"] <- adjGammaHat if (any(grepl(pattern = "scaled", x = names(fit)))) { gammaHatScaled <- p / (p + 2 * ((fit["chisq.scaled"] - fit["df.scaled"]) / n)) adjGammaHatScaled <- 1 - (((ngroup * p * (p + 1)) / 2) / fit["df.scaled"]) * (1 - gammaHatScaled) result["gammaHat.scaled"] <- gammaHatScaled result["adjGammaHat.scaled"] <- adjGammaHatScaled } } if (length(grep("rmsea", fit.measures))) { result["baseline.rmsea"] <- nullRMSEA(object, silent = TRUE) if (any(grepl(pattern = "scaled", x = names(fit)))) { result["baseline.rmsea.scaled"] <- nullRMSEA(object, scaled = TRUE, silent = TRUE) } } ## Compute information criteria if (!is.na(f)) { if ("aic.smallN" %in% fit.measures) { warning('AICc (aic.smallN) was developed for univariate linear models.', ' It is probably not appropriate to use AICc to compare SEMs.') result["aic.smallN"] <- fit[["aic"]] + (2 * nParam * (nParam + 1)) / (N - nParam - 1) } if ("bic.priorN" %in% fit.measures) { result["bic.priorN"] <- f + log(1 + N/nPrior) * nParam } if ("spbic" %in% fit.measures) { theta <- lavaan::coef(object) FIM <- lavInspect(object, "information.observed") junk <- t(theta) %*% FIM %*% theta if (nParam < junk) { result["spbic"] <- f + nParam*(1 - log(nParam / junk)) # Case 1 } else result["spbic"] <- f + junk # Case 2 } if ("hbic" %in% fit.measures) result["hbic"] <- f + nParam*log(N/(2*pi)) if ("icomp" %in% fit.measures) { Fhatinv <- lavInspect(object, "inverted.information.expected") s <- qr(Fhatinv)$rank C1 <- (s/2)*log((sum(diag(Fhatinv)))/s) - .5*log(det(Fhatinv)) result["icomp"] <- f + 2*C1 } ## check determinant of ACOV for IBIC and SIC if (any(c("ibic","sic") %in% fit.measures)) { ACOV <- lavInspect(object, "vcov") detACOV <- det(ACOV) if (detACOV <= 0) { ## look for duplicate names (simple equality constraints) to ## remove any obviously redundant parameters #TODO: any way to check for redundancies implied by "==" constraints? RN <- unique(rownames(ACOV)) if (length(RN) < nrow(ACOV)) detACOV <- det(ACOV[RN, RN]) } } if ("ibic" %in% fit.measures) { if (detACOV <= 0) { result["ibic"] <- NA message('Determinant of vcov(object) <= 0, so IBIC cannot be calculated') } else result["ibic"] <- f - nParam*log(2*pi) - log(detACOV) } if ("sic" %in% fit.measures) { if (detACOV <= 0) { result["sic"] <- NA message('Determinant of vcov(object) <= 0, so SIC cannot be calculated') } else { result["sic"] <- f - log(detACOV) ## doi:10.1007/s10519-004-5587-0 (p. 596) says to use observed Fisher information, ## but ACOV will be lavInspect(object, "options")$information ## legacy code: # E.inv <- lavaan::lavTech(object, "inverted.information.observed") # E <- MASS::ginv(E.inv) * lavaan::nobs(object) # multiply unit information by N } } if ("hqc" %in% fit.measures) result["hqc"] <- f + 2*nParam*log(log(N)) } result <- unlist(result[fit.measures]) class(result) <- c("lavaan.vector","numeric") result } ##' Calculate the RMSEA of the null model ##' ##' Calculate the RMSEA of the null (baseline) model ##' ##' RMSEA of the null model is calculated similar to the formula provided in the ##' `lavaan` package. The standard formula of RMSEA is ##' ##' \deqn{ RMSEA =\sqrt{\frac{\chi^2}{N \times df} - \frac{1}{N}} \times ##' \sqrt{G} } ##' ##' where \eqn{\chi^2} is the chi-square test statistic value of the target ##' model, \eqn{N} is the total sample size, \eqn{df} is the degree of freedom ##' of the hypothesized model, \eqn{G} is the number of groups. Kenny proposed ##' in his website that ##' ##' "A reasonable rule of thumb is to examine the RMSEA for the null model and ##' make sure that is no smaller than 0.158. An RMSEA for the model of 0.05 and ##' a TLI of .90, implies that the RMSEA of the null model is 0.158. If the ##' RMSEA for the null model is less than 0.158, an incremental measure of fit ##' may not be that informative." ##' ##' See also ##' ##' ##' @importFrom lavaan lavInspect ##' ##' @param object The lavaan model object provided after running the `cfa`, ##' `sem`, `growth`, or `lavaan` functions. ##' @param scaled If `TRUE`, the scaled (or robust, if available) RMSEA ##' is returned. Ignored if a robust test statistic was not requested. ##' @param silent If `TRUE`, do not print anything on the screen. ##' ##' @return A value of RMSEA of the null model (a `numeric` vector) ##' returned invisibly. ##' ##' @author ##' Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@@gmail.com}) ##' ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @seealso ##' \itemize{ ##' \item [miPowerFit()] For the modification indices and their ##' power approach for model fit evaluation ##' \item [moreFitIndices()] For other fit indices ##' } ##' ##' @references Kenny, D. A., Kaniskan, B., & McCoach, D. B. (2015). The ##' performance of RMSEA in models with small degrees of freedom. ##' *Sociological Methods Research, 44*(3), 486--507. ##' \doi{10.1177/0049124114543236} ##' ##' @examples ##' ##' HS.model <- ' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ' ##' ##' fit <- cfa(HS.model, data = HolzingerSwineford1939) ##' nullRMSEA(fit) ##' ##' @export nullRMSEA <- function(object, scaled = FALSE, silent = FALSE) { fit <- lavaan::update(object, slotData = object@Data, model = lavaan::lav_partable_independence(object)) fits <- lavaan::fitMeasures(fit, fit.measures = c("rmsea","rmsea.scaled", "rmsea.robust")) if (scaled) { RMSEA <- fits["rmsea.robust"] if (is.na(RMSEA)) RMSEA <- fits["rmsea.scaled"] if (is.na(RMSEA)) RMSEA <- fits["rmsea"] } else RMSEA <- fits["rmsea"] if (!silent) { cat("The baseline model's RMSEA =", RMSEA, "\n\n") if (RMSEA < 0.158 ) { cat("CFI, TLI, and other incremental fit indices may not be very", "informative because the baseline model's RMSEA < 0.158", "(Kenny, Kaniskan, & McCoach, 2015). \n") } } invisible(RMSEA) } ## Stochastic Information Criterion ## f = minimized discrepancy function ## lresults = lavaan sem output object #TODO: update to extract f from lresults. Make public? sic <- function(f, lresults = NULL) { ## p. 596 of doi:10.1007/s10519-004-5587-0 says to use observed Fisher information E.inv <- lavaan::lavTech(lresults, "inverted.information.observed") if (inherits(E.inv, "try-error")) { return(as.numeric(NA)) } E <- MASS::ginv(E.inv) * lavaan::nobs(lresults) eigvals <- eigen(E, symmetric = TRUE, only.values = TRUE)$values # only positive ones eigvals <- eigvals[ eigvals > sqrt(.Machine$double.eps)] DET <- prod(eigvals) ## check singular if (DET <= 0) return(NA) ## return SIC } ##' Small-*N* correction for \eqn{chi^2} test statistic ##' ##' Calculate small-*N* corrections for \eqn{chi^2} model-fit test ##' statistic to adjust for small sample size (relative to model size). ##' ##' Four finite-sample adjustments to the chi-squared statistic are currently ##' available, all of which are described in Shi et al. (2018). These all ##' assume normally distributed data, and may not work well with severely ##' nonnormal data. Deng et al. (2018, section 4) review proposed small-*N* ##' adjustments that do not assume normality, which rarely show promise, so ##' they are not implemented here. This function currently will apply ##' small-*N* adjustments to scaled test statistics with a warning that ##' they do not perform well (Deng et al., 2018). ##' ##' @importFrom lavaan lavInspect lavNames ##' @importFrom stats pchisq ##' @importFrom methods getMethod ##' ##' @param fit0,fit1 [lavaan::lavaan-class] or [lavaan.mi::lavaan.mi-class] object(s) ##' @param smallN.method `character` indicating the small-*N* ##' correction method to use. Multiple may be chosen (all of which assume ##' normality), as described in Shi et al. (2018): ##' `c("swain","yuan.2015","yuan.2005","bartlett")`. Users may also ##' simply select `"all"`. ##' @param \dots Additional arguments to the [lavaan::lavTestLRT()] or ##' [lavaan.mi::lavTestLRT.mi()] functions. Ignored when `is.null(fit1)`. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Ignored unless `fit0` (and ##' optionally `fit1`) is a [lavaan.mi::lavaan.mi-class] object. See ##' [lavaan.mi::lavTestLRT.mi()] for a description of options and defaults. ##' ##' @return A `list` of `numeric` vectors: one for the originally ##' requested statistic(s), along with one per requested `smallN.method`. ##' All include the the (un)adjusted test statistic, its *df*, and the ##' *p* value for the test under the null hypothesis that the model fits ##' perfectly (or that the 2 models have equivalent fit). ##' The adjusted chi-squared statistic(s) also include(s) the scaling factor ##' for the small-*N* adjustment. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' @references ##' Deng, L., Yang, M., & Marcoulides, K. M. (2018). Structural equation ##' modeling with many variables: A systematic review of issues and ##' developments. *Frontiers in Psychology, 9*, 580. ##' \doi{10.3389/fpsyg.2018.00580} ##' ##' Shi, D., Lee, T., & Terry, R. A. (2018). Revisiting the model ##' size effect in structural equation modeling. ##' *Structural Equation Modeling, 25*(1), 21--40. ##' \doi{10.1080/10705511.2017.1369088} ##' ##' @examples ##' ##' HS.model <- ' ##' visual =~ x1 + b1*x2 + x3 ##' textual =~ x4 + b2*x5 + x6 ##' speed =~ x7 + b3*x8 + x9 ##' ' ##' fit1 <- cfa(HS.model, data = HolzingerSwineford1939[1:50,]) ##' ## test a single model (implicitly compared to a saturated model) ##' chisqSmallN(fit1) ##' ##' ## fit a more constrained model ##' fit0 <- cfa(HS.model, data = HolzingerSwineford1939[1:50,], ##' orthogonal = TRUE) ##' ## compare 2 models ##' chisqSmallN(fit1, fit0) ##' ##' @export chisqSmallN <- function(fit0, fit1 = NULL, smallN.method = if (is.null(fit1)) c("swain","yuan.2015") else "yuan.2005", ..., omit.imps = c("no.conv","no.se")) { if ("all" %in% smallN.method) smallN.method <- c("swain","yuan.2015", "yuan.2005","bartlett") smallN.method <- intersect(tolower(smallN.method), c("swain","yuan.2015","yuan.2005","bartlett")) if (!any(smallN.method %in% c("swain","yuan.2015","yuan.2005","bartlett"))) stop('No recognized options for "smallN.method" argument') ## check class if (!inherits(fit0, what = c("lavaan","lavaan.mi"))) stop("this function is only applicable to fitted lavaan(.mi) models") ## necessary to load lavaan.mi? if (inherits(fit0, what = c("lavaan.mi"))) { if (!"package:lavaan.mi" %in% search()) attachNamespace("lavaan.mi") } ## if there are 2 models... if (!is.null(fit1)) { ## check classes if (!inherits(fit1, what = c("lavaan","lavaan.mi"))) stop("this function is only applicable to fitted lavaan(.mi) models") modClass <- unique(sapply(list(fit0, fit1), class)) if (length(modClass) > 1L) stop('All models must be of the same class (e.g.,', ' cannot compare lavaan objects to lavaan.mi)') ## check order of DF suppressMessages(DF0 <- getMethod("fitMeasures", class(fit0))(fit0, fit.measures = "df", omit.imps = omit.imps)[1]) suppressMessages(DF1 <- getMethod("fitMeasures", class(fit1))(fit1, fit.measures = "df", omit.imps = omit.imps)[1]) if (DF0 == DF1) stop("Models have the same degrees of freedom.") parent <- which.min(c(DF0, DF1)) if (parent == 1L) { parent <- fit0 fit0 <- fit1 fit1 <- parent parent <- DF0 DF0 <- DF1 DF1 <- parent } if (min(c(DF0, DF1)) == 0L) { message('Less restricted model has df=0, so chi-squared difference ', 'not needed to compare models. Using only the restricted ', "model's chi-squared statistic.") fit1 <- NULL } } ## check whether methods can be used if (!is.null(fit1)) { if (any(smallN.method %in% c("yuan.2015","swain"))) { message('Swain (1975) and Yuan (2015) corrections depend on the number ', 'of free parameters, so it is unavailable for model comparison.') smallN.method <- smallN.method[-which(smallN.method %in% c("yuan.2015","swain"))] } if (!length(smallN.method)) { stop('No valid options for "smallN.method" argument') } else warning('Small-N corrections developed for single models, not for ', 'model comparison. Experimentally applying correction to ', 'chi-squared difference statistic, which might be invalid.') } ## save quantities relevant across correction methods N <- lavInspect(fit0, "ntotal") Ng <- lavInspect(fit0, "ngroups") if (!lavInspect(fit0, "options")$sample.cov.rescale) N <- N - Ng P <- length(lavNames(fit0)) K <- length(lavNames(fit0, type = "lv")) # count latent factors if (is.null(fit1)) { FIT <- getMethod("fitMeasures", class(fit0))(fit0, ## lavaan.mi arguments ignored ## for lavaan objects omit.imps = omit.imps, asymptotic = TRUE, fit.measures = c("npar","chisq", "df","pvalue")) scaled <- any(grepl(pattern = "scaled", x = names(FIT))) if (scaled) warning('Small-N corrections developed assuming normality, but', ' a scaled test was requested. Applying correction(s) ', 'to the scaled test statistic, but this has not ', 'performed well in past simulations.') NPAR <- FIT[["npar"]] chi <- FIT[[if (scaled) "chisq.scaled" else "chisq"]] DF <- FIT[[if (scaled) "df.scaled" else "df"]] PV <- FIT[[if (scaled) "pvalue.scaled" else "pvalue"]] } else { ## Compare to a second model. Check matching stats. N1 <- lavInspect(fit1, "ntotal") Ng1 <- lavInspect(fit1, "ngroups") if (!lavInspect(fit1, "options")$sample.cov.rescale) N1 <- N1 - Ng1 if (N != N1) stop("Unequal sample sizes") if (P != length(lavNames(fit1))) stop("Unequal number of observed variables") K1 <- length(lavNames(fit1, type = "lv")) if (K != K1 && any(smallN.method %in% c("yuan.2005","bartlett"))) { warning("Unequal number of latent variables (k). Unclear how to apply ", "Yuan (2005) or Bartlett (2015) corrections when comparing ", "models with different k. Experimentally using the larger ", "model's k, but there is no evidence this is valid.") K <- max(K, K1) } AOV <- try(compareFit(fit0, fit1, argsLRT = list(...), indices = FALSE), silent = TRUE) if (inherits(AOV, "try-error")) stop('Model comparison failed. Try using ', 'lavTestLRT() to investigate why.') if (inherits(fit0, "lavaan")) { if (grepl("scaled", attr(AOV@nested, "heading"), ignore.case = TRUE)) warning('Small-N corrections developed assuming normality, but scaled ', 'tests were requested. Applying correction(s) to the scaled test', ' statistic, but this has not performed well in past simulations.') chi <- AOV@nested[["Chisq diff"]][2] DF <- AOV@nested[["Df diff"]][2] PV <- AOV@nested[["Pr(>Chisq)"]][2] } else if (inherits(fit0, "lavaan.mi")) { if (any(grepl("scaled", colnames(AOV@nested), ignore.case = TRUE))) warning('Small-N corrections developed assuming normality, but scaled ', 'tests were requested. Applying correction(s) to the scaled test', ' statistic, but this has not performed well in past simulations.') chi <- AOV@nested[1, 1] DF <- AOV@nested[1, 2] PV <- AOV@nested[1, 3] } } ## empty list to store correction(s) out <- list() out[[ lavInspect(fit0, "options")$test ]] <- c(chisq = chi, df = DF, pvalue = PV) class(out[[1]]) <- c("lavaan.vector","numeric") ## calculate Swain's (1975) correction ## (undefined for model comparison) if ("swain" %in% smallN.method) { Q <- (sqrt(1 + 8*NPAR) - 1) / 2 num <- P*(2*P^2 + 3*P - 1) - Q*(2*Q^2 + 3*Q - 1) SC <- 1 - num / (12*DF*N) out[["swain"]] <- c(chisq = chi*SC, df = DF, pvalue = pchisq(chi*SC, DF, lower.tail = FALSE), smallN.factor = SC) class(out[["swain"]]) <- c("lavaan.vector","numeric") } ## calculate Yuan's (2015) correction ## (undefined for model comparison) if ("yuan.2015" %in% smallN.method) { ## numerator uses actual N regardless of sample.cov.rescale SC <- (lavInspect(fit0, "ntotal") - (2.381 + .361*P + .006*NPAR)) / N out[["yuan.2015"]] <- c(chisq = chi*SC, df = DF, pvalue = pchisq(chi*SC, DF, lower.tail = FALSE), smallN.factor = SC) class(out[["yuan.2015"]]) <- c("lavaan.vector","numeric") } ## calculate Yuan's (2005) correction if ("yuan.2005" %in% smallN.method) { SC <- 1 - ((2*P + 2*K + 7) / (6*N)) out[["yuan.2005"]] <- c(chisq = chi*SC, df = DF, pvalue = pchisq(chi*SC, DF, lower.tail = FALSE), smallN.factor = SC) class(out[["yuan.2005"]]) <- c("lavaan.vector","numeric") } ## calculate Bartlett's (1950) k-factor correction (ONLY appropriate for EFA) if ("bartlett" %in% smallN.method) { message('Bartlett\'s k-factor correction was developed for EFA models, ', 'not for general SEMs.') SC <- 1 - ((2*P + 4*K + 5) / (6*N)) out[["bartlett"]] <- c(chisq = chi*SC, df = DF, pvalue = pchisq(chi*SC, DF, lower.tail = FALSE), smallN.factor = SC) class(out[["bartlett"]]) <- c("lavaan.vector","numeric") } out[c(lavInspect(fit0, "options")$test, smallN.method)] } semTools/R/missingBootstrap.R0000644000176200001440000010107114764276216015771 0ustar liggesusers### Terrence D. Jorgensen ### Last updated: 12 March 2025 ### Savalei & Yuan's (2009) model-based bootstrap for missing data ## ---------------------------- ## "BootMiss" Class and Methods ## ---------------------------- ##' Class For the Results of Bollen-Stine Bootstrap with Incomplete Data ##' ##' This class contains the results of Bollen-Stine bootstrap with missing data. ##' ##' ##' @name BootMiss-class ##' @aliases BootMiss-class show,BootMiss-method summary,BootMiss-method ##' hist,BootMiss-method ##' @docType class ##' @section Objects from the Class: Objects can be created via the ##' [bsBootMiss()] function. ##' @slot time A list containing 2 `difftime` objects (`transform` ##' and `fit`), indicating the time elapsed for data transformation and ##' for fitting the model to bootstrap data sets, respectively. ##' @slot transData Transformed data ##' @slot bootDist The vector of \eqn{chi^2} values from bootstrap data sets ##' fitted by the target model ##' @slot origChi The \eqn{chi^2} value from the original data set ##' @slot df The degree of freedom of the model ##' @slot bootP The *p* value comparing the original \eqn{chi^2} with the ##' bootstrap distribution ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' @seealso [bsBootMiss()] ##' @examples ##' ##' # See the example from the bsBootMiss function ##' setClass("BootMiss", representation(time = "list", transData = "data.frame", bootDist = "vector", origChi = "numeric", df = "numeric", bootP = "numeric")) ##' @rdname BootMiss-class ##' @aliases show,BootMiss-method ##' @importFrom stats pchisq ##' @export setMethod("show", "BootMiss", function(object) { cat("Chi-Squared = ", object@origChi, "\nDegrees of Freedom = ", object@df, "\nTheoretical p value = ", pchisq(object@origChi, object@df, lower.tail = FALSE), "\n i.e., pchisq(", object@origChi, ", df = ", object@df, ", lower.tail = FALSE)\n", "\nBootstrapped p value = ", object@bootP, "\n\n", sep = "") invisible(object) }) ##' @rdname BootMiss-class ##' @aliases summary,BootMiss-method ##' @importFrom stats var ##' @export setMethod("summary", "BootMiss", function(object) { cat("Time elapsed to transform the data:\n") print(object@time$transform) cat("\nTime elapsed to fit the model to", length(object@bootDist), "bootstrapped samples:\n") print(object@time$fit) cat("\nMean of Theoretical Distribution = DF =", object@df, "\nVariance of Theoretical Distribution = 2*DF =", 2*object@df, "\n\nMean of Bootstrap Distribution =", mean(object@bootDist), "\nVariance of Bootstrap Distribution =", var(object@bootDist), "\n\n") show(object) invisible(object) }) ##' @rdname BootMiss-class ##' @aliases hist,BootMiss-method ##' @importFrom stats qchisq dchisq quantile ##' @param object,x object of class `BootMiss` ##' @param ... Additional arguments to pass to [graphics::hist()] ##' @param alpha alpha level used to draw confidence limits ##' @param nd number of digits to display ##' @param printLegend `logical`. If `TRUE` (default), a legend will ##' be printed with the histogram ##' @param legendArgs `list` of arguments passed to the ##' [graphics::legend()] function. The default argument is a list ##' placing the legend at the top-left of the figure. ##' @return The `hist` method returns a list of `length == 2`, ##' containing the arguments for the call to `hist` and the arguments ##' to the call for `legend`, respectively. ##' @export setMethod("hist", "BootMiss", function(x, ..., alpha = .05, nd = 2, printLegend = TRUE, legendArgs = list(x = "topleft")) { ChiSq <- x@origChi DF <- x@df bootDist <- x@bootDist bCrit <- round(quantile(bootDist, probs = 1 - alpha), nd) theoDist <- dchisq(seq(.1, max(c(ChiSq, bootDist)), by = .1), df = DF) Crit <- round(qchisq(p = alpha, df = DF, lower.tail = FALSE), nd) Lim <- c(0, max(c(ChiSq, bootDist, Crit))) if (ChiSq > Lim[2]) Lim[2] <- ChiSq histArgs <- list(...) histArgs$x <- bootDist histArgs$freq <- FALSE if (is.null(histArgs$col)) histArgs$col <- "grey69" if (is.null(histArgs$xlim)) histArgs$xlim <- Lim if (is.null(histArgs$main)) histArgs$main <- expression("Model-Based Bootstrap Distribution of" ~ chi^2) if (is.null(histArgs$ylab)) histArgs$ylab <- "Probability Density" if (is.null(histArgs$xlab)) histArgs$xlab <- expression(chi^2) if (printLegend) { if (nd < length(strsplit(as.character(1 / alpha), "")[[1]]) - 1) { warning(paste0("The number of digits argument (nd = ", nd , ") is too low to display your p value at the", " same precision as your requested alpha level (alpha = ", alpha, ")")) } if (x@bootP < (1 / 10^nd)) { pVal <- paste(c("< .", rep(0, nd - 1),"1"), collapse = "") } else { pVal <- paste("=", round(x@bootP, nd)) } if (is.null(legendArgs$box.lty)) legendArgs$box.lty <- 0 if (is.null(legendArgs$lty)) legendArgs$lty <- c(1, 2, 2, 1, 0, 0) if (is.null(legendArgs$lwd)) legendArgs$lwd <- c(2, 2, 2, 3, 0, 0) #if (is.null(legendArgs$cex)) legendArgs$cex <- c(1.1, 1, 1, 1, 1, 1) if (is.null(legendArgs$col)) legendArgs$col <- c("black","black","grey69","red","", "") legendArgs$legend <- c(bquote(chi[.(paste("df =", DF))]^2), bquote(Critical ~ chi[alpha ~ .(paste(" =", alpha))]^2 == .(Crit)), bquote(Bootstrap~Critical~chi[alpha ~ .(paste(" =", alpha))]^2 == .(bCrit)), expression(Observed ~ chi^2), bquote(.("")), bquote(Bootstrap ~ italic(p) ~~ .(pVal))) } H <- do.call(hist, c(histArgs["x"], plot = FALSE)) histArgs$ylim <- c(0, max(H$density, theoDist)) suppressWarnings({ do.call(hist, histArgs) lines(x = seq(.1, max(c(ChiSq, bootDist)), by = .1), y = theoDist, lwd = 2) abline(v = Crit, col = "black", lwd = 2, lty = 2) abline(v = bCrit, col = "grey69", lwd = 2, lty = 2) abline(v = ChiSq, col = "red", lwd = 3) if (printLegend) do.call(legend, legendArgs) }) ## return arguments to create histogram (and optionally, legend) invisible(list(hist = histArgs, legend = legendArgs)) }) ## -------------------- ## Constructor Function ## -------------------- ##' Bollen-Stine Bootstrap with the Existence of Missing Data ##' ##' Implement the Bollen and Stine's (1992) Bootstrap when missing observations ##' exist. The implemented method is proposed by Savalei and Yuan (2009). This ##' can be used in two ways. The first and easiest option is to fit the model to ##' incomplete data in `lavaan` using the FIML estimator, then pass that ##' `lavaan` object to `bsBootMiss`. ##' ##' The second is designed for users of other software packages (e.g., LISREL, ##' EQS, Amos, or Mplus). Users can import their data, \eqn{\chi^2} value, and ##' model-implied moments from another package, and they have the option of ##' saving (or writing to a file) either the transformed data or bootstrapped ##' samples of that data, which can be analyzed in other programs. In order to ##' analyze the bootstrapped samples and return a *p* value, users of other ##' programs must still specify their model using lavaan syntax. ##' ##' ##' @importFrom lavaan lavInspect parTable ##' @param x A target `lavaan` object used in the Bollen-Stine bootstrap ##' @param transformation The transformation methods in Savalei and Yuan (2009). ##' There are three methods in the article, but only the first two are currently ##' implemented here. Use `transformation = 1` when there are few missing ##' data patterns, each of which has a large size, such as in a ##' planned-missing-data design. Use `transformation = 2` when there are ##' more missing data patterns. The currently unavailable ##' `transformation = 3` would be used when several missing data patterns ##' have n = 1. ##' @param nBoot The number of bootstrap samples. ##' @param model Optional. The target model if `x` is not provided. ##' @param rawData Optional. The target raw data set if `x` is not ##' provided. ##' @param Sigma Optional. The model-implied covariance matrix if `x` is ##' not provided. ##' @param Mu Optional. The model-implied mean vector if `x` is not ##' provided. ##' @param group Optional character string specifying the name of the grouping ##' variable in `rawData` if `x` is not provided. ##' @param ChiSquared Optional. The model's \eqn{\chi^2} test statistic if ##' `x` is not provided. ##' @param EMcov Optional, if `x` is not provided. The EM (or Two-Stage ML) ##' estimated covariance matrix used to speed up Transformation 2 algorithm. ##' @param transDataOnly Logical. If `TRUE`, the result will provide the ##' transformed data only. ##' @param writeTransData Logical. If `TRUE`, the transformed data set is ##' written to a text file, `transDataOnly` is set to `TRUE`, and the ##' transformed data is returned invisibly. ##' @param bootSamplesOnly Logical. If `TRUE`, the result will provide ##' bootstrap data sets only. ##' @param writeBootData Logical. If `TRUE`, the stacked bootstrap data ##' sets are written to a text file, `bootSamplesOnly` is set to ##' `TRUE`, and the list of bootstrap data sets are returned invisibly. ##' @param writeArgs Optional `list`. If `writeBootData = TRUE` or ##' `writeBootData = TRUE`, user can pass arguments to the ##' [utils::write.table()] function as a list. Some default values ##' are provided: `file` = "bootstrappedSamples.dat", `row.names` = ##' `FALSE`, and `na` = "-999", but the user can override all of these ##' by providing other values for those arguments in the `writeArgs` list. ##' @param seed The seed number used in randomly drawing bootstrap samples. ##' @param suppressWarn Logical. If `TRUE`, warnings from `lavaan` ##' function will be suppressed when fitting the model to each bootstrap sample. ##' @param showProgress Logical. Indicating whether to display a progress bar ##' while fitting models to bootstrap samples. ##' @param \dots The additional arguments in the [lavaan::lavaan()] ##' function. See also [lavaan::lavOptions()] ##' @return As a default, this function returns a [BootMiss-class] ##' object containing the results of the bootstrap samples. Use `show`, ##' `summary`, or `hist` to examine the results. Optionally, the ##' transformed data set is returned if `transDataOnly = TRUE`. Optionally, ##' the bootstrap data sets are returned if `bootSamplesOnly = TRUE`. ##' @author Terrence D. Jorgensen (University of Amsterdam; ##' \email{TJorgensen314@@gmail.com}) ##' ##' Syntax for transformations borrowed from http://www2.psych.ubc.ca/~vsavalei/ ##' @seealso [BootMiss-class] ##' @references ##' ##' Bollen, K. A., & Stine, R. A. (1992). Bootstrapping goodness-of-fit measures ##' in structural equation models. *Sociological Methods & ##' Research, 21*(2), 205--229. \doi{10.1177/0049124192021002004} ##' ##' Savalei, V., & Yuan, K.-H. (2009). On the model-based bootstrap with missing ##' data: Obtaining a p-value for a test of exact fit. *Multivariate ##' Behavioral Research, 44*(6), 741--763. \doi{10.1080/00273170903333590} ##' @examples ##' ##' dat1 <- HolzingerSwineford1939 ##' dat1$x5 <- ifelse(dat1$x1 <= quantile(dat1$x1, .3), NA, dat1$x5) ##' dat1$x9 <- ifelse(is.na(dat1$x5), NA, dat1$x9) ##' ##' targetModel <- " ##' visual =~ x1 + x2 + x3 ##' textual =~ x4 + x5 + x6 ##' speed =~ x7 + x8 + x9 ##' " ##' targetFit <- sem(targetModel, dat1, meanstructure = TRUE, std.lv = TRUE, ##' missing = "fiml", group = "school") ##' summary(targetFit, fit = TRUE, standardized = TRUE) ##' ##' \donttest{ ##' ## The number of bootstrap samples should be much higher than this example ##' temp <- bsBootMiss(targetFit, transformation = 1, nBoot = 10, seed = 31415) ##' ##' temp ##' summary(temp) ##' hist(temp) ##' hist(temp, printLegend = FALSE) # suppress the legend ##' ## user can specify alpha level (default: alpha = 0.05), and the number of ##' ## digits to display (default: nd = 2). Pass other arguments to hist(...), ##' ## or a list of arguments to legend() via "legendArgs" ##' hist(temp, alpha = .01, nd = 3, xlab = "something else", breaks = 25, ##' legendArgs = list("bottomleft", box.lty = 2)) ##' } ##' ##' @export bsBootMiss <- function(x, transformation = 2, nBoot = 500, model, rawData, Sigma, Mu, group, ChiSquared, EMcov, writeTransData = FALSE, transDataOnly = FALSE, writeBootData = FALSE, bootSamplesOnly = FALSE, writeArgs, seed = NULL, suppressWarn = TRUE, showProgress = TRUE, ...) { if(writeTransData) transDataOnly <- TRUE if(writeBootData) bootSamplesOnly <- TRUE check.nBoot <- (!is.numeric(nBoot) | nBoot < 1L) & !transDataOnly if (check.nBoot) stop("The \"nBoot\" argument must be a positive integer.") ## Which transformation? if (!(transformation %in% 1:2)) stop("User must specify transformation 1 or 2. Consult Savalei & Yuan (2009) for advice. Transformation 3 is not currently available.") if (transformation == 2) SavaleiYuan <- trans2 #if (transformation == 3) SavaleiYuan <- trans3 ###################### ## Data Preparation ## ###################### ## If a lavaan object is supplied, the extracted values for rawData, Sigma, Mu, ## EMcov, and EMmeans will override any user-supplied arguments. if (hasArg(x)) { if (!lavInspect(x, "options")$meanstructure) stop('You must fit the lavaan model with the argument "meanstructure=TRUE".') nG <- lavInspect(x, "ngroups") if (nG == 1L) { rawData <- list(as.data.frame(lavInspect(x, "data"))) } else rawData <- lapply(lavInspect(x, "data"), as.data.frame) for (g in seq_along(rawData)) { colnames(rawData[[g]]) <- lavaan::lavNames(x) checkAllMissing <- apply(rawData[[g]], 1, function(x) all(is.na(x))) if (any(checkAllMissing)) rawData[[g]] <- rawData[[g]][!checkAllMissing, ] } ChiSquared <- lavInspect(x, "fit")[c("chisq", "chisq.scaled")] ChiSquared <- ifelse(is.na(ChiSquared[2]), ChiSquared[1], ChiSquared[2]) group <- lavInspect(x, "group") if (length(group) == 0) group <- "group" group.label <- lavInspect(x, "group.label") if (length(group.label) == 0) group.label <- 1 Sigma <- lavInspect(x, "cov.ov") Mu <- lavInspect(x, "mean.ov") EMcov <- lavInspect(x, "sampstat")$cov if (nG == 1L) { Sigma <- list(Sigma) Mu <- list(Mu) EMcov <- list(EMcov) } } else { ## If no lavaan object is supplied, check that required arguments are. suppliedData <- c(hasArg(rawData), hasArg(Sigma), hasArg(Mu)) if (!all(suppliedData)) { stop("Without a lavaan fitted object, user must supply raw data and", " model-implied moments.") } if (!hasArg(model) & !(transDataOnly | bootSamplesOnly)) { stop("Without model syntax or fitted lavaan object, user can only call", " this function to save transformed data or bootstrapped samples.") } if (!hasArg(ChiSquared) & !(transDataOnly | bootSamplesOnly)) { stop("Without a fitted lavaan object or ChiSquared argument, user can", " only call this function to save transformed data, bootstrapped", " samples, or bootstrapped chi-squared values.") } if (!any(c(transDataOnly, bootSamplesOnly))) { if (!is.numeric(ChiSquared)) stop("The \"ChiSquared\" argument must be numeric.") } ## If user supplies one-group data & moments, convert to lists. if ( inherits(rawData, "data.frame")) rawData <- list(rawData) if (!inherits(rawData, "list")) { stop("The \"rawData\" argument must be a data.frame or list of data frames.") } else { if (!all(sapply(rawData, is.data.frame))) stop("Every element of \"rawData\" must be a data.frame") } if (inherits(Sigma, "matrix")) Sigma <- list(Sigma) if (is.numeric(Mu)) Mu <- list(Mu) ## check whether EMcov was supplied for starting values in Trans2/Trans3 if (!hasArg(EMcov)) { EMcov <- vector("list", length(Sigma)) } else { if (inherits(EMcov, "matrix")) EMcov <- list(EMcov) ## check EMcov is symmetric and dimensions match Sigma for (g in seq_along(EMcov)) { if (!isSymmetric(EMcov[[g]])) stop("EMcov in group ", g, " not symmetric.") unequalDim <- !all(dim(EMcov[[g]]) == dim(Sigma[[g]])) if (unequalDim) stop("Unequal dimensions in Sigma and EMcov.") } } ## Check the number of groups by the size of the lists. unequalGroups <- !all(length(rawData) == c(length(Sigma), length(Mu))) if (unequalGroups) stop("Unequal number of groups in rawData, Sigma, Mu. For multiple-group models, rawData must be a list of data frames, NOT a single data frame with a \"group\" column.") nG <- length(Sigma) ## In each group, check Sigma is symmetric and dimensions match rawData and Mu. for (g in seq_along(rawData)) { if (!isSymmetric(Sigma[[g]])) stop("Sigma in group ", g, " not symmetric.") unequalDim <- !all(ncol(rawData[[g]]) == c(nrow(Sigma[[g]]), length(Mu[[g]]))) if (unequalDim) stop("Unequal dimensions in rawData, Sigma, Mu.") } ## Check for names of group levels. If NULL, assign arbitrary ones. if (!hasArg(group)) group <- "group" if (!is.character(group)) stop("The \"group\" argument must be a character string.") if (is.null(names(rawData))) { group.label <- paste0("g", seq_along(rawData)) } else { group.label <- names(rawData) } } ## save a copy as myTransDat, whose elements will be replaced iteratively by ## group and by missing data pattern within group. myTransDat <- rawData names(myTransDat) <- group.label output <- list() ######################### ## Data Transformation ## ######################### for (g in seq_along(group.label)) { if (transformation == 1) { ## get missing data patterns R <- ifelse(is.na(rawData[[g]]), 1, 0) rowMissPatt <- apply(R, 1, function(x) paste(x, collapse = "")) patt <- unique(rowMissPatt) myRows <- lapply(patt, function(x) which(rowMissPatt == x)) ## for each pattern, apply transformation tStart <- Sys.time() transDatList <- lapply(patt, trans1, rowMissPatt = rowMissPatt, dat = rawData[[g]], Sigma = Sigma[[g]], Mu = Mu[[g]]) output$timeTrans <- Sys.time() - tStart for (i in seq_along(patt)) myTransDat[[g]][myRows[[i]], ] <- transDatList[[i]] } else { tStart <- Sys.time() myTransDat[[g]] <- SavaleiYuan(dat = rawData[[g]], Sigma = Sigma[[g]], Mu = Mu[[g]], EMcov = EMcov[[g]]) output$timeTrans <- Sys.time() - tStart } } ## option to end function here if (transDataOnly) { for (g in seq_along(myTransDat)) myTransDat[[g]][ , group] <- group.label[g] ## option to write transformed data to a file if (writeTransData) { ## Set a few options, if the user didn't. if (!hasArg(writeArgs)) writeArgs <- list(file = "transformedData.dat", row.names = FALSE, na = "-999") if (!exists("file", where = writeArgs)) writeTransArgs$file <- "transformedData.dat" if (!exists("row.names", where = writeArgs)) writeArgs$row.names <- FALSE if (!exists("na", where = writeArgs)) writeArgs$na <- "-999" ## add grouping variable and bind together into one data frame for (g in seq_along(myTransDat)) myTransDat[[g]][ , group] <- group.label[g] writeArgs$x <- do.call("rbind", myTransDat) ## write to file, print details to screen do.call("write.table", writeArgs) cat("Transformed data was written to file \"", writeArgs$file, "\" in:\n\n", getwd(), "\n\nunless path specified by user in 'file' argument.\n", sep = "") return(invisible(writeArgs$x)) } return(do.call("rbind", myTransDat)) } ############################################# ## Bootstrap distribution of fit statistic ## ############################################# ## draw bootstrap samples if (!is.null(seed)) set.seed(seed) bootSamples <- lapply(1:nBoot, function(x) getBootSample(myTransDat, group, group.label)) ## option to write bootstrapped samples to file(s) if (writeBootData) { ## Set a few options, if the user didn't. if (!hasArg(writeArgs)) writeArgs <- list(file = "bootstrappedSamples.dat", row.names = FALSE, na = "-999") if (!exists("file", where = writeArgs)) writeTransArgs$file <- "bootstrappedSamples.dat" if (!exists("row.names", where = writeArgs)) writeArgs$row.names <- FALSE if (!exists("na", where = writeArgs)) writeArgs$na <- "-999" ## add indicator for bootstrapped sample, bind together into one data frame for (b in seq_along(bootSamples)) bootSamples[[b]]$bootSample <- b writeArgs$x <- do.call("rbind", bootSamples) ## write to file, print details to screen do.call("write.table", writeArgs) cat("Bootstrapped samples written to file \"", writeArgs$file, "\" in:\n\n", getwd(), "\n\nunless path specified by user in 'file' argument.\n", sep = "") return(invisible(bootSamples)) } ## option to end function here if (bootSamplesOnly) return(bootSamples) ## check for lavaan arguments in (...) lavaanArgs <- list(...) lavaanArgs$group <- group ## fit model to bootstrap samples, save distribution of chi-squared test stat if (hasArg(x)) { ## grab defaults from lavaan object "x" lavaanArgs$slotParTable <- as.list(parTable(x)) lavaanArgs$slotModel <- x@Model lavaanArgs$slotOptions <- lavInspect(x, "options") } else { lavaanArgs$model <- model lavaanArgs$missing <- "fiml" ## set defaults that will be necessary for many models to run, that will ## probably not be specified explictly or included in lavaan syntax lavaanArgs$meanstructure <- TRUE if (!exists("auto.var", where = lavaanArgs)) lavaanArgs$auto.var <- TRUE if (!exists("auto.cov.y", where = lavaanArgs)) lavaanArgs$auto.cov.y <- TRUE if (!exists("auto.cov.lv.x", where = lavaanArgs)) lavaanArgs$auto.cov.lv.x <- TRUE } ## run bootstrap fits if (showProgress) { mypb <- utils::txtProgressBar(min = 1, max = nBoot, initial = 1, char = "=", width = 50, style = 3, file = "") bootFits <- numeric() tStart <- Sys.time() for (j in 1:nBoot) { bootFits[j] <- fitBootSample(bootSamples[[j]], args = lavaanArgs, suppress = suppressWarn) utils::setTxtProgressBar(mypb, j) } close(mypb) output$timeFit <- Sys.time() - tStart } else { tStart <- Sys.time() bootFits <- sapply(bootSamples, fitBootSample, args = lavaanArgs, suppress = suppressWarn) output$timeFit <- Sys.time() - tStart } ## stack groups, save transformed data and distribution in output object for (g in seq_along(myTransDat)) myTransDat[[g]][ , group] <- group.label[g] output$Transformed.Data <- do.call("rbind", myTransDat) output$Bootstrapped.Distribution <- bootFits output$Original.ChiSquared <- ChiSquared if (hasArg(x)) { output$Degrees.Freedom <- lavInspect(x, "fit")["df"] } else { convSamp <- which(!is.na(bootFits))[1] lavaanArgs$data <- bootSamples[[convSamp]] lavaanlavaan <- function(...) { lavaan::lavaan(...) } output$Degrees.Freedom <- lavInspect(do.call(lavaanlavaan, lavaanArgs), "fit")["df"] } ## calculate bootstrapped p-value output$Bootstrapped.p.Value <- mean(bootFits >= ChiSquared, na.rm = TRUE) ## print warning if any models didn't converge if (any(is.na(bootFits))) { nonConvMessage <- paste("Model did not converge for the following bootstrapped samples", paste(which(is.na(bootFits)), collapse = "\t"), sep = ":\n") warning(nonConvMessage) } finalResult <- new("BootMiss", time = list(transform = output$timeTrans, fit = output$timeFit), transData = output$Transformed.Data, bootDist = output$Bootstrapped.Distribution, origChi = output$Original.ChiSquared, df = output$Degrees.Freedom, bootP = output$Bootstrapped.p.Value) finalResult } ## ---------------- ## Hidden Functions ## ---------------- ## Function to execute Transformation 1 on a single missing-data pattern trans1 <- function(MDpattern, rowMissPatt, dat, Sigma, Mu) { myRows <- which(rowMissPatt == MDpattern) X <- apply(dat[myRows, ], 2, scale, scale = FALSE) observed <- !is.na(X[1, ]) Xreduced <- X[ , observed] Mreduced <- as.numeric(Mu[observed]) SigmaChol <- chol(Sigma[observed, observed]) S <- t(Xreduced) %*% Xreduced / nrow(X) Areduced <- t(SigmaChol) %*% t(solve(chol(S))) Yreduced <- t(Areduced %*% t(Xreduced) + Mreduced) Y <- replace(X, !is.na(X), Yreduced) Y } ## Function to execute Transformation 2 on a single group trans2 <- function(dat, Sigma, Mu, EMcov) { ## Computing Function of A (eq. 12), whose root is desired eq12 <- function(A) { ga <- rep(0, pStar) for (j in 1:J) { Tj <- Mjs[[j]] %*% A %*% Hjs[[j]] %*% A %*% Mjs[[j]] - Mjs[[j]] ga <- ga + Njs[j] * Dupinv %*% c(Tj) # same as vech(Tj) } ga } ## Computing Derivative of Function of A (eq. 13) eq13 <- function(A) { deriv12 <- matrix(0, nrow = pStar, ncol = pStar) for (j in 1:J) { Tj1 <- Mjs[[j]] %*% A %*% Hjs[[j]] deriv12 <- deriv12 + 2*Njs[j]*Dupinv %*% kronecker(Tj1, Mjs[[j]]) %*% Dup } deriv12 } ## get missing data patterns R <- ifelse(is.na(dat), 1, 0) rowMissPatt <- apply(R, 1, function(x) paste(x, collapse = "")) MDpattern <- unique(rowMissPatt) ## sample size within each MD pattern Njs <- sapply(MDpattern, function(patt) sum(rowMissPatt == patt)) J <- length(MDpattern) # number of MD patterns p <- ncol(dat) # number of variables in model pStar <- p*(p + 1) / 2 # number of nonredundant covariance elements ## create empty lists for each MD pattern Xjs <- vector("list", J) Hjs <- vector("list", J) Mjs <- vector("list", J) ## Create Duplication Matrix and its inverse (Magnus & Neudecker, 1999) Dup <- lavaan::lav_matrix_duplication(p) Dupinv <- solve(t(Dup) %*% Dup) %*% t(Dup) ## step through each MD pattern, populate Hjs and Mjs for (j in 1:J) { Xjs[[j]] <- apply(dat[rowMissPatt == MDpattern[j], ], 2, scale, scale = FALSE) if (!is.matrix(Xjs[[j]])) Xjs[[j]] <- t(Xjs[[j]]) observed <- !is.na(Xjs[[j]][1, ]) Sj <- t(Xjs[[j]]) %*% Xjs[[j]] / Njs[j] Hjs[[j]] <- replace(Sj, is.na(Sj), 0) Mjs[[j]] <- replace(Sj, !is.na(Sj), solve(Sigma[observed, observed])) Mjs[[j]] <- replace(Mjs[[j]], is.na(Mjs[[j]]), 0) } ## Compute starting Values for A if (is.null(EMcov)) { A <- diag(p) } else { EMeig <- eigen(EMcov) EMrti <- EMeig$vectors %*% diag(1 / sqrt(EMeig$values)) %*% t(EMeig$vectors) Sigeig <- eigen(Sigma) Sigrt <- Sigeig$vectors %*% diag(sqrt(Sigeig$values)) %*% t(Sigeig$vectors) B <- Sigrt %*% EMrti A <- .5*(B + t(B)) } ## Newton Algorithm for finding root (eq. 14) crit <- .1 a <- c(A) fA <- eq12(A) while (crit > 1e-11) { dvecF <- eq13(A) a <- a - Dup %*% solve(dvecF) %*% fA A <- matrix(a, ncol = p) fA <- eq12(A) crit <- max(abs(fA)) } ## Transform dataset X to dataset Y Yjs <- Xjs for (j in 1:J) { observed <- !is.na(Xjs[[j]][1, ]) XjReduced <- Xjs[[j]][ , observed, drop = FALSE] Aj <- A[observed, observed, drop = FALSE] Mj <- as.numeric(Mu[observed]) Yj <- t(Aj %*% t(XjReduced) + Mj) Yjs[[j]] <- replace(Yjs[[j]], !is.na(Yjs[[j]]), Yj) } Y <- as.data.frame(do.call("rbind", Yjs)) colnames(Y) <- colnames(dat) Y } ## Function to execute Transformation 3 on a single group -- TRANSFORMATION DOES NOT RETURN CH-SQ = 0 trans3 <- function(dat, Sigma, Mu, EMcov) { # Computing Saturated Means as a Function of A (eq. B1 in Appendix B) mut <- function(A) { M <- matrix(0, ncol = 1, nrow = p) for (j in 1:J) { M <- M + Njs[[j]] * Mjs[[j]] %*% A %*% Ybarjs[[j]] } Mjtoti %*% M } # Computing Function of A (eq. 18) whose root is desired eq18 <- function(A) { ga <- rep(0, pStar) mutilda <- mut(A) for (j in 1:J) { Tj <- Mjs[[j]] %*% A %*% Hjs[[j]] %*% A %*% Mjs[[j]] - Mjs[[j]] dif <- A %*% Ybarjs[[j]] - mutilda middle <- dif %*% t(dif) Tjnew <- Tj + Mjs[[j]] %*% middle %*% Mjs[[j]] ga <- ga + Njs[j] * Dupinv %*% c(Tjnew) } ga } # Computing Derivative of Function eq. 18 deriv18 <- function(A) { d18 <- matrix(0, nrow = pStar, ncol = pStar) for (j in 1:J) { Tj1 <- Mjs[[j]] %*% A %*% Hjs[[j]] mutilda <- mut(A) dif <- A %*% Ybarjs[[j]] - mutilda Tj2 <- Mjs[[j]] %*% dif %*% t(Ybarjs[[j]]) Tj3 <- kronecker(Mjs[[j]] %*% dif, Mjs[[j]]) %*% Mjtoti %*% Tj3add d18 <- d18 + 2*Njs[j]*Dupinv %*% ((kronecker((Tj1 + Tj2), Mjs[[j]])) - Tj3) %*% Dup } d18 } ## get missing data patterns R <- ifelse(is.na(dat), 1, 0) rowMissPatt <- apply(R, 1, function(x) paste(x, collapse = "")) MDpattern <- unique(rowMissPatt) ## sample size within each MD pattern Njs <- sapply(MDpattern, function(patt) sum(rowMissPatt == patt)) J <- length(MDpattern) # number of MD patterns p <- ncol(dat) # number of variables in model pStar <- p*(p + 1) / 2 # number of nonredundant covariance elements ## create empty lists for each MD pattern Xjs <- vector("list", J) Ybarjs <- vector("list", J) Hjs <- vector("list", J) Mjs <- vector("list", J) Mjtot <- matrix(0, ncol = p, nrow = p) Tj3add <- matrix(0, nrow = p, ncol = p * p) ## Create Duplication Matrix and its inverse (Magnus & Neudecker, 1999) Dup <- lavaan::lav_matrix_duplication(p) Dupinv <- solve(t(Dup) %*% Dup) %*% t(Dup) ## step through each MD pattern, populate Hjs and Mjs for (j in 1:J) { Xjs[[j]] <- apply(dat[rowMissPatt == MDpattern[j], ], 2, scale, scale = FALSE) if (!is.matrix(Xjs[[j]])) Xjs[[j]] <- t(Xjs[[j]]) observed <- !is.na(Xjs[[j]][1, ]) pj <- p - sum(observed) means <- colMeans(dat[rowMissPatt == MDpattern[j], ]) Ybarjs[[j]] <- replace(means, is.na(means), 0) Sj <- t(Xjs[[j]]) %*% Xjs[[j]] / Njs[j] Hjs[[j]] <- replace(Sj, is.na(Sj), 0) Mjs[[j]] <- replace(Sj, !is.na(Sj), solve(Sigma[observed, observed])) Mjs[[j]] <- replace(Mjs[[j]], is.na(Mjs[[j]]), 0) Mjtot <- Mjtot + Njs[[j]] * Mjs[[j]] Tj3add <- Tj3add + Njs[[j]] * kronecker(t(Ybarjs[[j]]), Mjs[[j]]) } Mjtoti <- solve(Mjtot) ## Compute starting Values for A if (is.null(EMcov)) { A <- diag(p) } else { EMeig <- eigen(EMcov) EMrti <- EMeig$vectors %*% diag(1 / sqrt(EMeig$values)) %*% t(EMeig$vectors) Sigeig <- eigen(Sigma) Sigrt <- Sigeig$vectors %*% diag(sqrt(Sigeig$values)) %*% t(Sigeig$vectors) B <- Sigrt %*% EMrti A <- .5*(B + t(B)) } ## Newton Algorithm for finding root (eq. 14) crit <- .1 a <- c(A) fA <- eq18(A) while (crit > 1e-11) { dvecF <- deriv18(A) a <- a - Dup %*% solve(dvecF) %*% fA A <- matrix(a, ncol = p) fA <- eq18(A) crit <- max(abs(fA)) } ## Transform dataset X to dataset Y (Z in the paper, eqs. 15-16) Yjs <- Xjs for (j in 1:J) { observed <- !is.na(Xjs[[j]][1, ]) XjReduced <- Xjs[[j]][ , observed, drop = FALSE] Aj <- A[observed, observed, drop = FALSE] Mj <- as.numeric((Mu - mut(A))[observed]) Yj <- t(Aj %*% t(XjReduced) + Mj) Yjs[[j]] <- replace(Yjs[[j]], !is.na(Yjs[[j]]), Yj) } Y <- as.data.frame(do.call("rbind", Yjs)) colnames(Y) <- colnames(dat) Y } ## Get a single bootstrapped sample from the transformed data. If there are ## multiple groups, bootstrapping occurs independently within each group, and ## a single data frame is returned. A new column is added to indicate group ## membership, which will be ignored in a single-group analysis. getBootSample <- function(groupDat, group, group.label) { bootSamp <- list() for (g in seq_along(groupDat)) { dat <- groupDat[[g]] dat[ , group] <- group.label[g] bootSamp[[g]] <- dat[sample(1:nrow(dat), nrow(dat), replace = TRUE), ] } do.call("rbind", bootSamp) } ## fit the model to a single bootstrapped sample and return chi-squared ##' @importFrom lavaan lavInspect fitBootSample <- function(dat, args, suppress) { args$data <- dat lavaanlavaan <- function(...) { lavaan::lavaan(...) } if (suppress) { fit <- suppressWarnings(do.call(lavaanlavaan, args)) } else { fit <- do.call(lavaanlavaan, args) } if (!exists("fit")) return(c(chisq = NA)) if (lavInspect(fit, "converged")) { chisq <- lavInspect(fit, "fit")[c("chisq", "chisq.scaled")] } else { chisq <- NA } if (is.na(chisq[2])) return(chisq[1]) else return(chisq[2]) } semTools/R/runMI-score.R0000644000176200001440000011242314764332604014562 0ustar liggesusers### Terrence D. Jorgensen & Yves Rosseel ### Last updated: 12 March 2025 ### Pooled score test (= Lagrange Multiplier test) for multiple imputations ### Borrowed source code from lavaan/R/lav_test_score.R ### DEPRECATED: 16 June 2024 ### supplanted by lavaan.mi package ## this function can run two modes: ## MODE 1: 'add' ## add new parameters that are currently not included in de model ## (aka fixed to zero), but should be released ## MODE 2: 'release' (the default) ## release existing "==" constraints ##' Score Test for Multiple Imputations ##' ##' Score test (or "Lagrange multiplier" test) for lavaan models fitted to ##' multiple imputed data sets. Statistics for releasing one or more ##' fixed or constrained parameters in model can be calculated by pooling ##' the gradient and information matrices pooled across imputed data sets in a ##' method proposed by Mansolf, Jorgensen, & Enders (2020)---analogous to ##' the "D1" Wald test proposed by Li, Meng, Raghunathan, & Rubin's (1991)---or ##' by pooling the complete-data score-test statistics across imputed data sets ##' (i.e., "D2"; Li et al., 1991). ##' ## @aliases lavTestScore.mi ##' @importFrom lavaan lavListInspect parTable ##' @importFrom stats cov pchisq pf ##' @importFrom methods getMethod ##' ##' @param object An object of class [OLDlavaan.mi-class]. ##' @param add Either a `character` string (typically between single ##' quotes) or a parameter table containing additional (currently ##' fixed-to-zero) parameters for which the score test must be computed. ##' @param release Vector of `integer`s. The indices of the *equality* ##' constraints that should be released. The indices correspond to the order of ##' the equality constraints as they appear in the parameter table. ##' @param test `character` indicating which pooling method to use. ##' `"D1"` requests Mansolf, Jorgensen, & Enders' (2020) proposed ##' Wald-like test for pooling the gradient and information, which are then ##' used to calculate score-test statistics in the usual manner. `"D2"` ##' (default because it is less computationall intensive) requests to pool the ##' complete-data score-test statistics from each imputed data set, then pool ##' them across imputations, described by Li et al. (1991) and Enders (2010). ##' @param scale.W `logical`. If `FALSE`, the pooled ##' information matrix is calculated as the weighted sum of the ##' within-imputation and between-imputation components. Otherwise, the pooled ##' information is calculated by scaling the within-imputation component by ##' the average relative increase in variance (ARIV; Enders, 2010, p. 235), ##' which is *only* consistent when requesting the *F* test (i.e., ##' `asymptotic = FALSE`. Ignored (irrelevant) if `test = "D2"`. ##' @param omit.imps `character` vector specifying criteria for omitting ##' imputations from pooled results. Can include any of ##' `c("no.conv", "no.se", "no.npd")`, the first 2 of which are the ##' default setting, which excludes any imputations that did not ##' converge or for which standard errors could not be computed. The ##' last option (`"no.npd"`) would exclude any imputations which ##' yielded a nonpositive definite covariance matrix for observed or ##' latent variables, which would include any "improper solutions" such ##' as Heywood cases. Specific imputation numbers can also be included in this ##' argument, in case users want to apply their own custom omission criteria ##' (or simulations can use different numbers of imputations without ##' redundantly refitting the model). ##' @param asymptotic `logical`. If `FALSE` (default when using ##' `add` to test adding fixed parameters to the model), the pooled test ##' will be returned as an *F*-distributed variable with numerator ##' (`df1`) and denominator (`df2`) degrees of freedom. ##' If `TRUE`, the pooled *F* statistic will be multiplied by its ##' `df1` on the assumption that its `df2` is sufficiently large ##' enough that the statistic will be asymptotically \eqn{\chi^2} distributed ##' with `df1`. When using the `release` argument, `asymptotic` ##' will be set to `TRUE` because (A)RIV can only be calculated for ##' `add`ed parameters. ##' @param univariate `logical`. If `TRUE`, compute the univariate ##' score statistics, one for each constraint. ##' @param cumulative `logical`. If `TRUE`, order the univariate score ##' statistics from large to small, and compute a series of multivariate ##' score statistics, each time including an additional constraint in the test. ##' @param epc `logical`. If `TRUE`, and we are releasing existing ##' constraints, compute the expected parameter changes for the existing ##' (free) parameters (and any specified with `add`), if all constraints ##' were released. For EPCs associated with a particular (1-*df*) ##' constraint, only specify one parameter in `add` or one constraint in ##' `release`. ##' @param standardized If `TRUE`, two extra columns (`sepc.lv` and ##' `sepc.all`) in the `$epc` table will contain standardized values ##' for the EPCs. See [lavaan::lavTestScore()]. ##' @param cov.std `logical`. See [lavaan::standardizedSolution()]. ##' @param verbose `logical`. Not used for now. ##' @param warn `logical`. If `TRUE`, print warnings if they occur. ##' @param information `character` indicating the type of information ##' matrix to use (check [lavaan::lavInspect()] for available options). ##' `"expected"` information is the default, which provides better ##' control of Type I errors. ##' ##' @return ##' A list containing at least one `data.frame`: ##' \itemize{ ##' \item{`$test`: The total score test, with columns for the score ##' test statistic (`X2`), its degrees of freedom (`df`), its ##' *p* value under the \eqn{\chi^2} distribution (`p.value`), ##' and if `asymptotic=FALSE`, the average relative invrease in ##' variance (ARIV) used to calculate the denominator *df* is also ##' returned as a missing-data diagnostic, along with the fraction missing ##' information (FMI = ARIV / (1 + ARIV)).} ##' \item{`$uni`: Optional (if `univariate=TRUE`). ##' Each 1-*df* score test, equivalent to modification indices. Also ##' includes EPCs if `epc=TRUE`, and RIV and FMI if ##' `asymptotic=FALSE`.} ##' \item{`$cumulative`: Optional (if `cumulative=TRUE`). ##' Cumulative score tests, with ARIV and FMI if `asymptotic=FALSE`.} ##' \item{`$epc`: Optional (if `epc=TRUE`). Parameter estimates, ##' expected parameter changes, and expected parameter values if ALL ##' the tested constraints were freed.} ##' } ##' See [lavaan::lavTestScore()] for details. ##' ##' @author ##' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) ##' ##' Adapted from \pkg{lavaan} source code, written by ##' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) ##' ##' `test = "D1"` method proposed by ##' Maxwell Mansolf (University of California, Los Angeles; ##' \email{mamansolf@@gmail.com}) ##' ##' @references ##' Bentler, P. M., & Chou, C.-P. (1992). Some new covariance structure model ##' improvement statistics. *Sociological Methods & Research, 21*(2), ##' 259--282. \doi{10.1177/0049124192021002006} ##' ##' Enders, C. K. (2010). *Applied missing data analysis*. ##' New York, NY: Guilford. ##' ##' Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). ##' Significance levels from repeated *p*-values with multiply-imputed ##' data. *Statistica Sinica, 1*(1), 65--92. Retrieved from ##' ##' ##' Mansolf, M., Jorgensen, T. D., & Enders, C. K. (2020). A multiple ##' imputation score test for model modification in structural equation ##' models. *Psychological Methods, 25*(4), 393--411. ##' \doi{10.1037/met0000243} ##' ##' @seealso [lavaan::lavTestScore()] ##' ##' @examples ##' ##' ## See the new lavaan.mi package ##' ##' @name lavTestScore.mi-deprecated ##' @usage ##' lavTestScore.mi(object, add = NULL, release = NULL, ##' test = c("D2","D1"), scale.W = !asymptotic, ##' omit.imps = c("no.conv","no.se"), ##' asymptotic = is.null(add), ##' univariate = TRUE, cumulative = FALSE, ##' epc = FALSE, standardized = epc, cov.std = epc, ##' verbose = FALSE, warn = TRUE, information = "expected") ##' @seealso [semTools-deprecated()] ##' @keywords internal NULL ##' @rdname semTools-deprecated ##' @export lavTestScore.mi <- function(object, add = NULL, release = NULL, test = c("D2","D1"), scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), asymptotic = is.null(add), # as F or chi-squared univariate = TRUE, cumulative = FALSE, epc = FALSE, standardized = epc, cov.std = epc, verbose = FALSE, warn = TRUE, information = "expected") { .Deprecated(msg = c("\nThe runMI() and related lavaan.mi functions have been", " deprecated and will cease to be included in future ", "versions of semTools.\n\nSupport is still provided for ", "analyzing lavaan.mi-class objects (e.g., compRelSEM() ", "can estimate reliability using pooled results), which ", "can now be created using the lavaan.mi package.\n\nThe ", "deprecated runMI() function now creates an object of ", "class OLDlavaan.mi, which can be analyzed using the ", "deprecated functions in semTools, like lavTestLRT.mi(),", " that have been updated and improved in the lavaan.mi ", "package.\n\nFind more details help('semTools-deprecated)")) stopifnot(inherits(object, "OLDlavaan.mi")) lavoptions <- object@Options useImps <- rep(TRUE, length(object@DataList)) if ("no.conv" %in% omit.imps) useImps <- sapply(object@convergence, "[[", i = "converged") if ("no.se" %in% omit.imps) useImps <- useImps & sapply(object@convergence, "[[", i = "SE") if ("no.npd" %in% omit.imps) { Heywood.lv <- sapply(object@convergence, "[[", i = "Heywood.lv") Heywood.ov <- sapply(object@convergence, "[[", i = "Heywood.ov") useImps <- useImps & !(Heywood.lv | Heywood.ov) } ## custom removal by imputation number rm.imps <- omit.imps[ which(omit.imps %in% 1:length(useImps)) ] if (length(rm.imps)) useImps[as.numeric(rm.imps)] <- FALSE ## whatever is left m <- sum(useImps) if (m == 0L) stop('No imputations meet "omit.imps" criteria.') useImps <- which(useImps) test <- toupper(test[1]) if (!test %in% c("D2","D1")) stop('Invalid choice of "test" argument.') ## check if model has converged if (m == 0L) stop("No models converged. Score tests unavailable.") # check for inequality constraints PT <- parTable(object) if (any(PT$op == ">" | PT$op == "<")) { stop("lavTestScore.mi() does not handle inequality constraints (yet)") } # check arguments if (cumulative) univariate <- TRUE if (sum(is.null(release), is.null(add)) == 0) { stop("`add' and `release' arguments cannot be used together.\n", "Fixed parameters can instead be labeled in the model syntax ", "and those labels can be constrained to fixed values, so that ", "the constraints can be tested using the `release' argument along ", "with other released constraints.") } oldCall <- object@lavListCall #oldCall$model <- parTable(object) # FIXME: necessary? if (test == "D2") { if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L if (warn) warning("Unable to pass lavaan::lavTestScore() arguments ", "when parallel='snow'. Switching to parallel='no'.", " Unless using Windows, parallel='multicore' works.") } } ## call lavaanList() again to run lavTestScore() on each imputation oldCall$FUN <- function(obj) { out <- try(lavaan::lavTestScore(obj, add = add, release = release, univariate = univariate, epc = epc, cumulative = cumulative, cov.std = cov.std, standardized = standardized, warn = FALSE, information = information), silent = TRUE) if (inherits(out, "try-error")) return(NULL) out } FIT <- eval(as.call(oldCall)) ## check if there are any results noScores <- sapply(FIT@funList, is.null) if (all(noScores)) stop("No success using lavTestScore() on any imputations.") ## template to fill in pooled values OUT <- FIT@funList[[ intersect(useImps, which(!noScores))[1] ]] ## at a minimum, pool the total score test chiList <- sapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$test$X2) chiPooled <- calculate.D2(chiList, DF = OUT$test$df, asymptotic) OUT$test$X2 <- chiPooled[1] if (!asymptotic) { names(OUT$test)[names(OUT$test) == "X2"] <- "F" names(OUT$test)[names(OUT$test) == "df"] <- "df1" OUT$test$df2 <- chiPooled[["df2"]] OUT$test$p.value <- NULL # so it appears after "df2" column } OUT$test$p.value <- chiPooled[["pvalue"]] OUT$test$ariv <- chiPooled[["ariv"]] OUT$test$fmi <- chiPooled[["fmi"]] ## univariate? if (univariate) { if (!asymptotic) { names(OUT$uni)[names(OUT$uni) == "X2"] <- "F" OUT$uni$p.value <- NULL # so it appears after "df2" column OUT$uni$df2 <- NA OUT$uni$p.value <- NA OUT$uni$riv <- NA OUT$uni$fmi <- NA if ("epc" %in% colnames(OUT$uni)) { OUT$uni$epc <- NULL # so it appears after "p.value" OUT$uni$epc <- NA # fill in below } } for (i in 1:nrow(OUT$uni)) { chiList <- sapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$uni$X2[i] ) chiPooled <- calculate.D2(chiList, DF = OUT$uni$df[i], asymptotic) if (!asymptotic) { OUT$uni$F[i] <- chiPooled[[1]] OUT$uni$df2[i] <- chiPooled[["df2"]] } else OUT$uni$X2[i] <- chiPooled[[1]] OUT$uni$p.value[i] <- chiPooled[["pvalue"]] OUT$uni$riv[i] <- chiPooled[["ariv"]] OUT$uni$fmi[i] <- chiPooled[["fmi"]] if ("epc" %in% colnames(OUT$uni)) { epcUniList <- sapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$uni$epc[i] ) OUT$uni$epc[i] <- mean(epcUniList) } } if (!asymptotic) names(OUT$uni)[names(OUT$uni) == "df"] <- "df1" } ## cumulative? if (cumulative) { if (!asymptotic) { names(OUT$cumulative)[names(OUT$cumulative) == "X2"] <- "F" OUT$cumulative$p.value <- NULL # so it appears after "df2" column OUT$cumulative$df2 <- NA OUT$cumulative$p.value <- NA OUT$cumulative$ariv <- NA OUT$cumulative$fmi <- NA } for (i in 1:nrow(OUT$cumulative)) { chiList <- sapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$cumulative$X2[i] ) chiPooled <- calculate.D2(chiList, DF = OUT$cumulative$df[i], asymptotic) if (!asymptotic) { OUT$cumulative$F[i] <- chiPooled[[1]] OUT$cumulative$df2[i] <- chiPooled[["df2"]] } else OUT$cumulative$X2[i] <- chiPooled[[1]] OUT$cumulative$p.value[i] <- chiPooled[["pvalue"]] OUT$cumulative$ariv[i] <- chiPooled[["ariv"]] OUT$cumulative$fmi[i] <- chiPooled[["fmi"]] } if (!asymptotic) names(OUT$cumulative)[names(OUT$cumulative) == "df"] <- "df1" } ## EPCs? if (epc) { estList <- lapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$epc$est) OUT$epc$est <- rowMeans(do.call(cbind, estList)) epcList <- lapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$epc$epc) OUT$epc$epc <- rowMeans(do.call(cbind, epcList)) OUT$epc$epv <- OUT$epc$est + OUT$epc$epc if (standardized) { sepcList <- lapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$epc$sepc.lv) OUT$epc$sepc.lv <- rowMeans(do.call(cbind, sepcList)) sepcList <- lapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$epc$sepc.all) OUT$epc$sepc.all <- rowMeans(do.call(cbind, sepcList)) if ("sepc.nox" %in% colnames(FIT@funList[intersect(useImps, which(!noScores))][[1]])) { sepcList <- lapply(FIT@funList[intersect(useImps, which(!noScores))], function(x) x$epc$sepc.nox) OUT$epc$sepc.nox <- rowMeans(do.call(cbind, sepcList)) } } } return(OUT) } # else test == "D1", making 'scale.W=' relevant ## number of free parameters (regardless of whether they are constrained) npar <- object@Model@nx.free ## sample size N <- lavListInspect(object, "ntotal") if (lavoptions$mimic == "EQS") N <- N - 1 # Mode 1: ADDING new parameters if (!is.null(add) && nchar(add) > 0L) { ## turn off SNOW cluster (can't past arguments) if (!is.null(oldCall$parallel)) { if (oldCall$parallel == "snow") { oldCall$parallel <- "no" oldCall$ncpus <- 1L if (warn) warning("Unable to pass lavaan::lavTestScore() arguments ", "when parallel='snow'. Switching to parallel='no'.", " Unless using Windows, parallel='multicore' works.") } } ## call lavaanList() to fit augmented model (do.fit = FALSE) oldCall$FUN <- function(obj) { ngroups <- lavaan::lavInspect(obj, "ngroups") nlevels <- lavaan::lavInspect(obj, "nlevels") ## -------------------------------------- ## borrowed code from lav_object_extend() ## -------------------------------------- ## select columns that should always be included below myCols <- c("lhs","op","rhs") if (ngroups > 1L) myCols <- c(myCols,"block","group") if (nlevels > 1L) myCols <- c(myCols,"block","level") myCols <- unique(myCols) # partable original model oldPT <- lavaan::parTable(obj)[c(myCols, "free","label","plabel")] # replace 'start' column, since lav_model will fill these in in GLIST oldPT$start <- lavaan::parameterEstimates(obj, remove.system.eq = FALSE, remove.def = FALSE, remove.eq = FALSE, remove.ineq = FALSE)$est # add new parameters, extend model # ADD <- lavaan::modindices(obj, standardized = FALSE)[myCols] if (is.list(add)) { stopifnot(!is.null(add$lhs), !is.null(add$op), !is.null(add$rhs)) ADD <- as.data.frame(add) } else if (is.character(add)) { ADD <- lavaan::lavaanify(add, ngroups = ngroups) ADD <- ADD[ , c(myCols, "user","label")] remove.idx <- which(ADD$user == 0) if (length(remove.idx) > 0L) { ADD <- ADD[-remove.idx,] } ADD$start <- rep( 0, nrow(ADD)) ADD$free <- rep( 1, nrow(ADD)) ADD$user <- rep(10, nrow(ADD)) } else stop("'add' must be lavaan model syntax or a parameter table.") # nR <- try(nrow(ADD), silent = TRUE) # if (inherits(nR, "try-error") || is.null(nR)) return(list(gradient = NULL, # information = NULL)) # ADD$free <- rep(1L, nR) # ADD$user <- rep(10L, nR) # merge LIST <- lavaan::lav_partable_merge(oldPT, ADD, remove.duplicated = TRUE, warn = FALSE) # redo 'free' free.idx <- which(LIST$free > 0) LIST$free[free.idx] <- 1:length(free.idx) # adapt options lavoptions <- obj@Options if (any(LIST$op == "~1")) lavoptions$meanstructure <- TRUE lavoptions$do.fit <- FALSE obj2 <- lavaan::lavaan(LIST, slotOptions = lavoptions, slotSampleStats = obj@SampleStats, slotData = obj@Data, slotCache = obj@Cache, sloth1 = obj@h1) ## --------------------------------- list(gradient = lavaan::lavInspect(obj2, "gradient"), information = lavaan::lavInspect(obj2, paste("information", information, sep = ".")), #TODO: Max wants to calculate EPCs as averages across imputations. # Run lavTestScore(epc=TRUE) here? or be consistent... nadd = nrow(ADD), parTable = lavaan::parTable(obj2)) } FIT <- eval(as.call(oldCall)) ## obtain list of inverted Jacobians: within-impuation covariance matrices R.model <- object@Model@con.jac[,,drop = FALSE] nadd <- FIT@funList[[ useImps[1] ]]$nadd ## pool gradients and information matrices gradList <- lapply(FIT@funList[useImps], "[[", i = "gradient") infoList <- lapply(FIT@funList[useImps], "[[", i = "information") score <- colMeans(do.call(rbind, gradList)) # pooled point estimates B <- cov(do.call(rbind, gradList) * sqrt(N)) # between-imputation UNIT information W <- Reduce("+", infoList) / m # within-imputation UNIT information inv.W <- try(solve(W), silent = TRUE) if (inherits(inv.W, "try-error")) { if (warn && scale.W) warning("Could not invert W for total score test, ", "perhaps due to constraints on estimated ", "parameters. Generalized inverse used instead.\n", "If the model does not have equality constraints, ", "it may be safer to set `scale.W = FALSE'.") inv.W <- MASS::ginv(W) } ## relative increase in variance due to missing data ariv <- (1 + 1/m)/nadd * sum(diag(B %*% inv.W)) # ONLY relevant for scaling full INFO matrix if (scale.W) { information <- (1 + ariv) * W # Enders (2010, p. 235) eqs. 8.20-21 } else { ## less reliable, but constraints prevent inversion of W information <- W + B + (1/m)*B # Enders (2010, p. 235) eq. 8.19 } if (nrow(R.model) > 0L) { R.model <- cbind(R.model, matrix(0, nrow(R.model), ncol = nadd)) R.add <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd)) R <- rbind(R.model, R.add) Z <- cbind(rbind(information, R.model), rbind(t(R.model),matrix(0,nrow(R.model),nrow(R.model)))) Z.plus <- MASS::ginv(Z) J.inv <- Z.plus[ 1:nrow(information), 1:nrow(information) ] r.idx <- seq_len(nadd) + nrow(R.model) } else { R <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd)) J.inv <- MASS::ginv(information) r.idx <- seq_len(nadd) } PT <- FIT@funList[[ useImps[1] ]]$parTable if (is.null(PT$group)) PT$group <- PT$block # lhs/rhs lhs <- lavaan::lav_partable_labels(PT)[ PT$user == 10L ] op <- rep("==", nadd) rhs <- rep("0", nadd) Table <- data.frame(lhs = lhs, op = op, rhs = rhs) class(Table) <- c("lavaan.data.frame", "data.frame") } else { # MODE 2: releasing constraints if (!asymptotic) { message('The average relative increase in variance (ARIV) cannot be ', 'calculated for releasing estimated constraints, preventing the ', 'denominator degrees of freedom from being calculated for the F ', 'test, so the "asymptotic" argument was switched to TRUE.' ) asymptotic <- TRUE scale.W <- FALSE } if (is.character(release)) stop("not implemented yet") #FIXME: moved up to save time R <- object@Model@con.jac[,,drop = FALSE] if (nrow(R) == 0L) stop("No equality constraints found in the model.") ## use lavaanList() to get gradient/information from each imputation oldCall$FUN <- function(obj) { list(gradient = lavaan::lavInspect(obj, "gradient"), information = lavaan::lavInspect(obj, paste("information", information, sep = "."))) } FIT <- eval(as.call(oldCall)) ## pool gradients and information matrices gradList <- lapply(FIT@funList[useImps], "[[", i = "gradient") infoList <- lapply(FIT@funList[useImps], "[[", i = "information") score <- colMeans(do.call(rbind, gradList)) # pooled point estimates B <- cov(do.call(rbind, gradList) * sqrt(N)) # between-imputation UNIT information W <- Reduce("+", infoList) / m # within-imputation UNIT information inv.W <- try(solve(W), silent = TRUE) if (inherits(inv.W, "try-error")) { if (warn && scale.W) warning("Could not invert W for total score test, ", "perhaps due to constraints on estimated ", "parameters. Generalized inverse used instead.\n", "If the model does not have equality constraints, ", "it may be safer to set `scale.W = FALSE'.") inv.W <- MASS::ginv(W) } ## relative increase in variance due to missing data k <- length(release) if (k == 0) k <- nrow(R) ariv <- (1 + 1/m)/k * sum(diag(B %*% inv.W)) #FIXME: Invalid extrapolation! if (scale.W) { #TODO: This option is disabled, kept only to update with future research information <- (1 + ariv) * W # Enders (2010, p. 235) eqs. 8.20-21 } else { ## less reliable, but constraints prevent inversion of W information <- W + B + (1/m)*B # Enders (2010, p. 235) eq. 8.19 } if (is.null(release)) { # ALL constraints r.idx <- seq_len( nrow(R) ) J.inv <- MASS::ginv(information) #FIXME? Yves has this above if(is.null(release)) } else if (is.numeric(release)) { r.idx <- release if(max(r.idx) > nrow(R)) { stop("lavaan ERROR: maximum constraint number (", max(r.idx), ") is larger than number of constraints (", nrow(R), ")") } # neutralize the non-needed constraints R1 <- R[-r.idx, , drop = FALSE] Z1 <- cbind( rbind(information, R1), rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) ) Z1.plus <- MASS::ginv(Z1) J.inv <- Z1.plus[ 1:nrow(information), 1:nrow(information) ] } else if (is.character(release)) { stop("not implemented yet") } # lhs/rhs eq.idx <- which(object@ParTable$op == "==") if (length(eq.idx) > 0L) { lhs <- object@ParTable$lhs[eq.idx][r.idx] op <- rep("==", length(r.idx)) rhs <- object@ParTable$rhs[eq.idx][r.idx] } Table <- data.frame(lhs = lhs, op = op, rhs = rhs) class(Table) <- c("lavaan.data.frame", "data.frame") } if (lavoptions$se == "standard") { stat <- as.numeric(N * score %*% J.inv %*% score) } else { # generalized score test if (warn) warning("se is not `standard'. Robust test not implemented yet. ", "Falling back to ordinary score test.") # NOTE!!! # we can NOT use VCOV here, because it reflects the constraints, # and the whole point is to test for these constraints... stat <- as.numeric(N * score %*% J.inv %*% score) } # compute df, taking into account that some of the constraints may # be needed to identify the model (and hence information is singular) # information.plus <- information + crossprod(R) #df <- qr(R[r.idx,,drop = FALSE])$rank + # ( qr(information)$rank - qr(information.plus)$rank ) DF <- nrow( R[r.idx, , drop = FALSE] ) if (asymptotic) { TEST <- data.frame(test = "score", X2 = stat, df = DF, p.value = pchisq(stat, df = DF, lower.tail = FALSE)) } else { ## calculate denominator DF for F statistic myDims <- 1:nadd + npar #TODO: not available in release mode, unless calculating Jacobian of constraints, like Wald test? ARIV <- (1 + 1/m)/nadd * sum(diag(B[myDims, myDims, drop = FALSE] %*% inv.W[myDims, myDims, drop = FALSE])) a <- DF*(m - 1) if (a > 4) { df2 <- 4 + (a - 4) * (1 + (1 - 2/a)*(1 / ARIV))^2 # Enders (eq. 8.24) } else { df2 <- a*(1 + 1/DF) * (1 + 1/ARIV)^2 / 2 # Enders (eq. 8.25) } TEST <- data.frame(test = "score", "F" = stat / DF, df1 = DF, df2 = df2, p.value = pf(stat / DF, df1 = DF, df2 = df2, lower.tail = FALSE), ariv = ARIV, fmi = ARIV / (1 + ARIV)) } class(TEST) <- c("lavaan.data.frame", "data.frame") attr(TEST, "header") <- "total score test:" OUT <- list(test = TEST) if (univariate) { TS <- numeric( nrow(R) ) EPC.uni <- numeric( nrow(R) ) #FIXME: to add univariate EPCs for added parameters for (r in r.idx) { R1 <- R[-r, , drop = FALSE] Z1 <- cbind( rbind(information, R1), rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) ) Z1.plus <- MASS::ginv(Z1) Z1.plus1 <- Z1.plus[ 1:nrow(information), 1:nrow(information) ] TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score) ## FIXME: experimentally add univariate EPCs for added parameters, as would accompany modification indices if (epc && !is.null(add)) EPC.uni[r] <- 1 * utils::tail(as.numeric(score %*% Z1.plus1), n = nrow(R))[r] } Table2 <- Table DF <- rep(1, length(r.idx)) if (asymptotic) { Table2$X2 <- TS[r.idx] Table2$df <- DF Table2$p.value <- pchisq(Table2$X2, df = DF, lower.tail = FALSE) } else { Table2$F <- TS[r.idx] / DF Table2$df1 <- DF ## calculate denominator DF for F statistic using RIV per 1-df test (Enders eq. 8.10) myDims <- 1:nadd + npar RIVs <- diag((1 + 1/m) * B[myDims, myDims, drop = FALSE]) / diag(W[myDims, myDims, drop = FALSE]) Table2$df2 <- sapply(RIVs, function(riv) { DF1 <- 1L # Univariate tests a <- DF1*(m - 1) DF2 <- if (a > 4) { 4 + (a - 4) * (1 + (1 - 2/a)*(1 / riv))^2 # Enders (eq. 8.24) } else a*(1 + 1/DF1) * (1 + 1/riv)^2 / 2 # Enders (eq. 8.25) DF2 }) Table2$p.value <- pf(Table2$F, df1 = DF, df2 = Table2$df2, lower.tail = FALSE) Table2$riv <- RIVs Table2$fmi <- RIVs / (1 + RIVs) } ## add univariate EPCs, equivalent to modindices() output if (epc && !is.null(add)) Table2$epc <- EPC.uni[r.idx] attr(Table2, "header") <- "univariate score tests:" OUT$uni <- Table2 } if (cumulative) { TS.order <- sort.int(TS, index.return = TRUE, decreasing = TRUE)$ix TS <- numeric( length(r.idx) ) if (!asymptotic) ARIVs <- numeric( length(r.idx) ) for (r in 1:length(r.idx)) { rcumul.idx <- TS.order[1:r] R1 <- R[-rcumul.idx, , drop = FALSE] Z1 <- cbind( rbind(information, R1), rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) ) Z1.plus <- MASS::ginv(Z1) Z1.plus1 <- Z1.plus[ 1:nrow(information), 1:nrow(information) ] TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score) if (!asymptotic) { myDims <- rcumul.idx + npar ARIVs[r] <- (1 + 1/m)/length(myDims) * sum(diag(B[myDims, myDims, drop = FALSE] %*% inv.W[myDims, myDims, drop = FALSE])) } } Table3 <- Table[TS.order,] DF <- seq_len( length(TS) ) if (asymptotic) { Table3$X2 <- TS Table3$df <- DF Table3$p.value <- pchisq(Table3$X2, df = DF, lower.tail = FALSE) } else { Table3$F <- TS / DF Table3$df1 <- DF ## calculate denominator DF for F statistic Table3$df2 <- mapply(FUN = function(DF1, ariv) { a <- DF1*(m - 1) DF2 <- if (a > 4) { 4 + (a - 4) * (1 + (1 - 2/a)*(1 / ariv))^2 # Enders (eq. 8.24) } else a*(1 + 1/DF1) * (1 + 1/ariv)^2 / 2 # Enders (eq. 8.25) DF2 }, DF1 = DF, ariv = ARIVs) Table3$p.value = pf(Table3$F, df1 = DF, df2 = Table3$df2, lower.tail = FALSE) Table3$riv <- ARIVs Table3$fmi <- ARIVs / (1 + ARIVs) } attr(Table3, "header") <- "cumulative score tests:" OUT$cumulative <- Table3 } if (epc) { ngroups <- lavaan::lavInspect(object, "ngroups") nlevels <- lavaan::lavInspect(object, "nlevels") ################# source code Yves commented out. ################# Calculates 1 EPC-vector per constraint. ################# Better to call lavTestScore() multiple times? Ugh... # EPC <- vector("list", length = length(r.idx)) # for (i in 1:length(r.idx)) { # r <- r.idx[i] # R1 <- R[-r,,drop = FALSE] # Z1 <- cbind( rbind(information, R1), # rbind(t(R1), matrix(0,nrow(R1),nrow(R1))) ) # Z1.plus <- MASS::ginv(Z1) # Z1.plus1 <- Z1.plus[ 1:nrow(information), 1:nrow(information) ] # EPC[[i]] <- -1 * as.numeric(score %*% Z1.plus1) # } # OUT$EPC <- EPC # EPCs when freeing all constraints together (total test) R1 <- R[-r.idx, , drop = FALSE] Z1 <- cbind( rbind(information, R1), rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) ) Z1.plus <- MASS::ginv(Z1) Z1.plus1 <- Z1.plus[ 1:nrow(information), 1:nrow(information) ] EPC.all <- 1 * as.numeric(score %*% Z1.plus1) # create epc table for the 'free' parameters myCoefs <- getMethod("coef","OLDlavaan.mi")(object, omit.imps = omit.imps) myCols <- c("lhs","op","rhs","user") if (ngroups > 1L) myCols <- c(myCols, "block","group") if (nlevels > 1L) myCols <- c(myCols, "block","level") myCols <- c(unique(myCols), "free","exo","label","plabel") LIST <- if (!is.null(add) && nchar(add) > 0L) { PT[ , myCols] } else parTable(object)[ , myCols] nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">")) if (length(nonpar.idx) > 0L) LIST <- LIST[ -nonpar.idx , ] LIST$est[ LIST$free > 0 & LIST$user != 10 ] <- myCoefs LIST$est[ LIST$user == 10L ] <- 0 LIST$epc <- rep(as.numeric(NA), length(LIST$lhs)) LIST$epc[ LIST$free > 0 ] <- EPC.all LIST$epv <- LIST$est + LIST$epc #TODO: add SEPCs if (standardized) { EPC <- LIST$epc if (cov.std) { # replace epc values for variances by est values var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs & LIST$exo == 0L) EPC[ var.idx ] <- LIST$est[ var.idx ] } # two problems: # - EPC of variances can be negative, and that is perfectly legal # - EPC (of variances) can be tiny (near-zero), and we should # not divide by tiny variables small.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs & abs(EPC) < sqrt( .Machine$double.eps ) ) if (length(small.idx) > 0L) EPC[ small.idx ] <- as.numeric(NA) # get the sign EPC.sign <- sign(LIST$epc) ## pooled estimates for standardizedSolution() pooledest <- getMethod("coef", "OLDlavaan.mi")(object, omit.imps = omit.imps) ## update @Model@GLIST for standardizedSolution(..., GLIST=) object@Model <- lavaan::lav_model_set_parameters(object@Model, x = pooledest) LIST$sepc.lv <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.lv", cov.std = cov.std, partable = LIST, GLIST = object@Model@GLIST, est = abs(EPC))$est.std LIST$sepc.all <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.all", cov.std = cov.std, partable = LIST, GLIST = object@Model@GLIST, est = abs(EPC))$est.std fixed.x <- lavListInspect(object, "options")$fixed.x && length(lavNames(object, "ov.x")) if (fixed.x) { LIST$sepc.nox <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, type = "std.nox", cov.std = cov.std, partable = LIST, GLIST = object@Model@GLIST, est = abs(EPC))$est.std } if (length(small.idx) > 0L) { LIST$sepc.lv[small.idx] <- 0 LIST$sepc.all[small.idx] <- 0 if (fixed.x) LIST$sepc.nox[small.idx] <- 0 } } LIST$free[ LIST$user == 10L ] <- 0 LIST$user <- NULL LIST$exo <- NULL DF <- if (asymptotic) OUT$test$df else OUT$test$df1 attr(LIST, "header") <- paste0("expected parameter changes (epc) and ", "expected parameter values (epv)", if (DF < 2) ":" else { " if ALL constraints in 'add' or 'release' were freed:" }) OUT$epc <- LIST } OUT } semTools/R/emmeans_lavaan.R0000644000176200001440000004207214752750163015371 0ustar liggesusers### Mattan S. Ben-Shachar & Terrence D. Jorgensen ### Last updated: 11 February 2025 ### emmeans support for lavaan objects ##' `emmeans` Support Functions for `lavaan` Models ##' ##' @description Provide emmeans support for lavaan objects ##' ##' @param object An object of class [lavaan::lavaan()]. ##' See **Details**. ##' @param lavaan.DV `character` string naming the variable(s) for which ##' expected marginal means / trends should be produced. ##' A vector of names indicates a multivariate outcome, treated by default ##' as repeated measures. ##' @param data An optional `data.frame` without missing values, to be passed ##' when `missing="FIML"` estimation was useed, thus avoiding a reference-grid ##' with missing values. ##' @param trms,xlev,grid See `emmeans::emm_basis` ##' @param ... Further arguments passed to `emmeans::recover_data.lm` or ##' `emmeans::emm_basis.lm` ##' ##' @details ##' ##' \subsection{Supported DVs}{ ##' `lavaan.DV` must be an *endogenous variable*, by appearing on ##' the left-hand side of either a regression operator (`"~"`) ##' or an intercept operator (`"~1"`), or both. ##' \cr\cr ##' `lavaan.DV` can also be a vector of endogenous variable, in which ##' case they will be treated by `emmeans` as a multivariate outcome ##' (often, this indicates repeated measures) represented by an additional ##' factor named `rep.meas` by default. The `mult.name=` argument ##' can be used to overwrite this default name. ##' } ##' ##' \subsection{Unsupported Models}{ ##' This functionality does not support the following models: ##' \itemize{ ##' \item Multi-level models are not supported. ##' \item Models not fit to a `data.frame` (i.e., models fit to a ##' covariance matrix). ##' } ##' } ##' ##' \subsection{Dealing with Fixed Parameters}{ ##' Fixed parameters (set with `lavaan`'s modifiers) are treated as-is: ##' their values are set by the users, and they have a *SE* of 0 (as such, ##' they do not co-vary with any other parameter). ##' } ##' ##' \subsection{Dealing with Multigroup Models}{ ##' If a multigroup model is supplied, a factor is added to the reference grid, ##' the name matching the `group` argument supplied when fitting the model. ##' *Note that you must set* `nesting = NULL`. ##' } ##' ##' \subsection{Dealing with Missing Data}{ ##' Limited testing suggests that these functions do work when the model was fit ##' to incomplete data. ##' } ##' ##' \subsection{Dealing with Factors}{ ##' By default `emmeans` recognizes binary variables (0,1) as a "factor" ##' with two levels (and not a continuous variable). With some clever contrast ##' defenitions it should be possible to get the desired emmeans / contasts. ##' See example below. ##' } ##' ##' @author Mattan S. Ben-Shachar (Ben-Gurion University of the Negev; ##' \email{matanshm@@post.bgu.ac.il}) ##' ##' @example inst/examples/lavaan2emmeans.R ##' ##' @name lavaan2emmeans NULL ##' @rdname lavaan2emmeans recover_data.lavaan <- function(object, lavaan.DV, data = NULL, ...){ if (!requireNamespace("emmeans", quietly = TRUE)){ stop("'emmeans' is not installed.") } .emlav_test_DV(object, lavaan.DV) ## testing multi-group requires access to ... dots <- list(...) #FIXME: the nesting= argument is not passed to ... here, so the warning is # annoyingly printed even when nesting = NULL is specified. if (lavInspect(object, 'ngroups') > 1L && !("nesting" %in% names(dots))) { warning( "For multi-group models, don't forget to set 'nesting = NULL'.\n", "See `?lavaan2emmeans` for more info.", call. = FALSE ) } # Fake it lavaan_data <- .emlav_recover_data(object, data) recovered <- emmeans::recover_data(.emlav_fake_fit(object, lavaan.DV, lavaan_data), data = lavaan_data, ...) # Make it lavaan_data <- lavaan_data[, colnames(recovered), drop = FALSE] # Fill attributes (but keep lavaan_data in case of missing data) mostattributes(lavaan_data) <- attributes(recovered) return(lavaan_data) } ##' @rdname lavaan2emmeans ##' @importFrom lavaan lavInspect emm_basis.lavaan <- function(object,trms, xlev, grid, lavaan.DV, ...){ if (!requireNamespace("emmeans", quietly = TRUE)) { stop("'emmeans' is not installed.") } # Fake it emmb <- emmeans::emm_basis(.emlav_fake_fit(object, lavaan.DV), trms, xlev, grid, ...) # bhat -------------------------------------------------------------------- pars <- .emlav_clean_pars_tab(object, lavaan.DV, "bhat") par_names <- pars$rhs if(nrow(pars) < length(emmb$bhat)) { warning( "Not all parameters have been estimated.\n", "This is usually caused by a missing mean structure.\n", "Fixing estimates for these parameters at 0.", call. = FALSE ) } # re-shape to deal with any missing estimates temp_bhat <- rep(0, length = length(emmb$bhat)) temp_bhat[seq_len(nrow(pars))] <- pars$est names(temp_bhat) <- .emlab_find_term_names(par_names, colnames(emmb$V)) # re-order b_ind <- match(colnames(emmb$V), names(temp_bhat)) emmb$bhat <- temp_bhat[b_ind] # VCOV -------------------------------------------------------------------- lavVCOV <- lavInspect(object, "vcov") pars <- .emlav_clean_pars_tab(object, lavaan.DV, "vcov") par_names <- paste0(pars$lhs, pars$op, pars$rhs) # only regression estimates pattern <- paste0("^(", paste0(lavaan.DV, collapse = "|"), ")") is_reg <- grepl(paste0(pattern, "~"), par_names) is_cov <- grepl(paste0(pattern, "~~"), par_names) only_reg <- is_reg & !is_cov lavVCOV <- lavVCOV[only_reg, only_reg, drop = FALSE] if(ncol(lavVCOV) < nrow(emmb$V)) { warning( "Not all parameters are included in the VCOV matrix.\n", "Perhaps some are fixed with a modifier, or the mean structure is missing.\n", "Fixing SEs for these parameters at 0.", call. = FALSE ) } # get only RHS par_names <- par_names[only_reg] par_names <- sub(paste0("~1$"), "~(Intercept)", par_names) par_names <- sub(paste0(pattern, "~"), "", par_names) # re-shape to deal with any missing estimates temp_vcov <- matrix(0, nrow = nrow(emmb$V), ncol = ncol(emmb$V)) temp_vcov[seq_len(ncol(lavVCOV)), seq_len(ncol(lavVCOV))] <- lavVCOV colnames(temp_vcov) <- .emlab_find_term_names(par_names, colnames(emmb$V)) rownames(temp_vcov) <- .emlab_find_term_names(par_names, colnames(emmb$V)) # re-order v_ind <- match(colnames(emmb$V), colnames(temp_vcov)) emmb$V <- temp_vcov[v_ind, v_ind] # dffun & dfargs ---------------------------------------------------------- emmb$dffun <- function(...) Inf emmb$dfargs <- list(df = Inf) # nbasis and misc --------------------------------------------------------- ## DONT CHANGE! MESSES UP MULTI-DV REF_GRID # emmb$nbasis <- matrix(NA, 1, 1) # emmb$misc <- list() return(emmb) } ##' @keywords internal .emlab_find_term_names <- function(terms, candidates) { terms_split <- strsplit(terms, split = ":") candidates_split <- strsplit(candidates, split = ":") is_in <- matrix(NA, nrow = length(terms_split), ncol = length(candidates_split)) for (i in seq_along(terms_split)) { for (j in seq_along(candidates_split)) { is_in[i,j] <- all(candidates_split[[j]] %in% terms_split[[i]]) && all(terms_split[[i]] %in% candidates_split[[j]]) } } if (length(terms) > 1L) is_in <- apply(is_in, 2, any) c(terms, if (any(!is_in)) candidates[!is_in]) } ##' @keywords internal ##' @importFrom lavaan lavInspect .emlav_test_DV <- function(object, lavaan.DV){ # has DV? pars <- lavaan::parameterEstimates(object) pars <- pars[pars$op %in% c("~1", "~"), ] if (!all(lavaan.DV %in% pars$lhs)) { lavaan.DV <- lavaan.DV[!lavaan.DV %in% pars$lhs] lavaan.DV <- paste0(lavaan.DV, collapse = ",") stop( "{", lavaan.DV, "} is not predicted (endogenous) in this model!\n", "See `?lavaan2emmeans` for more info.", call. = FALSE ) } # Is DV ordered? if (any(lavaan.DV %in% lavInspect(object, 'ordered'))) { lavaan.DV <- lavaan.DV[lavaan.DV %in% lavInspect(object, 'ordered')] lavaan.DV <- paste0(lavaan.DV, collapse = ",") stop( "{", lavaan.DV, "} is an ordered variable! ", "Currently only continuous DVs are supported.\n", "See `?lavaan2emmeans` for more info.", call. = FALSE ) } # is multilevel? if (lavInspect(object, 'nlevels') > 1L){ warning( "emmeans support is unavailable for multilevel SEMs.", call. = FALSE ) } invisible(NULL) } ##' @keywords internal ##' @importFrom lavaan lavInspect .emlav_recover_data <- function(object, data = NULL, silent = FALSE){ ##This function was contributed by TDJ dat <- lavaan::lavPredict(object, newdata = data, type = "lv", assemble = TRUE, append.data = TRUE) ## convert to data.frame, if necessary (single group) dat <- as.data.frame(dat) if (anyNA(dat)) { ## mean-impute any NAs if (!silent) { warning("'data' contains missing value. Mean-imputing them.", call. = FALSE) } dat[] <- lapply(dat, function(v) { if (is.numeric(v) && (ix <- length(which(is.na(v))))) { v[ix] <- mean(v, na.rm = TRUE) } v }) } dat } #TODO: delete old function after verifying the new one (above) works # function(object){ # data_obs <- lavInspect(object, "data") # data_lat <- lavaan::lavPredict(object, type = "lv") # # # If multi group # if (lavInspect(object, 'ngroups') > 1L) { # # make single data frame + add group labels # group_labels <- sapply(seq_along(names(data_obs)), function(i) { # label_ <- names(data_obs)[i] # nobs_ <- nrow(data_obs[[i]]) # rep(label_, times = nobs_) # }, simplify = FALSE) # # data_obs <- data.frame(do.call(rbind, data_obs)) # data_obs[[lavInspect(object, "group")]] <- unlist(group_labels) # data_lat <- do.call(rbind, data_lat) # } # # data_full <- cbind(data_obs, data_lat) # return(data.frame(data_full)) # } ##' @keywords internal ##' @importFrom lavaan lavInspect .emlav_fake_fit <- function(object, lavaan.DV, lavaan_data = NULL){ if (is.null(lavaan_data)) { lavaan_data <- .emlav_recover_data(object, silent = TRUE) } # Fake it pars <- lavaan::parameterEstimates(object) pars <- pars[pars$lhs %in% lavaan.DV & pars$op == "~", ] # If multi-group if (lavInspect(object, 'ngroups') > 1L) { # condition on group (no intercept!) RHS <- paste0( "0 +", lavInspect(object, "group"), "+", lavInspect(object, "group"), "/(", paste0(pars$rhs, collapse = " + "), ")" ) } else { RHS <- paste0(pars$rhs, collapse = " + ") } lavaan_formula <- stats::as.formula(paste0( paste0("cbind(",paste0(lavaan.DV, collapse = ","),")"), "~", RHS )) return(lm(lavaan_formula, lavaan_data)) } ##' @keywords internal ##' @importFrom lavaan lavInspect .emlav_clean_pars_tab <- function(object, lavaan.DV, type = c("bhat", "vcov")){ type <- match.arg(type) if (type == "bhat") { pars <- lavaan::parameterEstimates(object) pars <- pars[pars$lhs %in% lavaan.DV & pars$op %in% c("~", "~1"), ] } else { pars <- lavaan::parameterEstimates(object, remove.nonfree = TRUE, remove.def = TRUE) } pars$rhs[pars$op == "~1"] <- "(Intercept)" pars$op[pars$op == "~1"] <- "~" if (lavInspect(object, 'ngroups') > 1L) { group_labs <- paste0(lavInspect(object, 'group'), lavInspect(object, 'group.label')) pars$group <- group_labs[pars$group] temp_rhs <- paste0(pars$group, ":", pars$rhs) temp_rhs[grepl("(Intercept)", temp_rhs)] <- pars$group[grepl("(Intercept)", temp_rhs)] pars$rhs <- temp_rhs } if (length(lavaan.DV) > 1L) { pars$rhs <- paste0(pars$lhs, ":", pars$rhs) } return(pars[, colnames(pars) %in% c("lhs", "op", "rhs", "label", "est")]) } ##' @keywords internal test .emlav_run_tests <- function() { if (!requireNamespace("testthat")) { stop("Need 'testthat' for testing") } if (!requireNamespace("emmeans")) { stop("Need 'emmeans' for testing") } testthat::test_that("moderation", { model <- ' # regressions Sepal.Length ~ b1 * Sepal.Width + b2 * Petal.Length + b3 * Sepal.Width:Petal.Length # simple slopes for condition effect below := b2 + b3 * (-1) above := b2 + b3 * (+1) ' semFit <- lavaan::sem(model = model, data = datasets::iris, meanstructure = TRUE) em_ <- summary( emmeans::emtrends( semFit, ~ Sepal.Width, "Petal.Length", lavaan.DV = "Sepal.Length", at = list(Sepal.Width = c(-1, 1)) ) ) em_est <- em_$Petal.Length.trend em_se <- em_$SE lv_est <- lavaan::parameterEstimates(semFit, output = "pretty")[15:16, "est"] lv_se <- lavaan::parameterEstimates(semFit, output = "pretty")[15:16, "se"] testthat::expect_equal(em_est, lv_est, tolerance = 1e-4) testthat::expect_equal(em_se, lv_se, tolerance = 1e-4) }) testthat::test_that("latent", { model <- ' LAT1 =~ Sepal.Length + Sepal.Width LAT1 ~ b1 * Petal.Width + 1 * Petal.Length Petal.Length ~ Petal.Length.mean * 1 V1 := 1 * Petal.Length.mean + 1 * b1 V2 := 1 * Petal.Length.mean + 2 * b1 ' semFit <- suppressWarnings( lavaan::sem(model = model, data = datasets::iris, std.lv = TRUE) ) em_ <- suppressWarnings(summary(emmeans::emmeans( semFit, ~ Petal.Width, lavaan.DV = "LAT1", at = list(Petal.Width = 1:2) ))) em_est <- em_$emmean lv_est <- lavaan::parameterEstimates(semFit, output = "pretty")[15:16, "est"] testthat::expect_equal(em_est, lv_est, tolerance = 1e-4) }) testthat::test_that("multi-dv", { model <- ' ind60 =~ x1 + x2 + x3 # metric invariance dem60 =~ y1 + a*y2 + b*y3 + c*y4 dem65 =~ y5 + a*y6 + b*y7 + c*y8 # scalar invariance y1 + y5 ~ d*1 y2 + y6 ~ e*1 y3 + y7 ~ f*1 y4 + y8 ~ g*1 # regressions (slopes differ: interaction with time) dem60 ~ b1*ind60 dem65 ~ b2*ind60 + NA*1 + Mean.Diff*1 # residual correlations y1 ~~ y5 y2 ~~ y4 + y6 y3 ~~ y7 y4 ~~ y8 y6 ~~ y8 # conditional mean differences (besides mean(ind60) == 0) low := (-1*b2 + Mean.Diff) - (-1*b1) # 1 SD below M high := (b2 + Mean.Diff) - b1 # 1 SD above M ' semFit <- lavaan::sem(model, data = lavaan::PoliticalDemocracy) em_ <- suppressWarnings(summary(emmeans::emmeans( semFit, pairwise ~ rep.meas | ind60, lavaan.DV = c("dem60", "dem65"), at = list(ind60 = c(-1, 1)) )[[2]])) em_est <- em_$estimate lv_est <- lavaan::parameterEstimates(semFit, output = "pretty")[49:50, "est"] em_se <- em_$SE lv_se <- lavaan::parameterEstimates(semFit, output = "pretty")[49:50, "se"] testthat::expect_equal(em_est, -lv_est, tolerance = 1e-4) testthat::expect_equal(em_se, lv_se, tolerance = 1e-4) }) testthat::test_that("Multi Group", { model <- ' x1 ~ c(int1, int2)*1 + c(b1, b2)*ageyr diff_11 := (int2 + b2*11) - (int1 + b1*11) diff_13 := (int2 + b2*13) - (int1 + b1*13) diff_15 := (int2 + b2*15) - (int1 + b1*15) ' semFit <- lavaan::sem(model, group = "school", data = lavaan::HolzingerSwineford1939) em_ <- suppressWarnings(summary( emmeans::emmeans( semFit, pairwise ~ school | ageyr, lavaan.DV = "x1", at = list(ageyr = c(11, 13, 15)), nesting = NULL )[[2]] )) em_est <- em_$estimate lv_est <- lavaan::parameterEstimates(semFit, output = "pretty")$est[11:13] em_se <- em_$SE lv_se <- lavaan::parameterEstimates(semFit, output = "pretty")$se[11:13] testthat::expect_equal(em_est, lv_est, tolerance = 1e-4) testthat::expect_equal(em_se, lv_se, tolerance = 1e-4) }) testthat::test_that("all!", { model <- ' LAT1 =~ x1 + x2 + x3 LAT2 =~ x4 + x5 + x6 LAT3 =~ LAT1 + LAT2 + x7 + x8 + x9 LAT3 ~ c(b1,b1)*ageyr + agemo grade ~ ageyr ' semFit <- lavaan::sem(model, data = lavaan::HolzingerSwineford1939, group = "school") rg <- suppressWarnings(emmeans::ref_grid(semFit, lavaan.DV = c("LAT3", "grade"))) testthat::expect_s4_class(rg, "emmGrid") }) testthat::test_that("missing data", { raw_mtcars <- mtcars_na <- datasets::mtcars mtcars_na$hp[1] <- NA model <- " mpg ~ hp + drat + hp:drat " fit <- lavaan::sem(model, mtcars_na, missing = "fiml.x") testthat::expect_warning( rg <- emmeans::ref_grid(fit, lavaan.DV = "mpg"), regexp = "missing") testthat::expect_false(anyNA(rg@grid)) testthat::expect_equal(rg@grid$hp, 147.871, tolerance = 0.01) testthat::expect_warning( rg2 <- emmeans::ref_grid(fit, lavaan.DV = "mpg", data = raw_mtcars), regexp = NA) testthat::expect_equal(rg2@grid$hp, mean(raw_mtcars$hp), tolerance = 0.01) }) message("All good!") } semTools/vignettes/0000755000176200001440000000000014764374533014107 5ustar liggesuserssemTools/vignettes/partialInvariance.bib0000644000176200001440000000270414006342740020204 0ustar liggesusers@preamble{ " \newcommand{\noop}[1]{} " } @article{cheung2002, title={Evaluating goodness-of-fit indexes for testing measurement invariance}, author={Cheung, Gordon W and Rensvold, Roger B}, journal={Structural equation modeling}, volume={9}, number={2}, pages={233--255}, year={2002}, publisher={Taylor \& Francis} } @article{meade2008, title={Power and sensitivity of alternative fit indices in tests of measurement invariance.}, author={Meade, Adam W and Johnson, Emily C and Braddy, Phillip W}, journal={Journal of Applied Psychology}, volume={93}, number={3}, pages={568}, year={2008}, publisher={American Psychological Association} } @book{muthen1998, title={Mplus technical appendices}, author={Muth{\'e}n, Bengt O}, publisher={Muth{\'e}n \& Muth{\'e}n}, address={Los Angeles, CA}, year={\noop{1998}1998--2004} } @article{cohen1992, title={A power primer.}, author={Cohen, Jacob}, journal={Psychological bulletin}, volume={112}, number={1}, pages={155--159}, year={1992}, publisher={American Psychological Association} } @incollection{millsap2012, author = {Millsap, Roger E and Olivera-Aguilar, Margarita}, title = {Investigating measurement invariance using confirmatory factor analysis}, editor = {Hoyle, Rick H}, booktitle = {Handbook of structural equation modeling}, pages = {380--392}, publisher = {Guilford}, address = {New York}, year = {2012} }semTools/vignettes/partialInvariance.Rnw0000644000176200001440000002437214006342740020223 0ustar liggesusers\documentclass[12pt]{article} %%\VignetteIndexEntry{Partial Invariance} %%\VignetteDepends{semTools} \usepackage[utf8]{inputenc} \usepackage{amsfonts} \usepackage{amstext} \usepackage{amsmath} \usepackage{natbib} \title{A Note on Effect Size for Measurement Invariance} \author{Sunthud Pornprasertmanit} \begin{document} \maketitle This article aims to show the mathematical reasoning behind all effect sizes used in the \texttt{partialInvariance} and \texttt{partialInvarianceCat} functions in \texttt{semTools} package. In the functions, the following statistics are compared across groups: factor loadings, item intercepts (for continuous items), item thresholds (for categorical items), measurement error variances, and factor means. The comparison can be compared between two groups (e.g., Cohen's \emph{d}) or multiple groups (e.g., $R^2$). This note provides the details of the effect sizes in comparing two groups only. The comparison between multiple groups can be done by picking the reference group and compare the other groups with the reference group in the similar fashion to dummy variables. For example, the comparison between four groups would create three effect size values (i.e., Group 1 vs. Reference, Group 2 vs. Reference, and Group 3 vs. Reference). Alternatively, for the measurement invariance, the change in comparative fit index (CFI) can be used as the measure of effect size. In the measurement invariance literature \citep{cheung2002, meade2008}, the change in CFI is used to test the equality constraints for multiple items simultaneously. The functions in \texttt{semTools} will show the change in CFI for each individual item. That is, if an item were to allow to have different statistics (e.g., loading), how large the CFI would drop from the original model. Please note that more research is needed in finding the appropriate cutoffs for the change in CFI for individual items. Are the cutoffs of .002 or .01 appropriate for this context? In creating effect size, a target statistic needs to be standardized. Sample variances are used in the standardization formula. If researchers can assume that target variances across groups are equal in population, then pooled variances can be used in the standardization. The pooled variance $s^2_P$ can be computed as follows: $$s^2_P = \frac{\sum^G_{g=1}(n_g - 1)s^2_g}{\sum^G_{g=1}(n_g - 1)},$$ \noindent where $g$ represents the index of groups, $G$ is the number of groups, $s^2_g$ represents the variance of Group $g$, and $n_g$ is the Group $g$ size. If the variances are not assumed to be equal across groups, I recommend to pick a reference (baseline) group for the standardization. In the following sections, I will show how effect sizes are defined in each type of partial invariance testing. \section{Factor Loading} Let $\lambda_{ijg}$ be the unstandardized factor loading of Item $i$ from Factor $j$ in Group $g$. A standardized factor loading $\lambda^*_{ijg}$ can be computed \citep{muthen1998}: $$\lambda^*_{ijg} = \lambda_{ijg}\cdot\frac{\psi_{jg}}{\sigma_{ig}},$$ \noindent where $\psi_{jg}$ is the standard deviation of Factor $j$ from Group $g$ and $\sigma_{ig}$ is the total standard deviation of Item $i$ from Group $g$. To quantify the difference in factor loadings between groups in standardized scale, the standard deviation in the standardization formula needs to be the same across groups. If Group A and Group B are compared, the standardized difference in factor loading is defined: $$\Delta\lambda^*_{ij} = (\lambda_{ijA} - \lambda_{ijB})\cdot\frac{\psi_{jP}}{\sigma_{iP}},$$ \noindent where $\psi_{jP}$ is the pooled standard deviation of Factor $j$ and $\sigma_{iP}$ is the pooled total standard deviation of Item $i$. If Group A is the reference group, $\psi_{jA}$ and $\sigma_{iA}$ can substitute $\psi_{jP}$ and $\sigma_{iP}$. Assume that standardized factor loadings are from congeneric measurement model, standardized factor loadings represent the correlation between items and factors. \cite{cohen1992} provide a guideline for interpreting the magnitude of the difference in correlations for independent groups. The correlations are transformed to Fisher's z transformation: $$q = \arctan\left(\lambda_{ijA}\cdot\frac{\psi_{jP}}{\sigma_{iP}}\right) - \arctan\left(\lambda_{ijB}\cdot\frac{\psi_{jP}}{\sigma_{iP}}\right)$$ Then, the $q$ values of .1, .3, and .5 are interpreted as small, medium, and large effect sizes. For continuous outcomes, the amount of mean differences implied by the factor loading difference given a factor score can be used as an effect size \citep{millsap2012}. Let $X_ijg$ be the observed score of Item $i$ loaded on Factor $j$ from Group $g$ and $W_{j}$ represents the score of Factor $j$. The expected value of the observed score differences between Group A and Group B is calculated as follows: $$E\left(X_{iA} - X_iB | W_j \right) = \left( \nu_{iA} - \nu_{iB} \right) + \left( \lambda_{ijA} - \lambda_{ijB} \right) \times W_{j}, $$ \noindent where $\nu_{ig}$ represents the intercept of Item $i$ in Group $g$. Let the values between $W_{jl}$ and $W_{jh}$ be the values of interest. We can find the expected difference in the observed scores under this range of the factor scores. \cite{millsap2012} proposed that, if the size of the expected difference is over the value of meaningful differences, the loading difference is not negligible. See their article for the discussion of the meaningful difference. Note that, in the \texttt{partialInvariance} function, $W_{jl}$ is calculated by (a) finding the factor scores representing a low \emph{z}-score (e.g., -2) from all groups and (b) selecting the lowest factor score across all groups. $W_{jh}$ is calculated by (a) finding the factor scores representing a high \emph{z}-score (e.g., 2) from all groups and (b) selecting the highest factor score across all groups. \section{Item Intercepts} Let $\nu_{ig}$ be the intercept of Item $i$ in Group $g$. A standardized intercept $\nu^*_{ig}$ is defined as follows \citep{muthen1998}: $$\nu^*_{ig} = \nu_{ig} / \sigma_{ig}.$$ Thus, the standardized difference between Groups A and B in item intercepts is defined: $$\Delta\nu^*_{i} = (\nu_{iA} - \nu_{iB}) / \sigma_{iP}.$$ Note that $\sigma_{iA}$ can substitute $\sigma_{iP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. The proportion of the intercept difference over the observed score difference may be used as an effect size \citep{millsap2012}: $$(\nu_{iA} - \nu_{iB}) / (M_{iA} - M_{iB}), $$ \noindent where $M_{ig}$ represents the observed mean of Item $i$ in Group $g$. \cite{millsap2012} noted that a relatively small proportion (e.g., less than 20\%) is ignorable. If the sign is negative or the value is over 1, the interpretation is doubtful. \section{Item Thresholds} Let $\tau_{cig}$ be the threshold categorizing between category $c$ and $c + 1$ for Item $i$ in Group $g$. Note that the maximum number of $c$ is the number of categories minus 1. Because thresholds are the location of the distribution underlying ordered categorical items (usually normal distribution), the location statistic can be standardized by dividing it by the standard deviation of the underlying distribution. The standardized threshold $\tau^*_{cig}$ is defined as follows: $$\tau^*_{cig} = \tau_{cig} / \sigma^u_{ig},$$ \noindent where $\sigma^u_{ig}$ is the standard deviation of the distribution underlying the categorical data for Item $i$ in Group $g$. In theta parameterization of categorical confirmatory factor analysis, $\sigma^u_{ig}$ may not be equal across groups. The standardized difference in thresholds between Group A and B needs the pooled standard deviation. The standardized difference in thresholds is defined: $$\Delta\tau^*_{ci} = (\tau_{ciA} - \tau_{ciB}) / \sigma^u_{iP}.$$ Note that $\sigma^u_{iA}$ can substitute $\sigma^u_{iP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. \section{Measurement Error Variances} Let $\theta_{ig}$ be the measurement error variance of Item $i$ in Group $g$. A standardized measurement error variance $\theta^*_{ig}$ is defined as follows \citep{muthen1998}: $$\theta^*_{ig} = \theta_{ig} / \sigma_{ig},$$ Thus, the standardized difference between Groups A and B in measurement error variances could be defined: $$\Delta\theta^*_{i} = (\theta_{iA} - \theta_{iB}) / \sigma_{iP}.$$ Note that $\sigma_{iA}$ can substitute $\sigma_{iP}$ if Group A is the reference group. However, there is no direct guideline to interpret the magnitude of the difference in measurement error variances according to Cohen (1992). A new standardized difference in measurement error variances is needed. Assume that $\sigma_{iP}$ is always greater than $\theta_{iA}$ and $\theta_{iB}$, which is usually correct, then $\theta_{iA} / \sigma_{iP}$ and $\theta_{iB} / \sigma_{iP}$ ranges between 0 and 1 similar to a proportion statistic. \cite{cohen1992} provided a guideline in interpreting the magnitude of the difference in proportions using arcsine transformation. The new index ($h$) is defined as follows: $$h = \sin^{-1}\sqrt{\frac{\theta_{iA}}{\sigma_{iP}}} - \sin^{-1}\sqrt{\frac{\theta_{iB}}{\sigma_{iP}}}.$$ Then, the $h$ values of .2, .5, and .8 are interpreted as small, medium, and large effect sizes. If items are continuous, the proportion of the error variance difference over the observed variance difference may be used as an effect size \citep{millsap2012}: $$(\theta_{iA} - \theta_{iB}) / (\sigma_{iA} - \sigma_{iB}). $$ \noindent If the sign is negative or the value is over 1, the interpretation is doubtful. \section{Factor Means} Let $\alpha_{jg}$ be the mean of Factor $j$ in Group $g$. A standardized factor mean $\alpha^*_{jg}$ is defined as follows \citep{muthen1998}: $$\alpha^*_{jg} = \alpha_{jg} / \psi_{jg}$$ Thus, the standardized difference between Groups A and B in factor means is defined: $$\Delta\alpha^*_{j} = (\alpha_{jA} - \alpha_{jB}) / \psi_{jP}.$$ Note that $\psi_{jA}$ can substitute $\psi_{jP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. \bibliographystyle{plainnat} \bibliography{partialInvariance} \end{document}semTools/data/0000755000176200001440000000000014006342740012770 5ustar liggesuserssemTools/data/exLong.rda0000644000176200001440000003351614006342740014724 0ustar liggesusers{?UqQfJd IjLIdΔY*D$D1D$!IuIf<㾟y?#,;[v,<5p8jH=;7"; w ;?YK vuDG{˿s3w\wcޱjnZ)h~ͪ-2##q^ZK7ZĊiGQ1_hõ`Ρo*. 3UR=J3zٔ ?c[J:gJǡx@7guY!Dil} y QQ]~#5NEK1-FHÌ:/Q+:Ïv:=t>*\WʇoIȓ>,;^}D f {uwҙ j4@lLu&sh2)'sϽȏtZ] ɬ'Х5HfJ,5>?k m~wcG<0Psu:.<#JrY?)fiꧣоŢr飾>tq{zbsTnEMGצj)0/vk^0teZ))/iϨFFu!:`.:=w"6xx=rʁ0IZʶ/ݳ4Z1\2äm36,nrq&XlEL-4&,#.܋g`tQ8bBexH0|jOQ+\G\91@;$B]Gjeq7gǪS$/ -r<9'=3Eڡ -gPu1fxlӬ,kBYi@٥;{;|ǥTa Ra^-O!*ȋr>lfrrw8m.ZN5Kk.~&DVfvw0Zic:w )Q=5\0~ZLgmia( ǧ?~ iKd(04T1rLNMR\o|^:>0/1\qh4&Sm%䡥,̭hrV'2:DŽ4HeB5.4ƸQ__ hfb BU;1M u/L9${l Pg[O@3fo IXfh@#{ʪ Me)BwAQK!Q^u<`UՊ9ysspAidBa@;H1 TR6\Sa.g.T/۹~3OG.CwWV%ۏ_5 =.bhW d@Ge>^=.^EF']sݾ 7AcMgr'r 3T-@KYGǰ5N^YL=L%vͅ2\A{z/|B &]hwUQs6Xd: LgP-M:)㳾D`޵[o< ]τCZ+[_H <?ˡytchaX$ _@daA6]ߏD9q^Dm~O"F̈ &jRn0}G~*B$eɷa E+ ly_j84HĻMp ]S*Pu {8p.Ѡ-d*D~! ;ċSH yثPV'>KPE#9E6d Tc6sxUDCcyk+hRiCUP3;|P|0Z>,UmS/5Lr;_Mg$ ^4|LW4I፶Pҙ/fXfaX '"қQQo9 ,J-;~E;CBS&Ƣ&ڦq ~s8:EPcӜԣ{F$tmeH@m8ᥒҮɂq=ӨVw)ϢS<7<_>z"8r$?7U\Z!шF#f}Cɵ:( cb|иfy0Q/'y9COԫq3 6y 6w o|u| s*4L!ftȠo f;5Ѳ&#Z(D1$6ʡS f4$W/: {wѠaUʝwLݸ,L]Z{ RO&F^~QJǾ -ePG ERAY@Zv9Lyil_GCbAJyhhްڢd7A gB?Oއ|҈6[7Ԩ V0ς *I^4ϭ?8BB~r7C Bw~1EW묐uwt+~=? g=>Zv"hQYv!Qݺ)L&C]bl<<3?1 Vvh ڟW.Ynzqjʷ]n0wlԩi).*;MN)a̻ĥ$eظ+Ȭ\2\o |`*7A_rNJ`1չ 0xWc *V;+2t%m0d& \caP[zPA(䅍S2VB4uY Uǃ%1h2{ZX9baJ*Ku$b7?r\聉?.{)Un*Ætb@! 10o0~J~9g1\ -G%q{i Du Pd̆.rVV=\a0dK74`Yzz9싄rF$L}X<!heOM)7ڗH0ʞٓc`F4Ry -t|4x-˒+ݡ$? 6 L~+я5=GXaP}``lcGIOVkVeg0o3w~~~NsPX 4Gb[ h*<ަuݏ1Wb(sҔRCΫ(gm\X<ԙl[kbcB`JCcx (O/\OA<;:huMagug2T-4k4zGr.K6H[ 0+)X&fF>1An쁜{2 6ƆvU P'5 u'{׾y=z\0{Su l58T[]yDTX`.tao':v5Hq܋.dX)}v%"&'RyBՊۘ=\a">Bƹ{U0|ؐa蹼x|dԍva|>!Ubt9X ㎬u^FSZocĚzrb,s$g`I`HCe?/В!hs U <򿈇[g`;ԹrRL/}0h^>:S/,U(SE)􈸻wk3&E[+~C'"`*`̛8?ElPmP@>+X<%S \A)4@i|U%+ zYsUZ%-,}K0{q}Fp4ucXg =DC9mÐKgS@/\l]6 *5`ⅵxl4Jӭ-9z.(| t=x -wH%K9ܨ|i8I3+ˠvPx!)drUDbZǻ`H:,,ľ,m<8~UtZe?Y\C&.JeS2\b3颪;lBԠ ^l*1<'>J*[9!Cч8R#YQJ\?[{L/H||_Nh^*yez7 T305' Qu%&UKә5aWijB}١}U >9'"Hk"]~Gxoh1aX+Kx_XĦT\9qjc: 閥~ 'cL8L:+B T^^)?Z^ O+xduםPM( 6 R0Pwc&^>#~1"̵0Č\(m~z5VaGы }gM3[}/`G?A2Pɛrxr^u& |{V}at srͷgaXcMק@ѝ?;, .HSlj8mLS;k @H :^H7Cog0 )`+eݷtCկs>,lK4*Nح;xg:L?:̞l mOЦ9z\KCB'7>i:Yww'o8A!X3LnWB!uV+t(' +Mȩ?'<1\˚24Է\ 3",G7peڻ%j~D|E/kFϢ-N+7-h V{Q C Eo1أ(ͻ!3 aKVA 6fuSDDt f˥jݿgVa%-m DaXL8RzjЏHYR܅yI;Ըj<G^8qEͽ+~_L+{`$,}T ɛzt>BԳF(} %zq ĕo݈/,JVO}52:^DNuhbR%;<[Vcϭwp0B;p6 ',ta0]LOtDj̬N]??Z%x̏ZW^_ߺfSvK=kW-{UZ$Du]0L.ļ@?9IyĿ$-jQz{P8+h8݆SJ ŜRBvt* E7#V#`r5${Ejfrja6b8H/-Y仅 +hf,v^ ـeeP̵4a4'ivXs[mAM_ IPIv:u|d0swߴٷSq3z[(:i:V$έ( 镧/HQ Zb{GZʩsa{{`I%e*t~_W ׀Ur0dVTSAE`u[05W9HGP\5&}lqatBO4,3&@1GDaI.Qp=F5kOvԗ{cKJ_ u0Gh*s%Y@ kSIGz}6*LT ]w~Y{30hjW*myFbqm-yX VD|bwIa+ettaUp$X {kVCap83bU ]kR<֕@M& blOl~hjgAY#rLtYhMw2W=b'bPV]4Y(Gd1F1WdzbڏT9_uMy=kS-͓6Yu: d`D‰}1cnNW0k }Yp}]-T6}p:bӄi%q:cgn9 EvO킖*=267rC@vM)U2'CcȘYn3I-9UbTד”B,]aoH&Jw8Y-a\ &RZTp(*!T]Z mT%za}Gqd ÖŠ$h8Ra? B+5VBG>W=~6ߔLMFd3 V^&PNGJL+/`]L^uT ä캜Yg|/%PW\_I*;ڲuCɁ]h"z0FoE{k`D$' @;ђu Ý/@ _0Ic}ka+vЭ6z5jD=ڎmCM/m5-mŇ_=*#Q r,^nq+ y_n!ZS2}@aT=(&$J7`%g!U\W_,Ry32).tǯz4?zJK,zoGtpvBi#8hϽci9iz}|Q;g)VU:ϲEX 7 Q^$ŅwpEn0jFk`nGX :=\e^%x%Cۭ;ѧam mآgS4^)<\/TɊ>]];pڛ y%P?m@T:#^~^} T~FvN'Sz@CdNQۢ#n_pOak䠏VkX9btW*Ƶ19na4!4B7UxchbFt?°V,'|_O3sPe|yOHX4 dݷ"92ޑՍ.hS+;hf &%irp@k%Y9,ONn}ĕWo2{jB}kxiQ Z<5D "_`AN qժXjG#th&%X~=v鱝 DB{`9Ly:(ܶTEUVRӟF}'[?eQ/ qw/ LU]A$ [b4}+;+U@B0=9d V>$%'IF<$<*!r"V_X&z8|q LfZt(B1M`2M0%U",,o BŃ)b#gOo|_GaŠl0FUS0jZj忯 k'bwiKnl=0ptþH^ˇak4Ft 5~"Ys}Ine C4g91awG [0I}Flμ ˞e':1&1&LfPHiL`~艽׌po?q na{7}&Mb<Fm\X+۟vwX5%ڽQsM .IauX4X^esLywgs]} MŦ&F-9(rկXe-א~GupDc}hxwwUyx4fʽ0cTL9>iD$m>`l⺧.0"`[(l}AoDoGs^Bt5FlWh%ߒ9WΒuYybxpcn_u*_UL*-/]]. ,g(΃o)k8HiƒVrTr<Sݓ<cۧ$49_}w Ȃq47czDghcN B}g냯8@=>G OŪa$H_?U?y9oG L?w #dJEs*7`Oy>˖L^fD PI f0_nF0ɾ8D]vV|k'elB6ƨgѼ>> ~1up.O/NLm^] SM-R#Nsȼ^f~3Q ge3V Ɖ|Ї,cOJmM ArJ=E"\SFX e5U;**s~f*sg7גoy Q;sr&Zqp?^7 }D,y @ydci_̨>,)sGP_}>g8ar*aTJ I;67&1sWFh>OX>v]-~3 \ kPC*G8,G|@W}Wg8!K)4AF ʻԤÐхJq?PW^ Ðѫ"暃Hc~sqz@ZOu>}t*Lhj+xa "(]3?alReC `15O5v`4>;/@IO O%J'̵B`l,֮x8z+ɸ+qq `z͒j&eœ\J`^CY3F/8=7Iٿ`K˭ZlW!hYYJr7ՠ 2"24aaMꎮ̏ @'.[KC~P4ߡ7pR&h/z[zuX[k~J2?ǡ?<6X/dVrgC;i;F-L L zO_WsFvًf6^ʡժ<^"͍`=螺2,_vѳÆPEƙv u91 h",4:bRC0az^yGc}"[r-8~Z7Y*5Bg1z2~p 圿. ^f,yG7ݳ%?砝3eMX 9NtAu|5(avaARpAdxF|W8Xbt(lGd@$Yd*Ia-NoU|Lw;ʺ(71cH eoќ}`uvUýj(Ѐ[f40|Ԡ65pյFc~f_NMWƢ0} s_`31ԡX w0XhLټLlΦ`B;9Ao9伏 \M^<9#|sUc[C{z wUX EPLvSI M/kHB>Kgo2]J 'cal#; 6={c%O~1h9{| +38`95\5鹲O&vc;}goXcxϐ0(kLyOV`u0Fk!p1o,`E^bJ)hXRUiJ)jlsJmJT yKš|w#k_55pcz`4qx' } υnhBꇧN8Nϰ\b&{6O%sE4P|Ž8a]YfCE>L͎F^lhph }V;alE̽e< W.Yq\4@k"aDdO@7 m(Lq~/rXҋ*TEoo?bl_"ʣA @VXL[003'@FL+bIe9#tO$ [;|15}[M$c+# 7Z }W0\ ,̊s |X'0r2Kxfl5~4(Ԃ"Ű\1#@l[K"ABg6`vZcFe@qL;ag+(uG%2rǨ_.Ӄu. MYV éLvAW3T1衏0tOkrUd)lE~L)aϪ잯}3mᶽſ$ZNǗ7'\-Fb-ŜcN=$5a7zY2v-a3Z-/=semTools/data/dat3way.rda0000644000176200001440000026523514006342740015051 0ustar liggesusersw8Ǐ="$Q* *r?JH4DHҒJ(J%BK2ʌP_!c{~~y]\zs 4M9M8) #gi!3 ±vfukﭧPd:q'O8I Vm5O"ayL^)u9#!7'~+`jZW8d2sС?qkiF =s|V1;y-xJ\m0K鞨o@EXS5h4ъm^`Gzh0>BnE`s0O0f$/-?& .ḸsKXn$(2<\8o@ W>>ˍw(o`gƢ83{~aUKrߎق]|y_az8˷~}Pl, ~ͷ [pjr#,{^g<)a7pqiN'hfs}{i'L%jQ6h}v"gZ<;kqCv^OC =cZ |[-T& V/wol{;b_ˠ}®|"};UG5iR3(\zU'jwWN`γiHV^E 637^؜T-+ҟpoi `U2;qff\]#KV^j#K+zv*q=߷VB}#d |;:KGqzcp= }>;NWWFcw4'7DcH1(2 &? #ո8Vq6gAHM\Ʌ^> O%tS8#uDJZcW# k{@u1"p]ֿٯXCS?A>Nw?'q{#*k7)e {:|y>[K*VF]m[e־GAVdT~..)oՃ>D(Y>.T9v4*8E0R[XI [&{HVVoN0h6xnr]{S~fqUOo N½Vd?^ M뷎LXחaEHKtiMtq1.Ӕpl軃2mg*5 ZlKh[ ޻ ^Xq^#fRTaxϟW@49+h!?@FK^K#W`qf[L#?C|24.+BH۩hGRR~`Jl@~q)}INiFjίa]i^|miqk>x*.+%9+ OP0@1tt>\'H&s z"_5Z>zPh/ UpGyU`9ɏЛsY92\THj8T zT(덝1 ~Bߓz:%[<܎n q[.߸!Y,OTERMz텲iҶ$z4Ne'1”ʫ* 6Xks{|CC X}OHe '1BZ"`=o1% adV_㮬ݖw[[v]yk v>#8,W+-&e9P+:(@E'>X%][êeh(~ZpT։-ep22bO 63)qi 'q5fL´ zv!MN ߰ri*ɔ?ؾo 0G&iLP})W`<B8vx13¿")BYwofn@ |q`Wc`ߕ18ţh6=WlhYxS$-lԹؗRy74^3&L8v&i[,ʻu=赓v9 U}s,;vlSGTms( V?}YmTa|I1b 0r|gj+wTp`ekX-֧EN.`n68y]Ra اf7a7ncw sy;RTE8Cϕ!Ū"Ex'+&N K᰻g䇞c-CMeZ8'))KW?l_TsIg%t7RInt%>ꫝMnLԟuVy2S\㳚7ުrAVfN' U ~@vRdƩ+^݇ =Žm ]SoLrTrI,;s+jKĒu~%7CF5=e5'`upZ>9ݶ.F&Z%EmIiDZ{^Vs &O5&'a3UkݬL0r;?|2ͿR׮30{@yՒsUgZ u+/3C˂v3b[u;\AjX~IRIh`q(S\|VQ.FطLnnNCV%h9"liDP߀!t#ʮ8[v`c)h^{)H y5S%"5Nz 7b ɲ[.qN5;6ׅGƌ߂Iƪ>8k>pE ̫,/QU vOWȱ?W^=⒬Xb|Àu:b3!u8{l Bi "M/ca9vN7N3̟ن?|sAu 鞟00jJܥwFr<ر/Ès]j[EȩB{@۰6U82y6BQ8q,*Us*܂Zbplǹ~=0d $N&²BvZ/f+Cx`MN=HA큧=rzDK!l6Ɉ/,aA= 64t> ~lY7`R9>,=A:05ݯ;0_膩ˤDպ6mȾ0C, |bL{3Wiw)0`q:T'C@'vW;p`_p^FJ ԍ=5 v8ccuՉD[qw9k7CIcgye ctjXL0Ue%Xt`V Ίt}NdwIf.'QD#iy2!=&_HAw'B`$M9܎Cۄ.p6y6wvgF!CQڜq2/hEXI[9at&OIE8ea1`ύXm6vk$s_y S[~_%q_{tΣMN$7O6]WY*Z~f:xYS&$@Y( XsVNj |a\F3#qHԚ3) )K`#js3G'tKyX1YkyR\IZ ;EBT,=m};NiuKъG-֓sd:c;=apkve0)pܗs ㅉ7b@GOVۛ0P  *_h5fɺۊ88q^ SQCk:Fؕ]qm15uC[io ֏Ό9a4rC3aΠzX(KժԷq[O}[Ka?gwyN3$鋻ÕFIӴ t"<6f.d`"/bҏ*b3/>0}'\:ޯ C{spᒦ%4l'IRy([˜zaCq̗Vt5u&Fm!JxpݽST~º@ E UFH=6݅T3 qC??jÿYtOnNêb3C/jBXSiY%Pߔ?gSErK=7 n=j'̇ygW8jZ*1]exÉ6]N>kT#6_= l9cI9تJkFŹˑرUqnxjY;ʇ>JaɄqٗoH6N_J+&QJ02UD$[U$:n\X/+W~ [p%%q{42bqr{8X( >o='`'lgIgfޚ{hBƫݳ9<v !6Lá"hkHvJ ̩z/_y[#˂Hh=ŋ uLygZ\$W/9z,Vc\!30}Od#N;;A>' X6ov '-hU>XZ=1-;1d#rb#mncYR8=YT%frhWA}Uɼ&μJrX?M"ϛ`WQb'PpbόA"D~=my' 7$I'M|8msehQkߐH/c*Azls\ڪ}C4{aAAT,?$cV,[N8}qNEI\u5I6ՙe@eu\mEp1[uHT:sB!O׮OV^(?\}LPeMԢshLl>&sɆu‘4f}d}/4D͚FgbpZy/аnfTz6Lo.) >M>S#R"^4X~zt)X֐7GQ[[qt䉞jSgU4Zʿ[) L ]x .tO7r_.eً8;4n q@[H;y6m|J2kZyl ?lpΒo4#Nd^@l{[ T1/qW}N0Uɨ ,ڤb謘+ 6%LZrBv̱D|t>8^enLDadom61'`}C;ia0{M[DVpV{`V\T993WSwjԛ@$?Jz7f3̑eE?.ϥ5Q tŪ~jEe/; |f#VBũPQy*LDZ^2q=H-;)V4ÊSpr[2oűJ^8|ȎjOx=ZN/ħ2 5{P*?:v'0dIIPY'utsp dX[@`*-l0է uκМUokhL2e~F*x=W m4`UYoXN NǥS7K%eN'B9pηFޤ5&S)A.yt"L}Mq4ۖ"a5 n+1G3 vaERo$ǵri Ҿdtt]'.-Q1][?j,1 /kN,?,FiUzQ!u;X[4/\S,\}kt8T7LG;q&)O {m|+.lʡP^|F(훀88#*)3a}-??V59pD8nT =]>dl\JDžќ83В1B-^ګSG6llx10>UCMޥ 7n7?]]2Fau ~8OIWù-w5bXq֯F\cŹ/F0K [ Ƹnc.Nh )ܕn 8bfXHGfsOI6DU%Cc5\s 94WO bJ@e =L)= 7#)dĴHÐd5WLg5ޏ2?{Z Fj K.=*1ͧpsTTqʵgBULg̟ZMA X"h?]yi,~ .Uk9(`w~r +.)k yJYؓkRPʔE n2g11DIWu8~q%-eÊ^xOu`nFv )V7Cw7lꗇ`]tl7鹅d8t']uK׸Qh.B""`ŃaKC2 Ӊ ت26jc%&?ns'Owz.[٢wEKq;5J'ۥ"6A7{mya/V&AyUgn[aݟ)m.Hh>5x_'LPVy3ҡXsԣ{;\STgud._cYxTݸ?Gdqc_HєşgcwV2{ᣝ[uk- y0bjR'FοեױKhzN8G &37UmJY8L#Mayƈuuwpw|6]J#гPz?Dk̭\6Z<[Zq=gUDŽ}ϯ_3WȡB%Q*φʽ K)@yy+.ӻIsNļ({]6x40 $GwaW3'.|? ]b@ݣ3R05iR;vbGJ \&,(zBo0]~oW702_qWZ j]!g|a;NB U@M?J{.aNRutl6.I2%a%<}:[k&3n>Q6 ]8KTA1.LvALk$,yqfzRmˑ ny苷 jѕQ캫 VVt~H4QJ/wEʭI 0]$V^OR~ Y_Zq"`z-q%OwvB~ڿ͙ryf=+;6<5?DR,NLn}-n ufI"RK>~`m_C.~<阇'JIƑ#8ОzHhL5R. jN'MϓطN)1t8q#vcSgYV=[Uqj >htp<&M+Jwo?l 1G5M<-٤}=ViaL~59: 4ҺAs3V(UFX`Nf,i{w`֧=[1 kqxLmi!XC+|zMßCVL ;I&I!IQGrFb )vXzw7,]"}̂' ?>]Lϵ==q¸{Iirc6t Ybn{׸xHٶv.GK}fR& rudTZq)XaewL}IبG%׍,Ҥx53@^j4*{ݸ]o96Nq$sJ]7I]U a@IT)Nn.jǦԞ\2ե-QOLF(8׸`2>cSn V or 7לz)BC;d[|1Fi 4@ܹ)E<7} nxV [NrT/w‚fY>/ۣxlS!< UTM皫a8lpa>.,m?,l. 6@Pf?d޵56J?D`;ehGZu-q8*q(x\^ٜ3ԘB[=ׇ&]paAo9^qiC Év%h~[N[Ņ'sː֛?_:nqk _/8=MLgg߆Aa60Tj MzK9~$C%39_ q6"?5o̫;v>aOpA= 㿝3' 걯36/plHw$ӓ墓oV4p+O8v݁qrBPxlfw8ME6Pig`.^awېfbu-v%x|ֵy,'}~Jš]8ߖ; u׊-Eï9B{{􇹋l07$kIiz~3s2Awv=cϞ=6:; ƣ솯˱j/}ͧd>` ɼo"c jnY9D:gt "-ˮZE-jz%ۿ[a?äkV菛qa$,~;&j`aÒ=hH:'V{U1d >e$ &$ gqMh\A$o ǾO!mOze=۬> #\ݲywRYt0qoe-9u=[Y, J@\ݸ/Ьf[(tn%YM)/gǒ_jBNAVK#]\n|Kr7 jNb]7mC/[a@ƺO02pRlO+m]>uhuo$ [LuBv(뻛eű/1><-;x \Aꖐ890wԢkYɽ'c_/T^@{f&k //8~{`©k{:aThXα"L2Ʉ3&넡cMq+>3 =gF vL hLZ /v8NiJ^" 16bϛ&5xuPi:W:Y`ao>_0Y3mre&X:JB'q Mpd]?goϕV3=ZtjIIl*}_ gX?6`4zͼG,]/υ # /jPqvzr=y#Ry=ޑH}ɘPdT|6ͳg>z@~1d/dGiBntܰKi 2R`LEgLD_pxۛ/XhصRdw8wɚj{k &YW/ >}R#@ꬄ)],;8Ur[ cl}rgs]X>P*N;E#xs[cjJ XmMPЅŰ]8q2f>*-_X`2N\AAz)(ߙA8 afÛDlk o=Ќ#O1^pKٞGܻû fW2aq˫zw|xKg-_. H VC1Kw8+D =TQi[yd"gX~O,bCP|sx/: LFBmxʼnOr0?iw"rC10.u؇~^>a2ɤ^W[RÙ'b82nl? :6s=ʇ%IIv!\mݝ2fHl.M{} ڋΦ78f*z\8N}{,8. m_PB oQEa,]"0p]n{W8.U\ $sYY0<: o1j}*5l)L@՘q{MLgz}&!_C ;#4aU5ɜo zɜ֖;=Nȫ&B7?KuwW x딺B]e9 mU^D SO|0juh`O3٬qaS+?'tVkw;-C3-Rbɱ.U*3y_a7X>D]r~/V|V]ЌХAIaO2>֒JЩ'%xt=Btl\Px^Zj 7ܿ;aUoA#[Pҵ׃u<ԿKdm>,zU -yO)'=ӶS`x\+h_>)Zǀ?t ɠ?"gc"Vb-VS9Oq(xwxWs髴55޹w*_Zư_1y`ZZ Tn)0p|A+txae(I|ޚf8 AM_B6v[VupyCp*w0tRZ\K+[,FPdË.$obyS#ጲ# s~L^;<~bf s\O4`gs\?qh-Yf8sgU&F~@͵9@N__w=ڰ.5jeCk%2hJJðFɊʇm_e< =@eˀw ?)bg{*G/Nn&~|ٓ*cBdPp^~c;T|TxV,ێhү ZasƇz+U& 5lz_Ns$#\܎QDí%Hh6Tw[a)h}WfIHR 9 OeY{׷-|]r*bم-'ّ zWph8navKPk<9V;f}Q8~bO0ءoc$=llUNUToiLӶd*tzK~I ,63{ȵ8UtR]r-\cazJ엍oye"cjh~|/}{1 $͏§HxI/R*3QXiˋ)%TAYZG Hld/[ ']y{-_-,)|u zB߈ J[4jm5@0.ӑo:&8̚To$GԎп$v> +VNzM'aUxMa#\O\Y$z6$o6RH,jk>P%y~`Sp_MzUCJpAuCaCXs#T;pI'+#|c/#{0[׊ᄖNRT2Ą-;Ll]~IXyg4Bl^иo]h:PY'%Yw%ھ]^ 'B:TIΰo\B8Zl3Wg}7Pj<&U@$<Ij+J {A[9Ua{ zv7':.@L܎^Yg2Ҹ Y?KMo^gcɅU ˼8Ǭ쀬0Z{a(4/^*3]&F Mguvgu)űdV7|eIBRr%!1;YCSq)SNX 0n2x7djڞreNaLp.1l o+*\83_&ҫzYG~Ex&pl7Y*"")'< |?g?$5HNAE*9vTBE hnuΦQ^BLy+]ܽ"\բu׋O:AgQPg9!RVӝ^XfTC~N17KI{dJXm|}/J$NY._?#`Z0u.V>^3o=N&)7NeLhʘ3eth:vi/ xNq+v$pȅϑ6b!jrϽ@c8x͖u𗑄|rק ǿ8w~)tc]D`j, 8{hAdxNdx`kq1n3f*IÁ}ޖЩU(6S%k~ xs7Uޖi-/֕ Ǫ7]̀o < Tn`X^ݳPdhqql3fe,* ҊS'nbQKif~3L5=ZZœv< v P^+vD`a5L1e ]/O2yPy>4w43<pMMB.ɵ|hs `_R]gkS+.o G/U+gw B;иiF$wRdw0`ہr0~IZ3Mg=EPyG]x)?: +ٖ06Q{)3р4z93ν- K!3>ksSJ cJcL6zHy?\ӷCLWfo8 #]>y; tZPxc>癵u ;zt2o YtsbHv/(3sV?;'ެ3fyDdʛAXfl?RlBk0Ycr;v\kgYbwE<x4u3I/JH̟ ;ퟫKkRd71gHT{ לp9 !7%/F,f9QFYi:t"׹I6ZC-9Nw-Y~q}ZNxXs)y-@>s~΍8Q&v)okV%Jho(Eǩ!8x)'eM T,{3V@ ~_[g=12?qXmYcH2ŗ &rS=MV%q9N[yNlHV6K,fyl$F?P̹w0~7s\/#۲]܍{Np_8 7.ȂA5>rXz;_o*FeǛގU2!MWPtsT%<?bzK PɽGTcQqCXBhYL}9wopsGtl%΍e @[AAX{ʩ7;d٠ e%Pi([z$[DI)v+ϋ+.\r (rq' yu8= >Uqi(%(c6[x?G 76C|>Ϋz{zr,l[F1 :Ow &˒5>M)a0GT5Dq~m VkGܝDe6Ől$oMoS27bӱw.G\3kǻ~0}?g,Z} M=_X`AbxA"Gu?{6|Ū80v\Mvqx9T8p&?d1D5{ G3WTg,*j5WO8;]񝂝ָMjn!fwlu=QC%]J`VUv_35I#p9 ocoYW Kck$kE gȌbpe&l7 pۏE֚cf0.h5[wfapc[AA_]:8L•"pgoVy M,Xfpշza! D V{[j+Avs0'|+:@Rɧ sztZlw<::Nyu*y] X`B~ l ~"n 'uEL9 Wݎ QN/o_7_Bq)4v|$%6{_~${lzbzcyRG;lgڨ8| ~\]".aL8vu1eGGHTD7c敯P@h JYS CZL>8eFzgGoVcy ^HU#n_dWB{Ÿ+{`}mSi&N 3KVŅkH^qwmݘY?s޷*;~eISvEaGMZ8*q>f\ZܜM ;Hmؿ`Gvǯ*^V.TS"(۔\bo*n ZY PfR8}kW1GY`_f!IʻZ,ou!yW!xhsޏn[S1I4qsN!FL]ݽ 5!U˴twNE3yU~ߞ8k[Le.iX`98S'g/tbYE7*i*0T+{Ľ@6v#xg<22vƓ#/,"DD&xIg{ ŝz0=pC1.~yk8&>ɦVqE/,]l> ?/n΁60è}{Iy{ L8ZKTEH6k~Qfb49̈[qnSIb<(,=ָG~?vNC 5Ԑ'a^={o J5Ӯi '`"e3vL?~X/<:K4C{g Ð ŞzڳKT» 0yaRqij8rfG?1VK xA kݥd5h:5-f27^1&9o ;zL };e(#- gd\=IC0] 2{"يIỰyXY&Yɛ2GbyMdr^p G0Gio'mS}5;ǁvuug=ۄs } m\.˜`0ze㘥=>Ss]m-+ g EF1;·$a˷瘀QWS",cpثKp\xO VD*]R( swn0pIW ]t@+w!mNFl_=bT}EO,eԆp63)ױ9 7E5c|O?e[l+94Dױǧ-썯|ӥBiu96uBB, U2f.0v X?5qiAyw3h.GFɆ5|"OOC7/ҋa^2']lޱÞAʐɐU:Tz;p-\b$%L]]6yT$̈́9MumtX6v6+. 'HuͨRL֯0'b=2fop;qzj}̯4% ε^&96$T`Aȯ݇ϔűkGjiσX)CoRS8@R*4&9 3O6vۓ4j%L{…fbgrG;\ͷA!Uo4׾&: 8uJZ@4#7aU 9BYu&X#ko4S|lZ bEWo`#W]YT=mw.yu_y+jnoIhj;` < oQ [-H~-.\Lاz6 [`뇽毰S=+`;Ŭkstۓr4hON|` -k^i g"+ۡ@\MSz{dh.ɔ^b=6*.="X$_@gỳןJ+gM g~4%/+{pj?*xz3gERz%W?|W~LOa[dcY9 4cÄzx{[}{pX)gDRX31@YL'Xn,ut\~"sEgN]Vn0rW8cud==S* l7%6h;=]m 1~?Nobv#IW{_k_ɥ&o;E)ue%LEΕZp=93Ln| m;jH־ƽBp9\^i?,<>IZ`LeFj˽ >H:$CMR9K9ކx d4l:^yQ3CkKx=̿~kd;e p>JK>2u~-;5e$pf0,$ɛ6n; s? qZGgjُK\9_!ը`~I|!g qk4ڈӾ Nd.G-N=7& Eټ_`矍Vo`yRQ|ƈNI/챍QWJ& za[^}@3%jr`H GϦK\yt9ɼU*Ykէn@ӚO{ZKG:T;MؙnXy\"c +߫I&eK0jNk[Yr㊧΍NPyN blӶ0`or:=k0L૛/HW>r,LW_c&gNNUXW WSTCLhb2v!򇷰rPD6Hyۉf$as-A8Ȯvn1ѯּ}G_r%\SҙzJɿtatYn;E0ɨ&X!3s/HWucH- hY<|-z_Ȭ ,>@hDα0O0 3)L乹W M W| %^ l?^Vpr@E5ɤ4dZwR,pw˂(ܼ#;|t p"Jjm7L\{JyF0l=z45 HttO5b1U4`@̙ˮ,3ɏ{qQaBu;FžcZ J$.F`lp dc}yԏM,Aj,\>$SGE엻}WI$VTS7`.`=8gífC0)=IoyuV-T)I[T+7P\/)gf?#uꈋi:oqeL_?o밟_Ʈ~egIFm#WqNXmq 3:z0]Ă&4؝S_] )0bDpȘ1kkQ) KAR+TEx7J#ӂdP~1aNum֭fvTut6 ByǗB鶂, G4u`cA Nz$ =Auߐ[":6%&Zv`6#v9rH-.ʂdZ򙾅%44h~ czu Qx  *z%W>d3G}Bz}~G@R8M\Y$%JmXbfNݖ%!)m$ WH%lojRK)G8B`7? cѪRӵ^[̚gtdH UNN3h^>7YN^ĥ/1'Y9f}ׄ˶Z8*tAT3N|pu%g]ry߫,B1P|vK=N&xo%M'K.IjL8W`%) ޚ } soW,o=X[ھ)_deM O#B[yN_뵾t=z+c /]cq̜ح*X2mn<6=쾂R0ws|cA5{>q:8# V690Ė& p\AKiJh{Kh"\ k8M~v4Y:cBS@j%xb^Pd73N} ^gt@w+% `ߥ=}/mE X+:rv a# x1V&lTehq*-DŽdݰo7d8k~ʶ+uˆhgz't3<g>e;Cv&<`'VyȖ'sy.mY7n HZv<=ko:V(x0°B2_.lsc;{~g)Hzm^sC/)קBîo%`tWY6O^<` h i7㈇,sZ76 #wUaF eLP~:RIu5k6tV|^a.g?Ð1@EJDt,TYf8SzȶPf8XU][&YHBJq!fq#/zL+wZJ$HT*H I{>c'(G~6ps0tΨ_6vW Y؆|P!t9~N셮/e.IS|DVF: L(KQhfaDFfpo,qwvbhQ ^Џ2|D3Q`yLHE?OhK+s=q&\a:AWw+lOU6{N C殥nخNyc sB4R| i#MBvZL7^~ eX'R Fo?pW缿/ĺष @^2Y' rЩ$#~@* < ɻ~//GS,ROiqM;`eOCCj.=-͟~]yQ.(=V#ٳY$y}\ECpգc}–{.BnHዷ3dAX?*.5:WLHj -;n: >=厓Mރ8JxQ` ig‘fݱXN)_Q(ųL+ eSݫϣMJ!XwUC259qK[2 0v{.L4-PF֍,aW]_x}Xd/]JސN g6/®ҝf/bHg|J (~29Gⱐ+u@H .>Jy]SU]sά)WnvRIPs|%#p̴$&[qK\Yz+ {x:Zz pB \9qĴ66N-Z}9s*W3귿M ^xL.v)+-BgN]=O}fm<$!/AǏ WЭaΠ}"k,|NIysi!!+Q<ܷY8:sJpGJC#̼g員J^ҳlGSV8}0w%^Sƚ=60R[g5A;$!N6h z؇>1 :<+!Mپ$F5/]Z&%|85SĠ3P/TfuXNnpMNzwaSgE$ӣu 026T8k }%ž{* /loZ]?u B[۱&0-azdڐ etq^^͔: eB {:ob~=e yU$[4_&2og`TZc@~:FiX.0ɵùSu8a SOs|NV!/ﱏT$( ޷L]a8^h[0zC;sX/ɶu$3Rȵ o$8 ;m{FĦQ(tZvbIߎ I9 򷜲Z֔.CىDZVWJQŪz2wنB3 , }{NR"xEMW-E=C-L8ҡ&'=bc`" e&&eىGmPfþ W:ƔiaÝjmycS٦&\l_0xEWG9oP\?v9ʛV'J}bZnԪR*}j/<]Sޱ*~kʲ/{11kjU&$CL;aik@PZI×\cy*+ Ͼ6&芭=>Urn8fsL2E25t={ 5Y9ѩ[Kk'"uڄqvW3\.~17ƞ]$ӉvW`2wIqu5dv7Hzox|$(0^zPg2x2 `E==!OM["r 'w6 5X/k$4=;PUd.Y؇n>WԖ:1YUm#QqLJLo*L2$rJ8F^ {@hywYG>xth?灶d.uD :KdFKufs5뼣+9N~ԃ nڪν;(fx$RPoA!se#',%_܋ѭV\flK>OdspQNɠqia,[f ]"ծay8TƿWNAp+aݕm pSZ% _K¹G ,I1a&/PqK7a"}#:IYҲ-_jc-d5i⇫3u_/%)ӗ⹶z;4_G]E!viVgCAO*.ʶv[na፪yP䭲$vج\:du1q{&jLޜ]!0{vD(PFK;g KIPJKz;c/,3Niކ-GpcǓh(?&_ j3tV=6~h"{o0')-.ma5lDF._r;WR_B#3]YィJgJܰGvz9UgQ* R0S9.v}X0xZB՘} Ea.Yz;F*%Jz4VfU)aàJA A \8,yJsRG_HS<+JFQڲ/2 3om ݱJ'>3%58@3f0'6jUl8iПgvkl]9VرtQX %4r )YJP$7hLb9y)02>}sES8 ;gX|uTJի_BtௌPt;a0$i \dE{Gg Ljn@iʴ&.ȝ9UҪA0^a~ {To^j*Ll \jhna̗~yEkȂmT6R%} ?$wZMܳp37ea%|ZhiIBhQ0թ6O7a8V5s`*(c9Mp{lr>I2~Cω#>]p-gA -hnʠtlƉs$: m|?c>~% pH{~ :L=vILd=Lm׎IZg~z"7=;9.L*TI$iY-ThIQTBFFHe'{{>9y|sCEc'c; ROs_ҫb⧽(^a\P+xfc(PQS -/v>^m)8]+3U>]O?.ZA%|)\Ip&g)=a:|M>U;rns:,V9lJ׃jnReK2`^߅ s0a[=_a]~L*ּQvv^E6X3s-j|x8H1Hk1KO Y|F8d-)Wt.^FYV  0WΘ Z`22{dxrmu vI?Yd=,xsz} ؆Cۤ#Ȯ엙'6VBw 9J8@2ލfP?68C'+TK^67)_ 0_qתo~)Ň##~[ZtX'.U$6Ș熎rґ54 Gچc)#~]^쳻/ݤya\iX9c_kI X}8hdR ]FMO8SqkDZ=Iƛi iМiץ|$Ϋ|˫ȇESM#Rl*#+ 3XTD2jIg<6}ؤ~V7sv fJ]ngpj{2[+bt8\>js'ڛ+=a`kr<RY.wl#2ܶtV'ݷH}+\5E?@ "0yL|iZC576f#ώ:Eӑ65& mް#4ﳾ= t\χmt.A7A %*P%to<(cT/3vp.{vْ[aVCFE !#Xϱ UD>Cs\Sp 0i ye5=A ֝5r l!\ >™ޮc G);DL%]@mO9ߕ*^©x.9D 18@j^qX׉+<7>$ai`ǘoPpX ƒvԳwZؼK2Fs6IIO jxK=%]-Ce3̙Լ/¥}SQ`U;@rRxיLω r+n_o3#ɺˌCêC'Ba~*Eji(0PׇSʂ޳ib",SӦZX+8w2N1$o!gP5 sL{TaAMj3+wy5}O㤸zq''ؿ }Ǘd Ʊ;vű\u/9Cg5@Q +0g+6{(v6/MO}[.JHq6<\ɲ{Dos"ijf@.y9gR/WU>QgϘS{zH" ,/p[Yt7KsƯO,\h9b9U\87ef-:dmFrܦ%gco޺AQa\xz(~ts.iL:J0dh06|G5V'u!'b]M$ js' fI2P3di1 +v7.|'`8*'R7(}:`ڻ,lO'$&dKI28K_9/S738i |ΰ\wSuIq>zG`ӳ%݃s u5vDIFa2uGLW.M$&gHU*hEP޾ˌ!R ܫu ?R} mQRQG`zltC"ȹ]=hO'⊁{B?(Sit莤F HcJ)7}}:jC^zD>X؄^ZfOaPI7bc1Zf9Ǚj`)\aKrNK k"KpDF@_[Xv>eq 3ֶ;_x b;!S٬Y=,n=9Z^bcbNl.3aƥ$ݱX[&LI{fhټԙr@ -]u"9^yhP:ш4|ŧ>1,® fqu\=ʾS0:' 5f.@r'zzR[Ϯcַ\} ?߳6bNMӒ/b.ԍ)Ò#à԰&|_#42M ]{}H+s5\:"ZV/ !aVLjڂ SfvmBڳCq|1_Z,jtEp tؒnsصSdem\-wp6Bs-[(`n=yf T%du+106zK v\8EbMY~oVٱXȒtۉ@V&Ӓl'\zP@+"Pym9Xa/Α->e_C&#dNJI1]NrShT&V>N8%E2ś=qS['Urr_$O(}'SNpX9l]K~Γ{F0f,frs F Gn)5boC8iI};f']nVrzpȎ߹׵"&..Mٍ 7m؞&Ya͏i3dKa*tJ lC{ ̇>_q 0ݖ(MFR`n"CHag_ [& vT#/IJvYIp?MW܋ COB#BRlXx'"{/VŎ _'AGKje,0)&Xqr"6^W& kv@ޅL):aw]:,w`V~ⰬU\ص;&b;Tʾ/tulno^wRWZVJ?/у{Y.JDa{GrJ! "pv^+v(l黑{7OsFRZJnϕs0%Vb[r6T7wD`$ܙr\|9S>B/a!-{cP?]x,سAOېQ/ΊA/NgG`#*QL.<(ly|3*٥;Sh}M~%[s1ۥv7Kp3ʏ3ʫUaz|Ƞ/!;N_P )YnÎVֻJg,R?yk>Vc,9}IxC?:C?\1I;o>oqzv1Y%A+>:v5snJt%X<`|BRޞ(QGhPh/cd$Z$6o$Y㘣a\bQV v֮#7`ݗ4疰Mk\)KfXԊrI5iϺ+Ay RUnY@wXwh@j\s+]v^Ş`+ZW7Dxsշ|`=peС]oѭ1M G-ACL9T,i[T0ѝ0'N0w= 2#roPPݭ{JVS 黡u硥0xbn cʏX kREՈ Uѥ#հ{Gs%{uЛgY{CR`?|kw_^{2!X^1D K†٫-H<4DVB{WڽKgz"E~K9̬zTyB#ռWOaod-48LIw3NZl:.y'7&ƻq" _ݷt9LXB1~_H O.hiNq@ᎆ {ao@~? Sq7J4N}]ǝ[f޼<uz$KƳ0^F՚]V2Xu7Ti|A'pR󔯐oRY  UWƶfyc. 8x:boAc0߻wqfݠV;M7&ƧW?`7>7O睫SCc竸X=BEeر:;ԡ;wपZW W|Ut,ZxS|Bޡqϴ-R tD>Ϫ4ЄվLޚyϬ:&I.O!_o|kIr߲y)QGC}i8/qsV>̉=qRo:ӻ\U-h罰k赩 +VWp ⼽̹WʟC)?}^&fHLpnL?`ƾ1aÜjGy0 aՋ{?V_YfL`Mk6:2A&>wnmG8 -[ azVh)M2.,])rYs LK2.݉[|H VmDZquY!J6޸lQoԺ<^ 3>t]2V~y3 ~9QmJ|m)x Vk7*v%&/=ǎn1xgrJ\CxSl霒/M_w< )% կyj*!.<ЦR8-XZgbן仆Y3}Ǖ_޲ݖOW A7rX_ɨ,Pb0nS w X3y"W %a&v]&br\$9 ×p`>/҇hOOÇp*oė aO[k\ƞu)Vv|lkk㬕In;[6|}{4G]W(6aۭ#ҴQdzjκ ۸6v/Fӷ! &*x]B ٫LU\Ḻ@X3% 󖶽?܆JS~!8{eAuD&ɖ2qs\8Ї{C>kGMIS$#Cst*Jvi73v879OuN}䏘 .y?c6KGaxy19_`y`VzX|w9%TW/s /n\P<^aszpZo P _.2/H֓m>$/+nrasynuPzŠEj`7ϳw̖dJYyfw{^Џe3`sZ PQt'l3л,37NmI0y<&E6}5>' gE  ScT=)0BkJX ôE;$,d_c ;⠖k#HO>3Ov{cD&KṯO&qjmWsa ZΐPF <~P,td a:$#z\pU+JAeL{vF[FｍAFW5]j{8F&,q:Pjp]:mXZ38ZnNw=P ZF­ػSUղq5t%M`勿 \-|7Ir|I0tk֐/78Wg>U ?jZ.lJ|0%5 {"V,_!vp/Q.sGtޞYY٦mLO.m'Ygz[QE}zwT_|e ֋g-T޳*1kVePg?iXSyx}a'd1ƴ䫋p`_`3_+ MƶdI~}9b0i̓]{&F&z^@)z,?+;] ?V]߫XE9p#.՜I_߻ahl@x>b)'t.X 'MY á4M%[p gd%b8bM{ tʈO*f5fSU?>nFCl\P{M<5U然 WsU7 gi $7|?&",iu:{/bA`=z?8WgK 尹q} ob`´W270$e_'N/<;LsW:d6&z6U⌬xwgJܠ]1t)1 W>G1?T4 N=2 ae` ٌ. J,5cKl~I66BxU:CXۅ2FXT8ZIkԾmTp珍&}O^3-Ws]t)}! /OUBv"N>%n@=!n̍}g鏟l|>nD "&.tR}U٨/|8EP-B){p?s1ڴ-{/3 `.ѕ~3ǻ߮퓷! U0%K](=/]8"bK K1q&TH7Q$,<$&Kէ3NSƼ g87W#)@q~ip]8Xg r`6{'G#GapA:q|iKqVˑzO5l8zM9Lߕ"}p|w'0ߑ`yRS0i*iVTͧ5Wܐl0}5/tXVx|h ]ܔqzeʥ8Zr8XxI5uĆEӭ?/a>`vꒄ+r@¬$aIXܧ\iY#ޘpP [t`9,".m 5DeI`c6EC`>"Iά3MkJ5lgi[`epB8X~J_SpXts^ Hf=qaegZ3e6٘҇7_Cp`LȿHFiۓ4MXxj Sq , $cZޛ7q|UA1[CLN_on` >`0[Ŷٮ Th^w6R&T ٶ>Kv zhFYK\nTcqw3XymkF\wvI井B5Yy r۝"]^,A@ k&)Bo| Nxg iοQ=<$'\rR7aJY} 8O<]2ST?[M9׌oƥHjgwP:JkH)(N??Z#fK%nĻ/>>[gXa͍Ԇs0HͳZ=8."y.$fKXm/OR o<|'TnHDlݷ < |@tA} 5Lwө]HWm47棗q[g5K/@{\ꨕ{2G_/7y9q_?-nx[9(%HsrL X}cYE`pѫNcHL! {Ϙk[B}B\u;!~vh#u)@ۓt8ÉIJ9VVOJgQIEab69Zi N?6MI]K2ﮱaس ?CUOoȋ] M{7Ͷm[6F[^fȿޯGdDfp$a+mW5/tQ[p͋CǤ8W+&cRzLK_J6*T ա{$wG(P^ĩ;,mK$s&a,N^fglK=w Nn¥½Mn8}.\}.:r؄N%R:8!KCg4bWh+_WB,ZJHsFV0zW oRwZK3,$6hu.ǼFKH"iE+}g+;0y潆t-ڱL[ߓIX$,;pF{<ỳT7M6=.X8-P2Z'fG!US}^شKnw<bfZQ7wGq}Ea]XP8~8z < 5Zj S&0r/?pY0A9jc,NIA=ћM {j ~Bӟ]taCQsݦSEnh7x+QͶqCzq~JpXV@ڎlnox1wrγp,4|9M4`_ Kn 4.y TqDX;FdT/ gmt_S: JGXj44޶v1v9>)kvPo{ s PST1m6xƙ.o5Z6`QE2];C:1RO0:%CܻgM==/8G[Hlݷ󧜯Ua~xm.^y {e} +ϚE+{;w k|skk:tg,&Lm,c![Ba}7ͮgH> ]sK8VV@( ﻅl 5"|w`(t5m?4 TŠ~`r+s'6k7agum9~2KU]^YWz NOuJb&ָpBdUX&&/U BǒjZad~atdtu'?ޟ! JZ6^JW͎j0)MZo/&/Y~sW}9TZba0.ӊ/ w ,8)pc+YeH;m%4O1@PL0)opHw]FG ݮsqؿED(/ozc(Nt &UGb97&I.69tNݙ!A- =XT+^0{u@g5"u/2^43ObG\Xv`$V,odϮwԠDM}xUҙ2ɐ(ͫ jAu<|FabdW,T¾wxv`J,6Xp~T)[)默+үᜦlsVo 913/$^DhPѸz]9i#])@-R=HV\^y}LҫT mNGFqՍ1⋕VڭANa ,f$wl 688Mgp=1#ΒE]{8N)D?,>C6v K]@Sǡ:ԦWu8WJž.1RFSn`NJ',Y]ƿ?|OAUCbS #<]ma$Hi L :F&s|Wҫ6@O흓rmaA.3 0NCz l^А~ hlx-d!ncDup,K7/̜{_ KFyB[}.![Ty"{D}[q}mmX5/ C^3fu$oO0;~S/i=`;y \]8؞@0WN$/\-&׌~ŧ:)O0@mwL[}Qbu'`, t>]YFn, H{iKܭm革309ɷT|'Y^oQ!n|+dO?Xm/32n%"g0OXڣ*=5}#HiN0i\ޝTz%kB-k9=>p `u~$T\SOf$2/FLMn<O@OH޼q\Ъz3Q;ҏR!7?~"\֎_ZmY/qY!`h'7TֆAk3,؟vi>+Yk>h~H,Է9݂gՀ.m[{t=4k0  pCNy99 T{q,;lah.Hm;.+pd ʹFYRRscb}} O ꊃA3k[{Mj_5dêB#j3YGPE2~|eg;8]\S~dy|P탳BN*@MVМ)ީI2G2MCG~uς qrùTm1(.]յiMQ]T02?0OE+7.ۡߗ Cć{@ g0{c^]%]Pq4RrYиmգOGH i;{+GHm{zV&Xpm?S(+=S t1K$ڹ^\7<_?0S<^"-YiH5 ]cM,P'Siv(K})[rd/}3K_,K<Һ^@;n[]Q+$ 6:G%/g BI~0qrJR?mR 6`weSF{'Y pM6\6bTkc%m{[Zo}Koĩw$N_0\y]D- d=O$)&pZkzԋHlZnf~ y]4[d\x,8cyhRTi޿+W,q*>S9].FX>dV7D9cOiۯ]s8S na MP$vA*]hV8+~bǻCSkgcP^d8 '˝"Uf xumra݁+Tau/]%v$;`zcFvua^nԔ%iu#иQ̊9fӈJo[oBVկB0vcޜ_qt0eg[oR S-"|`IN๒ +j 2/v45f,;w%]ݔ`q`e'SI>qgA3M4bWYڛgʪ0fgs`r}%=չ7ݕ\N },50[dR,wL;R(K2AQ02Nv9+Ʈ7#5;]_Ժ-BDTBhz /Dp߇nLEA61tQXY2vi_QB…:Ys qud==5re:GBv\ǎ#{a.jwmxÐ=(f\ XOk>h,ʛu`65Ϛ>Hi+ö)װiRQ.5:f  XST]i̒ E` ͙;u\6嚑z`8o3nmJI4,Xlr]IMtp7qU5ڣHl@ i$ã•c{K]%>,σug/æ 0~X.&qFo e|9\??qvͳ$[\5Djc1jS2f~IM*P`.IyStE&|g!O%Ac~N,IПO۷6$BH|#B2/]&WK{-`[q mԩ#|Q?s#d 7 {wHcuszӝ'p%ްmr[>@ɉNAp k%vh*%kt~"$&j輤pGPd:RFU,?!kNHcwW "M_-U5Ur,z ªಓ`-VӼ_OQ"(ȓʖHR:oc#5>ذ=v/N b5M Nn9B²!2L~zyWdz5]xy-ym3~+r{,,l$qMĦm$ɮ@ް1Aw݉8[ᕱ2^M~ηIFp±{-wmWzָs"uTջpC*6[/4I.vlPW|S<6̓>&aZM4qn. ʌ0gsB$36vBm#H7n][$O,&^IE ޫ>lIuK<{*m9bq`44fJ &J&П_iu}WjA;?>TSU®UA=F۠o98Sχ'\S*׉J:đǵ8Q!# %pri9VzDP6 x=s%qyدwBa/$9afTy%[TӪG<ZoN).8ݪ[^1b6W'7qqӹPf{_X9Sm&aȃ+R^ }%nkAM^~} \YbsF^\eG"87ӏ͂D|qy!3xg{NmlY4o% &m iO* |X5޽5/̾9mƷ=&̅XQ vV@iFSs8].F_Z'[sɄީ'˫}X^e& #? ī{< tLa},w_a"$;yZp-ަ/H5_I6wnr>N$YHC4ë.Qn5E}@'7ƱV_X7_&XjFL\(P3NIT0ftuc#&'$vM㈃^5XKoI0Z>8xd YUpץ·fP9~,९ֻ)0K})M v"Y[,\ֻ8B!;@?vC&lzhW9)Gغz,RnŞg8)fUE%X*캜F5OiKPhSYCm;D!;>??q`=NL4-b\:$#$Ý1$qH|w̠7̖ݻÛ-G0~kl=. 5YRxCwE[;y_C+0޴#fҚ['[-\'mzwSoٝ-0MkFXbn+w7ȥl3f;G̛8e~^w^>r SVwoք-bHVv7s2yQ?7')o}vxZ=ڹAs bzܖ=Ýr„tbaBl <>&@cG=i!.ˌjw@f)z812rdXdkn6X$"(EWJݡYג}pl-]̂%J ߲ܸBзXwlj&XBŐO 2@YEkI#/C u(QKKvZ>'z h! }u=)DѰ5$͞Mw Nb3X8ԜiV6'^t({ϗKuςyvȇo}`N~usJNck7C\haTrı$ݴ XiF.[%k RY2,k`aRfop2˲׀yKx"O.H"?+컹7]8e' DnGO*D$[ Z" S3W7`eW` ]Y̵Z zpa9[C7.2pO4mWc?]^UK5?&X#T}\tC"k~W "-Gh{o{vS#ɰc>,(vK:M&lLs1V֦;]8M_s<fk͸=Iнqo?7c#fFCf+s<)gxM-.Lo g7) ☬tĻ+ohTzi)0z{JK]/DS8ag=goﾌ2tpojt 6ʹGxAU\"{ߎKTDz^niJ*2Iח;^!w/yR=#X4s5C 5qf}1yjԾ-8u̦fHa6_r7_qb]N|6Ɖaੵ<]F׻XsNq;n=r:k V۸<G91I;8ek}R'roUȐS?{4?$0@V赕$7`dž =Y;Λ<{KtV7;Wv> @=G0r Ъd4^DxeN|76_gT/ӏUf{'-j:+~~ # fTvEŃ=:,}b|%{:Oϟ-2N Ps;t+l͌TjC6jRzl:eMr1m* 4Ol aDg&R7^R^'>{o/<ʾ%h|eB9c,ϧW{ZIysH퀚MVUa_C`wppF 'GTqdƁطnHU>ƍ7Ԫᔙv+= efOyYf켘ּdب͔%ۀi|@2L\_ͩ;0W,9ldՈ{&MzaYA&ڳk;w ha|߇2$ `keqgH._QH2h$ &Ys0n7?fTIǂGaUJyX$AIuɢ]ߡ6QyRNy?T w,/x! 3VU>~t]U-@4*zL/2RG aB!= SG$R΃\#sl>5IF[I.,% Hc>tQ?9~ q^C)f~1(g~aGiorpMۼ]Fݏ_9qn 1k{+w̧UmTرnsF8X6f )׻ W=g{|: ƒL7 nSYaW˸CkKy~މ@54A0޹m7VS"ٖ%yK0/ 8W~1%,*}]1Y 3r˾PSux3 U%eŎ%b0١+ğuܻ8s6w`v\gW~O@mnr37ov7NJkE`¼&X:-)|@r)kR?!xW 1 &-m8mTEd'nё>BM0e3fر&9!'$Sl?U;\zLX {r=M=CX=~ԯxj>_zоmwqaM2H0;:|p{+yNlBHS /$ yjCIV${õu |ra=֭/y7gzʽ^)B`AO`@} .4O!`f /eI{>@Ρ /}e ΉV*Kg9ЛK ]>P5O=V^n VM,##`%Nr~;zolnK9qe4Ygf3:U`L>>~\jto؁-0+mˁ{s%% yffv[@ۃ}gZE:f[O efb~dEGX׋9nvʱ &JJP|Ew.D  ͡ZЧ&8MZz2^8IAےhmR5'cᣝ!Q8vHi:8mah/}Py7;`I>;Щ16:dj6Hj!`mBX~~DjS{}" {k0pfl ;bcm#s/a]?9X8W+l޽ԋ_g#L3~ZN҅0ƥJ5 _C{{}G|eo۩4Xٛ0t+)ץ| MإEWf7֑/B0׺.C2} m) N&<ySyRc[\|Cϫ`O ;|ҌYn>dܢ[ΈPUWm@X}D,=ĵDbIhW =4&o8WJ)\;8MD/s}5al7=q'HԲLEPq5N=CDnFZٿ,]0+2A彉kJb,e'j6yQ$H_vLZEaf׻j%3ݩFN!}T޽ g_}\;4{Y{xS~F[bq^OM8eibm6۪.`ey&|Ⱥti \<^ON |;kB?3r GN>}:jVܚ<ܲLk}}O 0Y>ɺo*t9);o&vHY1Ⱦ ,|`d@M̛#`40  v"ͬ{k8~9ھOi۹gzeNr 4_ J~1C0nr+X] NinhH` jXp>|Ea!tR}?LZ2~}F'?.VV]rqs{)6G=z!l-*B;J8v1:}xmWKnDdHw C[Faay' CX}mj-v>Pc}HlJjV!M0(*nv{vd)+fDy'K}Xņe/wn%Bbtd0q#u2Àa=9ws?̖(Rd 1/abe?y fbiX9cF"29>(G2:;N΂q/9.ޭ #˯:ƅb=kc=QLǪ]eYf(0ς-3$ vjo [G }SػH':z?VGx;|L*qթɪJ@Syl4g4& /pXIoj,r:K2o+y{ KܵqQW8MB񿯸hŪWKaVZ}AqYu U^Z-,>\;D"O{#O0=-.3%g^@ju*SIVn@wz7tppLT'Ъdpr㼃;(d܄ ̋b 27xC\@οogTo;oD45K)kk[/, Zn0`9 SY ZaW AxЍYۦ?ocofNm4F`]Wt,xzG@̿37 Nފߧ5 7gz@2۾M)c6'X o^סG}W'iH&GK{@0 K_Gݙ@Vb{p#vHY,n]-v{' a 7qKp./.>J~'}Z3[bQ1ҧ'WvX,jR#S^)c_rҘI  3ǜێj+ M`\>0 .~p, l;Z-7LcEz7fԠ3Mi l"F_qADžsES$%Iu d a #q*AXGr;HT~H* 5\FIDAo {C 'ʻ~߮)ǩۅ/>8,4.%|Âҵ03U/c3.8_sW]°Z›pn!s7LZ 7a4 j@#X:#!)lD0MD0qu}Ѕ礵 ?\Hq$#4S'.2aۺc35qD0r&А<\O34#qZ'~În8G> =㸀H`PѰyr->|/ P۫5lG'z\Z=iLOqK}&N:{g9 LG=kJ\aͥ[Q?~Qa`7wz gLq|,gC bLZrF8yqwZz:2o|"ZvɎ$e8{n7nRda?șm s.?b`TlXeȔ<;._AӠaahP_w${j9~錤X= {{"v | #J̢Oq~z\6:=_ywB"ҩzIAENuuh>#f]H9+0"׸뷚&V1k1ܲ'b[ӭ/w A{d9bdJPFl{Oq"g\IWž^{nT{dR"wtJ(t?t'kdlBԏĺ7nX}au]y_ sh+{{VyJ',O38yh,цr:XMQ΀! =w1ɤ+UύBT]2{(bPf (Ԣs./m!yX'O(Lz!gt-BŁg8 aG~ a\Tf!@6DX@}>)y5`%yl)QU5'^N2 zh/9 $cck9) XQhch/?e҆IbaL٢ã 3~wC/x |Y"x>｠+r jfCrPĆ5~aUz|>N࿫*[ʊD`ܨ9rTT):X8pr$4'H7N/ *kI"[.YQ&Y:>nm]azz''m>b/}8ʜg@0>1aa{C>, PbD9 } ZܓBn0a%g}]8p]݄; l=zsfXSlוبkR[ 4F㞈PW м\BRpWZ tWd@]{1vPG> \<ljSpv![v_m)/X{2:őWec37U &` Dhm\7ZvJ9u1U9\֛!('@RXGN< f'8z5EUX_"GVS,||I+NgCm` yWnW9yqӖ*R{qYsX}6+ R1Tؽ:kS3ڨE,mʲdoWʶб%q# 0ؽmBN"RrI{ڒ_4[OA(7G*${7"6!,F;9qZC8|ծg6R]:lOуЫ[ˈ+\aڿ̑O3֖yqwz|J &1: >tk}+YRޮw|9r0 C}Nۚ"35HƸ~W"agmS1|L w CKABB 1g$`$(0n= FE?A3PssbEQl.8s݋-K½#|ϯ[:8͚U5\' JDJoNG#f|U/ՊO)nW&$Qj`|sdzdv5O +mgw̰Bv*~džƘ_å+'X7Ij\DrQmYq/ l/8>v}Q\29ŝF,qU?}A2e;뤇vD9˨MX#Ep׍]C09c~ nSi+$é-gA.o x^WI"}ֻ[ROOC66|0FdkۊWq`n?<+d_sΟ#YLexe+tn }|gS? Þ[.l5[e,SaF%!)(`iCO>aKµ^~tρŃ%<0C$'V7v:d+?f{~!#z89.s_"N0[HJf=lٸ0 Mn@J[Ǖ,MOɌ{Oݦq \f! 7Z?=.ncSJXu.$Ξgp9|^%Յaxár>~ǂa}HT}{/ Mxt7cIwlq&!͉}Dέ`gw@~LjUܡCuĶIs ƦVӌƢڭ8}V{-o^$6^hj`0R"g5%3&a@x 6}$`N  ̟b5a-M0p c.h1n3#0tPT|?k3f]{my3e;ǽ_C۱,#i1!ǿBo{qIȝyQXb[z+.3\a1Q @;$xa#, um0 ]V0ev̹=aSaSF߳MTxT5dH"b~>$'j)X,.Paq(«;8&/ Kd;5OW Xks -g6=um?^:C>uRywpyʖwP}l??):y_MNM/[#*2~ Λ<Ӽi?oyNXp-Ep|~h~wK)S|o^nw (q:Ga~*V;ʼJNU.9?sZf%1[)mFen[by Y'i6O?#]WwP͌rIUk[v+ZݪWND=7C|)SfW](ݎ5?]y8Uo>֭l1g%vLSA:X<3']ӱ00l{r:_'fl)@|rf+_VN+qҖwɞM>%G#Jܦ!q:%6 G?hzpׂ߅]IuoXg {n\m# }ho†!p>x@)^7lƩq+$/ㄑx[m.S, Y9'izÚ-BʌW_ݺeTEu&DkXśx{uV&jFqA/Fvu31t3s\&!vfﻞmĚF qu9t<܋sNdTw&`LW< cm2WdX 7{_BvgO7f#`oav]8T.L q>΅PG1//~V8ŧS9dzxJKaĬKL͹M~m 7XU-""݁=fOPf %trr3?gu}Rp"Sn¹;LaaƬl[r hgr?W/x}90,X-K0|IJÔzh?7 ~NaHnT1Sjרvhm{*  1پvn!lȾa l *U8Z)GZWzĵg;}k9ϰZCM~r9hix>{^ p1V.hr?* /r.EvM eĚ[QPdhxUR?C}Eq3X0 ;X؁]+gX ȴV^h٧0KJՠVxEvO^vݖCeC^X%Tupi8}Cu{0%ELM>\cN#+Wi`IKnP䆿y$Y{6ϓ.-Yv^*',|1Nr*3@rlӒUsY($sJ/ߍg@99*/{D̆jl/`رJ)`^z"̞K{m/zLدcM^ByJbOVH9nrree*`Z>9GqRUx #)^Xq\I6S w ',pDTQ7jj.!^M:\mo{om!(7l{~z U@k`U]GaM"/Obů(9s00rIk˳0׻eHء|]$FiJ/JR(1Ɋ/ Q]qb]>ɡk5HgI(;ܴ׵Bocš #3ocW(`~MPHMs% $l$4EpHk+u5uؗcfn^5V4H vh-pt_{n{ÊÐ~܏5:0|N̽>q2gȬ /N wr7obkiwYm[u}k\ bn}[A4]OQ,b0e>RWD2J^og+K0%OR˩_gU*0_jԋ|cAO`hlun:\ If\cL8:e?.]t5R4.^Ji\`AzR7Ԯ~8(A)- Ƣg a m2 =O|d;۳g02kgvn,+qG $r^oرx `>`r'˭X _:҄?|j%-i`+ڱWő<%y&߲Ê<-Ϲm&8w?Nrj0V{2cOVݮ0$'[8?S]- pp,P~ @Vl5ge*?P jUqp2oI('9L9쌆VgK*Bhk9x`2ỵ*?~N`JKdHXa-C"8'|#mw:p=IyacitzͿheI! JCYPR$m" ]?2=O:Pdl3}w|.8J/㍬ڱ-EP43&t $U@*c}g[dY0n˒ieo/hVN{U]/D'Y-;^l ҖT%.AW%I(u9k/Fj"je߮A q6xZ)Me5h'+e1 5B]d8N06.vHn, h2CKU255[/S{D>"m Źnow2zX6I&^vi;8m4@s״Ԭ~V]E&h1كV~1/(z08TY:iWS;R L6,# ^lL!95EggDw+96p%WB֕Ey@0@{S-CqEVزH0q* }~>NkE`I^!5Nd9pశo/iEZ Z`D,]2No%N0>V s.3/qB@$n~9։q4a$wa%NkXFvU?wzN.bS79"k?( ~xgD9< ݀w3 K-R[qmmV@8dc[@RQt`~v@g4ۊ#vl=1GKت" 'G ʢtX6pǡC?Y%˟C1z_ ?tحΉNǹPbh (>19Xal*l7.ewgՀ2 lXnGjmߙ0Ԟ@!(hH+|w%6e4eVL}evjZSl{\ԙq0!X77Uv,}X\^ xUxPÀG5Iv970q}TzncOK) h NF{|(eks߄b3oUd%vܾװS ޚ\s>y.4Sdv#sn(OcΛJ9If<}6Gw qoH~f6[o2ڗMyaBla -K~1WT|^Ҫ>ۋKM!VɣPbOfZ 3|eu!8io_ֈS @IW) =PO@;bA2?V׭d`^9 Np۱JX;{gې̛Ao{,;a$r_{5Ŧ}4;7o<#Vy,ӫab.7r>L5Hk_HRSx)_0Lhgʮ7RAmiuӲk/h`Vq@xd-?~,`:I@B}'YmsGp$P(ւƫ+s:;зOxa(;muH5KO?UBcJ%{ z*y >? sZ^SBrg2I۬~9aoČMwwzI Aj+#Y&\yG2H-a2]Aeh6~޴u/u-f{ZI A7n/A NTv) Qh5tP-YXG5I]yIN{(=IҾ pdž3[oCgD85s|,|>[S5_T_{>i< QҨ;tk3 ,-dGMHeQgp<߉d eCL&LqF򌀾2R#/ɅZ9nyx2C`=z5}G.(W`yGVyv"S*znjE=E9\z_ /[ fUF_°ЙOҮ%X{"(6 ｗWۑ9W6 77 նofEN/;!|?Éa+8v4;jor_^0ah~ʱ91.aIH/}~)rxMh¹ux@l.$?'5]NCǟ`!Vg7Uh{Gn0޲`Hw@uSb'6uaʯ6H8r]p)!fd0 YB,csiv8~,`z?%9{J mN1d惾=^%?yq2s:jOàХ0Nݞ9B1&x&qn!R X[' .IWj`鿇'r,L)vzr 9r=mN4& jIKqAiIhrهB3񲍼'03 l|pZ LTKs)7~cMAW* vܭn оYnX 3 QVcK%FGԽxq,2Ph/hZa˥Kj w{$)pȦ<5VC'ReJ;1!Pv^'e` ,rǏSgFqPϮ?$ w|ն0RGpb%x Q}Vk`yHn?6"̧INítBs' )#z4~kyv sD=G1GUv]X~{Fv}ͻs5N1,W|˗ch/moޜ]ghi/>sΊ;YB-s$Ha뢱iXޗ8a[3o! ZaS.d(81;SN(>C-9kj fJ}THh޳=&T|ިj3j!6C4$2#(ޒEGHfVݶ8)keN2%,Ư{N y*9q_)hW8K>d"Maܛl0ۮ719S./} =~9aΧ~8{@w+]TB*#JORʄ6K @}KΰPx)%VaƩ $,q6-N!'ֺuЯ絲= x'(?zlyf0Ipd;H~, ~8]EGvߔ:kgǻqp?ϖcwdhEJ)Ls]oGDz 5zF|!%&yk?gyymYZ\qXFmf~ zMٷٙ5pNܓxt6\V/]8Xf}z\rL=xMF/3Sc@n!G(t<t0+buDɍd~ryݞT)$Cuvףϴ~'9'pƘv/R9ߟ&N):x _NNGwi!=r!4#5B%f_iҧB۴ƙSNC#7t*!bJ,飵U\%[1ǢZ+VÖḋ/L uToOȓGe6u voxكaեX,H0shJTA,TmUٷf[ޑ{\fs$gzV>\Tp5<*>43KLۣ7Z7B|ղh/LhOLU XYfSFw7K,8{r`$Vk` zG,H&X7k<[Lr+ŶέA/3I;[@ 6ԌdSoy3ӧϲz{ȅo΍;%q UiIS8{ V¼iۮ(+(ByZy}aD'8s]]H./FuŎV }wmuB67uJ#ɴj?a*rD!E ҖIC%HO̩Zt>ĹS_=_Gp l[m3 ,grʌ¤H~v,R_cVm` Jy~х^ yE1?&%6ؼzN7@$cYZ$c&F?jp뢑r{@ݍ6[k'j Ƽ5֤6sH[ ]lV144wZsKS}󺿵87og5;m6~ڷ_v0`PFmɼߋcsǡH1(RtUO=ˎPR,HOyCeqwY%*(LD[-H|.9 _*O0D ;tь/N?x;Vc+±R}Hr߹bpWrŕm->BCf i$ˆǃΜX˦_Op&p(\d/ohҏtt;q9 e0T6 绛u⤁JAV& ӌY*HWs8gLĎ~ɇ>${̵\KG |^V*e!3Ʋ?w WD]j'7GH7WZ;o\7ťqMc{W_*K$ꖻvW/k4/ DV֋  3OaO&웩2!Hx}1ǟHC9mF(;/XĶ6Aq[{Jaﭻs{BnG7L3)bg!.~'F~G0+v =?D{ '~|̷XTz"~FrRE~!1(i* 5vkw\5[j3GZ]_ĚbMklhrh$yׯ\B̩>ً Ű3/T3יP`$R(G[_W$υB!V cDqJ?-B%jsWjܷ7 $Zھ XfW(V\t}63aG fz 6! '~%kmр`~CII EÎl!ľkIP61‚NjSbJ_T)Ӣ4~Ƨ'T <2o-}6߂o=bEl:S 0 `!g:5roVvۇ+unV,j8 c5k弙ds:>P9Il(f1GRČTuGat4) oCφ]0AiBX61H2={k,nAOm~Rٲn@28S%EkӦ& ;`F+\%]8se2Bs`xia4''o=#!_aĦ2R[\pn%Hd:d]cyB/P)XTp3S/P2u ûЧ^S2od~ J@UrIĹg|8dG2_LJ}~Ag;ϯ?ָosl҉I*tJQ0^Ty'%G@6>':&A =fi4iNEԩH/[S@ ?{n/FZ5_8yz+0Y#J>3a٥v $FkI'g' }L7'D(hKϷ8DI+@yqX7 }e $˕} .=hDܒΆr{p ]fEM[Y\4wa%ɬ56jwݩ8-qȑainФ>nA= @!>KavE,l~ 7HQמxgyW613ɠ7 Ap𦞐yCRB~<ʁz;z[5^ H'*OX~gwm]>%5hH8݊z;/l:&I'gbQ)P$"L=|AODUrD"Alm9N |sJ^q}h`ȹubܱK5:lK\^f#YM Gx#b|3~±7`z{l}LB_“8"ɽXO ЋujūuJŽ,\հNni܊cNE#8sk`;l"Uzi!R0P,岋u>Z3A<`Kվ52߽Q3Tl3́u8%# 7Y<r;bvgM,e$a;]Zzf'e]Jʼn{eP }OhN3Pz_=?WC݁}{# +Um O|\B>p:{ ?\~o/j}aa Ϋi_]{I*pCi[fY҆dtmKS]v3r1 jFRvg#+IH?Ϫ0s4Gu2HǕ~0mo&)?ԘTDjHpMp8$ ! v)$ߚg5nڐh-:ĭ4 KOvv<)2Vʾ\cjsW]ީAaD {,'W"k i$z~> 4;-Nr LH>Najd> K$)ܾk";K`PwS5*ݼREo(M~VuNp>d9ؿ_Vn\.[S?0KmC q{N}іb1 ]m>K7n_seu:cynL0~MK&JqBîrSϛ0xlh$vN]sI C듛;x L 3ð^j\LI]l =t}MWQqQpd^e|5fQX0ws Bd%"6;ZW&G7L"YT*cR ~|T Gp,:&M~Dh'4No%W^ބ+Tc8;b #;="rn2C>uBUlDpݺn3.U 쓂E'̫`qEչvhn|4/#X7,n_Ͳ̫ YhʰhVQgdfT&ކc [y>` tw4@\H`3q?7Q0?H`C)W{)Iʃi  גC_0?I6mP!/&Uv__`?6e9)X W= Cgxh&{X~)1:{,)l|k.L͏\X$>['n.P'(z=0Z˕W2P%b6V0/ujX#Ƞ)d!(D8?T!43qK+Tw2Оvr<u8;gܢ?I U1K2dUiH,-ii)翳Pט` cK~A|"Y9A0[7SC>ݼCo`'_g߁^jSc- ?~\xA )ᶇ9H.pCRaJr;dJHGpdr^W ?+PĴ@2*[uWzy5Nh4&X[NpOo($9^L06fJžՙ;'C$ױ@kz^wF3; K:QGMO-6.r$ _xڵDޑlݭcsNe8\d[m$,9۹&B'.G U;N,\L]…}I+jIJ8񁢇@12 (0](_g<۴cİ5*7?18#ɧ'!U礭-Vy_ 3>|]ma7ayj-u]G)ء0|Or>7Nr EJrwW8TՅW%4DMFMܷ T4PYt#CՋ_^0rst_:)沊1+T:yŒfg|P{V;R"h2gfK+ ]sq[Y.Fa4hr(R~Or(/gIpn:'5MD4ڎk8slx⏱¢^B Dr_AFܹ;bߑ5-dPNWvb}U돓7k޺J2s,$8$Rɋڻ#kx{uEqvy1, 3lÁRUHF"H7{qھ*wcvw'A[#gOZv ,g~GH>I0,؂ݿO<"Y4kw~I$k78$*ݯi]GTK#NG3;C_o&q~_mrd0=wi` W5/\?& 4)z(>oMĚ~I .( HƃbB `uɔ8Ro#F{s;7co88+:ZZ8YsO,}쳒Tׁ3G#\He. R+^C YZgJpi4< A%c)u\i8rBv|g54S9 X}| ~2U=gӈߘsc'#'Y:{% aqsMe/E$Sm {&J2)Bk<UWqbP5D}me,&8& ٛt_ ؏=Oĩ+}\d*d-!A!̌ws|? 4ssӃh{ pobpnH TunÅZ5}~'w8$-8g9.;a@nT:G`7N> I zoXµ/2~L|cTAN>{eөVx=TA9l <1GlCɿiCo7*# sfQ-wnDЧPGix&)_Mf}."d}{ Vm0d TT0 7/XqvNw(s˰:Gm gLz#ϋÐPYh{mg֔3kX0*4J|pkuO}IU]NWCXP C9H3dx?dj+\>r&͒Oe!0f4 G\:v}ihϿu/X{'KlTչ은iju8AYOPJ_x~5XWn/NW')1  5S6o''ϊ "J< ϙq*yB0oo5 ;A/EσNpn+}:K!G:ڷ ک> 8Ȥ=;L?F=2oaf'潎 #ǭ$ )_ = SL[Z} ]*Hoz")s-A]S}_PfR,Q*-c]ϑrk m+:[XLQfXV>{}gau8}#;)SM%A:Z7lY1Oex \tjb` dmdi=$3 0Ano˴Z}_7P<]]#[ է/6L{6`㎯cͲ8KYpx4(Hpyb EOS}٫`ns+H8h S^nY3=s+^s_d+]4='\w">€R3k=}1׽ݶvgHJ-fT(۝OrΊ$Uw߮zH +֮?OpNy$RHvAbs~ެMcR9.i Гq'dJLig-Y;dN|7HIo!Q߸]?6f9Ҳ}.N-a0{7vo!-T M7uɳ^{`>̨?K aݢʃ[UnmKN+PdvPO\{{ OT3ԥ(R7w"8S6Dsͮ8͈,;=%4s]$[ӫoa\Hҝ֞$+0~2,igŹ;c/8o Ώ?& gz`ƪMIɬfִ%1&&7tNשuцmH+3Kl~Q&).j=I8zr7WBuX7zi'^x$b-Vt0 ǪFo:|# Uq]irZ9?mc͌$nO? 0GJ$3W⑵}VƲR$Μ~)!Mvpယ.9kyK7c~taB݈2K*wΤK1x bt,u^ֵ:CPvdyS$Ӎ5Fd!1]}` k3c_*q5r#N|c-NJq`|y)^A UqDd{ Ljr7n&/1pѮxC`e'rv TUB5GI1nRvMiW$qYxG% m?Es0W͋/SJ& #RΫdXPgXsŐ1֌+8NqU09`u=ci/bIzjKՆpN٫dy=ؽGs9Way47n47vSE)D*owJ%uW,_j|pAu5vxN-.o0K0r8 ޯ/LcsBO^%qŢmpu7A- ]1v<{~kiH[t j4`U;ǭFb;L2mfE#S0.6w| wvmPsR@keZ6NHSi煪yS]hmp=ରsmL "7[Bg94NUsHGK:e)ttS!0e+N{[at?YCJp/b*WhcRO/''A}nqiR0F2nDrR+]z]U/l&{Qk> ] T$;5ܵyZXI T*^B%}V>$% {I{ZLqd~Xft]\Y&L?J¾$v,Hu(gY+׸r?&|6^g4XHknn7zk5̗|z}zGǓ0 ={:]X!ݻIVS17& S]9~R䨋}mʞ?&9^Va'в!9Ye5;\PwE#x_ÁvCQW'I8'vgU iƐY\=eYhՖʛ]$zf տ< ;]Hskz!vl4TPO2 ^>rN=bQt9uخ^%'Bp5RPowm\ʇ HGKCĶIDŶQ*gɡCN0TUэc/":p+Vj3<|h( 21'vg32ؓJ/"9{ {XmuSZ)L?lܷ%l Ko#18?1U: ,q'u4٤i3Ώaco6Ynv;Hd]J|Xy.?xaFda2sԆT2;S^ܜ|Ru(˚N(m&vu\28g80ݩHr8r;rk~p}xB^Z^rN䱒Q#0Q*Ev9aiuv KAJ&lﱏxPtlZ1Ǟ3e) x^[WzލC@\@qץ~%P^4}=sb CQ) ÷|+Aڰٷ ,'<{gM?3uDjBwbU8 Ԉ. TUsmx A 4EUFJUlsΎ]}Ӛ ?%YD Q,Y@Mxxu T D{~)14PLf%RN1?D TP[9岵"Y.\yRǟ?P\a5{%\|;'/J_M| up>jP|mMm CM n;"~铭$N?US[) yI#x[ob+]/UMpk2|:S- I=KRB=OΩdRywìv=VG0﬇xwy揩Hv}1UA:t %7H8}?tO7'HLEk>y!Z"9&eIʞ,(ݭ6AoBÄr8)1cv["-{F/hmŮk?8 F/_n\ꡟElmpY`<U!dgnoŒj4035yٹTxҰ*LW$:ab~~ S@|ѓ>r#b?M<ZIEZ6mO̢&␇f=/=p.{KXyy^)8[ԆF՗ҽDJ~w?gQN54}'mN$Ht@Sh}OdBPgIʕ?֕ _ R>0aqI@vHӛչS'"UE=ؘSY7n&(4a;ITށM^ucp~_ qDɞD<~0,W_^n}KBG}|'<ԙrl׭>o9,k 5I`Tܫ_H78}J_㰩af3RX[2cRB~$P٪]l~P m2URyZV6͚oV"^/Ҏdе75z_IB㢍i K{cbV3dgؼw4H5Ov(.1 ?N)K%_N[B߿5*8UU(W5n]T= 88R8~3I &cQq[գW-\,(OuЦ}fnsi%aJP Ht쫋k=mj o//S$y' _c[Ew[` H`1ٱ5lX"jw HKl/TAd N0ZMWJ*L'qqKvX2ۈӉm8p &lgH%fʹbJ ig<ٸtmc$uwK#vaJY~/e)  ~r%* LZߐt:&BЄ`Ulњ/]ce^ZA|_z2ybb-Z*UVb+5%@_u5$ۛEx0嬛qx5?u δ8h KNi؏{ycۖ#3̚ |V=W`5]jŹk{;FqoY`iq~0?)vkd%^g)%\Тuऄλqy0t>SA',=8T/vٸ_O3N O>J$B^XZQV1 CGGu'1׷va;;߆ҳVEi) FVtv)ɂqR YY뿸-8HN/9zn/l؆CL|IVNKnG  I0(!}{vw?=`ݽF_\D>#& ]q7MԍOÈ.Nݔ릜ʜ$8<; {d`awX w<=~:bv"\J];O0SBRR؟SǟHhWdX¿L~ZuP ~]$w[*Lva~孃T(A}I2>.RXuںoMc}űcfjvRRj87 8٨]t(6+4虿F{BpPмmɡtM9&,c=U>qNWA!cN?6C3U{{L= Kx0ήCQ0~KSQ4 uGN 3` ˆXm'/ Cra)冬 Q80KK~ \|=h[[b{h} qnQm~n۶mR Ҋ [C/Uwʎހ jF~K7Vo"q/ԇVsY}Yd^ۢ)A2ٟ(S&@}'CKIHy%Ч+ 5fS+-H6O706epOW%@5$ /`.jB2y {\15d7 V{֯n¾R5/zo@ \V_/ŕ`wH˃AɁII0Uc=tJrQRpve-ح\ifxKIw3榲oݗ]^ 3Iǜ3aȱ/A!f߶ nLwG`UNm}0ͭxO.[n:?,3قC!Sl9 >;. ]3b^7²1SKJTwXuay/nB>HV4u~]jNW #[ESQLM;f'BJl\=DHG'X~sarxatĢ?{;쏒,ۯ^Q݉\g+2[\^S24L#8}LB5e'2jux8Us,Еʹ+ ]WC+tZ Hga^L*Nfzg/g/Y|cjo* ?΋aևXezX,wLx>xƎ/7AI T??c*F$c3JF/<\>KtAʦsD+zz~P`ԤW#νfc1V!X&*+:8,q0UsȆkґK* At0U2z'Xj0!jm?O$WU`i`;{3.0.U `Bd DdIҮhDճ8:!!1I>Zf͇A$/-xgarM{:. (ӵtB Æmt\<]K3.{cFBgjyRh ɹO,Ҵc$G~,Xgn pE;;%>ٛ}ph. ElC'G |oL]JQc6+ةWDDŽF{Ml쩼T5v~ʭ*Xs0e+d%rFa/Y?>h+f4j7L&|[ Y{Jpu^c) |~d #o'Lw;`%h[_(O?Z> 3όaɼc#ɻzL4A9hi-ǭGya:z؊d{+#%`Иnf5 o[$PыƹFa8|[zy;~-O>xھ!V/,B1W[]ucXE=6c6@9 Ttm28D0 I]q_{SqXETŁcv5?wO-%-p4o$ȏ 'ڬv GYt~rdc}wϏ^ح8/|}z3uD2 go";_||6{1_*Ns8C%@Z_+.Z|Г~՘[P&PLf%(f/w#t3<_s'd՘,+'I<+v ]6B04s!ץzpeZ,NXrȁ﷗euHz71Qh$CO.@{[rD` bvg+[y'˓.8D5?Ÿ{lw g$W`/˿84!٣$ 2;  )h,aTEs8׻-87e[ ;Lt }\nAYP D%prkuiäO& f6ځ /E4^roX3BՔ# !Xc wOBwذ3laa' N X۩rv8%v)}iG<" } a)up8Ōe ]u1''> 7:8HhU(I,-}z~˵@ E9)CK8c2b/7o7#XSOBB;DŽ5]‚ݔ.x%~2ܒdr[;O-\I/0cX6Tx;EyћO-Q' Нd.U~>Z1 /VSarp<̹}_( Zw:0F492+Jo8^p,g1aⅩH='j< ^q?Y9[fqRX!s՞}y_x.s$q騒zaUIm}`|"F:#[ut[Hu~:ʧh  -pvn3d Oh,N=Ue~1ϳZH#wTC1&B;/@G3P[kp:UoL Z: SQk6sY\ -gci v w n&髢:7b8H %wwYY5wK~~ݤp~F>08V Kjv}4~\=V4zoiDUn;p{{Hq$}(Yu=I1SwhΥ+j.ߑ2[zVd,ʵ곅x6i+VAnWi:qHa_ Kr1\J!:!?/dYo\LYZMթl`jr=\R`ɦXǝ[pSr[HP(gZipmMa_bskGYYg}[)oVRV*[`WJg+AxsemTools/data/simParcel.rda0000644000176200001440000003213714006342740015405 0ustar liggesusers]{ 8]ў,mRQ'EJQmI)Rfױ113ؗofu5L1=&zVGGG[qL-xxX~&DuAm"Tzꁽi:MGa砊gCENhBΪE0afnhYtPwWڴkH\J_.^aB@>zLgmq^xz=BB K)īΊ ^a}מs][tLTV&;ķn {i_6cEʵ k~;,m#4> Tۧ 5#YiU,ҎNdC6M"`0xt!iRI0.jB #7>?"Z_\4}lS_Qc>zj6̔<>5ρaBo0klM[`R轰eۛ^@mS[Rv{.m؆jՁ .kյi(qL :(%8Q|H,k޽|勐tiA2jq7wsX b=$-9T@f= = I_˞J¿B@ײ +TyJda۝J_0Gv{6%ÀCکx],OEjݎgp}XeZ{<}?4 fUi |X fY;f&yuYgN//UMrM_[lJgl}c!`\2c06l].BSCLwu+N|YTgCKjHL- /ԉ*?w;)VwD8v Q=nC%f3 ]zSm,BlRǰWq0xg޻]@ۃ#8"V nFo?C,0="ӼİOK,Z[j~ !]޶'@x6َ42v ̢Y~~(ϮK~p[4Չe{՞'kAohLso^?}#mDESC.Bm4'fgb`4j1Obyf~QN Oz7Sž6S%X1~voX#)/[o.&rgf[3mLqg7{F5(k?=>~iye8Vؙ _IRq Uf fK8W㞝0TY"!n[CYa0Aaj3lZ ~3&w?{cￌWkk=r22O&-c =÷Nϱ:1ym2s Ntz:;](eHkUo_$Gυzj?x‡^C{_X&]~P mF 0hƍg6՝ޞ!<(i*;cmP0ja[QH>sAט|d6(̹=oE| #!3oKK zAXr(ĭ"S${yհب}sJ^)Ty 7=v5٤E\-ߤϺ+W @'=7tΧ=Fx3 qݫLȉV['%ECC\.cenoaG(bGZذQAiY W 3??3@Xǎsn'vjkK\ vjҳk(b ::nCrTRhGL꓆;{B'SCcaϮ<(,5_>sб *3UcX0Vm:\9t8EŶ~@=,sq@`7 V6*60}@Gͻe*0 faU,)*ɹy|:nVۑHڋDsuː%/:K8)w/!<,*@=#Nk?ki;A VJR;nDӉihܱZ >(8݋Balψ8PJkw7OFw_WZ ,ѿ8<ƓV8߆!*rϠe8A )SŞ ǙpoH#Pya)ϏP`iL \ˋ`#Cx聁WC`k|KL?-(jܵrh`9^׆%_É6 uP41&zƶ('c /gt~ثhh~!q[sUHCbǦ#_# :Jڒ@[G8d'H{5^yعzD9p 2WLDKiju%@6!)Fh` ^t\~!>{ *vZRA% `oߢO$ʘ֊ KÛ>5',!Cn-RZd$N]GC^CC^CPlgkB0Ʊ.b P`\X/DXğֹW~?3R2I"ԀWǚz篣ոB/[}7tc`}`,ZO7.*]9jE!.}wEtVV(0{#\C3' #e_PykdvȮuU׺6q50BOB3j%B9TKe(eᣲi.0d=V\86,#὘&0ki 3 Ǐ]{jvT6bO5+oZd}9XjH'ǖ3Ԃ+gbF>PU®faM%\ZzHx6|h`Ɗڍ rHZ3p(+ պ;'ҽZ0)ФLm2g[7?& @΃Qs`Sd-md!c6"Jopv=_;;UlF)X5i| 889,KtpK-NhqP&IҞoب:g7 W|ՌIilԳp`d0&P z;/]T rbś#0Mpƶ)GбH[nVѶQ{*v("ݻz/ֈ zOT+ %x icH"C7e1' K[C&0|/I J}yr$:ۙ5e?v~XX;y`A']y),+}ΡPz>̒SFBj薑y/T\)?U`jRd{K[BOkxaZ<g%t {e*f2]{4>2 EV9@֨σ?.'ܪ;%.RU}m&п;,FzW(")\cf޽Xf|(oFE*9䏵cݬ 2?M6H_H8;U< O*Ys{HwcQ2JfX9g{IIki}s`Ǽ|[Hi%R"m .v0wn=t(p[ P~Ta OuJ@ y۝֪(xwrhzdmX)=ǘ_Nǣcg0[ssXA"Pb#)N̖?)r:*\|>.\b yߎnr ~w;~m)Ѕݚ"Hʂ?lZ7a_hهȰu.Vb<nd:dC+[`T׆<86˟8.8 m{]IboߏufGvO|歙_]وk,y[~^;"?<i%}%Ts 7KjbJ\I#OugY =>*wMŧ& Ѷ|R-$is_Юp &]^[;ZBo=0vPW "@wU_8afb'FB,oq}n@~o`Ԧr|vS(*U7{?,l*GF%X}Cb Q&-s"u|jFCAVK5b= U,&o.oCA}exc'6$_6]CH \] s 2@l4/94>zWV`hꕐaj5J?/ʈpйT 8Jc??^GT9H I-? q68*&:xvWvJd)I =;ͰoN&ީ}f.gaM<%śE%qaM5GQa齓2Uk[3㦪.9hyBz\mh7{p*?Ii"9Oȶ@y>!8X1o΍M n݆l@Tqs_)б-# ȶ5Wf}]7ӊkP%dž9 u1 ]^1pZxNvԭUKvʮ6%vp\{_%ķ24Kêm0N-@:};H#6:Ce 9%} T-icZAJK5Ҡc `ɼONײPq%6ޤ_|4_GlYեVAPSaݓC*;&;|(C;PVa'Xf>x~n$2n4r-."Nv@Iڹe!HKEЯ!8ޛ#{.~D%HPc4NA3b:E^f,c%!mϽ -rHhM7hn;N?ع׳qlÍ{A6//|v>t42MdִFqK~ӗt?}@LNlC\K˹$gdwz yC$gri66! }l9 ;[KdZMgs./[9Cԇ-V yuHX?n[$UH2Ԋ w>`yc @NRSGS^Ȱ`mejN"|~qdtJ} ).$?e-bzykbmLgFrBlq, 7ï: S0a~Az킷"=GԤ@ikre$#G QES9Mp( 觊;7j6mۄWM ߕdd h۔A_sLyMUgk^Qy)vX@R:TfTPE ^-'3gf3]Njyоc躯+h;M 2ViH:`ZH|߇@jYm Xt[+ FT]N{ޕ'Onacj_P\ä"'n`ܤkeRaFH|Dhu&otzWCM, Zv[)>a X::7֛|8}s) z<3r PVv?1 >,u:e~!I\"}Aˍ.L4{gζwOF")܀:5J_]P exՙ<6&lb8*k|٦ʾVT8p6p̛;4?ǡY ged>p8|#wCG;o%Yέꔭ-[笖 ˋfڼޛO T y|@޶mqƯ CBuБ{wDJj CΘ)|y|BQokVqSUR_B?R/=&X>5tLai"QN oW %f_[);se":la0evj%Pi Ώ5(n6S_'=3_cYnAj" ϱ[0 65$knLwY*h^< ta^.nAϨr3|' 9V殉Gg!1Q$\}b ]eR*㓓߭jb3oV[mMZ!;бDyG pʱ-pfWn2]՘qؾN|ڈDvĪ'8'1"4dL;kqzM-S ޑ{яdqZ]Hy362-^xƊ:dj\fղr :-| hh}d} >v7[lF0c[Kbgn<[3o z@뾕9+bP1g1L/qa[UDLj0.(Z{h<.9-9||}Z~Qַw]1%.19[IR]p$ }I05䜳E0BIvMrîn/H`9QFRTf#$<`s"a8tm{@YڄhS*粅ȱ<^U/)5УsCj=WVJg\fX&ӏi&ꚒZ܌1ꥱtCD*eQ)OQu^%agZ-C?3:2F_}\-mB=i7f(M%jǘI9ő˄Css9`=VFOw ?'s=Y6#JnW;+2,CF3n$HvK#:p.O|[[;0^k%5vSJ[C[BcR2OQt-lî{>:͙)Hlzx\(ۡ?2rEROʹbuB _Qg\T 8\tz5,y2"i9!semTools/data/dat2way.rda0000644000176200001440000251335414006342740015050 0ustar liggesusersw<ƏUVI%QHO%$ɨH$d%+$D%q?&{q:u|q]믣{]BS7?2d_0R֟YLnh3n 5[b. xuTmh4‰[x^ avY Rѕ/"g& 8@KjkD!*̷1s$YZ_~ZR4O0jSٵf|yH3/ׄ]$/a?m4 ~HTe7_h?}`=pw%>:ozeߟx`@ ȞJ~q<0AfcEn&KAFhIW5jZw lXԛ =eƑF^]я!YpS0`Ɓ{Hǚ8Id}hҟ%5)q_Xw IG 픆<6aUo0NP9s3? ?an&wYv+ W㡝PhqT00`x2C R*6l>6Fg˗ s/\>XTѻEf8ߖZ?GU"#Injd\_ӃTftu0_68~6*KHĸjt*;;x,Yr\0GϮ*H,OcvD~];%R͸wQZs}~K3t0In*r)phV6;.CdU9Fᚫe,45bH) d̊$,*O-Ħ~,o3kJeHi:.p|L Ɣ>#p\^ʍ}Qr]WMh28{0^ qYF]n!yX㛽,]8z* z} AuQ3 þvϹ훡ҊTm\xc&/og5PqNHX<*N Fpiثi=^Jtp򢤽Oo(>TZa58PHB1 >s׶A`Ay2Y[~f*I #֘UTBҴYLz 4jc uF"%:{>`sǁ~hQH2PEQȐHRt2ө; c lЏ>5 ߗRMElrh~ ML\6RfOLY}p4bD~0ݼ$qI}P:ܙa01/,g*#—GaȬ?:8\7Q)FzkdH!60-` gȨ.΅n<| utR$5 =\SB;-ela߼˓W,O#4=a%Gix~"& }t:Kƙǒ>"M'^{^ćtWir savPL.Rv7en>?Z&=LO}Lxzt:`ït,g1WK+[{ӂץi6$8Nx\`H2I+Wl &`hWҮy\pNq܋G"[3TJν`s~$F4%8vɝ;QC6ih& 3:#pp!8ҋ;4U$H*EP!7xyEq.i^{I~|yUbX.=I/z [HVXJx4uWdžsZ.ir;c\?af_;I p%gP&<9UʖDC*0;y9xnuląb=5]IwZ>,oo~OdG&2߻@D6{y'k#a}s) l \{:$yW Q@4T[%qȔve 4~+LXDZʊfEOHL2湮ߖVB;}v0.td ,oD<8SZM;ߞÑ FbM7QhcPG40 NRf&J ;aUӖ;b2O)IG'?.S]ZdpzeTxv<%j-ӵBA.v ְ^%E9E:z-~FҾt Gto됮z?/HmMjWپ;80xbP;uMmր&*VEQ1aEtU'Al.&>o"U},{'BT99mέfb@{:4jLnSK Ih͢(|;̧t :.∬9N{|ď re|վCG߿lipQ-A) O[@AFm ۣ-0hmgur.wmi&goDq.ԟ1Z|Lu`P&ÆC,=TZ0t޻W{&/wnn=E^@wdNC7qiLXv_Js݁]_^s4'v\J۾L&" }MN7u#?#C{_pqeC+nn{U,#l˯ݑ,Omo*xp3;$9P{x_?3Pf Ը̖ ~tS qM36IU| GEfv;ȒǍ9Hd.D{f^ϯ&+ 3|'UrVIҔ_>`CPbt9s+IS7ވZ7,r2%wAMʝO`1*?I|b}>埝zeP@Aט5F?O|Qs?-*#NJэo0wul,,k#< BۡcLr)]Up\ KAסVOY]0hsK KqVs.e}7X*~/Bp^-k X2_퇯,%C9\A[jV]#;cQ.}AzHnj{_{cu3Ӝv5v3Vf8^$w*>׋y̢N}!2}/6_?g[ʗt*Jcz[աFC3,4՞6[vo`ښ6{$xX(so{S/Aqn8EPy& QYo/AlcX&ұۧt5$i9{$d tPa}HdbA#{BzoT9I>P1qk6Μ YBҊJw޳>Ew~C -{-=Xj^72"S)PwWA~xU'?Fp㩼QoAɃ6'~(\(kƴw=ҮM.AkӺ%SfnoZ}KPG8^HwGm'pQ ~fD'Naa-g3 F;>3R,?R+Rm̸BG0(HW׍#8rCXֹEqm&A^JÅcN%ssc$+ hѾ6|}b8pI en%zÆPVIiEecCwA7د6m{;ػˡWwkefk} <9x:; Fphbel[Vcܭy(@A64}2~|o$,X xy\zű)gzG,G +a|C{ac89Lm8}`<^6|NNʁ $0uT/>d8?/k :7$pyXqi*W_S}JKp5r=ul)&0q*%FV'²nhj?gߦiA><>S+\R/z\1t9}ڠHy 7RqVYHɃN)8Qpc0TEH:,dǸׅVcY1VMzŗ#MsHujWq=Dk&uq5@LenMc8k'?aQQl0G$}wl&|x :"u{e,t8Z5O#<;`W@vn99wdO<F0PGNfxKYC-/*2ʘ*/S0}䥗Д{Ѻrm؅=I,B瓰GTFn^?ӑJc0ቂ֧ Wbf9}}hͫxM<|d\k)zLio!P,?k\43+g7:Ta[ٻ:&9-GpJ].쐘O^'x MI )~Kg;0!8Ns܄e5ˀ)6% rɬ{s}2pkPeX#{ף6+]h+.Eh\ n beQef^Pbb)X}|,4=?~; .6tJrFXv" ªem[-v|ȕjDk_u7Q egmzYo!D&\fYL2/iMnju3ny4~1H0TH7`煰PS,}!IU;Xj޽ޅqeo-)gzqLqL}{ zD#CftA~?VJPm*^=!$=BRFp z?zg׾So!bw)B`޼]ƛU[u7ϯbǎH9w 3/|Mбql;4~K \vW E _\nWwbv;[UWkh1,0\vwt(J\T'e9cBC/ ~Ʊ=v99[0U*- Zj&nIƜLYGr~S9v+?ђ#KQ0e$e3|h1WS+q`=8z 4, ݎ[$_ߺ&-Ang4/SmyRhWj&ٓEn: %m/%l?l>c'eYp:'>r Kz_Zc^ !t.i8_7;H:cUEZJ0}sO: 0tf_Ui.qv".:?C˨J0?s03&?]I ŲBr}{r.WtzNY?`ΦO@͔6>>W!8q˩MH )E5aڬ^Ǚ@ o4ajUm~۫wb m۔Ԛ{n0PK`}sȊ}8󫸻Cئc2wrTU S7>CTǣ˲1Uto*'P7oez^%ڷ2+h'{z9-MLI3BKrTxW  HpqÎs;icZb' $:yE1 CDs?B@ն0\P+ZT|{AGS97iV(KŶ/,omsU 0#s,~Lsp[[@ w<@CuwoE2y$ `ϥ㧠Kєo/d #KM0sv:LuU(hqVWax6&Le"$G`G j!iFntZݪCO olK0%4,Q5=6o='lni:Jݚ.ԫulorjCd !FhTZӶ򰚿a-^fXjc[rW*bb F_h[ ndY®F!0un"C W9 -4Ԣ?<&~?iK/ t@Q͊Xqvσ> }oڧe=PP%xcb?Vؚ+fv xALS1V&e%XOEp]i%6x89HV#XuB~zޒtCᴍ]Vmw&>)<QɍALaRygj8:-q(˕]4Hla $ >r_4LQ=W.fa:E7 .Xps\O7.kk!"`@/Sϱ+.y)@)_?}~<'P=^n0JKzaa8k_~i"m`u&7ƚ"eb?7HeyɰQ~(d<%\Igh]-6;C/cGWѻo9nBK+ oܱ"A%<FXG̼/X`aY8jVTllZ ^4@Kg>=g.aŏ/?[ŒIq;xfhf*A?&G7'_i3 j$Яqӊ3;)%WpmW{i2tiݜH23ϼ SUFbNn7w5:֕k6o^EZ힘R<)D-?SѤI gq4]+ؘ-3:;&p}үO"jqf0<\/7 ۟oaXuav<]vd;R{ÐZ06yW;ԃoff*W¥_1g:Am$ 8o>5˚"C6COFDxt7T M€fI־884-[S;M6!o,Qڋݠw×[TvZड2..~+Wu$k~hv0sER7 6ӎB oprAՋR!$?qE|˽pL-i@0ߌ8RAn#AOzƑf&_!5oVK:/y;mwulwUl=Z)$[@F UhgH^q5wǞ?2 =T!YNܟ6ϮD2s+9š͡C=V~PVzà׋UONdg{ɬ$CUM~'(]0)YGJz̦t'ugpp[nY;Eat7tdņ k.\Ugz0ܶqy?=>W]$a_┫ǜ%?u.uw7toae`S|5Ig> .[ScO(A{_d<0%;v=Q^o=)r]w]}N1U>g Ï!˱/w%:V]n4l]tR0 U~Mq$YԤ^T[[7a:%}90Oj07}oiybaT#;toGI:|EN w1W4 u4ugz-n;ϻfWNc+ey1fh\\&pܽ=uU6c8{Uϊ"tF%4#w !Bh8w.Agh![SCwʹ 0%?; }; AGaJr%m[u"II e& C??Hg1mcWׅj{ dl-p'/xhhL`R˲W?yt<` zޔ޷8'o a$!KսW;_J>ܻ׹čXyQAmF[qccY0E8+2DԭrRQ޼!+^M֣b_&7vۼ:~dx|fAR`<|,n?h]OzDKSzsoxpszykǏOxr6 /Ή/ <ϑ8..z`D:qwx6<~h 00NRm .F(];ܡS=}s%s4.ӟ-";tx}rU_gd{W7<C qB/诺{S8I { IVy\7t9I'롲>{SԲGH]8U$4 XcVv gm;; `x g;-2$wAŗ?sg~c؎zِbvmX~'0R{]Rv80{uuzm#im{z nܲPt\&>woDtq@Oo3w RiQ0mS SF{oޮ+⒯ӿ"%g 5^@1{B^"F "TkiQ`')|)S<{ZDDp>Y%&,yiyqNؗ{54vrΛ$1vB#Z Ry #g=\FF'ѸOGbag20Im[^`$#6+?u۽YH2sQ*9ifksK%g,J3 FB>}4ָʦS7~c_2 ե 0t/*z| %› GŰöˣ0dX1/ڨNX)}UW<_aꠋ~8mQ?NuW9'`ҫ~3 F&S٢#ngVж #ć-\Ւ˵vODž|fd>Rmamp׿bif7,mc{0$֎]If fWXygr*6{6UK¥ W|ެ\~qMybf,vr|:8>"%A_t7MRmMA8BwLswP N)˙o"I[I`3X-pgݿ6 ӀjtZRΆ>m G_g>jס:Vta\.Yf>%{rfL YrXk9@%_zdaPr.)fޝl,=>SږL*a/y~3eZr kb.*5b<}3n]rt$g6{ X037goW)^:N_mX{S` M{ Aowß0!0M8-SP0iG8,4,>y&O <IVQEʑ8=4eorQ$ꀣT?faחO}}ڢ:j ԳϚ5tqa{*`/ c ‡=N@_a.L?ȑ5q<vnE06\b"*'@RyM#$$g$Sbqr&EGdX둛?y2NC`|AݩG6+klj'ԥ(<):cLJj̨ N^fsn?!E=_aGK.lA0V/I>]ȗ3)iDz Lt'`_s؉ W;]3^ag^D.`_3}a8Qso_[j!Xx?@KA2\kѿ"&ee'}I;*v[tO*%K7Ǝ00Xnj-87!)HO0N(&Ol7R2 .fG2}'L&T6KeņBa>~?IfYa ;p6#:amЇ[\^N<ާӉ;[3͒D-gr9 |yJcOu\Ild]bI7+hG)v|5qq³0fusw5B^ۧa˧!P‹Dn!NTTv;[)]iWPZ'o66 _o]S$) etӽb0μm\ƹvс__gTX=om-b$TC7AjQn;qkV| vFjZkaVvBwtA#l*N&@~5 +=GJ}h?>S4;?NFZ$@_LH֧8!cuDa[ hMkb﷝C8'aZ.D3v|TB^)PI~qtǺK\@{]yz9ǽT˩aRl_ &D%wEt%a:Q3p4,߼p0I)!&g˽O].Uhʈ6\}YC(t[ QC+8"/Xaa0!|v(d--=t=mf+m)2 ?/@/[7Hʎ bH Whr2T|f(q?q𸻭z-ؽzz}};GlT* CL7p볩U5I`Cz2L|W{fUew0)LӃ1=&hb Ƚ4XYmMay8Lm c̾B׏wC[ Q&,ui oZ-bOebb04,Δ|qHCQ JXIXKV'pn 0_`sR@(R.U|s72U>hMIp\Dl,.mre9D+{Sf.u|!TA.ԾUGxBћsga֓ya=m54 OI˼Qu3Š \Plص%O,^:)Il w3cA韇q+Oe6(,l!Lv6('XE2qh2t[WZiw0<%:.&皞F%B i~/J>i^䎋mipy[Ǟ,--x,p:LslW#گYh~eb3 =+5ipm0O|l!g{SH2 b/){hA6ҋfv8')yWӝdz5v0F]K!0 ~$= 0B*ƆNcvzw: 9 GLC5ͯM'0R8O AyoHVTr? 3KטgܛqxL. M$qy\\E)S$׭_ H+_05܇8J'+ 36%&P }9 H;楚vfܰ̾]N^{RnFةlqOHEOLo٠ݧyopŽ ,,e~56ʸ`=g{*Lu SE&q(;-6Mvf2mRoI# Ô+t-F-Aԫ{^lEu~{ XK_46L '`uYPh宽MGt̝$ox*̫Ėgtutg^__w=k%(N6t\\WIn[d5ɰνPsku(\X*, 5d ` 53sÂ)^Xk;n_4?;$v~m^4O">K;d=0m= =A4hz)${*&S[\9v%R Sgo"-ْ0o_~=" +{,QMW|;p|1W]g^uMPL8r]EHjUE/_&.c"yԩഊm. ߣWr:}ohN6~-gWr_Lތ4Q)6xl~h[yKb̋k0f~{~O\Zb鑐+{ҿD/9wb?zGٮc'_0^\;̫pxw"}+IL?gaCO@ IXZE!WTo͟w3j"J0%"76J| e)k'mqto5$?~Lc.=IӇսwpǾk&a-5g7L-q>Q3aOy[dFn-AI+_dRl%~-&##<ދ(fΣtXo7>34-w̓~b[q~hFkt35~j&)'vM=ɅtOt ^;M/ I羭$B_~qw"nj3ԲcKfkB$eRDVȚc Urm6c˱nGjt0gMj,=kʼnw<2 <\|}S[IyqFu\f; k-sZOygI3\V|9 ߴx4sYHH1 _c%;C/B[0K^H0յc :ea™ v=|5&>n $XNH4')WHٺ4=bJ8Rns% }׆a=2_koTJ ̏q2x~h .~dץ1#0 %VBWo`3f:`LxT,i/2~l#Ǜ. [$>Po1X&SqH . YW,k]8kG);{Rm EkVHS^Me#羬Dn!IQqNd'uT>ӂx+S@L1{jo[pt=?-ך &Rqsϡ7{\ >[3O?zν ~j'}CMӱ$0UuʎOӎb>ֆ|ÿ )äi..֔JM,%e6t=]\ݷ,q+nO cl{ r`O(IR.JJa/Kooѿ $tI㈰46} {r}OML5!uRrgV۪P)88ڷe4[$(BJ/ _.H~u@#υrn{UcgvS̥~$t ٷ.׀icPU+#+=VXp¤ݻA$<_m[-8 k/G<+J 60[q2NoZ39+:qefCY莈Y:p`}ʼ+N4amb*#\Q\S%Qrwh 8=?Q!Wd1T%]M4N[ω'k8ԫ:(f$>49$Fm)'=~̛΁gْ,cp+0.{7vArs1f(K6胙j8+y-V)2͐]+Jy*O\%Yb=X\_3PipivuLpPNgwq&DAOkQr+8\Oй47\du=#VOݓV[ 'חaFk* zA\Xu9]9֎Gع´u-Pݐݘ~UW"`ϵRI]ѩWby37jgw3SXTپ|0y~k4ʣW̽/d>ubƥ^PLF--%կ5`vQ1HL%aV±mNhgagS'HK,XQ/{U2zۘ Z|žA`L]JAZC0ReiDi|a召24tH\u&5C,o?N"m=a?X[褡eK,ćqg`)?X&V5M*4\z8I΄>7X<*%ʪÊE}DN< %k}' ZdO\xa#AP_QN)q|a\K׈#ۗHj/K3i08C:]J;0#V2G3.t Д4dI!TA[EfƧR3CP9c['Av1٭4h<5c3ۚ?]RU$ڇzhѱ/lƺ$Vgt>,8u+nR8p\11ZD7U`1&yIZ!_K!,O3)-+S94$Ybު8/n-}ʷnzMyQS.8݉M/< 5AƂֹ5|Sco˷$`dɃ`Wja,JK-]EΝ')w[%UYr<`_yX,J>9kSkPQO}é #{?|G3|*vޛ“V&MbeǑm8`$S*{:bqf}8p{qW]Lg/eMޜ"&kdVsA9'^3 3U>KbvFO*LXҀ\g$sȻ<ʁׯ8f#ϊ>ÛJīe^j=ㅭǐsf\Y$[ NQ Kj(:8}Ģy^NÓX +rHX+_͞eژ>^v8lL~W+nlo FMp0~٫_X_u3'b؝[c'rh4.z w}+W/=nʿI> v*d_h~,5`cf4;ʮL!̛zX@9W?eP;7ͫS.z10qSZ֗ݹe/G$) 'b:ù {FC{2g/Ks=:Ɛ_icNXfۘu{v{;EA0wZq|9p(8X */boօ}U*|f穙 8WCuε";f|"X$crҳb |5T[ I푞XnY`Yf/n:n*n+5=3C cFLI֗ P ԇ9af/21߳L@sÂWm3 &̠@v;Y@P8eAo|\HF#I߄`)CH&.PI:NNf:/M2 C3a#F0zaghy3th0tDAC1u;+(zߨu?h:*{)L* }@_ ЩSˬI9vSj~$ӽw?I(Qt6XպaXR9n _'c68#(%̛87wt`A1ȶLDEw@Jﷄ]uBe栭9 UIΐaDlNS7{%uw ) -tz/6.fj!MH_$L)Zaё󩰖rz2Xxz*^(' #0{e(YtqeuZۨ͐xkh|U=<{k: U/=LcQXq;{$̩W6T\e``fnA2y/xx'I3 c{1|(ImYp[]z.,&LX8D,5U쒆N>] \=F9W`u޿ kS>tO6DS`x{'[u|*ߢʹZ4q ͎R1l?D~'Vo~bN|^%jhry~ZckHs=Ύ|qi'bIcӘ2&[Uw#*PjR8zdB2.ôk~afmj<̽Mֲ)Y,2v}}/X ~LZĖg} ;*WdvOk6iX_aNL91 Zc%>^@\hL#K*aN$62$;foq8, z) ZMAW̶uO*ƌXŪso>۬Oc %|6KkZ5IHJí$!+fz l-9ws$ܴpipBSq7n΅r3+Wvo{w:tuf :=%xפq CUj ->s j"QAl*w}mn/UF0e*RKpDlƞ4_\I{al(jcXϋM=nP~"Fw|TĕҗpMV{(l㱽.xM=iσ_*;N'Ҿ[]9qO8 z>zD7F>.Wl`,aK 2MeLn9R/~5BhgC>5'}2Xp4 ^Ke {`#3=*{J+0|D>w*&mlgd&Z G^CKQ©gy y$ewHVF]M ߑNڎ!={Cza /*qX`1, 3_ ա4J\yiht9N)BDBwoE&m)iiwݱx߹PEwaf4 ձy +=r%h|aa}1.rӶH!_o+E#\$+-V;~g 诞ƴ/XϏ.nK|CqgGte*=$Ywz\;a0y̽.;VzLRڄo&ڬm]|ϧ_/!&78|D=<7O"Æ87pvd(6ݞ qBՁP2l9]3ɷ樗*qe6hm۝-8xMIP&kǁ1#7#TbOA+$|: 4l۸/ JIo4zߞ+Hm[bqL~<UgƁ)VX{mv]L ޗNn,g`Ҟٲ6&.:S,&צSqϯ RKu]G'< W{)•7K/F[Q;B 1ؚ 0Eu(GRYuΊ(_M=}| f {5h- +( .^)B/댒RGL\`uJ ﹳMƩ*9&@# [ze\f'(9_IUn6؍ϓ ; ;%ٽ =s9BRn-=֪S^'UvԸc9ea0_{7i"g}s Fnc(S\.œ SX@ٍk&;' 5VKF$9=QŊ-+8|4!QWlRtT}%70g/cDuZsJahXW(0aF8 cVkطXtIكAeb`OL; $jƟiyCLe.y횡cpAEMSgiûْt-~T=@n*}βmv"L=+Ά= ZPQpZ+]B3}6Q&*>ɜsPXSLwTUqʧ>:E!?GZY<Vln7{7+P4Htqcۆ$SQzО;%zWCQdj8t(:%Y Jұ1n_d]W`bR UuJNOjWH>׍(4g~6?R+[-!KܤJB2*Ih"0}QwWmwI;[n%FO(>-j WT 4egh7`;EL\T[E YwL>%8/ZW?atUԬ;ñ#`,V&Sr,7qqPw0Vٹo [Rga,A30˱/ɨq3 \U0=K)k%{2_y=mRQwӂb/x'`kXh={B(J@mK]BXYP/oI*lO;`ݻ ?O78K[f"˺|!NQV a_bל4yRms['HYjc Z< jKApU셩Wt<+Tu f=f}fH仗j28%:Jܓ݃}CC·br8w/*w ݾrW tQOt "S,}I7+.i*.Z&KǼ7 i0wR=xY3\`%j[:ܞIc\Q, z*þ`1?{I2*29WaܡMenV&bɳk.ek!yC>^83 GN:HEc/ t;wy̋/#6G;>i.~;zg;Ez_3^+}jԵ5gJۘvy+]eaLjj u"XFޞ(ncN]mmatoɹ{Ε$ݵB0q5Aωh\=2 <ۡMrmN7pLUװ=_Fܞ}{-SiG{/i^CagerC-pl~)7%[좭$Nq[>Cq-% U\L|s;?.֒jqئcW҄i!nN6 ?r5 s_8"ma$=v_7RE2c(Rer+ɻi)8߾X%f.hRG,KhZVđ̍o߮s)}X\ z_X]6% ]礛{Ġ㴘W!}MNq(e@/B:{ul FK-_b.Gk \۹OYzBDa{ibvқ%pCWIѽe wFn@{s~NMQ4v\|p!LĹK(j/ Ǟ(udQ(0d$2&\aN0-gmC 5 `$1z( |x+}`>gY_,>#h99ala8.}TMfv ]~]h dqPe>lu kE'uo&])[١eS0F'@Xyl(A{$'WU# G(.o4|P]?nl۹FZ1+Mߡs_fXÂ8jz(|,]I630~7Po`CNzX?{e>"Bn%deBE￠nt?0Y%{7w)?MmāD;R_[=_Ϣ&ܠjnA1ouUb8.EfLe8cO0ɬ,1s"/X6̹U]f:ztՊ'Zo0I׻24uļ%6¡u-Nq&V6682 Єvg X:S *?kq .{|H&W@qkR v f&36lN޼?4@ggDiMu,CH]"4a1^} ouZh^m ԏuJNTWSS{f(|-2\-]oՁs|ENaϰҼ qb DPjʇbVF=yY!ҭ8vmH= wy&X:77vPT+ |Mu+8Ɩ_y=~8„7 /@NO?-5>g}*nߊ{{XAs֙ VJIh  RĕI^2*|*FA%&LuFc}S/gzkNpJ 8U)@ymI{rϺ1zS#jesg?cf7?lSp7&bb0 pn{V2 w;Dj14Vή]ś/PRS4,w|ZcI}%uHB/{pE|'<ž oٞ+B ay[wZ p"czG.ozkXV(M~,TjaŒ&hbs`Y&.h ֚Jv2@\J,N|te|b~x>i 'l_-{xs1o!Ry}bYqBA:wvފF-@@wuȶ+ yyj`z&.&HWΎ_:kk2 }6JG:|}M0Q-ϑ4cocCvdxT.)СzzLϯAeޝrM轚!xB2JHnɆ7[R:P;/E#La1 ?azd=^mS%{|Nc]H ++<Ǫ7p~k{ja?elU I/M,i' ,qAY{@M˰x3-}?Y&苚=!1++8tӇm!YFM+.pˆΓ0L ZVC~뇨W/>ZRtAq^Bɕ${B$%&/`8_뇇[׺N]' 0+:X'VӖ$STݦ8hyC@{xm.Vܴ7mo܎̉*ʇ/#@.s+ `Vzg_X>1 l):NOno:UځƘ@m5L\[Z;2ec. `mrcSMVi4h,En,E}!pZ>MV9K'i&04N܉߷kK[`D?^bp 5+ +!˨-8Qu/#Ap`W 4v)]Wk}S,0{Jtxfqafُ3QKO S!lvoқꬣqsG;MBf/ŲO Hzu'O7tV1",tkr/;d&}'(T#iݑ?'N^ )ք6"[kx9ߘ6ء]h )$ JnX6~_O0R_]IQrOxֶ;-W/)WǶ~tn 납ܓ`MJlovt{ R*`&of6l.u uN+DYv$tss`.ddD/,9G,'?8uG1wЇSt/>x!:K\p#/*6$ {|u|;.4*z/5˭\[kFnyo,~M2%[% P^.B`? aBf牤7$ӆ?Cbפk3g635_!ItO+`b]cs&csr$ޛi\ Jw /ozە!3<\Rpv+,=cd`tD&kʥt;t~ُ-'xٗ^\*$ȃ7J(Bo=8{O_tFcC ؛ ;fϔMW3#К֖Ź+YڲUM]+m{b&2Fphpj):pE_Larn2eJ"|P]H.Mb8!׋|'r8vmDMC?ovI-ƥ[kjN9_VYS%> ?rL9VOF-̴caֹO֝Nl|r}_C>vK Fpjڃot<:yb#qiDj`r*v!(܂: f_?&Yf_%v*Cχ'c'A(񎑯cŹ~~_[$zbOL}޹Kc@~KN>U СT-P7 ;ҺT]tV"EOpq4P^zb= K%h */_>L=T"6v} Fv*WLsD 񨸚-8uQę6z?_Re/{q{KO6\jx;A2i!&Nw_]B2aNm~* PøOa-$,.el(+Ĝ&lqmck VxKLU;фuV%hur aRB4b| ngi"ݰ?@rgYhxt:Ye?8 blP=̛}>gD'_5,܃?ozVTU8 O؊Q;,g'UgMet`ߋ8{GSN=ݟuRžu z\Hu/)8/Z+/T6 [ca(w)?ˊq_P.tg5TkXb㻜 %_#kﻩ43zaNSf <,CYexJ;?;>i[R;/$mꁕox,I:𫖳 = }"4ݵ|n ^WE30G܉&f$K/e7 Nt8|Ot}(FPM)Ls$J >~ancoDԣW v,.:(7ؔ5)׎>Q 5;OL28G^Oϵ\9ev } >M0Pm)?g7ZťA?toybx)Pxp8QvJ*x Mmg<ywC_" A&#ΞQۨ~:"k*z ʵ$ *s~Xnjm2hVy#"A8߱gnmVo~4&^_qyrL=tf+xnC2m__^j0$`*Wg0J^{zؿ1Fqs#L3 #()IL=Mu̜/`(FJ?x?6Ծ1H ɼ<ر:9Z+Cۯ>ߥBG} /ozavN8v13b?_zCӰ`-&6<N/.䃥e.n+6ri6&FG^H셚c}{S_+{bxՂ)Jtr.\%yhk Mu kPpDbncz Ӣ'٣K*:/9^'`>;6̆ltVL*7dJF`5>őyX1+']{`:^0K*`{Oi%0M%[7K,sˏ v%qetj|bkg79BO׆1/I'z0o2^'~I9cnbn&{Aӭp  K?.#snpLժ yC={^:~(qv?PɽyW`ud\Q/'[nFݞ]ALKh ֫s1ɔ}FM#JI/m^߳27OV?ssY*wA2r8ad0tzwT7M08j/U7W_A`xXZEt6 8`? { fgh%J2~q. E:]i2'rڴ_"aT. ~1ŕI!HW^-0)wbRfQI:_&KHv"q6gנXg)v1]Ǟz֭:'_RpS=E`S|z\ep,_ eaՁ1 6fE|Vun)BA[N fqHSQFR{35=@{ޙׅ`H4Zrh\UkSV30X"J>h<  ,8.J;)O--y oWVO*X D..9Ѱ)Ao7pbq\}lx1~M}1-Z0c}߇7ZF7*pP NfMwL!P=4XW>WwХX3zMƣ WNoћG>v;OW䶍>!A@=X? 7 .$sFX+g0<4G~^Nl6PtMpzeCRw%oTAk\>?IeY+" 40{N nUa%H S푰2Dg&L6t$vWw8+WtI e@ٶ.mƒŴ$f5F">ŌHM HնPU,v ,&O ŝ14*?/9js!"sRk`Ay4#`P\mp b!?W!0Z̛NbD _&%WDLZ{8mv髒oY%b Eg`{6۟䑑ߡ׹E%qᳶ$N3,HnC'BUq*5ڳQoAjG(\z_BE&~Jp®(ӣ:Wɵ{."!>aWE6Z0ɧАu$ϵ;ec{ĠKvy%6nTtv-#SNbfY)֮b8YP:ХS1u.?Wʤ9{p=C"{<|5M_XB w{,Ky7 ["vs.Pi4{0UZWD9Y`rs5SaVqϵr7@2yܯ&ydgݮd┉ug3֋i- =ȻV ] |L$6S/ʝ{}YUFœbF̌,/=Vq|K!X.0Fk{sѿ78p3ٜž'vKqϝiwqbv/qe>;/Z'(ʍXrLBbgɴdߞwopQ'T!:|Ȅy,Wo*éL>k^ݭOwƨtQXyvj/HO<&q҈ơ$[l;^UƑ˳Udt "ʱg4nWpa Xe>!D=}, s3qmgg)hV0#z|}AOf'L_ ~) Cn!#kp(,/xZOS2a( /!鹚iLBRJ}@l{HN2kV9+{EdҾk VϤ]MljR{a}ץp4@ƥü#uќa#42`p{ӎ\UMY-JbwOq2TX-]ػŽQ$Uun%^r|HTcՙ/ L Y.24aH0Y]^kGrN0t?jkDCEzYu K^g{ j}!+elnD2f$(u&^ߐϬ }7{KӃ;ˇ t _k[=l.O6 2n3矆i{ $%jJMWqr*48m!a*վe3,GY#IfuG[?.a}B>˸͓&w"a UN*<Ko:qO0uϘ0,x{k4Ugf'nVvPxn:j|jw>Yٿq{q36)H^1Mz߬řV6_?N|RƕX:+bSYw#8(Aҟ ڜ מ}4a8c EM E'IW HDžGpJ%^!m'GZ4RhFl8~w7Mܔ儙K5C/=fs?`B,Oݰw^ ҷzs#B8[Æ%{L`NK.ujո.66M"ZP'8?]_+‹@-נV d)gg ns :\gqLCt(K28p=* ۢyȃ3&+B,8>?߉2q\20M g&n>WW/s :awa}7WwZ\x֜8&V~]edVapzq⎻2Atg^nfV 0XOnDMuU0$$b"9ɯ4׈oS8NVrѷZ|gIfၭ[`TlݱVKK޺)5^Wbl}ӻZwh5e%6;!bey@ђ#g(ml%(vnZ8UY. SƺZ'IZ]`g+W_7BΧ۫nC쯈:XAMTL +IX;?[//7үDcsν%H]\:Cw=5q{'WH'c_È0W1tMt!& vw;mcEHJT|,uv"ܯGd*n4A;Uhu'h`6(q3z|SAyX{MoVoJr|snx^P-c5BUŞ*B {mt"Cg$χA98oM.&B.^ >J+ś'3`IK-Ύ̟N!TI4Ĭ{(mKJ~XXSfI#I)ffN m= {nr,HV}:JհDغ!Ur q?ݸ5}LaPڄ?'RVρpqѦDd3;`}Dz, Op3EV_x{S_HuݝXlTl~{Y`Vпh'J]iXYޟS'wX}oSwܪ@Xf.+"5y[.fòSzUpOŜdx(V#wżyAT[AW儽/p X^R&%Bס$Ǫ}n4^kH?uf ͡G`faB/_m=3;w$``{!rM9s~其&07:͉o[ĮsPvܪ,th&ˆys_`|7'O0#eN<=As̕>8Ub2`TyhO vs|6L2<dܨT#ym=SoTϱv\ Keށ$h'^eX!&fI÷$];:Bt͑n L9D\ݛ0 )B9TDO˜pפ<#xNjhD`.jh/.$r;w5'3o^ K'+oʏQ!p6ǹAN=%P mTuF7͕or8t#1-W{}m@T IMv9hjѺϊ&zZT-0ƕHGAs$5+N@eY:$3aFTÅul˩-~sIOX<ŴQ-ƴ{4i,UlO"B ?#3Z6DZr%[j;O=X}u&aCx|cy86kOQxqs;Ht"|@o\ &^K],\1{XbR!?׭' #{{nFW*B0Η(`򄥸`zc 2] gC/+H7{DѿFX4> 7IEp%}~MdpxZe gӠ*(@.Kg G`خSï{7/{/&_!Yf^l_Ґ31$ET%nP{aNЧ}k9-=bW Wb+,7 sc˯ ^\$|ӯI k1$7INJ &EdEg*I6|6x=,t(\3Ox!.5}ۧ#ڱ7qC$7MVy)P6mhdĞ`O X0osgT9۰ŕ4,ç8:{KRTg];ƞNU}\2Iu4{S Ia05M[ ٫?y.rN6@=Μ5 _Z:mO}/ ߓP=ȋ+J%W0|_0 l)Q +]eU*|7h g1W(Z s"U+ HӉz`/ f-n=!)t}Z}3ZĸTW''m|J|*;̜XCOU7햟'rH%¯PzDt-:òX}9V # F M!ٮja6ck$ou9.ルpaMZXI2=*yu}4xMQFɗY i8 Cz<__'jR|&G|A6I.K2|Kw҆8o;һ97f237(ퟣblZ&"8-{f*5>.ukL@ ]8ܡb,vEoO11Zޒ<lf^ƪ^ź!S" O׮ \hMD+ yCG+ǬGa_N?>XwD!L|U ː2ɒioQ vFa* qp%bzt=28/:.Ǫ ~*w)+jL~?A0|n8Vs~5J0)M8~$9~CCX10ۆ$\mݾC%H.  5Zl;; 육k4r{g+D>)Y I۔"q>{]MUrx0aOTKZqElY)0Q Ѻӫmm{{ч0 +d:;?`s!x J6a3mŁ=4mmKߕbW6/'[|oQf\}+u@2V:n'nHmmo#RK̜y>CF,aӍդ l%#>re'ti[4^d9YJ elNy `[Чηߊ"^92=uZ_z\>'VRaˌ>r'wD.FLW7J&L|,jYo9` 8ĥZC#xp}դ.Xsݻ}=/wh]bk8=v<`8Tw"{ttaTC PS..\b{ >r;" `j5ش1}9]*ދ΅\0)(~W$NUg@ݻ0\Wv( [plP%l7yvg%=-HVCkLj?,{|\e͖ #Әߓ]6kk$~u !^'D>Mu\Duaw{ş]lUS*&?OL[}&(1׏P pi8|ql7 ص/=܆F^šc2ؖ(;;(|q)wޯLXti_CݲW(~u}/Mj~4~U;c*`U*yfl7²ܳIPDhA\\rq`beNzaXa#ӵSoZ .H$aOVMy{QL Nn$bJ Ći^7$۳џbGڤ1cg's8Hn$;azGώ/YG=8*Nx0 N\zQ z ɐZw@F$Q/[=T`fsyh$c:XR9?{.'-ɑRƉÔ,Pl>砇<,d'ѿd\MfّSXe%uXӣ&eu`N8 ?"Bީ=p0 4 K HDkQ~xZf'BU22I/~'(P{{\|"Zu".JFUXJI=^QGjGyPe7].SC4_y% 3$u3÷ϔuƏS!6ep踗_ٽp慼ONnF,pƈ}%G @훔֕+8:LQ|{@Z=X೨ 7ާ9~lEsн'iQܐ矂 [axiL6=REkn<ϕJRNX.lNωn+$_@MS{g\>'g%lp[ɇGs^e-^Pɍݘj>+LV'[3`蜗{Pqy:.ww4v𑊽vZ}`UjqXC$q hv[%ٯL 'ewo^ owBW<]=Ql `mI8&e6.Nl|5{nϼC?6=Fm7sjuρ5c8V5OF;5п5JpJZ<~R@09Py~{h?7GH&_#ܘ ʡy0o9.w7`'50U|i+\ I;D(:0P˭uu짠Z 0/g-N2(44#->ޱG>v^W~7w4\Ec鵚i?&̱qk,t`-p8 bCaLͣA06s^}v/*cEwh*bIuF$n6mll.d[ ܢϒ 3\oQZL)}F.)nOn/ ܅NWln2f+Mo>g`̳yzm8pӒVmcc}k`vey!55nM-_1`1@v3ҞR{Ȼ5Hj'vB'}!^e^/ Y~0l0(#3j+%\R":дA]b$Aᑰx~ 2OQ P#U%?N?t% 5O:.WOV:gcK/!mA/, #W0|r.+'N6JY`ƙǒs6:__O_ `Ŧ v5>fݘ|D.Xu/& 娬, ݤ Iv( yI[A}XI z8ǐ%R_FGHz|B}b}.-f8^3!+0c\?%]ZoWCV]) < =kjφ$KaD}i߱Zr`[}6nhA0> eEcX`ԍwz5WpWcNa-݈e, O?f\-uƙ_|51}u\nɕjUCvAu#ɻ{ë$~78:C('kirYWo o.IЯ;-)В\nkxLY,& /nuNfl('`/x&l/p4UƮ)0fB?/swӷ0rrj|{)^#`'9D#ZҏE[?`~w8llG2{8&6+DMNhO?K, &ASܱ=\& .&AH99Qqӭ =#4INh2s, (&dL%Z usBJ1T%{8M?+rGNy,4n_]ӯ:үEY5&N(~[;*`WSa;Xvxu`e4>Baj)X"vs$E/*'n} OTz܎';q)^ C¢e 6{Ty[p}0FXƲ Ln.}6=ܰfe *F {ԇ͔ps܉v;Ω{$oaSC w9֔8E6N\/ (y0WI8w^8L~zr+GW LU9ﭻ=O#ҡk^7 Zk*@;z.p5 Ƨ,kP\ 9#++hL*M<$7f\x2y$8ٯ AG~,M2K*:e脖-^m4v[SoMsXzh9*{s5ڀ.N# (Hv}&|u m%??~޲gq|tJy²o1\ ƶpb ֯q.mAS*4o/ 釡텫ln= M9qZӘ'˜)/xt[_eK21m*TWa5}{Y^وs 7籟?akr= [®1?!X)yU3>}@=47 :e+<ԲLaZ̖휕qMAU®H#4 bo.躠!@Aש(Ĕh6Y*ǯMa G66h7/^B6p2~d nx9%BS9D#U~Pnv TIXY+p`}N3˱17:n՛׌LO^Qk5jv-~fZm_Tru/*CtV]l9y) HH5Ƒpe?t](6s4v$M\FV@ v?8/mX mM]aڴ0t~m w=Osy)HI}:IR5Aߏ7H]UX:%+TC5YĠw 2^@KirX}t*kgiրY+[*?墰!s3.=Gf~S\ֵ\E?uguŋd,);uFw>H +62DM t/&RE\5).CV%: 3LTfW#84CmQo*qbK͐N!4y?#JBr7׼8R|f@յZڹ!t77`rI&H~s¡'@~94~>՚rmcЦ޿{wIōjr.4pP \fNnAOEw8!QbTf(Zr>4}X(%SG:}LqB;4L(;I1a`8#yqHI-9 㲾!\>cSPu(!mu'j5&j[6Q- 5+>8uu/np,'^!kK`lH1w:9IX=a~ThymjJ$E%앂+X7NN؎XhIGL ^=ZcohLfyWZz u_k?.߭C9B? '?'9G&b-Gq+=\ZzR+ `N"󣯷 W7JY6V>} ,6A=e~\si?b{dcpp;a<ǸZ2g%Xs>6t>#Ϝh20uKab\A 6CkzpYt:N|z3xK{oVu1 9~UYGlv}0D05%R^nO$L0VIDkPcm8N|~2k+6*h&?xaIq''{ oXcX(E4;.lBk#6e:b[*I~IRNP_+ک)$JJN]B:AꙋLon)ʜ%Y7Xcj}Xk.rf<5YD1Z|C`$+zrcRp̖njmE'%ȷ3R=#E}./X/3.ͤ8Ӷ+ER_Ɗ_)1QL}_2|WZŦRMeq~@Օ8fbpY##IJl$Kqi9+cvjRl 9Go;5@t=RU֓,#pU.C7ع6yLQmY @~󛻈gąsBK+kqj{_t0w닕^EԻ ?봴#/0\zJI 5ߏ4ڮӒhN|ڝDGKU2ABlws/j4W`ܻu[aN5 ?so4Z _sj%m:S w%- z]z؄aUbQ+M\#ڄ;״xgwô`bgh~>&Mr8ʶOY.Ҏv[뙷YWp! .+ҚN wj ?crjegU4>3&97Cݝy,ᵏ9: l-g>]:3YSMjެ#&Xt`@-I:WRT'|4rF?DE-lZ_wisiD` 0Fmk5ęg&U/oa{%Qq\J&3k}Uqti ӜibÝ2pYw&3<2n'a Sa0Wɇae&K$M7 &K ^z _+9P`dL];K#kO|8#E'Z=O\MQEdfy#GR ӱT%J\9r2uq=uj?9nDCGu0]q31U:[1a$Śf m%g|]߿~a{@ՍT\g[ t[ߞwZ!yvܓҟuͱ6n*mZ)܆$nq.[n%AÃl=7S?Z16O:\賮҂OA6Ek8y \=409{f#.x`ŏc7JQvY=tf%vm@=h;,c6S 8«}"= 0SM,NHu+xJqJ* TEjG2ޞbۢA{H!ul4O%jN>{) WcӞBכ7̶ْpU /ϛ2U I= jgjczJP/YBƕՋ8V>g.>nJA궁=Koa?v hO&aBQcjz0\ ( ̃8?*&GlV􀠋W|Z I6.]Wfn8@e̛d-r2ӷ@'ws?/,fu|G{0\c7j=9үC{p[јRFa_]|># k0Ţ$k}i KPjY ͝ 0F@HYĪRaЅY6ix+%\8o &68:R+JX᥺"5"f|>qƅd[&l3h[ t<⬂ WLA+S'_8LX޴äEj/H.AW/\ I[-W`Rߨ,Z;CpcF)t{4Eu%) JZKup=Vlt)ܞ|^,6t)KE$Kδ[GnH[U>ffJ*wA5ô 3E㶟;+]Ӻyg?Y=@T㫣!tQ:duݲK~޶&דGؔ_#}&r^$r1f9_ 1:kB}QNS$‰siV~juw۾.;8>=_iK&${?NycD':5#V_}v61e rEE^l:C\[Å{J%謫ƺ==UY@zޛ>ȗ|*v#†8M6Q^"oE88b}詥(d9(jυh/sWv'I/6y`u͒^sgaǶRhXx t33ft:K)f=xL;Rm;Mҥvmt19#q2|w 3Lh7۬Xb`꺠jKG8Q&˞|U\.kNon.qWu.kb~e2Hm*P@Zrvfcol4ќęWg> W L),e/qo䳛HI2 `9]YtgIs=3zj-pbL,>Kw}'Ku[&&MR呁pO°0_t:wZ"*l)P Ey{}PoBziH,ZRn:G3XPY]pL>eZUSy;=τs="G9À߮yC\?gH4VL:Yv; \1p&g :u&7処5n[eU ϕRqJ,{xMy{7G"Xٿ=ʽZ j8ks$^"9˺cǼd}1hJW$uXD,O`zxP}n ُِcqV(NYp gpPG >'o 37P4JMx3υ]۫4f}Mx^_c9iwV:i1ⷋ%1d)Yn ?f,q%JU:b'lv5Z~d:Iv+rv9H={xmWɸ(6+"171u Vh~ɾbؓa\{Q\Εnvݧ=3o+^Eg.Bnr geN1"I$ǰpE, *XDaC>ux%2.Z(U[gk,uZ8;u_?K'B 釷pЭXY:K/[zex]v1vù9($ldn=N=V圙L#JkL$mbZw}:9 {c>tZԜ@7Gę¿wGio=N4G`dݳDu-a'}Q%"Ifۏ9,^o]sKib u)Oa7<}g3i,*n&֏ f|<ݧvy% CTB5X?kb f{I?}sXg|?cѻYGn9󝺫>$'|(50{y2Lh_>)u.h|`Q/L=ο2~oo3_OEG/=M-zHݧqnv,m)SX?5,x ix{eL3l#Z}®*bq+>|]J^X4Iˡ/SNąVm̻qw{sh2? :AرhyngI(iMH>W?sj.p>om+I-+OQ}OR.JCPc}6*3X!#H`J jOejӣ>6] I|0h_UVz5kEf6MEy0KtVX> wCGbq[9'y,ڻ]D&+/q#By'= m?>Ttk<䂓g*;s%$cT䩇8,6& h1-V%&NQ.-<" !RW\i.5~'0Dsn|{ Yzg;lRA-TLps1uF9>Z&w}cU˦w"JӋ8"WΞy,sOe0Cr1֧8yg&X }UOSaNWCm(s4]䕅Gm0|fDP|<*N2>6Β#5i'ue5l?<wyo A{QЁ MRv*v60k4y'vOu1Ц?/HB.+ =FВU?omdTLЛhtF`v?7Zc)$xkW2b8O $yq>.20tβ tߓ WThP <4=R[C;`=ڕ` ҅ǶsPIAtQC*`3SK渳ӸZwO;/F@y۬m_qH>nK}3X*&n0 x/Bgᝬ `%F#`^ObDa{+["Ep:r&to`ΛyA]jw_i+[T3hcf9̏rqwF>uu0%Iцe0^g*M;ÀOLVvnݰ~>'o5ƮNe M9cc s,ł?ᯉ^ol\ӶyE ->Sڷqudg5k~>%YV/[׺punS K,>]qP9ӐHڴa-N2$7Vսhy aӾ)fKY8xٷK `ع~&N?Xx=j}`r Xդ`1+sFxBKÙ ˜u!HΉ=q*?BILz?y]e&e)oyǟbFv"VyFRsmU/oq\$Xm1~X$vvCOK{`[b=ɲ tQrϯTڮRBz7eqxõ< EȎ5yOnd=~'W§Ӄ㊸uFLkv:sμJ5l'a27,z(S|!fFرŕ?"0nN#gpTs!V-o$Cj3㨩r\ah};<ŦR+﮸0.>>/ViA2~CZcF7yp\u`/|(<*=t w%EIAp9{\{ ?{x<̬X;ؘJw(?=55~GC_ u3L0?қ!,{J^&KX+6OPwkI/쏻o]ȿl"(0<k Pc+/7e"eȕr֢:Ne 柫셯?V`VGN'+3>̉ a\صQq*3.zG=gI%bE_QK,-Z8VN|8=XwK08pm6< }Yp?_쥷+8!5;֍6Ѓ'Y^b¸4ե(N,[&xH.R]1;P?9ڰԙ_)$g8`^.0;}_n޿g~k'8I8ꀙ& pnkr1{.e^3}G5 Է{>T>KRȺՕ7drIX{[B ̤ԟ!t`;,d'XX䃶_ 0P`5(a3 k^cWSPVRuG)hg&E웨$Ǚ B*YPx23yKl|(mACI[H;1uDʼb Z Mnh g]Wa΋|/!7tfXu{}Ca$@rĈ>L:Sqb3!_嬉j#ZpL (byS1+#[N$TCZ֮%ݐ.UЁ/֕˛ʪP Y#vةշc67oq -Rq$r v}UWd7XɑzwSߛ fYZoW傃#*ṣ8>%$$I},Iي$I*YJ$ERdKB֒>}m`0_sΜ3}_3gֽY,;Lh^[k hL8ʛz9Bmlp$kK̰6OvNeq7G0zXfa$n[3 x= <@9`$\숝9)7٨ZMR] Po|,OJ|6=\ܽG2M^jl1?U2\`+c( T5j!]g;NjBeB6.tU#k<8p:sk/W 3Onwl#Rhc\9W^?˨h,wIXld;,Mقfg'\p>l8,\m]OZ0,(| 'MfC<`DىV.k?@][_/UIJj[{kq+ܧW:w!\'|w= ho{AryﻍdYNȒ f=;`u:^g!k3OQ/5Oywƹ؏[o~)j/Tzq$w^[LO=i+SXsWUdYbm)Ǘ0XX9%'Zo[A+eyZQl'<8by7XӮ'pt{חabbi :sj+ +<E@WuWa,=jzwʕ䨦&jqW ̘<PUiV tdj}qS\ľxÌ_]0$FL %Xn.c[kX{`Y}lf|R?hf=M*_f3慔A 딹B忯GdldR~kEgG*!Dc([ho*`Fo]X>f%^)rVSfɴuʃ|<&[׭`svx Z`@0p&R;ޞ20RY WoTMja;;[0+IgDC3OO!50w7C,$XS6b]ʻIbY6O{/m5GjeBzzz>@?V !UpSl- ncFSEl+{%F;Ϊ7\8Hp[ɦǿ. Ck3gF}Tِe 5U]0#9άe~~$#ݿr[N]sk6d+IF\gjWؼ>BP-ؔH'VC%#Om(xȀ[:C1LZ,R a҉ K Xfq7-9|pyu=&C9yplbƕy\?402/G`;m"_HnS:LFN=ش g%2 ׉á&|q~˂27< QxaCHdұDž40+M)b,:qڃ[:H蜻}Xؤr=㏉ރٵ~hq7Vr6tg5\P.y$ӥ<IJGgArMoE4qyD5w;M@y3r3װVm+Wke~^d`Ŗo)"zY`^Bt4HK\nuPpZC1LL9QFz86l|uđd]x͇|ٽY \y}\ɛht[ҋ.hsJ3.{SI< SϿ}%E'n:Bcݮ$u .8ca}b~غ߲^Ph*!a!ζ`,gE7Ax1GށKy8ɠ3w$ǃ~\>% BW~[o!X86O_6 4ylX='34ߺVZͦu$GXUto S:Su;n|6y!+qeA~|NY6b2{{צvyG(rVdu}o=hpܒWg>v#~HԀE&ǒ 8wҵI1 2.GK@όKi,smA/ \?g~1ĩ2+@׼fFl^;GYf'ׄ5<1/$@oޡtq>3a=xrzhd;72jX o…,l@邕7tecJ5U_7'Qz\u s#eH,zQsi_a9Խ=iu-BS.g2e*hǚO?n`dt1T9;o.wn^= R;P+l+ -`Qӿ_PIV±h1{} ΰ\д =jEI+"jv]~92 Rd|If)%u\޲d:z 9f%fP}70Ψr~7B}?I#v^БX-(CQ? a~] 0{J|i0+db}KgIg+&$jOV(T/%F؛#8kߠY6r! ֳCv]=i'L74k8h &']0v姝aGZ/,^t҃:!*n%֘P}gZ5m^vBVB0&RamT*'io> CZ>;' uc ۠6`36(T N>ԝ}ws<Ƣ,?=-5ND~  1L,hJ#n7$`~Te'u2%:0aϳ n%a/@r3sa:{WqkIG˸Z}chd8e` #&z&I,HA OXb+j~dO</$KY(~kEśi?3lI0 _;;ygOO̧ȑl uG|W'rq MS ?C4M#'1yjwHMğî+w^܈bú2YaVkV{SM<7ܪp禧aL/Bi=x܀NegH?xW{Fq]S{nB~TXo*0uy.@zҁ|0ПI$˫ fYP6V V71+,w1!q21h? a2p^];t("S ҕwqp)gk,qֆ Zi!+H[P#O: _7m Y v߰CsrL+gȁEKPѰ2'N/V|{8%cW/h+{: ypeܗ+{"V9GhHWJ쟩xz|{ry36,z$X?{7 ƢykkF(i)lK0%Z}M]=c Slե~ у!{n~M-a䞖K6E.sz&^`y( MK3Sic>9w:Jƾ'vQc0!tB56Ï$ޣnyѫ0t>|喂dmDjfpKBW,#y^.U zd=Nf^Pr yG8rNX?aJLPBO jx.K*C8&~N2ާL9t? >Hɭ0FrH5|-~;}g(~@;,ėVeK9h^JMm"aqzI0wL;k~Su0IRE{mTfg12W!2N@h,zw?\`H#@>`=չS໭k63NF1<6!rM~I{_HlԆSO.][msZvVe8]4']nO>,,R;y]/LHJM:o}XRSor>hC#N- Pߏسu0k'L$UƄ鍹aT0K`CTfyT+,ޱm۶l|5BTLΕvY?DlBŽ}fhFd~9)ܳ>|ֵfW3kZ|;MGe8Ȅ;oTox$rJtƾ-3}|_k}аeO!d+>4I!x-;G!{俠E핌PǮ~0LM qNŕ܁=ָxyu ]NVyel2.܊bF|7 tR<ЬT$[L[ Ƚx3ߛ`;DEN:'풲O"[fSFP_E)A֜=8zv(rP L=Z07k(\~뺑):z˳DACE98vѯw}Jmq`p1a|"ׄo8orp!j>h(C U"$o^/KꟅb:WoSmH;ׅ)-Yl>1N QLRyTZгD ~vTQdsd~+cӱARX`klWTnopͥWP=X*)*܌"n01|m׻yRcFM$7p:E+Yk&.<3֦$YL?Mr˷IeƐ!9,}IM;$u'/bP&tJñS3a G43U wVE-kt*=jaO.%>p~'%/A1[})v\37kY&w։!lWիL*3Y~-[L{}!D (<έ{&‚Ll^fN0t=. c!#X}ۍ)*1)Ot޻/q(M7^<~ ?u:ᷙI]BF`!s?͵gg]'q~t@չvVs \vIJ4/krDً 0y:LuVo6dTمۅcǰ2COᗷFj/[huNN}gl}5tZzn`I_P+C^iکǧMS~{O0eyfiN jnl\cҪ5;qqHc0\ݟ:n1Eo0LYꆹ["@hվ˂ + J'GEErL0.\wcwr4ճ#/np6\]fYI>s|_=%4>^8;7c7 \V̌su?Fak[1P[T{qߌyi P}ESm qN`\C"rSnz]Z]wG]bש΍GKO\]gk[?-ێĎ/±|. 榲a"(8dztTV DY–u: vQ|d+dܛ\d.ϭrei8\kD+u$dO"\Wj2S4 ?g &ar`/ 4ڞ7|L _^ (~$ v$ ylDxjGw-ɥg(Tj}j#վϪ|}f>  5;aD (S;CUq?a&2[!O`hٕ}= M N &g깗]_'6m׮Sr9 D?8wvH ȭTN[ɛRDmkr~^\;  7`]rOД|,H<) /`e{g2qRÈ I\Y0"pK'P.sk^$myM.)lYoV-oD*z?{f/f7'Ӂ%^HŁX/txNQH{Z*y00so;u7~K2 WG<GL>,w4:Fo$IA[#~Jrlt][V\w?ZXFgU$>.NnzdztNn]?cty?>ag+2{qz^v 7P񾊍$[߿af|fi-s@ -l45{o֙0/I=~zֹ٭d.z]r]u Wˏ^sB4 WV,Zw%Y`zǵ7s&:*8vYb_EHc׏gD򰍫7(RBhԦA'S_O0b=.؍g0>%p%`eM:y/:i”Ѣ`EL,OޘfeeG׊:ۻٷ{.¨\-7^3818{wz9\;W1Q >Kq\bW`Jxts]wXڸ:Ү&<Ä&\*t7v).}cV8)gW9ɬZԈ=o3A[:* "AOymMwd혨Z* !ϯhj:nP"|IN*+9afrj?}wLUVnUȎeqz5,{i2>i$Ut+&0)(8o4TȟYP[fDR:>7I)t53jW2qS J́Gg ӭW¹ bEc0Ri !+JV-˭d7m__M~.Ǟ!ib6=~Mz/.P;FUDku]ё?>{,wOJ:oexps4~eΓ8eߋj9_y*u}<̉C7\ = ~FFU+` 1гiW ynC]&}ݔ/7kS.=68wZj:dI!)/= ^vF)y Iu!0(8kAY饴1qť]6hK8GIj #22zEٱwqfOc.dK;76 j۸&qagoXlؼC̓bpQ`S@ӎPkO=2=R{qC;Z洸ۏ O'".]x/L'.ޑg*.-?zfnjp9j%]l Wk*W^{C̚oRnX@Gr;K܊X3n KsM6Y@tR%Rm1l>| G5$?wVB_HT]pKJ}?ELky Bg }>]uj_#l1Kq8xH;Id̎^º38R{H*;ljIW E0ء)%i`;?KRr?z{t_>]1{F_aMԯ$N X0% =D3Pa%m\Q;jpjzLunʏ#-wϢ&[Y2.iR$˴x{ktże\y$S\M5.}V{w)sώVNJsːGL>q?0_}v^JC,MI&9MBUeűPu~y\:N=lcӳXSE{~@߆)9X_^Z~h x{Q [rfAhY W/R!y+7el&6/J-2zk~Cˑ${LJR!,JohLJ&ڄðU#f+&XڍO{pfù?c[jcLh¡Q}!i  LʔlM $/a3ח wv" ΂78p+Iп9Z\sGHcN/%{4a{Kqn'] Mdnda;3J[v15K.ԇ;R瑤`1Ρu8AQ?&EZWQyhOSK':j1S/w6.f =;z#e0Oɇv$t*`gg"dsС䂾%ߜ _8#ڍ`?f<|[=2BLKŕgzqsWaREVT>ye-߸;˯AOu7LI[0 ,?f>]]cQu!KOq;\yKd>So,ExwbOU{dtf! 0XJ [ć`~u]J呻x Xgc2Oi=uB3NVLB+ [Xcd=,DɍViڃSo۱M qy(M CWrG;{^mf` Ģ8Rb"<}sؘU@7i~.El ٽtOE᫂\_I ?~Y}n6oΟpɇ /g瓏,oF!=xqʼn7pg5PziO%OM?I{mH|vּ)ct.eqh].,||_BLJ'qy84OsT!P5}# z}SkwId8;tL1@ ;/^ ;jFk'o2{N$t-XƱQOS ҇);`l!cYk\J u)[U`2}gyj]2"%5vѷ-(0&c)qx|e(.:@crտc)c?`]<[&m%Hm<*؇]%T@#Ւo\춅8mÂ[05ZOݽ$&PΌJ~dj=nx*PŻ/ƭoK>:9?:^K|,:AպWqLEیklbY{U(P&xfKo<ɾ o$l u_|^cRV]Mku!,? _R!OHnf6珺/ 9-Z㰳إ~0c9e0;|w"Yc_?ʉQVٖ߬??\~~SJ~z_XM7ٿN|PZ)G8+anV#At]|~z\zHM +eye`.sYR}?pz|eEӖdB5IozSC{;,2ڇZFp87<"-[j\:Ȏ{Hg*6xi &c`G~2/Ks -ؙ''V~=PQ1"='``[M#`*p^ӌY7H˫Nq7k^[Ywm_ڸ%e X6C湊Xllɺz8lj7{f'z~ .?jt{"@5`^o@iQ'E sgaUl58O۱|cw4 'u0%. ܯb#a̎kԿVaeOQ@Ĵ٩.'ҞV  QE ,H,t]_۬Sr"9F^P™`8>){Nrmޘ|"T_WR'}ݜ9O0}sv ={ 4u?νec<[<_A× +ǾeH,Cor~*R-jzMyTirz5~o"eE/.À_4 w6)B]0%|֝T&3BΟ2nS+^֩n"NjuX)CHL ؾ+kvnƺ%Ӯ8/&ix{3B+q|tG8s^ɜKf}ct<Z#aK0Qou-C۽o%lqp'8rVsMۓ# ؎cGǡZ5VS/z<ߑdfoVc!.}W1δbJea&E+6U=X82 qwI ).~j'>T=}>tkk1ܮ# KImyTpoxh1fgԷ8y[7;%ok$ /?ivF9Iv퇂CGUWc. %3ͷc_Sal\gBg+9uZ{gj$K3@BE݄(et~]ZE`#oYJыKkG+ٞ͢XҫRg7(ġ)9_-N}Vu=;Kd`CCAУwPC$G8\='hovcD|ch Uڣ/_%#ɥa, ^)YŇc8m-l-P2⦔G,`:^RFwEs'KL,)2lvG3Ңwg `]JlDR$,y4Ɖ&{ ⊲P< 7"XcVK3 44KᢛcN&L>C#1%8{ơw,dʫL+y9fz;h`#%Yk eX^Úo8q$"/a08Џ/ZM'sIwfhr )$S)E.kLI*8I?.lĪv"`Ee ayɳrmiy.[S'e9g/'G&檝LkztgߐƝgwF;Cx@ufW+h~//N&(:dk|upxErڈdrwګ/^!.lzhKqBynNīV9z/1#4I5w~87"ؼr9ZSZz@}"ԉCvOt`uخ7$(@~t}:s,z=n߁y}Υ@g#GW;,jxt [>kma .nKZWlj8G;L0WvJB ]=g悳`6p,zKnNHؑI5%9Ql7)G27L|j Kt1ԧ?Z l#:FARaf?>fl+cqe~x'brO$eQA%g|ɻ+Yxubأ{: bнؠZYXKثLmU}gNͨ:[A}[I'ca$Yx]he_8UVu;yu=ssȧ5k: ⵍ$'HTus)UxB_@ [6LN9__Ŧu&lDy f4`QjI>imm>5B+pHtgdtEz6s齁Mޅ™55waF]$SEU7߫ܛ #g);uƉ FR8Pz֯_  'R?hiIH >Xx.G6`oӭ(F;{ ]HbiuW HuK6t+Sb\43K۝QT]PR '$qֱ4y3 S\~-j1=xtfdOӼӏü/0qW!xhH?+;ЃdNl&қΌu q͍WIGNP^G0qmopxm "ra ^7Vyƴ'xořo.b˖mqCRA[b YhXzd 4x]E+9SػPM~PRe#-Cx,E~/VpaͨGJRI.MÎ!}DE\+yڟ7 #۟l~Gsy.NnQ'v5߰'ήPf[tKK'>YC71?fʏ X-))}=DtF/5bOt\]&\I6ݧ#mBx:\\%iuSg_ƊV EVWG`0wt:L)4VNaZsz~0sOe <.zg)| cv iC]qKU ?ծ/,T/B/H.i"֖wP(Ўq#~tyߘVoRݺ-qSt8P -g\':>U;'nf?Yѧ?v+5`lP9ssĀ0cM~L lU$\yCW_I8/оB?r& :\xA9kS7L_}%N㼜:0ةRJ 61p^ȯ)+\̩,-pZS#w0xJꦹBVt 呃3UHUu:NݨNPN 9~iX2) 6885Hwdq͝.l?#7rz<}A#gxv>/Ilr.ۍwKhOCD@=34Խ4łlx\k]:#`/x _Ůڭ\5Z]tљB.0}Jf8_Z^J.Nvg0Ci{Hfζ `(y-I2LdG2%р&C`X?x)xyuGOn>9t97(KҚlaqsj6noQ, NvqfېdXb*"7 ڵ%y޺Qx2&Qpw Z(;?1]{dk(VI}NpS4=y/@o|$XJ G6j*θAmKUUn4&n ՎHu{yp 2tk( 0n]51v1d %K*]}c-gK;9wZVNC>]?]0Aԧ.qt_C oC2p[~=_ڷͯ[Aorfs\hᚷ _=?\^:^yU(4m.I%WwK3fH/є]í\8*ߞ-I%d'U_3Pk; SP+&Nz Sw5.߿N(iΜ򱳯I eQ}0,hq!q[,B=a/:݅7~2V~ L$\~֫8w*Tǘj!^C8]yW}/Tpܲ7/06W9Q1?O4TCa5$Dm: w1lx/Eɿ~Hۆ/ٹ ˆ{,m:{g|xh$ }>Ptw;#HcMOclNg7|} 9^%wTG0}2җ"I t:]/H9s c6Nߗ۹`:Xy F> 8<΋#cQ0X/ Z{Yo<|v;A-}LX'I92s3W8ɼl8jpj҄wl J}աg/C*FN҃9BoY8;:+`/ݟw>-G2ļ<8r<޻*oWg\ {T bIr0z b}HpIm>\Aɔrw7zҧF% prќL v[PNXݟfIdoPK gV;% S? s9;j;aL$ƋRmܾ9Լ {N X8C9v]wgqY‹ # uh'g>넥qXT-W`9$ ޝ\a1hCQ>[o>{V+>e=V 7=sT_fFe02.-&9w_l`[!y} VBߪw$ʙ&84V*Sq,]~VpwC !f@“%o^ yq$?s-oslkN.Lmg&hӉ |z1ρzy\}[ߎ‡V:MCE$.j܍[9(¡ sWg'$5Jǘey j]Ŵ'P*>f\Gom0/#]){Dq|S¿ʸ- |vHa[IQ}NUh#BXαtڭCu(Ry8T5yyD;|Vg 񗏾CjmͦУi,[Ե8H}!횤 0)V"qpw;Fj={tdgNҠf1 7&aNEMWHD'y,5!aL ?;䖕N|LRGFފsnp<ǰt)1)YKbO?1ɿ~XMq[?)ot:.F8$`s`γm T@~A*v+m7LT0+EGt*To(^ȇC%Pkxӻ[_>%6c \4Gll(a5I` +ɸh|>Ο[iސJa.8brt_;&y`C_|/N jΩ4MjAV뽝w8S~ cj?*}ɧXDV|}E<̙dv,4U= i~41u3aՏa}X=)fG7և GNXm?Rk&P]95|Y^é%l.܀ųFN]apʳAhiGYU6l'X ux3BH]g]ulCϧ}B'ߙ°!y]iOpw?$SKlXdŽ ,>H"iS WCz0uF^UjƉ~lǿu,geq9ܐ>u-kk7\'׽L⇼Ρp.kFn؋H`mY,تӑ`9]sReڝ e\`M9oMp=N{ܹ -anChU\q i~y-gNdJLnSYLoIbbxfckqU*<6s&V䚯*S@򟜘5Dn_{c7iҳ4%y'J?T>žE; 코[sf 3GWT˷9@s3h&&,2 A0Âu^j8$e6f==%wca MR? ?y>@@? ޑzG RolDV1 {tcxEo~&NŤM'aKw6 Ĝ6rEq=L[m3MGU θ *3Zkc}® .bAeJ\4̐]oO7'0K6uʼn7šBmdҳжmz۰Hp0kzz0}PK l5P v, U}pJ0>]gI)>g%sF=81rfm%V+_ur~K]3ᴮ3{'۳@Z0c2MÂ'+U-#}F_n"MHĖ8ή8վd%?xb̛ gMe2=Gaxo`Mq&网Ǡ_B}vGa 1f`j=$Ol@ê8;s;u  l=_~@719?n„^2āƫt1d>DcAIzu 6C xYl֫VXw7;EoDEl|pa!sF?k[86F#xN55oA eCSt=.us lڊS efB`soQm0V)hQn#V ;SėώJ߹ *Ik-{I-?v_Y#Et*\!bK40(O]wzV53샠u[?bwg=r? G-~0j.X,aw8yKߞ/ZV?nF4Nm'&1WFIpl;(Jލ'*$0Xp2|<|sc!YcoG_~l#{V}2VOE:R _zջkiK|Q\1?Z0vO>[F˴رSdH*3.Uh|nn e;ؐ~d8X1gAdcB`1'ٜ73<[y0';_qz"xw}\1;Whr;=(S~=Lh'=pƾIZ׈7Bޏ>j{\RFv)2uĐٱy6 ֙V(L=W {7RGR6 ^)$󴛩/˖i`s{.qaڟHJzJNJ\# hX-=r%߶PݡbC c#R~mdkxt +{nDA_I[fz[ݻyR|bҋ߮K*W;r; r=rnY5?腑06u $չw==q'reaAUy&>V VY3+-_XsvZ! ߳ rvdSap/-5|G wʢ}\TS0jМ{տPH0b <vCeP<`iN՛"WyTYT nŸ4FšLzdܪ~]õy0#c3:eGI}Jo?o%4w%AɯԜ@)\,Z-7|7|i7] nV`rԏ0CV@ˋvjs; e۷<oʅheP˳0ܤ8Uc#\&tM;N`l;Z#bqwp\W0pf 7L^;No8 RvZfr2`gF㕕)E5Ь(8F`zוkAXh|XCk<^.b#GUx  j$I<7'8sҍyWgx!MwluԚ Y9ɗuX3aAֻPuf V>hEĂ7,։d37ۑj,~>]6 {3m o횴*R~)rM@oG\4憐_ϞS2ҫZ\~.3,<~O?Kg:w2"cݺ@R5Wy}n !Sqt}lh=0e=zVML/7ݐ ۿ8ޒ694oFUS~qlSA+:$ű ؘOZLPzʑ nCqLJsXi0b.0R-uCyyPV"y*-%vTBΆm1/믦噸(Keށ?pR@sj*oҕ.ǂJapodlŁ[ X`|_ӟ\vؼQǶ2QvC]ưAɩ:"Ň⏃$DZ=Ԧ6b-F09՞xǤbJNEpLk 隙Fu & glΘ=b MaYEffNg; zgYW.oKW%3X.SzsɷYf|r +ظa/4 +LLm˿^ؙGsяjoE ҲB  L!vk\<+tj(U0?$pZėPA]`AY?oƙˆ#KiW VqqfŃdapJ7,2Jc xÄc0g]H{eC ז9KJ/*HFn9\x=uisox;yx\ƉG'K=5$jpskzIQ(,=΃#3"vZA]mR27+%CMNOsHvͷ=^z.IH\gˁKql9'Zdhr۹-b[=8&,#,:*6<\Hm~$#B*46\HcǧU=ɔzVЦL3ݰ.\0 d=3fpۘf@)S&,y?&Nuot?iEgU<8׋i+vTyysssѢռ3/4`!R졖Yo!9wӷﺥA D+3b}&fsdNVNG:}qpGmɂ/ƛ̢洠^Q vv!0ЕS7ՒJ:_dHV|,,,ZϖF,#ٿ>IJjҼ|`dhc/+N,ACNCs$p< r5|2-HW4rRGXo4v]QL\^unnwm:uAO2̐28C#V RA0~bKr],:g$bc|֎jm c;'u*)xEIۇmW'XȤ)l}Dpzs.mPgg7Gn٭9qz[P#ƃLW5|g? aMۅu_3ȣJv&Y?߼7~ =G抹8u !=^:KAڰBa ?EWkcw"8eמZ3ÑU89k%uǮ7C̄_#*h5O2+ǀ'^cgVd?H 0~N4}6nRu~:ܦ&R9yݚ'ʞ gD# 6͚3aH[檲#̊Y<)bd5{+/d:P2L2\Ѐy/Ws˓wtێHgTjl{[xz"ҡO7߸:~w=YHq-Tbѻ"90i&\:Z= I>q0>w1O5 +ijF xHG.L$] '[Nnɇ!i[uǦTbϤ~̍#{0/zfiF$7ސ͍;Iy"ʹ8Kn5cɗ&o s q#)6Nr11x}oבnjԛK8`y8HD_:v!2O=,o̥47!c?n?c'>g=H7s쫈C;[Gc{d\v4 ^PDf&|dC$cR}LC c~1+h-$GyG(]2ː!V Sh-Lpi[cS>ursK_cAAYlS?pw hAuw9ꥍvdfJm5/xM`KjUt=S~vþ'3(Cgx><7rN[IJݱf0%"S>f1Kk,l75P`J|\^Tۂ(G`YvP˱}H͇ꓶCH^ :w:#xvB; 7Hه/6=MCdk[a5wmaCD oͷǿzaM~^*F:?(r_.$#XhMRNzs -~ I8ac6-q}a&󞡔)߸u>`a@ BkKpR7.>lMHRt?_KrUR B;{} bM_#EFuҰRd(4Nz}:N@ue͝I:g4sr#6=V ŖX6;1Iu>&}G^!^bμct,ׅ? odE>1\q<(uF?h0%{Jعĸ,3vrevfMK5f25rNz6m[V1!ƷGG:B29L5|/&(7A0ޥ6t]f~jF6gI֊1!qwt:q( mC/jQHf泹ꭖW8% 9U93Edp'K0 K F뽦.qUE`[ xdoYoׁԲiIREo{JgG 쫊tqt՟`Zu8>ygz"&}^9f(E0e uB:OGvҜ{a:#6A*PeVMHԞӡL;恤qjyx'z=9  +a팋/^ˮPezuI5zU.+. -3+v6N88>+sRKыz8!=vY.:Fh!D)n8U|.?tz:lj;$/TFY!U,u1h4? _iB!s8X9t+.ń*)u`UX 7>u#r:<42$Ԛ(|4fZȅ k;I.Y>Yz<߇hlla\/XHsUoe|Q q8@Pț%4b;1mg`φlo6%{k]?$b.+@ݽ^8j}dǂ=RUXG/M ؘkWd/=n2EZ@iiq%${`bcG"1]"e ÐQObW/Nt^aO$i2Q_Zr㩞нC;Y˪E?}5>O`N=W>EOх[۴.&)B1rG2&*=bzU:Wǩ&d-'hC8^V^[⾢PTC2~|.Ӈ#e.Bǃ]2pq'qKv7ˆ/ۘR0N!c IY%}1;7[K?u-N{3@0gGۿ$ťC#l?U4.r}fGh3|#C0.Z.Z3N/DqڋwXLgC_cH*kf HXۦ!Sjia:=qYY[dֳ78/ilr{7otk[^=<`nr&ΆZ?,}ĎS< TqQsunF"Ԃj!@j; 5B;V?r3'pɾvXC1*i$ECmZ q^ r]Y{#qh..K,x숂sVH|Jy KLaSЩ&:I0>4O̠%R\ .~HSV۟_ cbbn3Qa<6qJ˜z&tg@C8A:_(NɎj=0&(M4GIg)ҥy}_c$)Crϣ,ᗟW4)%8ʲ{op8bwbt|4w^ĕ- ?̣Зg'{VXrc>.s@V:qF k$rc`JG//_UтVç#Nk/.r@JK|Neߤk7b}(sx_8r/ f2}JHz",J, YN+}E69'-Yðҥq6|#]*ɨu]D<>RۭCz vPaxeKp8IXV0bx#k 44%ߍW|d8'osA0ˉɸR_9ܹB`Q:_2biPw@v6Y| RAV&ǥ_P&N5 MIUnLyLYOjJ9m[a%_0N7?<@FK,pfPz/O__  ر,,'ogmOM*aМhs6"ODXny= nJY "q]}ԯI>Cd X@;V of}IR$A@P:_t7'za4C`o:dIKbؤrKEgzB'.4w6"7ai"賚|{nQ"+qCݟ0%E <[= N+8Ӓs8=Kj?[[?ivowg#iVى7辠WhD/ X\ӏ^gc 3;wmLjnW1c=,­% 'jmd9ݞ`1cԽmZҔ_aEїUļ'.U[Mޢ8ï笷&)P_߆v-yHL]zoB^@!O:$өtM|m<|S&߅_cA2R}*TC/FBGp:YN)F@d@ *yHt\9S>kG_[`׎=_|ցqC@|?Cs-\v_&Xnlz2 K6vZ0(T523vSvc1nPR'LP艄i6%6kYf+Q]SA3I/F"6ۺwtEjw!tGߠ)eo Ă!K*fk'BmEЖu/xe{nb.ZF=ɥ6~uq0{Mo-#Y"e&HQ\1~v0֗2W}xTe%3ydϛ۳"%k9DŽxHAM7Eɫi;LUT򓔌@=r|\V*u{egG2xggp? k2e|+y*qX;Lr$t~Wl(rx>N!9C I6y~2>I0lmyRxF 4 .\:_=Wغ.Lw~śU'?caڻ:W1oYS]7(@XwpQ! tӯ0Kc.@U\h,QI!eVEgѾč% `Cn0XtSڨ vLjTC\eUL[gS~܇5y~V*z/=0{gtT.TVdئQZWUXd_x{{+c`+!+E7>; NPaזTFjHH~ =Շu@߻LχoWTr̷ "kqfЉlCWǐ&%#aTc06 9qn&>' 5"];p.8V3~.c+}%͝$ˈڏ XW8}OY =K zz\;m󛠦:ʒvRaT&9޻X?*2w%7C?m۪BB4dd>IJYLrdX&),Wna4JúNV4g.Ķ{,98m7DU:9=0#nG~:7}9g0԰#$.}-g=S*fucPR)^T SΌqqrFfl/: VA Pرc-=g_IlՔІԋ֜ b8ze"p=S= )), ƙr\uhr)}yz _q`imk%XPi6KpҤ~! 0ؽM*=%pv]q|iR$W|dj Є~,[ :vwX0( y v7tvDR?\e^`;j XYEu-&j>Hq(U4*r$H@{iVr.GuH&YsHVm/R8s:k֘`@Au:'8 oRJXqJN-Y_0va|4u5tAR _ڦ> {z>wEx]ߙ; rp_@/Ţr>Ñm;5|>snP"r>U?xvvjϤJ֮m$r=UX]!)Wn[]NگۏX‚UW$$>H^9߅JxnA[Gr2n#Ӧ縄>#^(9۵PU*tY 4`~.߽>9i=ʂU[(/UOoc+qBeJ=,dYUØ6-7ISʌT葥 CI[qؗμV7;;|^3@ϖj%Yv;iuŊ%t |m1/[F2\sSơ+JvX?g>q ޸Yչ̩\kLkrm|^A[a>{{Ng6 3nm_îO;_9 S`OFY~vz+ɴ]Ӓ=;5h}<W"Wavͧ͞icbrt^W4+#j60fg5CPئ6^A3MXbޮL G[^]ڌe )+'lE ,ҝGŠܧd$΋ ZKaD׾ ;2TlԩU)l^tm`0cu1ʢΟND0]}P˼뜒oJ2$ z{~&<=cFZ߈#Kq;Ny%tUM'/"$jN0rFL8yRjI.gdmf? `HЍ}IR ,3thދ95/dauoDg;,y|#[>luə]؉o &5qfn ##(2;f&+0+v@ $gj[b2LMI$ɭ(g7 gyYx) =w@!SƁrlڑyRX< #teql92%Z˃UKġ>1aC9Ǣ_aa󭿹p+ƐsVDΰ:O-fu> Jg ϟ޻+HzcaS +A;tԀ &'vQyqBc:Uȉ\ՁF]oݬj\ gT\e#ڣ {QyI`-7RQ +&߱SuS"jmt!aU O0\8TbXSң7rgle( ,yՌd+ͅA 98Sh3B 1u'G0Rі.M8h{Eɷڊø&BŸqRGq~©bwJ*"Ie=8!irq$:tfώC=$y'j-Mrjڈc\OnbeO M 8ꇭ[`^Ў l Bꕤ'=O#L `O۫/ԗA?(G2?$+Z~XbvC[Uar#s+ݎh*9ݲiPZ#Kw=*rbyP\_%/j!{`3"3T1CtYlＡ= =o ̒އ߰_9^;pGp4ތۊ8^=xъH>?Ǿ+Xs&Xq.-rꦟ"li-G ;%$JAZn9nD[Z>Xs|\M:)i &[LcFIL1އGu`N&n څxO,{T†G d`mꘊ!ҢFŵp.st7?'YMvV bI2&Bگ+8e&&kbksGu 0t~ N0^a9N`Ux9IНz8L0ۈ۸TXSx&NSW30IyzT%\ zLshҋ? qc .еTjf)&`SOŖBiKU06qp*8@{ ljc/gs:3t%vmt܁@i?8QPXTyj$s{ɐ"dƯH {5/c˧<`,{-_̒R90q)4I 틽O2*h A@w  /M/R `( (:p'J `#Jll,(9(s{oTBu, nFBcgAXR3'(G+׳xag"fm3ɵ> 3wR:tPQ_\~t6K /gǩХ6("Tϳ{ogqjJl?TB8?5rt#v$ÃҘqiU$w=)obN!></lSKadkvN7wm}+âi0_]% h I8ޅl^xgd{thI&LV6k I&}&G^<ƁOGc۽ ??FaI[dy9[:O,`H^Lf!B℣fFzrS/f_8~6d0;*/_V>ƇM]Gvcn؇O@su$/p "Ef)_mcK ˲An.gۉ˻9l}fq^qHZne(VudCpWgK2gt H=Gu?r:Oh 4ò 2Wy>l061^4>#<3PK?zۿs)1"orutpG=cCI2wN?{d ܶ8i\z<)QC| ⍮%ˑӑiW@2Xů ePCfQI2NO}{ć}m;^IU8)n="z,.yDb-G.<)hG(r J)j6|0+v׏dpz!$?xF L16)KFȷ*a2lˏPl?y?JT~="΍X0'Fyq#j>cWKx s"IxafQHlVr)wi]3vw->QWIȱ*͵[Ir˃xE⪾Jnj!C[lanv~a m<L) 7_E SuwGZa\拓YvǦ&悜m;5KE"&q"^rXjp 3-~3 v[Tr )k͒4x~Y8~<[T/Ȉ $R4[$8p{SA](;MRM\e`2l?~v~$TezVԞ ;WD׹8>*od$V-?;C;֋w` UjP&lǘJ EEf6A95gTIfPs0hc*AZ@w*dy7$mㅖ}4"q S:pر"C +J=lЦzhM}̴NRwb!׶Rπ5y8ȯ*; 皻075 AX9yd=WWZGp!nGȼdn㪵ycVV^$%'Wͷk9|̕WkmMNQ o^/`5'u%j#\1Mn6l Cq?.âQϭ0(sg<~ i*li;*OKk_('f >]{Ƣ?*ʬ*a$4{/Xx lXji1G~5VD CcmM\VBS\N6J-1DwRo>9 sRoYhG -axn?\O\vPąo1KĄA?u hq>etN;M=A_؀kK¹j3#+oiOAn{J~_LQs7?& ]9a}@ Xb(tH}< "[E112.m#3K=7źB3'TcNI'ɞ f۟`@!2pYE lhg'Do?e6f'PrDVz/tbC"9Jz~;V9D2sZ\$KUq~hdt ~q'`v#І!d(S[ja.WcMM4{[y+ND·>:ihMrO???朖#x1*o^:B{ὝՇy$m w\쉵qg)\9K vjᔻ<06Lw5xT $3UeF)~bF^9mh>l,f]]KRbJO=jP]S ~=/+{=ݪET*YA*`~( YƙD:?ŕRa`_hk<JKBʎZYk$s+>8} .V> /Unk;=6*.qZ$B+FKSH!D.k 'pv쩫j̢tl,CÓxj% !vF2 +ʪVszP`YEU?%4ℌD0Iihiڻ_7*m\'_p˻;i,̫(FGc&O.`cP^ .q8BeG&Z΋#Z>ę.%a #' ?޼LSn+̂&>S]L'1^/<70h{ുY;NݶWn8yxgr[2pn?ϾK1$|3PF~ ɞo!rLǥ>'Ղn\Gs[qUΗݭ$hc7uz*zCѝTik.7wu:v`}ĪN j\~%J绅|b~eSe fd }@a7@Q{߮v O/_o$L29V3VK’Beh t\1 oQ$'}c$u3\a1{Kۜh{3l랾sh</{yx| 9s+F0%!8СyV Ȫ >0O5ʤwzNh.&ý3`i 7Z쾓%c;E|8f:YpgtoqP pŒuV!8-ذFh|$ 5|—3BҜض d ,Ca`#Qj˟?OPĩdǞ~Ģʑu0pYDE-++?01M6C7⛽2::naBx2_4}bXr jo-ZaD|I7ږyۉBw@MLTSÚ |o(VlvU̸Z~$T6}}¿9gR8N{eW.+eLDAeE,;w\)vym鎓o3ŝp[ϟ.3m.Uz}Xq"X[yzoiL% %*T:Oy)__68icҼP#N^r|y~?:PZy}gI?O~ 3tM=K$dֱ֞&^csŽ˱Gh/ ,;Ծ?y |i Eou!&@Eʆ –4Hv;^a_/_pqI4O9V8i3-WTy .7(4=82X&A9oW'#Q7xO&ko}f']\ZaZc%.lw[*#Ϧ;=;a?Thry(ebTzI' <`x|P=~z9={Y( ~Ϧ= )\ ڟ;P@_R#έ.T?WaбL5?AP1gl2o&I2W1/ύ4s oQ-$S~0NY+w D vvX3':Yh]k/Y;Fx !Zak7^Nc*=R8ݪlPS#7_6AaHܝdGsW  b'_ :Fz۱o3jVHifmSaWH gnP'Q(Alh|QSBes?0ap5(?v]{qWE?l憓GOG)B擢oxq^p>qu# >03$jk+oqKPuC+t|v*hl[=h{OY? RNɎqlŮ_@ ?|.b訞bܠNÞC쵅L^Ja!Uz7w3Eې~ o" @ku#~*"LDcXy}2=Jwt=L҆:{pʹTqqTZxTCƏވ; )L9MlÁ>s_K魛9S-Y韗':8 K lTH#6{J2{<;k1#̋:񪹃\8:`v4c.p}' N] zV i׽!LYްA* (8S )^:/ūL}޾MwXO^`;%d>unP2VOV۝RW)AG>WG$ۃww wl#RzZHu?q=k ]dx t3U.V 8ҫ>YF:`<_:KA /oޗi@SpZnoֽ}f 7V `ק͒V\w%%}M$a6 \v,=o#`cY un!B01eg{l%ncA ͻUU2=."Y6\ 3N9rw&%qWѝ$S G;G\csP\eԽ@5ڞ.4s``7ߏeo0-V[2slMHUTez@eoU[P2/JRVjaٰ'8cqQݬKr6ϻ<:RqBvw_ t;SOV`EoR(5^^;nq%uKAA @mKCw޼;g/tg#{/G4py 00+W=gxKeHrݛ%8pfL]Ҁ),:$ȞO?I&'L8cA ]Z_OsWG /zAlio ?%ז0uGaPfs} oax8 #O,bs{YOIO܋\GzUݟc/TGÀߕ8~h+i#;1E8nZPJO0}޻KrFI,pSkzH~o(7ިZCGEg3HB]H+0{N2'w"wX~ UE2K^h/S`{w >)(Yoi0Fzo(Z8OY, "o;.Z$EؕP9f&ary:ͭSũ *i^ wKqkL٣u O$)lA`Ep )uud"6WсVaBTriuF'XnJ9ז'Hփ'5zb/[;-@eJ>Y/NxתJ+@!6*hk|J,pG=v|=b, :K0]rrqj{.byj6_I!eg O&ix&+ o״9% ʃ[&.e?& 3Oڮo4q#@`3?ݑsO&x`F|$]Vg.j3iBFBqug>*͐ҌNIe%O2@~dT8;ChЕ+HJfÍ@Q74DHەTl03gIr\"X>? e=ڿ >8 {˵0R¾7?'N8 9"Mݔ΃cS~Ⲱcu >=6~#ۯPG*}K*[q*Qư8/¿aݕ~AdH(&i{3 .*~wKHFէ72 okQvI[(J0wE *ۋcen;V}ЍtB^7-H~؟'޾FP =:NܮNy)Z^\1:N0}PV^К]P h? !;c׋t Ozc3Y|8χK3Hƈn-t5i3;an.'-A7jv*>0ܧ< sҗtwwh"dSG̰?/@W|'^` .s pًUU3+_mьå[ S ~vl/깪d|/4- ̠^P~ߙ%7by3~P2z\gft=p;% sMcކ71|~jrpk"@Sʽ 4~jW>c\;0B~˶o_2smRl2wvgKVscӵP I8g(qmY?-NȷB_`ޑQX#YUZ ɰV۲xoRƿpMI*u? [= D@򓄧׹c{@3sLNcϘsgFv=ɶ#Ð|΋el4׺r~<8yOtY[y`D{SR Ww*̥).HZ<㯴zE0PflPߟ| ^ۣ{q׿LqY[|-wvX JFٔ; H&`iDkeC3y1m{0]+~wG)6+׹aWT ,t%J~_`<'@o< z-gloq O) >Pr,VTf~F(ڹzf V.i {a>'>ź:vg3>guԋ_Zt湘?`ޑͫ.xOߜ`wvo$`avtS@l$<\>`q[q(!3i8F1oWmju[cXp>%/Nc1Nj" QD~MfH'd(ug6.N1)GfŶBx㧳ýI~-gߎߏI<۝m03=V cĎAkj_4qƂX-_\tB/dfp!aQ )lٵ8 _u:@^c< :z+$>1HǑ幘s>'+{6Uמh@39nMcj> 9fݣyTIEa! -7L߇Ss:ɾێi[ƶLL%귚 y`unQ*2O0>wu$Y<$Hx1&+fIyײ/]|}FeSޢױ z_pa_geFںٓM- oO]TK[W6?g匛eM{U-oCp,@Cj),zإF }} a56>48nF꣓$顣FaR k,% ^S;qm̳rN˒ ƴةK.NTvBzɊU z~Z*_|u#f*$ǰX G?R7[V6ӦCv'Zwoz'c?רass϶f{-B.=.!56دsg1Tl<iofr&oU#3ō^ }j|'De| [mؿvI\>dAıfԳ78fBxvK>a+NPo$WO~+ E̺nc>S?H t"̊#`#9g$5CF-:cm`uֹ ̔/AmBpg4 3ckZ #΋Ljj}D`]̙(Y`u8U$Ss]Η$GEm{59`jn@\yARlS@sq[,яp E]{.Qw>ת{O^Y3>s°Q6.:{*,d?\TdV^3GO{u[o=OP,|xŏH]oZ6hGK2>B8cdwy54n@gaHR߽8:q[`3ɗl`{?17B㭽=b's䉧 Y7\^$ ̏4A?+(3Z7S\Y7[Y(@Z_v')s/m%-~ݡɁAS}NItjVN|tj INw#%Y&OR'uRc ݥ$E1!.sKI3X 5ٯs}ӝI0.fZ8Eny0ƴ1*g4}KjP#};7O2k).1NU\2a57yk {CRIkfЬ$Yrr>HOSA`N\. mgF 0M/p6s2l 쭌u@vh>^v 6/ܙzsea\ ؖ!;+5Q H ytV}M>@2rDj"bwccyzde+Ku y뇺z9vJH(sAI;!JQn ̝/W*| U|isY(k'pIenS?z,NIDY4!x7XKr:./yE *Wccmr]qܩGpHYӟXɛ8?|uŊ6;qu3> ,; Żkcf+^n'vU1oN!&#UX{| L%*_;I@b53@eWI{7Zny(?= x) 92X_)w06+6*s < L#=pf&蛼Ux 0ۇ?QK:( U@뺵tds^xGg|J+mc %%%v3ʼnϗ™bjްı-=g1I|f.3:o0lC2ac2ZfMm 1;$ hHAx<ļ:/=WNK}C4Csvy IijdyIBp^2D]^ռKxQ `rsVAiEs/Fs;oTo އZ|j.bq|,DDa=KN3kW:O$cOa܁cX6$6 Io%rLJqk=ma6CoɇM{ ̺]_q'=,o2vdtN.xa V̙~8},G1|jaOͱ rAsmah"}J92{l*PY/'^d|'\|OgFp=o?B |;D3HBz'HU8G>{i@0YgԔ4^žyOد535enVq {prc^ӬnHkz|Y)%oܥjq Ք8boɟ-NXc%" %#M,c_Kp7tT |¬4iH\\;xX)æy8#k4^Zx-#<W?Sep][\3uʩ݉O}Rql5YѼsQ gc?̜My|JpFAb4}* V )~˨ *]QvhT<^OWB]ФՄs`g ]ܲ U[`o͒)(ىݚq+C_ sl_C)h sLūKy17jRވg/JZ?$}V_`H}8y`=OÝ]$fkE*@ҧya~uژ8tz*mZX,ff)E2ylI[tـw ͮl%Gۇ=B0-!  $GD>3P}ܤzF־0iv;iŠHTIL^?ߔ$ )~d@2%Q1V-.X@ uwv;\[ᅱVz]Ǚ7 I6:;$vmǰ_Kιl~0yzn5pblmf.n[Wp`_2<~ve'U8}Nhb W O%fOEPT|UƢmU߻GIe %TTq[:wu=Evb}۠.Ye.o~Ar^L- ]NRu ܿRPɨ/,[mqK ~O89V Ig3')7RٸLTG%Loƞ\n@j78<9uYSN2{IXV{adѥ:? W%"vؑ zljC0hųiNJX W6r7^^lƆ?6ɵ8UylVcVkn)CcW8[ } ,^0Lb}i6T1%58^D f!Na3>kW)W+jb+;+w;1q@κI\nM)D0h8 5 w%ҿxű$RxzۦY:3lXUDf6OR!OgG.W=8=Kr}ڒ K=Oomm8GV@iZoY#?ŏB/7Ilk22O0Tnc- ;Sw)$ݻO+#H|`P;;zeun(>5c#wz!CwcژD}٪"ngNf,n0]\R&}S#|W%"~b+8Nb~F5 |]YܲlS&؈cJ^@\6 ,;%@IAx p$i[!:(gx%4q>ǸlLS8pB[==V]//Ɇd9?MmR>0rJ"=$=UKHWep#茘bEn삹w{qO3đ\&6[USoͼ974dnp'2uH n5& VɔзX7Bq2dk)>;s>TCjLH:q: Yd.%[W`i^]Flr/ Wj [`;!_䴖iW~{aDŽXiAiƨDmqֆ0Kg T4=ؽێs)l搡j7GX1y9Ad!.m=';,`߷ڠmCL ~ەM ِ$NY?pVd#x%[j܇q&8u'R>|[3#_ǥm8Qiv$)n$s98PVxH=|ī('kfNB8:zLQ%1㺈<גwAyLr/G=75/}Nӽw|iP{@S͊`0X~$E9. zTȶ?X`Tx$(6&m1U^#>9Lb𷛡NOM}MqԨv SbCM`!>V0wnGؗnY|L@w"gOhʯ~wt6xF\*5כ"N=PS`wgc7vueIU,- /4q>X՝+$X?LU`I2 ݖ{ Dx?͉rj$hTJ0$LR7V\jzY('$ o:mХخ3<m҆سE}|>ɝ 2NX +qK]:@vsO "Ӈ&ʋ85rk5?R ?o")L/BO䰁 7- eKHB"n`ɑW ƙr%:&&zj܆/͐zNz¥ggR^"5"[\8yO3t2/q ꗾYFsxQcq?bĞZ5W^S5Nb}+w*%$[!9(nI2Nݺ$uY[cAxclK B*ZKʇ-@-0aShDҷj:/JJ!$kGNbeŁ7n&R-ͿV)z{}I;dGmHJ5[FإDZhA躈ӥ;luBoÙoc;q*yaDWʿkd~ ?wpEŔ 0}\km1Loumg dǩ/^@ͅ@,N>ϐ#^yV{ۭ] mcY{\諩WAQsss}Fr^M2 pVj*&~ 7%qy8saLébBzaD=6-jp|{ҝTnVua*mrrK\7Ɠ:#umP/ ֡. /1,WU1GO-)~K&,S-'$Nmfib`懌U :)?a+j"lӶl,CRe1\^2WK1;psT?9}``ɗ&a]d)vQ w583mǕ4^$xzMh.jONUjq ᮕF1q0lbO?YW9アR@++ a2E0:`]._ k Y l:{H75߷0 + ׆SpZ:?83wJ4ܛ<8f7wHR~% ӷXs$+sl-|2Jpm͸i3t(8#O(+V -kg䆩Cg_bh[Z-]tc;A1B9UZaJq;]LH]GlkiY,zqXAQ81ֽ#o} ibSI_=;ȕHx4=IvӃ+<+ "Bߧc\T7+]aqjI3l>{x| &g,];OҙW^)5iuְ-̔`j֜NƼS;Sгr}X:5U[A[#qʕZz0~H0UT\^5ƄFPfyc*oMa'쪬RN2_V gw;݁7^C%k*~>5ͬQ`~?Ȫn'o9=G$-`k7FXpbQ抝j~OoFB!Z8(19wHs\(l.D vjTqc]alu@0s#ɿKJXyWlGq,п9,+1VDrїwwUaKzN] Wr?+>a. VSp= r\e{j+x/˹.zc㸪:zy*"]+㉶޿p"DY}q#dݟ!w%筗CU\L_z/PRFn 8ۧLOz`$b 5b=gPWAn'Mo1tS텗ƹqf==3or{ C]z݅?u2GV!Uan{/Xnvur6Yކ؛bON5Iy 1]GUEy~~̐?7&%88èPI5pmT@5A7М/\,N0?)[znk2IOvg)*6kGG90MÛ8:w[lڟg?%٩4\ܖ ќly$(L炁:@SU;ұ70” rZU8%8* uIW+$ήg%Уy?saEwna]p]?г˝c p]V=d̷Š_Hџ~KOHa''{+f*)놝'q<a[J>AN A3(2umqțpbݜ/0Zg;Tq.tGu\qsD*c-q6O6XH =T[ƈ9{uwڽ]3vX8 v/ B'a&!Ibd?P] s" JsP\h`W,jmvaJ4=DgE_4 sKe3}H-s8}83Sy,f+NN ߜvYkZUz1gk|*Mǣ :?Gm JE8Ssҗ tQIp!#;,kfƙ2%y [a*fL+0sEӁɫւQ8:FT854ГXefi򥄄ga f+e5v=\F*-8Pi0YO?uvƊĦr;Y!vsNZ~IEݟvmL8n?KO{򵇀&C@ 8F\qJ%m'WE,ll۾? ˴Ta68ٳ'5x9" ; R%i sMXK-5-\BiP>F/m}H]]8v'/\fUNdEE"9eSmBIJd1u/=y`&5BD¸df PsR14`[}~oPm B5+.:ZѰ ?rϤ)ÿ ?89{>γra=c}U\V?߱}B uFlg"b`0ۢl*7>{Y3N01h[K!sm :mNlfo 쎲|V|9Gp)6Z ĜԤee{aNA,(=|葖*|8~;# IRR_IBJDC"2ZP  {=c<^<}ݟ׹;tnNb/OHdy]}MIJWe>^s|gV LA[88XG[R96^qY6 a‹v s"}5aNO/~_ɒΣhca /=)βJ;ڬ/ Rf˳Oѽ ؝N>@킍v$=)0bY8YK>M'X;NBHug`LeyӀ٩G뷼7~REcwNl,90*sZ .;)-9 |~úzN)nXA:W] Hw=Ӹk3[E.|*IMʵ7L7AVN,C1|klT,Ce&lN&-@Fu?A_׷} y>C{_ -\/m:ג&#fA#N~_xߟ2B8l>Q~UF"ҷqŽZ'pMЕeuCvB +f."+n/y8]Y:,ٝKG?.x߭OqS_]dp႗[ siSrFce.r9nߟr:*mL~w/Cr z C/:&Vx`U͕Hٸml';֭%+P&6*i3Zk+8\,hJ yvt-4hwE`ޫSWyFw3v 1ԧ_QSj'+%|sגXD+e|뀙'Dj<[1+[=PoqhEO xF\bs*pժΚ'8wo]\J:gW M,k%k̅맦Rױ\\޷.Y+j^I6S˷/z&DhZקxxWڒ1W zxޝb}Y@)ԺIaK!O=+;\U[/+?AZuQP " ,e?ҟXORtP)$4:Ey$oxQBmvǺ-fwl >[u up3~wk!.g>Seߓt kC\;ѭo- r n?r?bq 1yR9?LP~@R,k\Ӆ|ǣ7ϸU%Hm_0& 御&X[*MW(<.X:d/g|}px^TST@8.q⿷uYg8]ZT721k撚 ]7F7"j߬ ,g0Tb7 ~tž v}Ҫ`8؈;S'U.j Z.MCTvhP|N^^wפNgg̐v-Q +9ɾr(0ȹ986^;-Fιu!ѐ(tߖuh|33vgrMFBoJ*Rh)};865i+U){k-FThWo ]'>qH@lSb R &ZEl^# 1.sRJq$WX$Od!+e4Ʒ!.P9S89tCt[7+l:!%Z@R嬂[,e/lZVh-;~Gʮ&tKD}AsxĜ/]-~u Eroo[%k\`.zXOӌQeQ-0-qz\l,DŮ͎?an2+7fa `X$ezޑ8#0.A}z 69%Ip}udLV*n$@Ob.lRJsVZ(/$uߧ˱v0ircNF-_9ACS\a+nKz|z;J zb0Yagƀ,:zI&q?:$N<fbs":-WPTD=+`"o9W4SO$/\՝>4gOCW#5__+^x:6SGpz@SN=4o8jށn*0mupE <.kcOzNKA=3Qb?8C瑤}BhL;zo@vEcaiS ~3Re2F-mIW|/`G 8K>†p楨>A[˱,kI!qJr JwVz4HGb3(Ǖl /~Jƽu8!w^de/;ONa?X sI/bQ]U$%UC+{r T}We󑚉 FǾAt-BYn~VŻj=zAH `w'/Ȟucğ 2wZ1,ǸzdC,at oxGÀbqQU!mc'_~T%Q ՗uF&5{r&B`U=o˺_0;t,ZEz!;.of' \I|Igdܨ{DyKtT[bG0H̄ _g^HdĝԹMܜlƫae2˔H 9~:GrIۖB =eJAAΫ7UV;7[p2KJEfO8~턗8T =U]jQ$׷zKpdRgI ;LϰXo /]LBZtzj  TܡNnQ†HRf[!>e s%l}1`{f.MpTGi>̋-}/C¹fп^y}"5mu8 ?%OǬ8.h/Ww| zG?XF .O9!ٸ<)AVT6ݸ8mvdVmmmKw\_i5佲/a y\1.E\(_CM[}q/4q{cS3X/` C6-_e s_nCW5X{{"ٌ/ !u!"PIכi Q60ÞY"j?ݿGg('" _+ˁx-(8ѷ6?(i6ƩU!8f׫ȿn Ӹ~X7oH`ڵw #<~z +qrڣwQ X+Cqk].!~O, Z({$ȴR@WXb9jmI'sXky .+z2Py؁tG`ִ<~<:i 5%9W!>9rW`˪ kb{`Ӧص"64HPVTPB]u#׵maZdv/)$Uݰy/)yZ]~5HJiC̝J;x0){,'i jaw <ο +4?WatZ:.m5g9orİIYW̵u>MCf̣AlsbN)jMl8 ME (gsg.HmoJ#5@~w;uh|QXJ|Ɂϸ/eȻ[vXWn" SnqU>r0+5+ i[d` g;|$צxzXnBL7$?c\ [yێ,+ծm")sTnPnkTY͓߆whYh{ dPӶ8-5.&+Sw7+#w4/ߒ (d *I*?݇epYR^4(,`]]n4u۝efɒC% OUI=ZܚJoKVN +Qq]U'{-ݔ}aK릇}v~pÜi7s^zɠT-Clv-!aShVq ;mƗ Pl}ĵM,N_Uvi0@{fH4[B/cFXonP4 GWAƌ[\ҏ}u#GqdM3b4R;0Eus} -'aD*,.ݍbkae=M!HKK3^߳O_/vMkS0lJ]NSզ!Ctf3lK)^^|B6"bT\RmWdrN _cH'O}bCdHz~1>جX2#'O9"fm*6(}x~_dasqPiv$H+Kζ9В}T ߾p V[8qd@3:upd=c9͠y yLx7"0cQ>Id|/N.!&x F^?s.| ǁX`+:e]mE2BWߧv0!1љIr};sc3'ͫ:0+Te|=Jaj-߷Ъz >gLv>gd!{b"صE!:-@ps'<\9+] uײ&94"yxh&V>P=%m g(H{d?S C㮋Oא+֛t 7NkvN;ʼsO ۉXjUIi|¹-SmKJ&cxƶwةU8myHMghW<*>nS{Sq#+/`u9N6_s `ܴr QWH-2S?44~EdN.6c/L tƳ;qjTzs 0kCUK"ilq~) =_7`=Xbo \K /*V @FI̱`e]|1AqPA_Z9Įf[o͕k^`K[UFIUȞ lk柂YsGp|y(?ᘀ{1fB{-,5zCvr%ߔlg_Az2h~[/sF!,mXJ$r̷ݴC &c5d 1ZYm`oc SK Wh2&<>v6>a|f^JMB9FzAv_A;eJ Cxj),5~L4*v"@?#oȞN $wǥ83z[`oH6G֠ƷAыA`-:ݶ<xJ wYiPdSҕwsy7cFjf8!6Yrad~cp fVRƙ{NA8H?Zzm\PGtZ#Y`VkUX;c#wt m=npy8o5t}xW}R'~g`o0#lֺ vYeob!x -8)wmI 66ԙ%js0,pǷf -néɮJ0rh_Bf,؁D8}0*%;,K'Obu[M"֐le+5<沛ɳ9sGvV 0DU.#wwޓHx-T:+7O¼2\s zS#`Fič{or 8B seۘ8֮ ]VM*v1"πw;h^i;JJbmӇ:g1m=1*zFgY''tZ}YWhwˎ(]/)夢͐Y㇮t=6sYL{z(nN*׍oV'!n–W<C퐋h:adpI]5b =/Cb"a 8zlFz+˖1)tO5no9}t Iy bNCͧG<hHg;P y)e?Is#ٳ8O*&9O[Yq"PO h KH.Z|ڔ0#R 8*3j#aqйqolf2aG7ԕ.SԬ3%UDWoy ÒICg;б&$u$\4u?)]b8LhESsqw";P.ZSx; )F9Yi;GBьFE>xP'lߝ8pሽ#(8 ۅC_ξ})ΈQpQtN tq\\:'Z ?{\_)O2p?V])r;N&ۚ?~n(5^N`ާkB:&잍<+āX";v\H*tuDZS$ 6 ?!ueB֮禰x5*uI) ٬ [qBȪM~ : #)oڗ//#>l27 yM漟<^rS]aou5vT]3/z5l?*~C{`en<:Qչ[_ ~KdE?Vу,T矫W^B kGyO$۟ Nv0zV-7U8rL!9d Ŷe6)럋dYpk{'hPv9խ0Vg6n ֓&rAVj>s^QqHNʱK1Ğͬ/ é#69/~_'(w/j5U (#5۷qmd;m6߲^)h- ,;ϡoũWuU輛f\I`~[^9 1SHb? E]uF? 3_B45woOk(N172"nyR!Wt{#c()Y "@&噬w2i܃s$X޽h$W߯mq$˹ghuD v)| 7w0|߰T{d-r:*GTviTn_齷`~\L F5t6%ٛegu-E.؍ o]0k8rn+7O1WX!Kɢ&qqvv1d9}T/N ZGtaldv, a +(\?Vށ_h*2}yU܋?wgEMu[u {Ļ: ˮϺd(8>_d\pS:KXn~pcoUb\qŻ ~DTkHxgZMl`ַÄ6: JLWOPkEr/%{.31CSpEr4+zPsqGen8J\|;Hv7q)S8P>SW7]>D͓G7.5A.se-;YA'Q Zl+vf}c54/hԔVF5IwJ.%ߚz8Y3= ^GbzZwFO,V |o :`ƈW Ej4+y~Z +nH%V uZF]l9'ࠇ||[%W =|M}j7~t>BX׵*}p:8f/]_uJcgW^{}l }ϖIJ 9v^3pf-i[b׊ؗ1<@x2E֝6º"R{苃.Pwi3moMoՊX!w/xLQ 'ꎉ-X{+Vߜz[)Cj'vd Zof@-' @jjos׽DwExX[K4ڮbN #)C\A'70է8tQXƤ2 VdN <_ sq\h٭{w|<f3In:%ar*e""Vr63dw> FX+=Bmahw(08 qq+ܭLt?_{外m%oM UܹrH<;GH)<) C9x'kPWt5hʿS_Ja#dB1\逐̾ C8xoHj]?d3n. 8<9i1G䒴[)KS`6cL} U?T-tgp;ڳvJ<{j^`)Tm.ѿC^Nyr?`uE{BO`;<}{aԹ#riw&mM엲0ӷ!>NN:! ^WIq&\[u}L9k>FYLXk1dlxu#ܙ)0LJGVѡt3uzf}+P?r5ƒ4-57k~n.?,2[34hU&U {JCr?{7Lx(ZĎ 0B۵~݂c?g`Fc P ]90dj9ys: #KϚ c鷱a6W/L=5}>ò9` LsJ 2UT 4$ʺaKz# QA2T~M6+&KoF/_a2yYwgۤl!o>!umދ#Vsרsuspg ʛeM ~"݆έNL,=P+}qc.z<,`8'b1.04Sڋ v-}A<57"k۬?f?  _h}|+j 9Ԁ鮚Jx3Ε֭_.WIU.{u;=$ Vxa.$AAϣOp;l.1ąë&XPs;K0>6S vQN4K>sS#J|glNЮ[.NJ{ۡORh)OW?,>~g3j1NmvU]A_z۳I$%F֗9+@[׺Xfh?|2~}dہ}_v+̗ ^_vSZȌ;|aZ,|lZoSBFmOskcp 4m?q2='l6~0O\z!4g!LkKHK8I$G3'6Hi3iiy+"L9m@TL:/`mK[ϝ[RbiII5S]5 X#rH;o ߘ60f4%ve߷zsc$nk8=;wZ];߭R)'B{ٚbIǜ*7LL  #[)uq^]H^g5oϹY 1Xpn^-'Oe TIhy&Z>ݣ@Ըsm0eJ>|iWE$ݚ)X%4)qB͠T[)C%.NU4gpC;1!*mF['>Pdu/6&|/tЙZa|nj{7 6GZPw%]rG6„WN@$w95|΂˳{JA'41݁Y%Gdcd&)[|1LuU7:o?}Kۻpj.jvFl$ /{&kۇ` !qCvM2M?ʗ~ule[(HP4YJBcJװ,LJV`LV[wm2&cμZop.coJw,sgFka&9?rem3 xrc2Ыfy/m͏Դ&ثwk`-j <;;sitPsRv}\Sy ձI;5x:v^uUWM Hk"I%]8tPCxqlrߝ۹/z~w ;iԮ.,3bd:aB!ro{*zuDOv<'pyݕz%"ٷ leǂ.ĤIN%_'3NC߼}{1 KG n?s])Z>Q; aaA Iw ]?l⯭+u_m|3WUn \\=M"iޯx%{V;H/k,@}Xm@N L$9,Sn%XGS]jԦJy0:M_X4Çz/CQf-+XSg`#/_E:do_k]0uSr6wt[|ˏ̘?*0SgE^Ě&x/xh;l_,qT.ղWFC<9ϋ_R4iG~dEv*kODC]GqɥBʡ%۵+ni2Hs3m-,N6$6j(3۳Hi){:1A-wl&h9+.zI`9)#'͂^HoKՏ8Lj\3L{ !bՉf9Vo=Xxk9 M/=ީa_IZ|!ٶH̓*uu&m/[*9"-L~XFZqzn` &8?⭃ x8&LJbCK75׮Hp=vf/$(?mjW+aR u7XSN'Q +}x\9~ݫcǍᷛ"| ||b$KiC8V6Ws =͎UTZ+  tT̖б.bȣ{lŋ7[~̕q?c`3 "|eZ)s@ScQ7mP;yȻIy_؟@lNW]/E1c]_8۞zǗ$E[wT[u}&}{Ntzܳ8^@Wx03W~y>ryRakZ^}EX?`;5=Nnptޜ&Q)8MHy=o3#zOH;VS,Ku cI&k8Kyq(ٱv@vY {AoLΎ] R%3,l~on[l;t9{݀}WZ ©;LaՊJUP!s\?>l/{ZP  U/BZm0z!"q?홰KK%_1R[&+,m"AR|Qe΅o,?\Ϩ8Չv`;veϐ0p#!j v uujwN-%8$c ₋qYMtU&5mأW+nU Mwehn{Vқ;,#)9P]M0枛.m,@JRvKd<ʐo-*3fb_į_ `~?-v׋(F2v׫QkpOsWOr(~"N'HQ!x{H>[Qӡz*3GħZÇ"Q{e~`Q.WYuEV. { P vnl?QG -#y^J,aF{s 5GB(I[_"|x!'$ނkNXʝ7O/2 /pN :^o"8Nw)ԷyI>\RZמ]&v1_bqP:ko !v}s ~],ap[%ePI >2J̐|@%(H[tclΫ(EFt/mINs-M~{c0?EF :sOpV1\U*5$gIٶ_տ&Ȗ-ZR!`%a*m|~%U[}<+nanjL*vsR/k lǖH#_$$0C׮<Ͻ_`gz >X,CU[ SK>.,bgMlq@}[UnRx9HW8ܩ;2,ctNڕ|Yc|AҴW R%Aw7KeˈZp y9]-`4f.ӁލWpBa{,UkE+/Ep\>{S~"6OI9kDr#>UZ40&&  ƕ.)iyfM NԌ.cv}y $G\<H\U+eLksKŢ8vÄ8EK֙[y*= 6JogL`.ڗ,I^Se>NiK2Go\Arx}")7pnt$`Dg`.r2 oHʊڦAƅ]=H;k|ʾV12C0~+&{v¼S)eUr3vjA%>Beض˧n9OF, []1>L1^,.]|_3>l'yr:{ކk8H͌{$+8ty5XKXE6uofεBcY_ C`Ys{ثq?c{%L*+]N_×{|izؽ}tUy-BS4wT" g߬mz L4RoK%oϵ![Zs@nc+(zeN ؏tIGbl/Y  #&^J68ci%=8wpl_v.PÔX&vHJ%<5$6Y|뭱j?LzFp?@EluRoyEᔭGse`Z|[ H۔ ArT{5Z`$W Sr[𪢛3KRf cttNLl_ vmyF .l)Yկ;/B2yRH0F[Ҝ"==ٵ f @F{9DaelYwLO7\X ?}qT́S\D&}C/.;$74Ě].n^8_AF8oIpS4d"a0/% pW2j2z0 ҀuV5 Fݺ!}XWtv0VV%@4;̮ERNdBF%g c_?)}Yw.a|\8-}/!d?_0Ae3vt=|Sd#qD)'VBSr2UumuBM8~ 88~ _fzx8.ڝ*XM ئqgNYU;:9 c}0myj 9]=Nu $58AUE'FpVծ$6.&7a֚%^=}AU/sւw0Rh$ TƎ_6℔j7TST\4+wUqp#-vgæ1v?Nf>t>wf%Jc6MHp'E{5V1_@х…Rt4y{kIl2NVx챯>T+kzpeH=};嫂pfwk]RQ`[LɻdÉqmŖW"1JbR~~HC+6p}88mn&S)/@KQshĿFFpu~Blc(pD+FϾ֤2`br*.e~̡{f6)!DRm,(Fމw{@M2Q;d&.ѳQCZjKh(Kfw<12͞N+2<,ɱL/NdyIT[ѡǞ̻FoPyp#A۝ } dCzDžOGH?h:uE/x Y əS'k+2Nmn~ǎw󽈳w{Fn\ 0O)amsU]=Oiha߷@wQvX?:=9|eipBf}Zsag_.LJCU-Kwzt_&ϙOSu0pv?Ljͥ=\o4ŎrCo^.K, 'W11Ll'3F 0wEa,F nI20cdd~z+@$JPˈ!I+bdaw\1gPm4/( :_H{/+V ,l0x B;a9z*to QB2-qR[dLsZͥ?sbѪ34Gzpgf](z;.ĘrY;=zs 96"Ar^l(WMqϝ8dY̕1k&qqQǮc5^7Wbka TBc`OO4_^7ux1[*t'<>֊U]IY;ol"ArJ&Q]v[4~jzLsqI[dGQk"U҇6ۤIUdiz2ɝfW+.A ܤ1 Y#9zkf FB 5?a<6}c!uU>>O/_o@J3Ʊ/2&8_'ϲN⺈t[OL~a*%0ǾݰZuѸf'jE($jWvB]jQ>\lEMkXvHC}:"l胎Vf_I 9E'°ZCy[5zOJE[lyO.]%7;pfi8Gg1XzegmqA՗2myk{+v|uq_毜j 0";Ԝw ޣpQm {1L8>[bG78^Er<&FƭHoԱТğߐS _( wP{ϕYޫ2%ln{,v^!,RF/m̈%m(h-"J˹{evؓ7lNRբt"|ɶaVR[_:0Qܕ/ a9(`igiOWӪׂ1ϗSߓawlLQ˲7-yP%mW cGaXＲ*l0CK 96gC>cwjfm_g;;\%kcW3Ԇ0,yj6Ѱ6Ȋ#>8w@oj0p8}ktȨ/mA keg{.CMϼEHkO%" 3"aWn!80wܱk:c~{5Oկ8mR]s׆lH>: l^}Ň*/U  bTo Gz?QG.ILj,u8 ȎFd[ ukwKpps1K]R|jmqz/?Cn#TWך@2CE`2r씨s]+L`=V4q ԿB[=O1u>yޫ` , 'Ĝ$IhQ  ( {g>⨤hMPZ3-!P'-`%?IQ^ g`N? .,:#8$B~T`O$tRe_q!#;qnئ՞гO:a{ $ F쮅?f+qdάViY!a}XRĦ[9aV!{@aCX:^np|5lcn YQπҹMv&W;iKkIh|^ޱGZK֧0mHFܨƫzIZ쎪׺fُЕ8q {%i.vo{=.uVɓ뼮9Cv*7:H>{'qQN|i=cKHlP)t2\~ܖ^FIo,ֵoױiW RwPVw<}ܴUS$sx|'O(b ݍ u 8ٝ+#CHʼ$,q{OTT/ߢNcLN] GW$W5[5snڭ~<Db NYHrXL|8Ƨl? $}[3GOTP`lɗXO]}r@7fLdFGr<οU]/9KR|&Vz}jXeH8Y<3"/=-jz?s/~e{R!$b:0nZCCБ)GTcJeb{2J]yKI R~$rFBmG&?G* -8fK\d }ҟ&k4`͎76^B l0͓lsu`Wx,k'/bw0>:-X?r<x}VmN;j8c6yEXop) ?_fo!W/=z2{Obx̼mB60ws"_?Np*Ķ' ),h_g3$wxs}h}]Q؀'/SX{6Aۢw0`nRpEVo l.FhJ L]ި R|g+e-10Kgnw0Y,Ap%0f˨:R!@<|Xkbۆ5Z%x;gB?cs#l] r8FrVhcMXQ-\8=GcbJK/+8p5o\7ⳅ{ϩs.uZ؅sC=SlLW[-#ep5+KS|u'7x,=9XE)ҞW[\NZg^ e|vM\JC}qGFؤ#L:Hіa.y1(NjdԶ:`AW'E0UKo%0 ^{9Ald9QݶwtPYJQhL"u$d~Ua#tK",pld6tȄuJGaBn'IJwL'tɧRW+h$Kib88uBv'==;߯'?m!{(ȷM~ !>ygRD:[G]9` ܙ0djF0׿c@m?4ɑc;D(0?x"NU|d2CkR Vh2 H=s`2kbKޯʖ붏ڃ``V_\/ )kz<뎲UomhX0V m|?y/AW~<ߕCHњ4N+n_p-<8ssgn҄Efҡn .OR+u)5˽I͊ۍV[ bɵ#_'Jg~a 3r%-3UY5+~Ħ RYz@/+{C|Y~:} .<t)GQLVi mKhPHlNJ9MZb87L^X0II᥏Tծ[{K}2"\2ZeM*RyKV0Ż}j {T"0c<+fm{_m#x{3 JV,`=:Z)tkk$' & oo-jCcUsޣ505̓ߊ.ҟqUAB8 g&z|Kf?(?z(g{:ڒtgص  ֔ FSհnjS -`gRQ}Աddmɵ]H,Ry4]N0,[KL6<({<i10}D6 7ܥ8-|t#Tg}Y6v1o;.`ZzrǤ R~°V_1l>5zk"jy[ i?uafޝyzJ j|0v>ɮii{( r4't0Q'fk݁:5Xe=0"LixMr*㇩f38+72N۞L}gC+; f5YdT@ܱÖ4휷QL}OX moAt_OPE6ZN @W!'-LZ ӻ`{B ,}`(ؤJpՌͮ~.ѬlRQl-ެuef[G%l{Wd>\R" 6J'=le˟ܰǒhh6pY[,Wff8(I_6qqy@Zh .{xt;u/AnmPtA=ƒ{ߕ'CK?؂Ԁ>;qp gVd *+)$ʆEY6Q2T&7]9o-&HlK_i* J qzi* Ҽ1ԋtH)~E*,ݙ`r5Ͷ Z>]~ o6&CU‚]ݚ22W)FVW6cmXy } [_!wK#ɓ퍐ݗgsUNź $`M$1Y2b5Fax3lw>Ϛ`@mлNrVKp޻ǿ[WOz VG:VZ: F8>oui\M/¡QlX \43_oN챗-{jKw$q !ɀ5$iN+\9w6LRWϴq:^.ϱzqS0(vp!LaoL*p#8&-]x,r艫~u1] dRz(/AP>S%FϦbKEI'84Zo^2g%*`wzM"H? .蟩'٢_i‰D`^`/M[ψI͹AM\s0$9mzp+Gt(8\䏄m_g ~ZxUg p}Ck~S@rV-3y{U #J6(<:;w} WKE3uu2ds1[T(ιQK|/ al !Nxl2K_gAVryv ;},Z 0(;YS9 h,El2,ժCVo6aeӦdH_3GWX彪f]6pڼ]<5C'h>@ ۴>?{X*%_GHlO*[iv2oyIRxwLbUNsUtOJ۾?0O[[RBy>K>ZRعp4;bBj8 0z'I;7ƁkC `\1ytW=20y.A7,x"50qVn 3ujSXm:<&?"3qb9?@zobM$svq!=5o9{xV;mg|Vӯ@ltX\,+d5z7)M )hH![]^w?fH-G {;QL}v;Ѕ=NC3KSПSC5T&V8QQkLU?[_ٚ?F0x7]q,I^(*̈́f{eIN C)iLݣ2;Y+oh}s:B0!xG=G;CD Hjam'ϟ8#e=BE6Mͦa)ͯd*XTijzIϱݿ8.s1 h|4l;[&^O?@P?.9tԨN\Bֈen/hS/MJ[L-lcX)kJpoq~'vc(ݙmX Ho [,̩(9\-Hb״i8!߅sb,oL@ A$u7c38B&Q $η-^3W8ܤG<F}|/9,8KёaAb[0c`@9jO߆6_ԾZK\ Ȃ2򿤴a1lMR&uPq&gjX'y3ԃ q`SOۯNCFc5u0_Բk_ fT1˻c{dw7t`.Y[8lN߫Cdu׽y jk$`ƖL?}u'OUE}s3:\5Zt^Su?WK@0tRlV^zٷuV .#)84+yIXOn9M[9^?d]UtƎߗ<~5nt'g}}*\+:@҅tvRM+ðԿ8UTxqi ?3g`^s#vuxfUS&A?3jq"ʥjD&@EhYUlCmPiw6UXC'2 u ԁ5c7L]O+ԯ Ly9ȧ+vߵqsQKq>8{ѫZH~Ԭ!gM{`UT;^OP޾ .Z/OP6=PU)rS: ,MBm/Z 6lrH[|9h2гBB5G+D-{{C;yG7'վ$(݆1h@i!\4<9mݜABܩh]iw9Ș0jBC!o89&kyOqle{b%2 Kz ]OycHhHJRI]E}$I%(2BZBV6{{u^ZNA^dfBb"؜D2O/}}=RjW$9m:$gAyNȐLg+ߌ@o_R \?Jz4@;kw'/'l1?ֹCfPqbx(?]ՙ*h!1; \iT `^ƥ޸>j Ufd=NHXX%X@zŅס{`_hha:U bw&Cp앣$ӝR!0E< =83ӛHe1_a3aϣ'GaRevf+l4fcq0b˛* M-w57CpNi 1z#289%.:djړ;>Jte司:Qq9z&fbDHc܍' I6?+00:c-"s> ?i](+>\5fR#Xq`~SSS-z~~ _y_1W13sH bc=W:|'PY.NN!mrC X{s-Z?X5`M#q97ebԌ4M工"~g1*/_? 1 J#XP6G_2}L2BZ0!UKH%?0{&M>f8rmKcQăz+k#6z# qfǑ =| gz8ߡwޛZĩPr/K~'кI&EfaA\*;y l#y@G Nۭ;Kl.ҩ<%eV0q=JG_y&g#0_1aRe'ZvTaU;?(Jl63s:F@ͺ`K%_ JM^ š8]6 O%ޖY_"skJFo1W.X:/L}tI.[l`z̾'ĸ #HhimXi?sdb4t~E}+*&1Ylza'UэsJ"NbeRr"vG;51^ ɊSmKpH/+ތNnx$J ۡ׽{{&b>d3 q5g+.EPCױʟf.IK@5 NnGa-㩅v7|¯$- u`xWEH nd;mV'dYMP`{o`"Q{{qF\ٗ Ƕgϥ|#v߼k ْb+~!=TKekWK<#{.%Y#^NG(59աMIUs[Vz֛^WHs7@ "u+Fq:S!XǏe}y4jWZtV,0i&֋?2 }&]B* à@NN8_z^7j$)E54xӊF@{ ! DW1kg}@D\1\ص,qLr«xd*'`dۡpߨ*VՏ}NpqM88GlTcouR/z6zJ?/ES/& S*p"|gmkU8UTsf"$MpG`%9Xi.X7d 170kg"vw; ykRDUڋ#Ul\"uj|r ?|\v7Co1iw[:[_O0`=ӜDAvm9HE}pd]o+Ez;{ͻ`/>.%Z a'H-N=H ޶ co+$Fky zr1&iJaM$Zi?sgoʐǂ[T:rT1ɺS>650̿&)jtg%~LV8)o`Sh9du/mk7;^W=߯#rC޻B/ɜX`P s<E8uŦ;dlo͇ c߀ڻ\D ;v= alV_R lF*)'j_TyM蜳֤/JH\!)7мtiRqAnQS)1cawBw)w$#}UH ş"v{Rz"\߼0nU-ZoDA`iSwa$h X(bYwH Gcb_@V>5>aL2claw>Ƅ0GI|oS/MnشI0 N9)ù&mZHX-00*سێl,/Üj)ɛ(z}-H씔)/Ѭ0I Dm+Q@(ՙ^dӊ-}Z\.D5?Ʊ^6)h,Tho+4Sj)J|o0Qp=ms;&μdJaV ׳0CpTj=vSyZ)/*2 <֍z}FpWiͱ3j>E@0VpJC "#a^bvo7t#Z] w C???ŝ޿`Gg+ҫ/phO{FUR Jv(%4f? H7I0{|"iW,.oy tRJڝe2 .?a.S|]#;$|~bD0W|i {$HNLLVw;TޚٶHm7 Y0a9/mX:L"ZKcI܃ TeBޟD9}i[ۋoQ" qH=:CԝJ!MRR-v%?OJ@z;K`'fCYX91ۙ`v tسpn{CT*k7BLLw`DžTk0pBen?X+!q\1\qraddL]8ӈn4&!3olEϊbdO9d%핮oyKgBa&)+W@rv "0soE,|Hgx!Գl9`(c\I?,^T׈]*͟OHũǛ.~Nԫ(G6ʱ@DΡ -8+yZpn.|iS4 $(+wᲊyo: SGlM[w}Ɓ#s0żE.3tn%`d;)vu>~l|Lf൛x92W> ;~/24& ?z*LLs "97goLI v!(<~jڒ? WvfqSmuR8%ٖa*'vr𼵪?\.hlӅ&Rl*Jxz,߉ 6[]C|0v%Y%rjd p҅hv@slʲ-X.!m"tvD:,~#gY%B;;L'C{b\28uin:+uC9 O{1ۅlt[I[[ɦAL0Xm< %`fXؐJ,~a1u{/Op_;Ɗ'?.GwcH3A\>0V )/} W[[;l >D0/s-4 2N_9mKsoĵ&MUS6VW$d:akO>i 3c}G6i@? ,P,'XYv1*} &TĦ1"f$]M|&lɾTXQgJW ~chd>+ı׽K@tqAtKcX̧ő´'BUբ üOm+io(>$`WQ߇IKv"kY%L!O=Ckj2N@i~1%'oזwf`0m59I&p G3X`p+=lull?Ep|ݻGD>޻g,qxWX z ɩ᡽S?(Z. v<03S`u>d [7g,c Yʑk-z-ÑIZ$k.ۋ`b;m>SFp~an 43%_{w ߝچZL´2GnQ_g7Ib,F_ٽX{} &N9'OZ)cjsv]s>c@ě eh_hnazAO$/Ǻ2z00fH:Rê 9ᵌ=s0H<"2 G zY54~w[ดg/VbRǃ pwj8u9L0R[ y"Y`\ΜgNY/ArVܿG f4OCkI>\-l8b=w[Dq|s)seu7.]|uI.NP7[1OL9q3 ]e+ +S1f`ȝXĎCHc ox] Ǭ/+byq|Z=>X{PU<tȵ $36JE֓5kxSI 9*dPSM5~y_D{˟Bܱ[07>Nz>Z~L.%3g#xJzl[ 6Pd6M >pTW@e؟:  61Iң$dշM @~QۆsuL$vTdtsR4Yɝ)\N68C~ʯq\Y?r8@8=ȱo5H;~g{8з)}=ӄԏW"a>CIV?;d: [.xOs&RShm2)vtp, k<[<'G/`N/,u4_8KӞ[o%Kp,:O`rӥFU%~z=t w ='@/Y? or`JB5 ܴxT֊*/~{#|jt/m6uiww{̧5J?_€zF]^vAgCoΌv0KX,Önuǟ');bcgr;[Y .{=A}`ZIoVg6$mʲ -;n[pԹM!$[$0!zycH#40z8b(G:vBݓ>Fk/aWOܙ4nl m|ژqhsCL'=>E VxlQW^A߫jAm=LduhX߬6 <[ |xYI~R ^d);۠1ս}&)X1>g fnA\}vnf'tg#ظH,xG;n!됽ݠ0vi=-y{+KĦg_S5\knù[{8x$ѩ4YǦd鑩TY$Ll~Yn9V_\wM<-~ԣ:A2Z8$}:g`2*K2]^e`},&bL| >ߖ3m@ ̖qcc[_c^\Wm+T?ǜ$}  a|-QGq2n'Pn ~JYwЍfh.U !'u|KA^^MU^L9+n@ڱL󑡵Z4N;~-JBX}qЌ+hSVܾ3!U~:g#$){'Ss5Nem.HG˥0Ǹ[p{C~}Y~)'CLBV!4Q-|w8XT,Á+Xow"\fYr:Dk?ajQ&Үn KO3|VϗO)2u8yHoszkX@%EN}2 ?}}N-┙mrđ6/V=`X+^jۡōZ>D3P;j)h2Q%=f%þUϥ8q>J]WKN |8qB>L;PpF e!ϖq_)9H0yBRQy3MJqYf!ZKveE?R?ϓk/4ethyO_ܼ 6)Uz)O_fEGa4͖F5RKQNF݁aJӸI2r*I4;` #RuTU6mG*wCGV[ֳ͆*^H*si͡]zv5R' -Xx{$3vwY˹0gk1͞"m@[1ڡƷ\7  :˭#-lL Vi׮~&caEz㩉jԻr ebqiݲ]h.**&V.~ŁmayrRhP .[/ڣ,*g:ٵI$_3^FAANNr.rtI^ &.+/vxuvKk8º!u^l>usQh#Z?xL|%"<-v,y!g&X,w>^$}TC͡K9WO2+iT❭6S9H)4Ů`sF0jGav[3`=q׵^4ј7F<~h%y-ܪB +G]O+VAeâj1v΄,ϩz# qO-?wDy>U`{j-}?Lˮ}'۞Op}\lj_/@ H?gϚouS뛰&Eh1$y'qVHAXa_pR',͸Wa.3O1c|+s LXaP` *v_p"$+]"W{lNai5L$xU_zƅ\H!A@_f`ZѤOph !m0q(KÛ[0&ϴ9aҌ䳰;}JljAM]$qCߓ77!-;|o@Á.kfS _-*Boy%h<"Mcv | zƉ>I#76jL}p폐3!B>6I!b`s`TJ9Ot)>B,% c[K̃y;6l703yg89s =Lmm†ZA0OUS`?D.Nǜܕi76ܬ~ To=ߠ,g8[ ;}#Xk_ iOG^̯ξS 2/q:.ǭJ^huϜTpn2tҪR$\qBQ070,r0,+}" tv#I:Ca3ror4 A5R'f6ʼtIQ,*G'd(8n`YگP`Q\r~<]>KJ6OFڼ G[Ӧ~W`!^ϰ񫊻 lޚuZCPpyK(`z0{X 7|w+ H& QI~{c_rƦJՋ8z9`F1Lܩq%wX (HiX0[Ě`eB}fPeo9[ ;F|܍p[ú@.7Bn͆̕-En:Cؚ1Vy,/?giU_ %5K$[Cq%jH? ]']V1 &븮=:kBX y 8aD5!|D)R3Cحv}Ǻi#hIԊ[zoӝgc_1^yXۍ L]\gqYs>6 m+rxH8$whP|\ 5㓪]8{,N8R׹j(spzki줯y; ml VK85rjȝqQE"Y9Xmu3:ھ̱%0V*v*,'uE-bݫĘHp`zTo.'/L(h)Kʲ#|8׈~6?6~ANZGvh@^ -=m[qen-ףLU4PYm`gBā;<ðqhH:W5d4x8 lՔo0uWQߝ/̾ '*%iViO~S do'aZoVCꦯkeV?G* ˪+?n]of6XJܣE/MS)HZ~Y:q|fVbq(0ˁh=KODlC5[vAaOSPD6 6詅qbP2%2o[]#yG/%([w}C7|NEf'[6+MGlno3[BHʿbkr~'n+ye}!:}qPu[+O!)W婻` ! 'u:Os-a_ɣ:UQ?+>etVNX}^d .0CIpksTX4 ɡmlKV:f/ өTjh_IҺ'M q`+Ki\-[Y=?tqǐn<@ư|R(72V,ߍ5Si߀}ŔC5Q,Eaf|K3"u"RE|=f0yv,\ә)0H<ɲYUnN&)|Qaz = xElveفSqkq"mcm\hk4 N~P+(B0PSP?wQK&6vBnJB3^qbP&\qA[LlaJwIsl6N?xsVj]kGELlLH̖~B9vN h[ل[9#-W2?j +t}b6 V׶(}^*إo85Hġy,'X-X5TRuf`ul|ےi£W46bN$yY9l2\i;?67ƷƱF#9cW0 ~#MkY?,=FnG*P jNF[c#8vp#r/G0 K#wPveSX(2zʌ4iA ͧ6VmWGLj1G~nה7zտ$S{6oe޲"jĒwB"Rkd'\:y?lsi{#U<`݇!G&̙ku[]ݞ˜ېCY=N,<:)D{ݙύ(rrK¬RHW'ؚBkaYARRM7&0Mf\pՈ;r43J%/ Nr췭0-=b[lf$ cXH,sq9BO kzH\|f8PdO#T #7iF+@O JXJ=Az?ES]#Fì |ø>\ya!JdvYZc#csǗf7L*B_c_u$t\ع~ÔWOi`>SRdr3dt@xNMqhF'-+R)M7 EC;R%J9ְLjP3T=*ecACᠮ] y=Ɔ-ߤ#fIk^%m,^;JrfVg$g۔GN\k!HyMX/ 7\Pͫ(A2v/`QP?aoW6㴔[fnR s d J(VU߯pL6Yf a%EبkҳWxμj@>|$LeG =_ q'BӍ%/kw~qt&iށMFX-<ˆ Rq`t)ɘ>}viO-eP,{V1 "ao:b0\`2 !G8\l,WJ<2o=ῑ;F%4DFC}#~8aq!|5A}b[f#Cr&ؓ=W,q\YWC@+ zL>pBTRzzU _~-2oCz8vRިZ/Q؈`r<A eN5/?ˆxS嵿~/M~v.7d{(%*$d|ms; &%}G`ԕ AwP#ZqoDs4n7<ͣ8z=h=0f3.%p.*Æ]sSax84mן"EXxul){ g%wU_w[ղ#.04lLym{_*m0kqܚoji`2y2|3*VBE-aEt@*O5-On #ѷjp.X |T .gd0 ْϼe.}Hk3 gfzQC\dY LW}_hg: GlGoV`ZnNC-ة+UZ[YocfoY-5V!}Xzώ>' y k_} 3Np/9 -kN`H;-.aҏ70EG#Y. , WT}kUn5N2uT'vmYÛm8U*f}ybI t.zܗ/0zx8F[pD9Qq^s)774,)㠏 =4}i͎G\++V3&dj'abk(&'en7bbᓌXUŸ(ARʝxA2cJISס1iݵd?уR fIQ`./o^Q v#_`l{tSӦ⃌*?BS_z CqIDZ`"ܡPwvN| &i8r{z(q~ORscI> 4pfЛr Rm+eZpz=v4v5`D -MYͬט/bYxKc!Q 7q6J~6ɒ^8.,\p &{@So=4Vcqx$_=KqJ8mT4̳6wYzX~i{ syo:Uzk>?(<)|xT= E)mU`ѷKN<t1B~LrS4UqiDt:bD}* S.SC6)ChOTrٲOW[vQ{^W?e=l_%p,8 ʷkUr{q5oz+탯.3R C_Tb8oEb71~7J& Hj{νEw2b$wRNbλ҉JyKDQMH mܠٻ4M.vǧvVP%~@@D >q{YFNB˙pt6$}~"z :\VHB_olvː1= lBgyi|F7u~'V>At! CSڱl@*.Ug*&M8Q{yN߀g/}ى&6WC\:۳2vzRaRk^SͰF -*L~뱟~p}"+ u T#ʤ!ޗiI$!{ŦXyrV/tGҬ͚bFiYLv?EϑE>N'}dL:=b|腨'6Cͬ6Ә'-L 'X(?{s%zFWK_:عvur6-/ gX[ ڟꧠ; ߈$eGz$h(ƾFǟrbN3}rz3Q@#Q0z0$#,Dn(Zߛ>;NӶ3X~u4̲4^@{ǁµPk.*Gg VV;`4G n&a.[8q\(,ɕL}PV3mߞ~) 3%y᯼$7w [874!o167`w)yMйGO ~S _Pe{jl9wz6g$ˎ%)lkEq aw ֨odaG{o22 ¢%& ;zmo<Z;ulT4LunNMQv:$N+_QNpdѹ;5ș(lFT8&EŃ)!nfXKq|M#N+~XCVz_ ݁Kը%vL2˛,G /x/+wOhjvMukļsl=$ vxn* }M{jԬvY{rTgMҲN\1l9zƟX… c$`'L쎬BaYCrM|p侓v-:K7 W< '.X[=A,^4aE,Gu$WJϺq{D*VܷS 1ӡ!NLQ+3\հK"Ke`~$X @K!+0/stRO=dn0ŊWSa&X[ʜ,\^i{ZQsZ|2j_aa3Iip%m&! /0 ΞS.T9 ;qmyG9"Xn)Ⱥ /ovx) )[>dC~5#J0ϱ44Խ3!sR~=>14l>¿A G_˔1 EXHw2Xعଭ [7?\Զ yIUޘS91]6sD._S$/v V$hF͡wF畴>c C/=̋b0woCef,Rw#?I?Y|kSlՓ?s+Q~Q$1]3 /Z[?=L@֓F0oޓѩc"p ?I1T_+ rEE C0zGUk IIt.y3}/)Q'D$dqS m,]e&z{!Q' ҩ`CZ-+Lp6h,.k.یU&7Td]MpVwN՝\ 'tAYIY7Ώ,4F˶mlX?0m}2}%? 'YR70™\o1WTԄCɟӟ}\xGYXhnYsChD%c|Y2Ryݜ0kgq۟`Z;ջ #?Kk۾lq㟾rG``ivN8P ^JSyH)R?܋83ңJ:{Ebe֚W$[0N-x!ua(x:]_xz7G82;5 ;#$vlj?f X%U"}*ʓÂT0[wY `2cWnӦKqdq?J5=7 qæyg98(4q_0~w V,Z)vz zoYz׾ć OcȭaY(>]sv?},P(pٓg><\7]'kn'Ԅ峘(;U W\oX,,u׳@/~g?lv41 j8AT~ުKg\RaWH9$mzr!CꏷG?{7kSEa)P7<[:bmO (z7cHU`0q~GfN`_3XtPMMJ>Q"5(;SN Μ 9}ke@\yf辙'oJ n| 3A0A}~!\qcSxDpm68 'N/}7 El\Gbs-dH%yU{06SqOֽAoV1m#s{|$Nǀpʚ3 fӞ㨭ݖ )0v\͒yvV~8㦐7P8wRUb/I¢v,}5ڈ3>8Su{~t4LӹtWsq$ǭijKI7y}r5aʖP'nr֋v+7=J.,+"w آ<ܙ:XN:[t~Ta{f5v+oao@5a'uk.:+q$֝*Y*/sC۹$IfVTMthr퉼%԰}~k<;YRgbw{ ,)VzHJٯwmq.BT0p3^ Ĺ/v#9ڒyz(Ͻ-_oVZB y/#ˑo[_m ԰[asuv1zR&*OlS(NtjoYpf/L1_qF8nJ~\c%,E=!3&&R 42ﲛdJ{ -%<8>ev}'`O{Q3^J"mk~TmB yaiNXrBezouyjZ&ֹ|9cedU/5BQי?_ X‰. sY!(Wлʫ߲}՚5+I _ЏCI<28´5BVsjy`ďE jo =zf>LyX[!ݛs5m"X.nrLbMLK05 y{&o LK_ 8$MH5T]Q_s )io鄙P'WT/Z羶/#i5Ww*1[$aKA)\?1¡:Ag #UqNnB.ۏڹ`A5#GX/:u?-1&LkwbYQEge.]7Nrm?K0wh1)ߙI?^d}Ν @{~`^۶Iޒ$+U?.uU\ùwhEU FF3`yS۳;j wWvzR qQ>ꛦdIDN5yJS^VB}Tҍ h>CXnvrmb @e). 'RVN^ǦkԚ_Zt.B/2h iz=͋dHFn;]`=B6":YZ'!;n0[Dh= ˱>G^0aT#lm8{h`F3L?ne C*b(ن;0ay?kM˟uO`v޿%ণ)oKX8YRԑ@M#cR3̼M&hw;eBT$R6,s‚@d.^uD {7F(!qRP9⏂ V/zzB 'x;lÇ}Q&j9soAxV\v*lƹ]fZvb/Ci7 ̊YA_j_tI b.c$98 mҺ471kX4N.8pEH):ESkwu$xc݃*6oW6䖀 ս&[IӯtaKEF\֣ 8#"?FcvX%k,?7=^v7JIUB,Bɜ$T]HR\۰S77HU&ɽ" Dw$ `ޟ?NbJlY_lJq=rz?rJv`^ 3cBlqY¼8/-]i-¡GRXn&Z̊9'_rcsmS5=]0* z1 )06*779X3 D.X]zdY^y㠫vUOMރ)GLH&=忧q۶\/)=i8z**As4 ܓI[м$V=-c$5`K-4<܀]s Nvl&U:-B[CǭWV ??5xTƑ8t+,M{ڮ')v?vkHYqڮ:ܣH c*ƾQu"cIi7ٚ  @t<'{Fqq_~w-!y6 Еe=um*eMzB۵0f*AЕe5k¶!a~@XC |*:WGYģzIx2ڹَ GHHz˟Ykwݿ5ā8\B%Isu>B]*;^nkÞk޺TB5(,oeoKPFW%VahYB?bn2LrjOÑ=Pk}D46qb. iFʹw#0Ω=oj/PmA &=D2C;ʳ,̡4,0ɻqZ0E>VU޽~ĺhvwJAgdEЖdX| (f~í!G=DعP^3Ƒ[_ y!eg4-@uf6Hrث|C~b#>zX[l {!-#S]1濬b31- K0pg7٨=ٖ3UuI2̶T\\7}bŤ"J[`~e ,64X ^ƩMۖ`.K[?i0 O=L> _坄jU[d62 (\ڝξtDCQm Gݤ2HoP #HҡʄWWľ6°J3MRtX^mGplTKuks1gI6u9v]aZ} Xwnoy x=R$lǡ0vej.ԙ6\6CJ5E׃`aY0?դ(!Y)55R~ҮH?U<5Jrܼv*q&BIn͆7.Eǻ a/ڔy|D/,s:?P?n+fxq~Q+vBjQ{K VQ}1RoFݏGnˏe;ն0VxDǶ07u ! no0-75v6og/|х ?H0;/K2;l+U^E{a6Յxsګ`nR):S{-IArO2Dn=.{̋P9}qJ$mw( blv#[Ewj [sƳ{qzz0">^w͔ԋOvvT*.@ 6=Wg)4`ǰSwBXk;6㢨s<峣/Tyg'|3@Қ4W.le{]-atjn )h8TAwwE]E^ o+ _V]Bd?o~g  >>3\+mL8 kӰU1-xh¾ 5ӏ TΚ. 3S*V۔'1<ޜ0}5r2G{NF^&9iRtUVcщ\ JTͷN<[dPsn}I:ťHsm \_7=K0m?^HR|FhS{{nWifzr->پ^Td:c14?))#3Veau9X^x &f6"}{srTrmzN*KǑߋn!K_y''\.D2~ޭsNd1*`ISCZ#t~=ΎLgB˅@vSxmV\D*ʿwIU Bd|}Ѱ*NtdnxZW"9:[*-߮)CόOx[={Sy>6ı uE$w暩kI~EBM NFw58蓼Ub|/?/r!܋I . K6M5#$}AړdRp\8gǯo nU N@5NSIt</hIi10gzr;+v> =U۟#H]+Y2@MxWXMNdsq/٬j@M?١>|ƽt׭/ø3Z}*H7džtQ|]fOceeרף8uu0r݌C%-D16`s`yuW\-;ٰbPK5B/T{Ίu=# t3hrY] \[VZǗ[7'!M:˵E#f핪W"Ud_sd*Wݜ Jl"nd *yr6FÐAl@Nn7mq]uZ-NMl&mɟ&1O uC_n;߼tHRvr8 2 F^W\/wrq6#6k&j7s,"K`U>bNRyU3#sKue-s1u8>"Viz_O`gNyce'69˵$ ?]}+XbpX(:\^uN8ci 0xYo0rsQ FRvdmŃXvEtCKarCҚUiHÜ;P{۴ o0rnA N܉-)X;Url+ }qde"qϥ\ . j9iW*pbCkv_ys.L4>ׄx4kOW:NGxa~٫ZX{v}QմOC/^-~N#)SVl l$1| .Sntu ~PR= q`0xn h=Z W/лվzb8ĻH7ƚGT=:o?ʳrZ +oBlh*u f6Mo߀4#-$wp^DKY`P'iM`6It{]no}5#yߜHg߳!ϝBahާ-qr q I/zgI (K^<>gO36[ j'{L^Y h\ 2&uϙܴ ul" Su9`U=5k5ݡߩZ_3Ξ{e`wF#ɃZ0ͳ_k0. k)!$H}`]26_K Lc{P퇻<{8XTZ&:ȸQẙӢa[[yH kSm}+H0 ?DL !8LgnޏC:7]1֕ڏlHʍSU}@R[܊ą̢6MZ8$qxڏ?#d9*vO,IX&R04r2Z݅$0ӲN0Li aǖKÄO,fDZJf.. )o^l-3ުÂԽOǸŰ,x*s)6N/cJ:j,~ۣ~"$?9C[%4ae:q{qj@(:g0ϜTWO n:-gD  =fo`!e=?9̔Q6L=*_k1]҅n@S[ _z6-gƧoė)\8~Q 8ã7>^×.d|G)^6r ſxpT[5PgtFc;c̈́lPzԯUkS׾B Z@~ζyzBaAs=0;Dpfw=kN ;}ςGbQ -ށג^zrMc}l>lgCvtu=frP=`yYv_:sDqjL r4J&f%$qUܷ$>(9s{aZ얿$PlG0>Ij%<N׬~[#骉4毨ٟ3JCt)`:ѵOLs 6m3 E@K΅(9E ^LW2i81c\%{g| #{^"XޤPm/AGp&9 Ԅv6;eR;kSSA^ $ez/uKcwUr9{{_%m`7վpb,88WYĹ;IBeX4jf h۟C3kIʼZf>#W>*19.'Y}gӟY$_՞_ޙ;3}r=b0ؽ6qE G$_K#Y7U)9yzY~#}·>Q$荿b{!EiJ?{O*Ưv)ޕcE*Խ;[dA╳H;0/WzMgrMLRhhiJ~:1#籂?2z͔Hr]dm`EVF^ Q,ڧ;f3S~s ,^l1 /.ۜI l;^C`RY|7AsdR=srd[iϷ\h2h+/}V']")9Nw CUq5L0|\9'RgR e&fپ[w)]炤cNgN(ý us,=ټ/8.qȻNIؕH\1=ݧ#oY5K|ݻ<*,n#፞|+޿-'8+MDh&,{vkM',?sZ_c EaMIy,;ƒuFo>E I*@\4k φlIoYgSP0"9o5 7n(f[m.طNh̳xE'BgBcݾ{ϲ ,9lqfq@x68L0| Ewk B OAwFb.~]w+[]왼1;Yj~߯PR9U 2c< 9#kq0 [)'K—Y's2FZ7d.$pgݿ [T[_R]`H+x {rɺ_XRJBPJ.G vz{%!Ӻ̙;Z ث}JwËG5pYk9SSy BY˩$Ј0iǫt 28߂'~c؋mBImW+ l^CO~d7y3V]wo# ?vf{ܜ~3Y[@Z1 v](DjYA u>~¥.5a鯊i$t D*kFu.LüˎF\k;%07˜,30] g6$}eR&88"z<<;Ŏ6nுʭy7Y4?aBtm~ >]fE֡N䕙\'V92gl%_c'pwF xK\ *}].pa 6o9g*^j,V\YދstD*Lx;bM%Q_k *7_ڛP4dm[~ˍT=(8t"/L'N1Mi[_n"UKfga_HCA=h*ﵗ`鵬fs0F0Fx$OTv_0w[lk'NޣA q ギAWWP!iMr%?Tqx4Ꟙ.GΪ nB\賅П%o%?Ҕ+ IM=`ĺV>mSanlߞq L tۆ5wa8oQsñ}zK]pN< +Ԃwx>%/RKٚoJғoBE`[oPVw9#zns_-cӏr?[q#˵W=rR%ݾz.+(iAϹ l|<&\Pm.=@/W7A螟*M|쳻e5Lc:}/HU 9 K'L"G]`R9O-.wqKZx]ˏۅ3 ^ _gMN{lxJ^ rصIZV󿗮:Эa X4E[sΟ别 F{e9vKP3gBI5F`Xx/ҭ[0ڄǫa"盥tmG>_&Y6$n~sҙo~F_aew24I?HVQx!z%~a5v~13/Թ⋜J@Uɑ}WN<`Zu}|[R= # %96PSsۿeSAHg6e=]܇J="`OHe8zYOy7ɲ/1|lPYDm~ #1WqQ| Ph cyl8cfMK \^cy{#A bǎcp%׈ϙPURXw’0盟WB 7(6+ٳk(LGg3UD)V;j VFzqz|~HT]thNߓ6ALw1ftϖ'Sgg5[ىÕd::>ܒ'=TgoWo}2qDZIAwCa.(m)}YqljU#?L.2\.zbyclďo2I&B[̯3zw6u0vv >^+(OUicMAsV 5JtR9 q."/v73D$Tɉq{~G y:asޟW<>ybo5Ӎ6  M6eAeq:MZX@ռv ly1Eg߆i_D*THHE D BE$E*EHRIڐM~2M5~2sx+̰;Љ{L|S#)G]rܳ:$sâ 81w\pd4~js3ꊗIOT.(b H}7 U/ġ4ov6u#_8y[K,I)agiH,샕`4փ)n gw.|ʐvk6^Hp`y^ $<8S{4s־0DLr(SǼ`_L2ͨf o}`ֿ̅56XV;["~N WNd &MN{dGjLPjP fL"0':_hW [Do&-(Jܻ藴#u;Ⲱ+az8AKOot_DE܀,{!Xd2]'=!Xj+RObg {aޙ,Fv1@zVý4=k:sd\~6w\j'GݿGY|> mZK\?GD OW:Agʬ,.stR8(r?8EA@$þ?\ZH[<V39!uw2^eZ)Ws g)N@=Ty(fp"__ x&팑]gbrƀ];)y)Gij\ 0׷䃔$4-w$tNeBI&@ܼa&ymŐ\B2\47؆ۀ ~P2bH=dpQ\> ۴]t?%y?Qk4 w%@KIߎ|{T6A0)ɉ};;$RZ%uBtu&o[~PqEZv`6G8ڹV Z6yu3;8d"5aC)wR7<_ߪR>\4%w+"t^-N3M|ߍ7Ä;8G=4g/ִ[{es]^m,êO4n{$CWKa C=u1{L :oBN}5X"4x,E7F-.H])k0êxfXbPڼ|Mq χ3ZR`+\wds^,du ]8$i`P;`%.J7,g~㒮1ة ˯`bӸ"ךJji ENrv=*u{}Hc*4>_q?RGjBܣs "Yhȉ ;KJC잍pqF60Oñ3/GS}SRX]$4L@^GqE)fp8 aX:9x 1 k m@&eꗍ,kvz%ry+;}$M&kW)P}+sW뙻;`,Wl܎mm N0߄fIƢ}Npn6nka0d3k{H2_|w{%Ma2Әo<tK[CW~vXYbqduq+ i\m$rĥ|g)K+uWa"᱆`n}w",/ QԳu0[7CcF& oGmȝ_mHL^ڗ=Q{7h2)k$V_sY)mGk.p>X !)c} F0V ̾{)Hc^˱rQ`jQO'[+jnbPcOXJҾ÷4KsЏ$Tzb7k;pN_n޿oǮ߯T$_$%~{$x足ϣ9`s=Yu6Sן4?ωSom\NLGb &`λ8\zIpN,m7|}N0j0 WWf+3V;3~u|U}Zi@Ҿ<[ cݬX|Ʋhɍ˺h }=E06j¯6ӏqrf64Qc[lʆ'y+~7NGbw`t^4[:`c6DP DZ|]/tr਼G4kmG[iPϓ$+C7fጤaHo k9w&G(=;Xs$L'PYI.[L"q0W+Ox)rt̪/hmfzou}=  >ykG2P0Je#=lIt7t5Vڎ/LZw`O9|vgL :2CUŁ ٧?k6bQ y:G׼g[ELq[硿TN8 Z,\瓐} f̻+:c\K֏X83N,:azc귤$Óe0x6Uq.Ƕ  CJp0Ϊһ/* -q2[`gwK"ئku?ث^o u[ՋZoJ!5UܪAR> cN[iAEŅas*_.,H[΋0C>3nX?+09[< s1=u7E@qcŰPL%4nzI0~ {C%0v⬱뻕pU]=r8ſt5ۖm\͊7C۳ VkZ`#3Lz1K7t_cz?{(3ɧ|ĹS]gp6C}~8̈ q+Ż`)gOU"dwSKl&tu3oRz:1ygQ|Oʚy%2V@HhvN,؊v5$ -r˯`M .2?{Q74wy5=ETbWZ 9{m^&=F4ΰ>(U{_C0a#6=7{kEtkjY m@(Oh>s1wݚsّLhwR72R7ڹأyęd>\gm4Rew鱏0kZ̈t gѥ#qn09[,.L aߦpEJ#/ݪ)aɷ?.خ 2A3鐭vГ4gvi 4NM;v%G;!xAW1nIm56%,J#mys7Ћ5{ -*EhL#n?W`%2QبtU)GD .?_*>]S4\So[ٽǃws Bov,d^K԰ﮒ'pjWsxhX^,?Iv=L٭L_!'fo$84 5(Ǟ[¥Pz]#M9߿ԪS8Q;A'5[ɬMX4Nhwj+;p;N5&䍜gbٜ!E=m\6ҵW"vX9% 9L"eYji&Dp6`Vgd,H:PpJ +¨RAE#AMy3zs>d'eSpt9ucKh  +fge}Ϯ 0#Be3|9伣`Z@"d?R 53q:tKc2zd t=ΊM+VqH6 f,6ƱA+S%\lו pF`qV6ky-1wבz6`00c~'۞/|y=#`䢸~\=WSngӣ;,m&6PַwCqYq;A2(-QCPk6s]tIaӼwjEŷW`u'9#h+٪rsx4kKܬr8`bDCOajKAʐt]$D3p/w;c_#x6‹J^uuf_d4a6,_p{S+o="Y VߓzQ5ӭq1WzX\5@)_̻^a'5>s 4VZL;dˬ<,:S +C&rݝ^=p`oF9v+ΡW8CK&θt)*XT\^"u֦gQSYm釾+mpkzoz~oЊ.&pAޫǐd,{sW)||{‚n[N#|gt˟doyۀ`ޫCNka@`=Hfi b/"ݫ>?m3O☥x"̙gQ251?V/.>aOCvQsz J\O)ƓksðnKQ(؜ +Blp]3xsW[ٝVAU!iJ8^مs$Ҋ6Gu1ilT=E H4(3u`y!DC320yY fs`jj;@T N<eo X6 Y8LCMEN0y;(BVq['tWD17z=/\G/Ti}'?0Rc9f7MwХN6 _\ q;]$hGRUBYOuFR\cNso4oџP-3ɲT&o |K& L5nzЦݠ˚++P͍%tb" qel fb$%  3qb}=su7s6fOX0&/!sݐr07<4z`je?x{>@:5.^F_~PISOK6+0og2촗2]}Pn^l%ǬogI/b[jI_w6s2֏|s@\Õ6;]9f7j]Yu6`ųI_J^j`V TLm8#U0'yֻO}gH֒@Xl`Wkz.s\2W}Y+έ%9޳"z65?Xa 3RUr;YGTw*)@s2ɍ8|S{b /hORмum(6ȥsi` &d+DbpFH:z]0d޺gߚǚyJV{W0s?2̉4Zĵ+8Ur;.>t+{Uٚ u,c-kl:kadn>.dŖcBzrw3κ3KTNYOUkw9cTN KBg,R8yg=4Q$SDǾ9l]m-gˮW77.By:jmV(n`4RckMz]vR{뢲y*0dⒿūcǟ wb8f+0VOE2l`׋cA94''蝙}/ % 7ԕj=&HsRӮb!T}k@Pz!/"Ϗ 5,&9 ߷/t;;uMP^m[="fE0)(Ws,[{8Gnړ,|a 踘 5BX{m"sh{&-w;Z q67K;.xҲͿ'`jەϫ!.m7j\FeCJ`R|8z&hq1N[5|A|qO|-q\TvB Ma)z]NZˡ;/gg0{՟p@`-ר)jLń6< -0t? q#2@:\zZ.'{Tj A2VoT1՗R\qy sLsaHG7FC-mo趿J]<9G;F>gX:\ssV]r]|7tl; k4`rhͺgSqہ i qRñ0397מǥLEljT#4lt"8wMêZ[O"=q&-w&YYR苃Бv[#|;VکG,\K"Gĭ~dך燦Rqpu j?o<-q}jCӚ`!5L} %DST `<3k4ZUnUqc$c1?؏y~ aU_a%1˚-ATmAjAxKa &I-P:Y6Tڍqmc:x#C'Cwݟcx|~ Fm@O2K`$Z3BrTXyVǹzI*l?Kj;lILw!֔x_QM]Z!!.j̿i$+nʶjܸU^a:ѡPSWk7q|zW Ͷj~ì鑇 1wm!8}ZO<9sIu#"%bW?뭗VxM^`h{:W}|Sj;gp4z)XXUqsL %ɰɚ_eK?~j# th N̒78o# dDe`!X.~:sznbއ8{I/@ܛp8m*M@Z>[}_E}wJIB OEGpتBxԫ`͖X( LjfW8B/-$a"]7ص aot:@C䞧(O$e>I=]Kl=NŶ.aZ79z`jZT&Bqҥgl2?{tTmY'՜$̓qVdhP1A; Xr*4AuG2 15 0r{\`d6Cr_ ~HpQ3K =+Ssq[ghc=uM mx岝8Jl\<~ {Caq)rT)}+qF{+5ajP<yqWM@k9?(pƣ@0CWo7=;y`8IaNwF׿~M9'K~*+Lw0 d$/ƛHfYtk?k2@wKcauga :Lc[̚$tq~uƍX>"sb/#61F{GN5Eu â^՛O'4M#1ٗ` ;ppCcD_b._gkh:xRC'Ka)2=~u=c"߃g/ _0f^MĦX ~!Vs;Hp7햿!M3{81fhUwܠ&s]>6BQFc:fx*"އceX_\W쐯v (椬sgخ;v;7n\F+wћ%ոէB3 lŊ23J@k梅fQmO:adVV #0otOd+ɸ%, tdCΘwJx$jX|mT{p ;ICJ6i1@ߗk6 ķ{p=#0 wT1QCwk?K[ Cs/h|v'˒z`ӺO&_m, G*C[Ygp;rVŞ;r,Z-O\NDz؍#z!^A\TLZ޺Ŵwm[6w,+jrY0)*x/i8͋|vQcK!Y. n0>qw+}ZKwq&q yࠢrA@7nC~8w2 wݫT\QVxjQ&kNb{ Xi:Q3o:7va-'Y :iJE'y'c]礯B6$^w 2d_ ?(g[7xnGIASVe"Z[svw?YzPרt' eܡɇOּ1Vpi=GpYZn .?A:)y}s V`CWT$z4 С>I帗}]x5}wd [65 K~#_\gů3``a@ΈI\*øMz|kE ~aşq2ϧ$XLI}IckǥP#h =_F|#1\r`\塜ngljz{'؝ Š_)4"]|4wab ׋܁]А*Z7 A^JZ Wu_{aytk8ڹ'An+7y_N հ*²UGܘIpڨ=:G0fgrnDwu=nt/=0i}j{SIu/#z2+ᰦEk5h+ ﵪGќ (&U7!ڥzݘ#XN6 ľnNkIa"-s2k"[[C@sYv1 6\ ݎo(8ea|VL(H,l<=jzI-U-j)n.}?P>XEm՗n`Ӂ}?;'VJTšcyY.PT K SM;,!8"` A?pg nP[{M}p3k˶J=:w& BOiC5 xɛ;zXlW,'TӧslY{>Aow!0!XGk^=ǿDZ\ mvLGir0~(>y͈?5v?͓ v'İlSR_;5^:XgqMq(<_j'vy;}g+; D3sb"nQhO?70q'$Q[?1u!gzp3׽=f]߱澮5)w\'gznsbA͍BF;m NtM,0E? +]ܷM/ZqkHL,5VK><`e/,€Y6];u .ł]8zxSWq 7^֮Ti}Ǩ1t9SJ>+ѧ@Ǐ%Y nQ{L;1$׾&Qde46׽ӪwGSSti2Pz,fqI^oO"/l  '9ɲ0㬘eBʦ .r3=Ti ύ "FqKTU#a&ire}%{(}~:Ws[KH7áu_l~c'XL րQ?XqT55` )oֺ00ȟd8C*]‰eb@med86+ '.|,{8ŹOߎg7Ħ"CGLIM5qC#+ҳ'TL-Py`9ANkp9sl9 E)$ZeN >l ZOo_ )ph)Iq!پluS^yC;kN{vS Zo%Ptw U}C' C+ b-WC- oՂg혮C,'ٖBY= Rٔau;ծ!e6Ŋud6*ihLn-!'Xbv(;o Ց?'l5?SN?USeJp>PIݗ$3!+ !pA }?yޭ=q-WcX_?e4robO<|~/NJ Kg~U%9Q ks g5=vPlDˮ`]&'[丵rGNU5~c$TY&b0ќ7'X &ϾP~xn^Jӌ+;LԂ0=9N޵JR"Pyi[$bpћ<8;P{99re&pFe/OqެPx",:a;qԁot03i.`Znʙwx/B(~qY*Ihl8KD{+4hDžsolN=Ui}ؠ{_-aر76M(eVZ;zI|{ω/򿍐~^k(/6&g]SaB0SiYHxYv7,z^' $}V> %\v$Y# euZLP!YS ~V8H+OX=ɰ9ϕx3cvA]bF/+Uv_< L߁^#zsdUZ)2"=cSw$ tv;mn$٤bWWl7o|r*/cXq쯺se̕uzI:Rg2х,/|:H}p)8\I?!ZUMpQ\O[\ힻ (B۹A$vNaį!Ke4RM'ͅ[l6׍qcW@X4}#A:\'[^rd@ rK+7ʞ}rfuYwFw(0(q2s<ҒH7\u\)QIu=Yh͵^.T9{KЗ_|c/ٔ EHfbR,ͨ`ÎQ qk=KX <ׂT eUogl3SHF3)Js͚<*Iχpz֜3Kw^Ǥ* yW>_:y_APtd\:=~yޚZǮ2i kdM4sC4n8Y,yhn= QS[W;õߝ!8ƩI/^!OO#wŵsuC0vh,?+\:NaIYԨ)~s;t`V2Φ(^XZj  y HZR'p]X#ej] Gǩӿ+M"vhq{;:qV?_#UVJƜրFn\t8n ₿uKz8;D?wjq0[5Nclٗp &6ބ7|)7T)pWTnw:HV0r+oMއEYqI|ƣVZ܀{g <ׇ+-8@~R5z$|<`-O` pzMÍ\q^T%(9w43?ʟّ|^"pv HF"۲}hw(D]lM8:Y*Q 쌟ĩ'GTkcpt5]W6` ʰd3~Rz }8^] ( }bP*2g6_M9Td%K6whT"byER-Ʊ+x/!GͪZ[IrNu!#ɕ,ör M돉Fbx% e7Pk}&)c*BtCɟ-rcqF2~ RO} ݳvᲂ3LJƙeL-tWS9I95526Cb\Xq}. ur2-w@_ueOX'.NHNiЗ2#LMMM"se:L ;@WYtv+~нL+yjZEǕvuf8q=?V:_sl"=5Z7zqE:EM/C덱2Ҩ_wI"LdjuSOD A;o^nwfm2.%dzwdwBO*Vx>/vq\OzӐ֗3t‘ɮ$8U{4!noKnS?Ǒ&>Pa-KcGa ΞxR\IN~q}@𜕓`9|>q-F,\L҄M~cݞ8#7_Hja iUڇaWSU0)g''`%+ 8Ŝr7jPAr,7Tf=Er7'tjwR/ü=7g+E5lVJu%A9yr2L}18P؝%2al ??xV ۸ @f}lڍT `oͯ=ճ$Ts530w|,[ aS(o-{`SyGE={z=~a>c$N]i <{\``zg=rb;qL'PwUIcIo~ iL^~K1P|<Ή;JOkH̓gԡgVs[N~^X'ָjw`hMMs~.mL{?X\{Eizv %UfA4Ia:&ş6^%:!~f8U"x6z#rsIg>o2pH0{Pv.RFmX尝EP_0|CY#{AJ%HNUq"}5aKkCxH[ >#"V\7})$Nʦ dю&~*- qAX%b~)SL`qxp;)es"|!dMS%qz kL.aqMO7,@9ԉ &*bN߮B)[N:vno sT(&L}./)'?9~¸:[n|8U2'hpВ ʻ_6Pfy0eRA;9>HxxA Nm t[j}=X__U~΍HI'^7C`8I!)ͮ_RD=#܅+9|$ǟo B$BQϤ+)I1Bl]9Nļ΋3"rCsfY;H^_- σ}Яl@w@^dVԺAXNܟf/[q~M# IY e Op&LwM8Wrj8z[}VX3*`kP'ocD2T1li"Yf +tā$s(4%4*]?U'p}$ṉZV̆yQN~C;ݜܠ3{AdرIN住 =,Ϥn,$9fp6}C8tz/U=rA[9B G%'q 8aʾ0ziCR*zMWevJkwv|% #[9{qJ? c5'yS[^a`rNc=S,.N5k%N,_FzѨvHuѕaZg[ >Y)4 +c{f Q}\L#n1ܵu{~0gfGA=q{oKPtR @ݻǂkyw09evwLe;iv]n"NP;se9~mdgu7NAjOOaGhi,L1.딅ݓ{H+gq*7+*.p} tƂ倥F8}@7JWqx/j~; gwR.wck>qo6Uq8wˢaUV[X_E7.i(bF:J~ 0ҩ' mكSON7rђy1s,0)d3OqVIz7>hec7ϟұ&=dgmcxX'nb }tZN '|w ]P9a6Tc;cb֝^}Bbkv3Nc~t&c|/҃1m@cP D[<9sYa#M8o qu aإ.e-?6`ě6 :Xa0?zQ_S1N? `^&.1(.:hӊ:kO po+ QA7s :@fQBO79ZM&BoSN…Y?i3n,au [Jk9i;B~0U=wGZHr~o˖â䉐L?5Vm{ѶW8~D c}{z7i+P)k#u {HV-0)P\ lJMc N Dz0i 0.Jpu3q?NyXl[, "/8칿oa(Q!C VNNP>51|7Z {%o+X5vNGaaHR(pD0sg8|weRf)8Ą!/|1YppHPpاP7\Oi;g`4=~댴.K999 1K*g2Ci $ Gl¬8q-DHٝkt#k}F {B.nf* K\'6@`FNm+6cbtMD;au~}1ǩΤw忛M-qq*m=t_ :3 64K=Q78 CEp㫸xdבhKaD3`y3^1"ÈjLmOZE 2/,1nVEf4S<2sHfOO'=_ӎN-műq.PM򔒴03S:UEI r4xTUGVS"ҴovWɡMAlܦmuyJ}mg&51+{N'm1a^8z/].)N8pq.t,%SrqXJpbFeXH3kI%s›3/{EHFe}j`R6aBhoEԇ4_Iݰ6̉;3|Fwq\p~!^sR 4J2ؐ0IyrD=zԉ׺ @=@Z\,#%dMW[|Xe~gȎC ~  NJS Mˆ\GP7=$٘5<#z5^Ʌ='ssF>3^5CN>5 +%|]1\O,%H rScl0e$Ά8MŒ+z2,y N_3MTytbЗd² u@I/0X]z)0+ܭ4|dNz Ԟs$kII8ǹOoQiY6гf}Щ6i, `s:NK$~$Y|8u`{F$r)-0Vz4Zg9u?оo܅c'+v-67p`5 z?hYH%,~\*\>/\5^72S23ENm,M-nWbuӝ:q~?aM{CBp2ݨ"\ g?oKzoS! ּIn4+h;}p^iseYUӁ2ZS81&qH\^E,71P*m%=8`$h@a%X~Ʀ1h Tܓ 3B˰*>̏#2<1wG<̤ n־'8;c")ì 7Mhck޾_:Zf`*_Տs;XY%oJE#v^ƙ?}HʀK}wN]0U#5/cD> ՍMTU0a}:88NUbE:%y˄`S~R=9F[ Bݾ9.OuwUO0G8`{Ox]&"rx,?<}mUO K'PwgfIM]쭽L0 _i|wr[\'HfŒ4^3c%Krz~{K(> 4Ж E0Y}y܀apUne&\/#Z=5uSDºïC&yWy'P_ga٬{7+]d*"%A\_YxM%yg#/i@?})%Yf<38Ѧx!`LúRO]+eȫG(0:a9k r=8=}ItvGLN:b]՞G/ @p:>>,0YoWk3>eeXT!+Y1y/ Fw=hم/*h00C-nJ"%n(2 +A֑s\NX{GBV$eݹx&E*ƙ3t`"F*`ٖd&w/zTr`[t[ZgX*"5"\$<5AnIOwW?z^m]o/A)H=NnfHyð(?W-ni[#[qC%Y[ 3K,O)A~3n(3\Hx cfпIq&,Vu!}$7f M{cI1 Bu=͇G/Zn|[S%/#u3=KXkLM[Cql׸պ ift܈t=JmY$S:$pW+ϵcǯfCYuy8s7!(Ib]][ͮK@bf20-N7"x)Lncib"R_κVOLjCŝMb0ӗ1ꌳ4 MSW@R1a874y%m28s;XSj={ BjDSp~h_=קw+-W= $>nZpxMq#y6qHwH{x)p9l/ܿrTT?qꢅyu:اs~L`tL!,y9safP>`kP^I)r0ףq0҉ݬdVg+Yތ%o6@dɇoVտvl>O7q<ŪnٗŊAv?-G&e0I|ep|+5ra8E鍋LÑceZ"nAߛO]uWNA5G-!U^Hr֢vsMWroJ6h%|uq׳᧟Pc+Dm'`Q>QȦ0i)AY=Sy*f;{\Єiڸ0o=#g .m|o&SQ7dyOvbt9= oAbE[gLs ?Y?Ev)jJ L\􂀀cXsGtS $_سW hxU2AW*H LFK==a~_ }qj "ZlXvJY >I:*MDñE;#Ht,r˖/N'֋ܐ:PSGڥSϺ-6n% 'o=&]l/-%sʸq8eǍ<KHM~;;[dmNyVgW'+<9=#m;cζHL# ljrAN /u >CgL@F sc..rFtn#usK+PV}Y~ H>=d|1[Q~G~w񑔂dϹGf$CA+Ӎz?mjX9Tswߍ>dk3Q{6"u.kxkR$=*kKL>?3ԑi#C( c$ň|&q^&#u֠-B,W*,_jR ]m.Jj3i1ٙ_ .CIV<)o,)S4ͪ:#tＬ&v+("EY0tG^a$tuv4_XY o־)9 GOX-Dp@ѕx3{̸lZ_!n-u:״y}b-Ag…'[o,Ιs $3P]<;C7. ϙx9w^,QksRrDž/ܟ.,[gd%/kQ}u4zOނQ|02  QdmU6JU#uB0T:Mи@%X>|/yaZin a\(y*+#dwLhգ!Z|-'z?SG2ZHVk Nkhg3b)ݯ5mm ?'QrsCIvL(5_8Q"a̡뾙8o8$`⎞R8Fw+(h1awD{)DA$~tM*=K\M؛6Yrn" P?}9~7̣ď!~ PRaUNR'<97mŗ~/1Hкg5Z9\`ZȄ mY6ǒ?mLHʕ2Q|һgƨRw\، u=[Kw3yZvzӏNxS$#|8v/$]=3ƼmLN]Å ^z ݶS`ӷd`tX)N+#PgmzwK"?`C*bN:!U {s?VZNp)k{`&۩R{,Js܏ήCS)K.(+}u'18~ Ӄ)Q: -[4CD;\L0y~}}bIN_qUR8A8;cW6)9,[l=GhyS8,ɢ=މ:ð=ӊL4r9-U8:h*,I!D$$RT*SBRoTTBE9Cyc_yޟuuz>BOă~Xb]H[).q|I$6}|# ra ?<_< '{< NAvݛ_ kǣ"lq>blɉ#.% @/yHuVَbɬ?Hgex*}+黟0SSOUb(2rI&誯xV";Pe^8 H85 J7 5.g=LP5fq>\ ]8 n+tO;Nް4=#8~9"~rWRwc/\3*"!Yz%|s濼M0&xg:KXO(tu7]qv$LF5GD歝@[b>FKOƶ$(3%'r{;FOCvoO(?}3 ˏ܃{+ խA1ft< IyK !/ZoS Գo=g}6&'٘\Pٶy[fû0>ҥ'؆ô7q9C8t3*=7fYI2xư'q9qef 疌89_Åܿպ>`R=; )c9Ӊ IDu(k`K`m:cS}v _M0~+R۲bT{+=ZWb{ֿq>{(dʑ3,ں7>D ʧtAwHW۶ϓ ǟT]7%3f?cCu۷g =akxq}qkz>HsM AەJ*? }w!E(f/޿;4ḮPd;BcF 0g=A0./PmUkǴw?Yٯz05?Ŋa$).>m'whj#)n#)!t4=F -ZBw_nAy#C3N[7e2.*+=aH^.8./2 EX6`_kiZ71_OŠw.`=|6lH2l]L׳|V(F>~Gq9?+Q#^R3SZqSia>57?Zq8 +M΅ Q&xm o>o3NJ 3v91\ЩQ;JB&Yx,=. NV "7qdņ@En&y3P_} 0`6AX2T[`a%",f[>k%/OT`z=̿y}jyoR%Yv3o]cL{8pA+)esxn9/ .}ٳ$a-e]>xuł;{bwRRg-!5m?2eڌOE7S*%IfSI.rua(9K!Uxf7 *K2% 5*ؖN1ĸ̓H_԰E߲j[<_yUnʨq z\pC+ fFzPNl .K7#س?L*cxEFJ? n&"z.di/i߷]Vm0B:_8S1WȄLWIb\q0*mP!\&O/7d=~ r_c/iv}zpA;?V[i u8wfUvJh9Ty%KU?=F o/?! 7 m!Y2}\Raa zǣaγ^Fܢ 쀽;@Ds!dicNoaZGm^XV`b4wYH9̒u1vMJO'#im8w<+]O2b!`.Wv":*@Z=|'+#mLgdGڹ½yYX. cw`Hz`t\\^zotO?|C!us@z>x2f UgըZw1> 3-lmy1w](kE ->LK\oU:l 0' g֓~~rNI0o/Anq.K?}Oo;MX=,)زH+F\@!O')y,k/9 K3OÜMC>g8+jݟ_k䆮[6>D#vjE5AnIO2UA g8K7\yXׄڥO mT9B.Ezӷs yjZ{ 侹pel7 aKd=] R93&+Fn_au9SL>2p Oiw>Oz*g`*$nb y6ĸˆkX!Unf xtmCϺ"R`r7~wu&:(m0\jU2 sK M, $9=:}̰'iV?tadi6)TkqTKJAl$6qnU̶"@fvk2W ?.5IW=T &Y؝$"}yudkg&\٥:Qy|N3|;3x\v91/~>)Ü8sxj`}[wi때 q.#)m|"`135 Y2 x"+{&O8ˬ"eNVPsO6Cjg T$|׉iRd19N`!n=V8u)O _+BCgiWk}39'ʇWvqųߎU螮,0.$Y;3g1W3l¾$]Ppgg{d)(O2r gq1#Z0vs@" lW>x6TKB\<]׎."kQX`jZBbotc^?[CrծP.T' `ܯLD|>gٞ چx`H9{'kmtuM ~Q/e ;bF;fo[\(o6& %懭{|Ӷ2 $֦&TKr^v߰Ǘ`97Kr ,QY} #hYz;v]!:VZY%O7#U?C,_= 60_NF1rVݧܰD㐙&_o~Ϛv.z'Yr(Cvږ@=q&f;,܏n3"Hv?-O6v߰aK0y/'g23L6C_ʓSXy-q O4v8TA ?ӻg8\8Ћ;rBj4nʇշ+)e}l1ر^~Lz "oǾ36f8)J&;˭Kw6G6\b[ xj+RYj/.;b:8TmmA+rÀZ|$SV=ۅzI6!]-lڥ2{;{=.Y]l%nN! _Y͍B!ЛI[ aD,8?(M3$4/emۀ~嵉luQS$}c,~UNO(WCĢkwڽ_ %(ob5 ׁ'8|!U7 뙒҇ R`+|^?7߁VI$20:*'>4fUGމZBPJRsڑ)Ģf= Y&8ozO/S$)EqY(o~w'^Y8bM*5{ll5W /.e=)C 'EHjNt >芴U #YO3.0vG,?f}9+ſߕO8{ufKLI]=F?}K0.bLTx88j k։cəǾ,PYa҃Gye*е{32N>aQV!~h1+7s2G]Ca2Έ5iQ԰o|ۆ'@uy#sZ'_$Ʀ_0lzRI0~3cV8Ruĺ/YBkqAuI"LelLCv͟D4A.Xȁ *֤cƲkd\{C ziϾJ0՛737~hn¶&G}CNF)Gz[= ԟ˺0+m*'Ji*f;.cO ,waO@kwиA7 zX#m~#-DwA Ѱ~:"b+iM۵6#}|-ŁX'wvsc统;*ኈJωRb\x V Q >cu[vLʷo?#R$e{˦gPtƀP|{[A?=^*AS"pIli0+$ql[:'!w7<΄bi{}4yߌ<)ςpѥJ#<ju! C8`q矤.EMQ'h9M;}hAfXgL[==/5Vdوhu^}>xO K<2&vbV"V SP<1*˭5m [J m[Ēt喴FðJMHkGj? yC۴FP61y Gߦq.O5>SXtl&kd }a=)G#9# ^B/9Qy:T&yܶG3%Ik=`6%;4^}?=ve04|T!M-|Dڗ_K>pguسecBG¢Iڿd+$/41^:}GNbN(2^QCKE-uʟMdWI {t`f}6ߓW`6>>d ('" j`Dzp"vn/tsu}#4FU: 3:B"iΈ(2J2H{{3Y1`0fr뱬G+-u\g^q䷣'p NdV7܆.P,' 6 RlqvHFAmօ=kWb.<#TF fͷrA;k^Y#ӾYi3D|AAjK yo ?#daԡcELM~"8p9Eյμ±^Q?3S F5ARDQյ[Þ% qL9K&ΐ:]_dP_Ww9O{h̩2^0=ٗ"92IFJ%c'ct u;EXK@cIN'.$+Iޛ<H&#TGSw)Նwj^yW6 KpF(zw]Y}Ap{^إ`~Ue䟻Z =ޝ`~Օ$mR9V`?^;ԨK0W'\i𸾤kG }E;?_FWz[Wu;X` 鸸N+rҪwPvÀ0ݔG* ᑬ.ܐZ{f;w'bC[׸Cijq2hZ GLutAձn8:TH0WgdU@dž&4hMUM{b? ~87⡺K;8Ru_B?Hhzރ,nRG'bR vcz68c,{ntl C6. h=㒻-%;ĦX/v4 n. ڿ:\>҇cM:\zs='rUE+gϒLN즩UrfozfI{rX|vLVpy~EkҝQ ,7k7b~瑶*+^l47ɐ?.sfP^Cr|#"~I臱K j)Жf(_' Er򖁺SoL7'dPJcMmdY*2uDliði-/aMt,*3孏AZ4 &P珦>V|; =\>`%D߲z`6<ۅʚ;tQ*s:q%Agi\rTk:_~!&+VE4ú$ 느~YO?w_"?Gu+`mU˟8SyZ+e`RU}!7y5磛O#Wk҃0E=؟LV ͣ=/;g&#ɧt|܁um5E-qUO%\K`)7X&Z .Mvos?_>sXgdRiw{NO\ v^\EADRZN3ۉ;@1b$g{HP,;fwgpВ8'>j@r\1Jc 2 N\l)y8I:$񊳽 znqY|u!GLB_$-8[*aޏtˢw{`нJ>}@|o|^`3wz8dx08`O}[~hU፸(7L6} ݗұ0fha탙4W-Y+|C~>T}?=G&Aی8x$^O>bHg0aO1_owO/=e]%Jksdz@9ܖdO ä{ʹ)oLW'"RK;qbt ->bV?= EzBStYq1%,W{{f%YXbm0>9>:j4˔|垩L )[6Bq>qT.Q5E>V;Q8G`Lꍒv ؟(yR3AB?-Vj^8IY;^Żlοn W'ȱ㖗3| + ֱ).6BIgƑ,( E蚋:@](L (yԇ~X}:`*3a"6'0++]T 牶LВ]ğ:ffբ9,g ʞœJ>^{k=ݨɣ]}L7b"w]IR eZ "5.іGoJCfH9rL}" nmKRWoH|&5ekxj8p8 6HHѿC0zOg.]\Ռ]*pe%Q M.>c Jfvsl[/jLd8:x ķ.'/xI{}cXZ=dv.o!BNk}GOv=L$߃/ۅ [wC{Ci.C$2q A=Y7)z['0"?­gVdH之G J-.`7KK[+D玵ivZp.3/wz5%@y6{]2SmsVNÕ 4˿3q< }]BjۥlOnXqjw6 ٺ)[>;$ƕkH3^:۴OWyGM;JR`Fs/VlxXN˅;ȹ 7D||xjF0tهv^s\ytV` A~և.Ǎ | )ηYPpF4 ]ߖw)=Ǩx;wqΗ όI=o$Eݺ e kZ4h#Az/ ane 2H0mkQŐ_ma6ΞT}F* }- aH8^?&gum6\OS@c"[ajw`X{uůR$볞ޖF/p#" G CLiAi#߾~k\9bddp1(7܉;Cqen6vlɁt"Ey_Jj܄F3\*ޘ{YpcNaӚDPm ^lgXމ{.&Bջf"pu'ihHRWŸNAywbCOi`}} #]1Z`Qꋟ$ۮFw uOɪl6˜Jq bllǮ w=hTӘ֐XBv^$&KMZRBaIj7μ_q1a' nww}*$mva['T'>u^ Κ);4 bLgKւ6ɴS v0a]hekdMXu_-xC iot֍ )}81O~3|˓z ՉKdgfR aglGuk]=FbwUߜB-41!ybٳs$q){mwF&l:v;ӋdAf{ ^$CIt{~Q6#^ZU CǝmÖ;6K\*{b:,_V N?1y-&\WbޤnYؾvu/vJI' RqƐƉ-2?66 B2gBs$/g@7s-Zr_e5qm۵2vn=_c38Ŋ]rje&ґ/d~x0`޵WޓHO"AWa5Al81uP(UǞ+g}Q[bXE9X 1'GvH̜ 9*r\\*quγO0.ڶq4|;a[e֑/K3J5ۦN^l"YxjyxXݵ不\$D3%ض`޺v[Z '_ wPK9?%\f; H.u[֕Iw]wL.?lw@,; M?azRW$Aa3 g2 >*⸗+ fѤ&!v$rt|-Λ3yfgzO-\! ` QHͰO(5G G;'=NDˤE;\}"͔dKHg ,sD 棻]۝?8y~ir6#em0;7}" Żq]=;k.֊㱯.'3rɔIhy_ ]h`Wy\.Eҵu׾ ZDzCo ?~ [I6o,$aćg׼4`( {6Aasf}x# O Ȝ -HkmݷiѰh4$P gz$|Pq˽SW뤻/lix_[Cd9WZqj>>eUڤp3b-X9gѽTl쁋Xd{)bE__=Ni:X4H[o ߎ\,xE2$?=Ck?5[`T[8K >߄]qsbG(0ZwX&̟epM:EZ`jܠaY3G{)gi~ ;|*qaZFİOBFin'T #;'MHe޿~A!~KQjQ!B.^_=xI=9{v Qo!c'|*roaL0 WlyV:!Y9e'?X9wݹ!.W\m®p>kt҇0s(7ʳtea)Tgd?J$G__a"ٶ TlS#(}k9k 3t|i듋lWF5dfzg6> # Ba=͡$ 2X]QiF:N~\FjF&&wPyˎ̕jX!vX>";ʶ$X"U*+ͯW\w"i|`=wsrԞZ+8!'%\Uɮ[%oܐ`Xg4d}r0 d]YK{'MS=j #ȾapچĞؙ3"v6z&>|}VmLf@8"Inƙ_o_ ЊMe{|(Rcq!$'Za}j?_;#`xm]vI:<?MC\) 47Ӈ9!Z:%٪yS}g??iʈjN^^t`(L_R ޵y#m71v#( m wyÌKϐ~§]fd`> t^ w\r^;)xmg|7ӺL$ hA݆0k`j^v?mE`ֆ0'ڂ13|$EJaTvDŽ??niB2oS(;,ez.{Bf]Pؗh0 aͮts\W8C`AXR-1^vymMeˆS{JR:On?x][ m %N"w8Ě,:߾SYv˦N`6jsm}<7bJ]NhszV9E*9+$r;^BsSt.,g%{h5ѻa7˼[]|^7d|y}]N,`ӻ8CC6۲S Ԅ^—U;iX&4`-e>L^5"?I+ϸzh7ۥ>M0'H^ ˃>]&JҀ崾 &N méC^m{ ~9$3pY;;`{'hݻ 0FIv'^%#}u/Ġrx/[?6-[à)^q,XغuS.؝m7Rɿa@ʽ1o|q!4/V3͌z{ u3g˱b&OHl*:*,fSY~aFÌ>zH <3ãk#}i<͹CmL=x'lަ8 =rҲ{ xw mp% A=XJ&Ѵ;ȩћCABXvg~?I&lkf7Oj rP 9}LH5T`NN[<]<u7!y$D`F,l8cT~MXP\` } 'XoZo tl%Gq|$6Qmh'9E}fEvϢa/=^ZK)de\񃨅;X_yQ7dN^λ9"4F|")gC|UXhT5)ݮ~_ ]mg#`rf(C){lܔZ^&9Gw[#c;qXi16U˅ YY ae+W"7wr8yi0?dG X?~c V%aդ#EA 5_XfH?,1~J0<8f'-E/.SzgX9u\{ytYfWyboU K 7^:1b0snbjlHwˊsi0{w{ N)c-_Ypǫ#w VY'n踱J? DWDA#7ls RV\[?y2.rԶo=JKmI9-;41imkߡp/ڿޓdm{ ~0Ź%+)OXz>$OI_ܪƲ*e&RSX\A2%ά r+A Y99P[~6\J4L)>_o:a:D ߝBrh(_W' vN[Rr)ZB"m%ly6,T6 EǪDO4ˬb(?&y r-6Ељϐg'<F$s&URbcq\][LAlB Jjݑ悋foLh&oR-F`:n{ov~=o>TX.5N0# 3'3'1rp\ W[2Q{a,|Åwzp>Lu?6sgj2C)c;pv7JP.m.u~8&s6x#$(0o*I{"Mk\Q|Ǘ θc;Hެ_8p`ƫxXNvLqo{`8z=,-m:WD0~i9ϫ ތwonC㫸v oGv/ 9o*_M\[݁~୨j=_Ea:/C'Te]t.(=U1^U$7$[fUQpA4$I)Аlښ"`dnOmrjzXtsT2,ˆL3 uej˶۵O+y;c{A'2'IOcn!(/J~{~D"Ja YPgVu~KRǡ?&nJNU7>EֳVH_wqjWީ.0\6?P%K} ըcl!(n#-kKPT_r ɡ Q hG BFa|b&c_>cv3+. 4ɛ0s"Nur'Y8^ -m[ic~;}O2'.Q& Aa+W?`ahgw\?3uLȘ[o;v.1efʥuGapyFCs8ub aIZɬw\) [>˼[*lemسrfcB RՋ{pȑW_h4Ѹ;c7r:Vh/ժWE:GW!SXeOFz(<5ޮ@85FS/P~fIL5 jr>dzEk.ܤQ3+n.֜]/QXi;䈓 } \ ܞBZuH54{ f`ӈu0R&hb -cp[fOnܘ8e  --?bvv*V`14fϼ@Ph 2H6$os[pY^Mͳg[E.w\p]Vk)];2;1T] D2f HPmg \78$J3t|Pɫamg. ̭SSPsI̔F>=,3H?ϫ}wn]˕xnB/fY 8m}일n`VWyE63/֕3'8!j T(CssN׶-zGft@t ?z$-a{r"7R'&|݃> IjntV-!8^ug^\7e#9wHEԿMBPK}|If*Z0ans]}^>m߶}H ry<1 tȡÜОU.5]T,k%(LU4 JKzeX)9dD0?20/u?v]W.ZŰ(&ͷ/bH/*q$+^ݞ ߭FI??3pm W;'L7c}ypg9g*_}r1u|FnD;N[,dϰ_\fiz8s .{%7DO/jPwh5`(- Í(t3R9cc!v:ۏ=[;绍Xz2e&_@17S Uk{~?.2ī"]/Q8ɹ%cgU4HeЏe5m l?7?6 XqWm;"6yO-8Z璡3CN4М7%~{$5NZFU';XJζO ]63CMa>>dZ%fn01«h没 ue"HvGq7Cjx7YDSb]~+"1ΘCPWRpbnĪu;v`pj0m:+ !5Ƣ9ɏ!H;~s3DO^~52)¢g{:!'h4?䎔]gprrpL0NV&vZ(aop>Жl0/v |ڢ`=J2Fܧ U.ekJ u$)ӄh>DzvZ/1\=o5s㕐#P?;@ ضSӄe f/^`ve[0fV|p/nMs\a&A(WP} `\kT\`p]7y+zTBUra}i23x+{ I}# 'LPXiw S |%!ӳl.0> 6BҕnXXM.p=ZГp[+o^^~ A0mT<*qAyFRBűPAY*o*җ[%Ӎ4 oLtqL9i Ow  Fe^2;Xf%h3NcDb{KJyg섩7)bE8KP҂K7lٶMG>\`{s91񉩽˒8;|`cHXkcpB;(GZ"nCfU;7s ^-=[l/68^da/Ѝ\1Ʉ2oO gq 9xCɈd z|c~M`{^.XԒ-H, c\ 8=!ӁuGr#te}-ffF ~ ]zNn1~;FЙ?́'Ymh=G6|f=;uG%N݊DsmG߸SPݫ R}G52fGE9=l_#Vy W gSU ͛fÞUﲕn{ℐQG.=v=|Pos&f{~pX|rz_ 0]B\TcVgaf!}fXs[T7x\VON w?9l1kmM}UB Ͷ4Z†5^%)NUQn#ImbaR_ucH+T{m>#?NU;ݏh&ahzr_AѺ+ZN2Ύޓ`/bH.<]b8>J'`5Ɣe(nؤ 5 PeJh+?xP [hX`e2SP\%Î]6Yl8ה:Xު{a=C(K NŢ0|\,N u5[: $-0lc: Z6t`Y[sj14fͿE<uyHuc.YclϱJt n\Ď)>5l`1v힫{H*+O̰Mvhww:~ruEkʮĖբJ0S믰`Zɼ&f^1Y.{BEK\o<|^:1$vqf?ft1,2d%b &G 1fſJ|2p㭙4X-Й|+ 3$G`tSiX%mɽdtR:N3 ಁ#?ޛv}A6˥ۡ~hoT|p)s Nw'oI2Iex'M O+w:ҠKl*ڎl6HPYDS&*P'y?Ny9W+UOp,_%sށ%^E7X}tv\g/s%e!<.d 6R}G0wsvu$p@.AU.`.yg4n]2\.إs^8NRy9_G}cfz 1QH[gD ʞU\ŲƦ;p5Sgyѩ1mXEH4͢),ŕ@{?qd |]P8` uңel ~X cL)`MR.q/Ji g8=MSL}Aޅ8~N&RVn4ݛXWL&,T'_U"BM)$F'R]8ocu{˼̥'p[^D1{~.AĐk}Ҿ?;vP~c=fˣ2PwTe O nsCEGf,p^b4m)`+Py\zWxtt-oJ^fRZ{u<3u q0'vk2C4fz~ ,Y:݊,\M %_{buXmZl7ԣ)vR602-\ޓuŝ]sN+m>8$,)P{2=7뉕] IZ0' ݲ Y.XZ~b 9VReO{8"yG!̶ʹJk}xr؀-ea>8v*|"tN? {, ȑ1v\Tȱ=ӕ_A\>Z4K`yX#A+ xMŖDYSky}Rb# ( }x7$sB[Ō@ {fL]Ad20i{CH5a1C%M h'6K S4p!GYKThP3Vݙc]$G_e@fRհdT dp|dۥ3ɛCEoB >UnT O|ay5Jnw$``UQ~ kQ]79 b}Lqq;L<. u䇢ЁO&Ea m@2z,ili~6ֿi t~7epBV__.;t(?~Y˃,qHl-bo[ySg~d!3$JT^cTUZ,4y,K>#rEOt̵<\bT%A]y ޯ3 'qZD;B}L8xtے0ZSK^MWͅ'y6ϡuX{Q=KUWKVgwŠU.) wC㡋zq~WZ'w@Uk^":L>Qk a)}W@K"/JԾ_]Hpj?s Ku iFWW q%mgi?};r`VX{cE-k-)_.dgR M *rEXR/: *!L205K h csZ٪FOn 2k?.&bf/ӯZ8l6|KƎ{UoرVG|LovxÆş)aR3z SiפGlQ mHP$;B(vq*-zcNI{*œi_ey4<(`x!W\0 q~{>.5C0{ + Nd2YfJx+\}8ݓsŠse`^̖Mb9OYa?a܄{'xހ)@>z/i!)$Hҭ-0kL^r&]?0C:" 3iW εCnI998^͞NރSG .i]Sf =ѻ52mP>U5^49C(nG0R.n&v% m$";n !G gNxn^* 2N`VSxփW@dpWآ c\l8I݃iI8{LswI!,v?Cg̒;:Shȭmv_~&v:j_KŒJϷ+yŭsX ,8. |71FZ$ˬۋ/Fɭ3tR^^YfnjeyCp`Ӿ,3_64O *_epRt[7- ̽fk$M>Ye!р>[q^A߹KfB:Ӓ6isXp2>L$πnTv$&X4$@ooK^;nǮ$:NxU_]x|,fDZ^UEO95g+qI+EE/">Zh@>I?Va}r7ifwwcIa()Es1~8~-o8R5:_Laˋ'I} 飽9xkI)}~N/S}hon zYC0In{^ l=:\sfP\j JXTUH["\?.g z:Ǻ#{+BnWżuN~u ;o` !ZM^q|)X+~{h;o5g"3aDD].}+PnˏU#5!jU펋#ء] h0˨Y+ˆ=k>A~1`( 8_b  ź"0@\eViW`rՆq"p >k.O_r!CTaN!p}GBnK,+a J~ﺔ?jN` (3]2zLgoo~@ySIVyTg⡠-RIP~f \1 rs)bp;m! |gyxEO[3Ɔ| sdz? i;B6k%GDFz}ך&;)Rjt"Nm9=p =}x 5gH6 ځmQiVwarC0Bjs ߥe |au߰퓾Z}˘AEkk (y0rsnHMe:aI i0QzuN.45V ~OqdoۊlOH[ GabpUh} Su+X_R3ɦM\"L o#_q&|$~}R5ި<^F`LT !p²~^OdS4ȅYzy%g☥)~>6Rþ#yYWFI%ETإމw YY!u'>^>*a7{`竁@z?0p~ Ư<C]{ gnP  SuF'= 5rzv-0!QW0ܯtFjI 78|l=*=~. s2\jZnLJoa|`e`pv/&Y)ۙy=/230&'9MHX|YZڪlRDyS 4c|S]>?|aqi疑}<F#[lHyU4!IX-ᘟ0*eIR7nŏ&[׿gF_ja|OIm~Oձ%F|g"z.f[xz0ԃ`'Y;L>',.Nep?XXC[ &Z7*blPtn9H2\zlԅdT4V 콰&&gWXxy[rhup"w7$)O96h] # JmA_LJt@3}sgjS=Vs ıw.= B1t;ۛD (_l q"$Sާ!EPh/#h;K3v*{> jIR9dyf8ΧssB5v0{#(tڙ vÄYJLuuҧUpeO7rp2w3g*Pp|#tX.JIkn؄J9:=$! M;Kf鲸<볤t+m#žg DR\qti'Q+zHPn,&&7F??s\c;>_ 3[x y`vI7vQgC{yAWgglü6Qӳ)HFhUCp1qe?5EzEl5pj\l@^<oR>ǻ675"Yk>lU4'gwYBM'#{*^_~n<e~00<(gvg/v,?ě <P2$J*I"SR4Q*) !ɳ<3|<}`}]kwlܜZlӤI`=0SudӶ\|% '0ĺIN;jBW;r*]YKr-( zvo0d+qyhO*Kyx v_`?`u5±t[ؓ럿Y`a(x` |j޺pHjky}N| ,MpN$=FOpY`"AyK񹬤 1v{^c$G+R]# ekpim]Qą@;֜ulxpJ?.ǢRՊu$ ~bl􈇗bNUpiĹ1{ڜ=8.~cѴKӨ4h;A3Vg _X%XeVnև~͍^x` 5W\:H}s{'>!֕4n0X!/rL-R0wr|>ǥcsSgIFO9ҙr$ ܝ * q./{۪2NRcZvQps#Am9޿['N)7X7aM\-q}`q -E\p5IG@-sl}BBH+g <%B9%F>)l s81~L c'fcUŒ~1Orhs"$0 "%`ג:cn-4Pp9zs#wT< ,rZ\-R#6TJ$WH[x~S`Sq$ 3tv$b ,ҪDip1LDah:p4TF='xl,Lؒ}|%t!GKV9ɝv&]tӒ;rww\7ÅH[Gȍ+>p[&\>*L{ `gW\$)A<޶[tY]:Z_oTB)8&YU]Y>lliٮ~;\XI9kVb S2CO`;.CcHQC$/Z9 x?ҁy.)c|QQqz4q8|'0Ep8\ӈi6jeQS:n }S /AkТ{οԺ63_F`RoĥqDţF6Q> "o//bF)foTs&zcͿ+HՋs]G`=^o| Dtn.̲g)#p p $$Y!S[lCQqq۫W /WfPQP2$0ݍ탂N$2I*sکN]i ^5XiУy6i޺y n0f&` $ލJ,a~Ԛ^<}vVj bE6|8S5\ꔩcU].nlYiRS g1/M7gJ[k:F8e{E฾`~<U&~a5Wo8! vR]{V-n珏umƒyFۍE/v ko U?OUPafQl|6nf%z矼 )G@ye~yH;b|`Jv?Jt"k[+}xM2^ 5%ȐG$՟|P`;==o^*]b* gCi-$HZ /\[#2a$n!APJ }&j0=oTI2Kh oo*|9"E0/3ϗ<7_)Gpa37%4z/(ia^KyL.70MS3'9,7mZ/^GKy982F3WtE0+bU/fnBρ'NF`+]лG1i˷3;?D2Z} _ Y s =̄`Y]W{5^.9WߦqYEPZ%Xiy-LN+yl:|o+mF =MhsVμM0dK_ 6bk=v'ǡFf`-vo<ʪBZ!iͅ*jz] NNg n n|ԕwV1zhU=>Uj?غ zhy04Us!՟-y 9<~T&6ܽ:H\ZKZlu>V)wL;eZȎʟ$l ԓ> i$˻^^ϾBv8S4tڭh( a`Y"'< }q1ف$Ҥ[8~W]~m6poPlOķ[ցey8@6 krŔ8"k9%VoHŭC"o5k@ȗ#0zX8^[ĩUc!_cc.oSU:4`TmkuM%yRpBvXn{* Ihu>|sԷjroۍ56:6mӆEHX*uJ\޿]nA6HzJ7FV9FC6yo!(4s`xU ]{=b+Hu?N/K>陲Hxyધèo=\ a%ŨC7}=n0i3oFr&cS7usEY J &j\Y`|.)MP16u^!Y7][)8b{%dRs~:s8vg-cfy0@u yR8{WveXocl,ly߈F h2;|mF]Ky˃Qלuk0̟en\"2MU={d.';TAô R)F%NW'l`E)XkHĜ5(0sN+*˱iaU[z my8s_\S8dPCGTNPcs"pVu\V>o)ڜ#X8#M"ɔֽ 0v̋#MgN:3 (YE޻M".PnpsЕaY~ zL1~;KM1$olgFe[`,#5וL$8N}I?pv4' ؆ bmj}|> {Xӭ/!j3?,/"Y\ʎ#,H&knY2RD4Np4M*"cb[p:b%4\>-;6M>.$(2Z^J> 0Q&X,':qiE5;i~lœÃ}xT߾/ |y)F?wK`sOms~ԗ=d*견KS`n3 b.HKU3=/^QX2׭|d^s{ʚ}ox9躌s<;_.Z}'{;ދ-V-8ܰ$I[k:eThtųskfS#r` otD5&ҤNmnr7+++Um;-:s]v )prP\$,;lm+zZԐgNwڨ#V198hyGnq&CK]sK% zmcN9e#m݋X9[`R0gW=oCuSj@uFLުxf(I;`(kd8^B7 HhE='(sՁ^Ef=f7+Ʊ[0mR'dך>!>g.‘g ﭐlk5L2UY<=c߫w-m"07|T ̮5-qa[<5?%q ào-ͱ5>w4Lľb/ho Xt"4t̺ŃX+7]"Xb=jw묜$&?֝b )ʲ<#)8tǏ ķgѡlu)M< KLVe)nꗢ`z6`ыG7),l@4S]FyG޹檽#0p`7N~8vcƢp o5mNUW l:k#yV ŷm9Fɚ5fWc*ѐ~a9!Y l~92f:Jr0=U'T0ٮx#zC3T;~Zͱ<{U:L7?T {h)է0ah9zmj 7{[UM c߆TךF8lmfKCainRiyrPwqDqiwEZ4bkq.l u;/`5[!/tYKbl2'k?ao-~Qح9OzE &}bR].h`Mi*,q]aDXc{@rnU_ c-Ha-x=Fp0Ƿ=g2SOvx%Y jПaKnT9HhNDImϣ aȲ~E=}AE$C"(+Tz] ~W-3 .I9:)u3!cAKtdxs!fGnВÖ_f.He) >5Bs*>gN>ƕ1 ҠSHN?6C>T9J3ʝ,Ҙn9-I'vWydlNr2.e6&&u`ғ %HUFoݕ= 32-`X||C#g-iGKC/oKeYUɢ8~$.F`7&8EZǘar%FIys8ho`>3_>ЧM}d|Q ԗS&8;z޺>kCF/w{_Eػ@`I}UTѿɾytmwnXW> oDWyrl)jXGidzEU.JBt荪t G׏_eҁ%~]08eN,Ŋ HrN~Ǐ۔[YAu6iq/{/N*>e,r&8];g!z:tGD_oҡTZ,LLN`ڸyX,yWF`쿐ïWUnK=>E2qj|dEуx$_|1sQߡj3 z電rne5πxЕ.tbG{5Jq3Z<ݿ#'P>6"Ɋ@R W5 M[ -髹<&? c dry}H*׏^zB-w|'L9=mjl?׈='׼U$)Y# $e09hF#t޵nY=ﭏIJGpBjaBxPxMH5L,b +urA>VXd~E$X@f U־nр^7s̗w;bCXjHn!kם蘏 %O 𘆕2ok/o \b 8(1yW s$;~o:˹-6jȊɅ !#LY%/ȅm*V$S^cV}9,׼E}&w=W';M!!0w쓔涓Tk-2A$ iƞ 0{,{mG~cS7dﺧU?B~oY-.TQmע:hj"1{Et+琕 ur٧k878$N]^VUz5П8G4!NVj$["mWyEtFX=IEX}t6Kƃz(cm ݯ} Hֵz0j;:19vNWI8Hrg^Ya99]'}v<3.H%,5 lLP0\}!@3g S:g& ڸ]H>^e3)P)o\<=m}ovɰoEQ#r(F1[-_؎ͼMztJm8}.3f 3/MOQ"&8뀳Wjtnޣ@{v/fǭsŗ5m`M V0u@ķAOSO2G??mV8]6?UWL/E];{"  Yyv+cŪl~&T4,&BH#A V\`A[>ͮwZGHzcB]-$Ӱm[|:ƬmnڋچoW8|m݅fF'2c%aX۪gyMZO*Z`1g\T $n${q,qQͧĐ| ݑ8ꖄ=`}Ǜ%H=09s Z!ELc/UUUKMݨ=Sp Z$^+@Ͱbr*c_E}* ˭3/ժqH;XYm-ׁ;i{ĵ_CJBXU/vަoE_Xb E96~msehб=ke)hP.. ~;/eǦ7%CN*xaO nK|s6o-[($ !S:U\6'rUvka~'%v=H N0Rqzhۜ Ə٩R¶Xw}$V/YkŢ?M8zrsې1浏䏑öb_ʦm$5oƂ=a*0~pKq.3[u6;map<6^sTAHܾ!49eg+EOpGu,z#!F; ]f-ٙ0k4*4#`AH!Xh`|M{ =kK`271pϾ 7Rg❛wt4WOdPGjrt0sI;/[DaEP2P48'9? }9U}=}7f-"DrצN, =z%٤SqB+|.ޅQU\@>w-(`˒eC˯6Um^_TE{S.Xٸ >0m [ZD։Qɼ׷ {҄޸!G5+F@2P[q`%,@^We΢/ &bv#/F7qv%?j@ywaF>ƿS8][qeKAo}_K.N>^mdIp)Bĩp$2)4`#F-Dk֩BnZ?!}7[;ٿ5D>z}X8\5dyUڣɛ.8uvt2|:o&Z*0ˆ[aRӞCc8>v3?9ff'V% [-"1zF^'V&(^W*ŖoYpP^w z,9qz8&pu 2[avGQKpB sB73vȷ;EtahShRXJMzVC)EΜ>й0t,z'|YF]oK_tJҙnw;=ѐK)tciŦ?/ϮڤkrRf+6ZVwB0mZ֘uFRq)b)rX-E`SXZE,ӛ`]Q Vۧ.kea)-{\Łk)Ox>ލ aw9ꤟ*v5ƾG w3!g~4%<9KL$*R͇(0N < K?kvۻϵEPl36<=1Z*kB#ߝ X-UA1GS|.-8Ep.=MLf{ʪ=8L.Uj, dpE 7 7x L|IcWƘ6 ir>K'/g6w * \T8g -Qh)ܴaKwF~f6]`HHf`9!c*v_~ m5(O_& KrJ;V~;U?і B/kMՠ 56(ܞ4.(GE_o¼ܟJ`c]̦WMb\a ?)+w#8q:k\%fF)aԦWWwTaʽ/̰}Wp;tp+饘2=ye]Eؠ2<]S|:2~<~ =>> )%C/aʖ|T7d'N?,G8ϖ[h0|uu_Vyi0eI-wH8xZ'5-?> BKo ,_.m#R=` Mọ:LvӽTCPMoͪp^G"E c׏ K8N:XJIjGLҰcOGI}Oel#s*U]Fa\ S/r'_]-Bp>_}fljCU %>tzHj4/N`OZA9NzSaiYv>nkW~w38=]r:z;8W”T#fb] n+.!s~de{2 I&ǯ`do[QHN*Vbl6C gح}Ga%FW|{*IG$5HfA)^0+SbSr([Wyh [:aZQZ &76&բ>%AO[Oԏm@/67ln͜foGLZ&m̖n HE'Of3%!W[L~K?_V~2-'.`㛜ĕ;'ngj M%_岉DŽ*>r0| 3+l,3QX*)w+t$Ekk;Up0ܳN8`6c+$Iw땚}x &u"m Z&xi9`'T^g~82^-O}f 'u,gG`j+N_) im5ZLG7Cݮu<'WN"]4adyYKQ^EY9Zcٯ/&|Pg 㬛9x#܌9{w;IgqzEՑ'XkC{y`xc_Q7WmVS2DZN''.܊S/{?ߠ^+sN!,D/)6?p kBM`ٷ=2Zw x @6ek`a@z+NޓҞ o6x9MNh}}851]FͨU51#/)voyƻ<#!׭HѦڑ8/8 ig(Zu$o>|WxYä"N3;=9;aD2aa$kv9ly=}ZOg<]Uc[C@|}ֻ3:?BR^W5jſ6Gz#ۀF(| 5orS-/M )[ґS|ßsV>rSA=8vS\0$ -\ yCG`}6(zOu[$M`ȳOdn&7`s]U2v{gabXyyoJ2*WO:j$S؜DES}szGC2w4tECNm|KKcmDKwVQ yC{a:f̑s$J0%0V%19wzG= s J$vےL|m@ŕqK\:<>7sЍEd6ib*/_,]9mpED1Vc&%ɃJ&cZ0\p,;vNGW,{CM.ֺXE{<7d7llr25ҴNצ8g$}69fZJE[nQ`|t^zkܷq ,"rQOԙ.nayj:/lKk3.ڇiUMH{SS{oC)#uUڅ(NpMΐ?qrМ}f)u mhhu8|Wy(<7)=R0APUy|GˣyBKF$Ĭq"n)y5O—k s!OQ T[{q"VD];57ɚ #TQOa~w3ř5k^b~,PURi-f`lu9L}v7JQıX 3Ax䁜"v<=nx0Vo+tR ~;xgάݵd>MQ; qooÒֻ a3kcaiqK?5{pL6\>Ops_~͌#)'l*fOW02gȰ'.I '.rh@W,dSp`r%nY$ۓUpȺM*/ )];rP¨g-e@_7՜) ⥷좾޺a;oIfu(.=JĵV|Xbgػ6x[-|Fz9*zG:XT߮_|->cfI<C%3J>ŹCF\\旺]#b"$ԝܻ>~'%L+A0W*MjK l1N4M+Ňplq|=+',_IPd6ͪ]>I֘7zfPKE 39!v{Ǯ=vN7VU>7$Xփb- 7rqʀL|hb ϫ#9C?Oךl}BVe,g  ]{~vQ2/У9_Dw1hVmCRz,͌lŒr1U9!^|]gaswѮsIma0L+QW WgI 1ܽȠ5*$6Pi\0Lrҗ$Fs8j̰]dH3!>qq:a.>ѹ/ύK_=Mz0sySXn\l/ɘKbDD #XwQ 5D+8sjGHk𘨎)#C t}tPis¢:/ٽIGƺc7NHԥGfyAc 0cU=|A!:8ǣ}ӽЧau^*o ev0c?&|b%C5/œ{1栌Tx쾤 _^IĮH.!j}elX 'ނdiEdf<ɒiOx֜%'K+,{'L{ 9Cv¼#2t>\̄i2'O fGZT!otz4 j#}lһ/m.ϰyDs}kHW,i")-2-C`oqYP`H2q,$pm@f8V[:o"홏iHv?h9yO 8v!y`ڒ%./4Œ78Ty@f߽,Ջqz)4np .X5)rGuHyIٓƥthXDr[[N `{DU9W#䙷%Ť@]PE3^*r;&) u4&q&Rf>}$ ŷniR~@e~Y8PrbV?OfʋM]XYL߾{лWsЋX(SI!QU\ mUEj?HNo52OEa[Ecd`ݷ#WNv5Bg|!q=p L笰+\X}_}sy\iTq{K |f9ޫHZoHCL>y%q_D{l˫sM[lp~btӿjc(ڝp v9y}]7 m΅nsGҧpx0 +-^gBgu҃kc  :{rvݕse5ñZ?\ji_;n.EH}m&Ns.8:fUS4`rWi{8[yx NjcxKq+H-b*t s60uAYS9ۉFNJ~!FAv}32 a8ߦ7=8ۼpO?k:T.`i )'7v݂svv͓;~GP{\/,zW Z?v)gLv 4<=e g(s#cov=1hQRc$K'cgKl쉎g7N>'X$U1`8eal N;&+^d#fωzG0{M_ =%|q*4_r kȶޝOD,!L{R9%mt;ˊ?,BO껻8`T q^ex^V d75}\b zgC`gӏ[O3=nS=7#នޮ8:p*TN6Y@s0kcWq)닡AG8OŐCгDkUc1L] 7]LʘS&oŪys,V)MI$)9~˜LCڹK"m\)xaz* v?nFس':M$GjeLlŪ#-Fw뱦2eñdX= ڟ閆A"''n^j;{F.==g: MMaZ\>x ӿbIK#( nOiA/5b8qnSM!@kǎ{k`E~\É  eCdKlvE']U/ԂM81#>f?4:&aM?Cf;epNHvtt RЀ*en]R7QhE r#zaMZ8ɤX~cK ,U5Ցn VlrbJ'ۭDZ)b2ro7C-0#>#3y;p|r|h0>:5so1fchQiYm8erF?uijz*YL侠=fk.zy#a.0 m#ha¢uJR86u,Ko2?ȱӄbZNB{䅞WtL:3tk2aD쏺KI,FL??u5 zn' ,piT3o\9&TLyRp't9vheLšZԐg6.*#!&tS}I'r뾠~ w^S];pʣ@sdk- ~0H6ݍo'XlF^n.Ub8y"]S *- ]њ'[ ~ygj5Ԭ$ 1g#Y5X֑'>7kf/L>z/G. f[~EFTcVX|t *qxBOu#YuHTI 4`b]f#A>.@OLdzKbqfTs~29E_> sB)0p5FN3hMrh?UW$5*`ze$Sr~d(d ۖVlngd*atsbe_Sⰸ%Rϸp WGN^RuCwHS,ӧKl>䴭b8*oܳer*~EZEЫ8\Qa3̺_1(!_.Bc|9UG U;`eD, n(@@GEBL ƙ?IorSY8R* ܦ!ݘ.-\ -dE6-q͚YAɤљ S<П,ʶ׹ Qbi3sGYbI9紘3ɴ̝,PxC=%Q-iIwftRB::(gy= {5wSnw^,&sބbݔ^eHfPFڐ yy2[^0cPPw)[l`Ya 5lDv#a0;4۶NZ}in 9fW{0Y ^SWc7.;b~e&]y7*$vm2$KN9ND޿M)ZJÿM! 9VV?'gK0mʼwqd.Oe~_ f!0ivs v??L `]a!&8,J5c~{)1fg'Bֻ0modeFZfvM';I9-+tL:JB=87?9/NPmov;lT^kZ+ iAOJK>[IEqG`hL{>pQ; XPmtbqT_+0w Uo߼g#)JP&cM?BEɰpЮM?pNofPqɛ-DI\ʫg=ۇ7q.R{7_Od-՘ݗZb tɗ=0-{ $n0_ >=yo$0qfEr >Aò;ujpb@Pt@joj^zƟE&5 d'oDbG 5pJ4Ϯ(\܄)gFpF+F-rcG1.=J;fa n<8lO00-^4{ %_:CI/3(SљBV3=U^#UXtB0 oK;Ppȏ(EVuw=EbE!{s7zjGw11akW>/ _ijFj9mI'ü5WDzj]|L[ͅ6+o,lWhoۃ8YsM>t=;=Jѭ3%cLi%6U߽ ;ʑi$t $Ӂ#اĴ)A%YyE?sCzZq _م})֫~=5&?r8 f U%XM }%Ĺ|w^u݋gqV5=ne]Mt(qn%nɢ:caT#' Ì\aIʭ3g&u!8(ZNP}^؉KMqe19循aMB-Tj;nYҞ8G#xuu/=G򰂌ܪ\Zddn},L p>O9&` Wr | P S`|䪭t]g9۶`KZJ` :xÚs4uW]BЉ)lXkٜ8dT_v? s!o#O^k8v(֖3I_FqNøuUƔ[$;WqIQXx3v-ױ7G>fM柨?VU+?6a>u@Dȇ6Dw/;U)ӿd%^<+FIR-0r3=,,]?:Fד "Y]?dJX͵5v,0TT 4o5bΌa{u^H?]˼2zs1GySޓ6й3I̪w>H֮ul}'[(Pl'}7P&qWp -PuV@GczU :dz /g4}&ZtfL[ErX3A_Q=iYqJ8+me,}? ռ/5N@۶Kq''gO)d-ŏU܂"r;e~0[e#vvK?gB_]r+^gv99B?VQdͻRь8&0{,S7l;/t{fkeW&wǪ\fD> t @Ө-:切]}W=a8uy]J0|'ᮻ>m`\eA][-\`VpIRG~wÆ_[/jZ F+fr@U#*XwUe^ZP>k|ӢplLW# 3{{0'+{ϺNckSѽݼ- |o*eTyaBjE:o:!/S0@yg?g#JҼ PKS#,='i&%r ^t)/&b#k 35/_,\= *]煦Ş1CVa؊5ޞ6}iI G8b`}LYXo=0PڅlgCuQSd <]W|=^v[jbcnRY?ub+F*cgo慂LFʼn_Zp׼"P58A׉#/U.ʻd;h=2C_|/&0pYKN$H#(VTmB-|q'tyCpn!2-G9T[7cUBבNsG-)u?61zK+X.{/9d+ S :G{̮EP8(V<0wM h|r~ς Agޞ<,.i &A3K>vi'.IҜ}{ BZTwfG`NKn/u.bGCJR}'`mE-eJث厚)>K,ḱ݅Gw8ذ(^ar1 ?~wN$dKq`y2> D6[?N$cw,~%QN`KRdLU넌-3GW$p&\bFy~8Jٰڽn}}6V@m`쓠@UI@澃$so§\R_=kOCkOm:%rNlny)1l nuĥz=T3s[ޕ|]=#AZ8ks ywkL<9Mn_Z}Z %+/~_¥c_Jxnltc!,K PD2 ʦa%EQXZd]wY'-S!d"t#v s{,䉋bm2KyԳSOAhPWp0$˖Hd4JsA_$,h :)W^2A~3H_1.M)Ro5hŒrcl$򢁾 >`G Ӥ7`ꙃϋ/ri DO8b{h7ILPZu ;af k4rO8(09Ց;H?۫Gr3\O˟;p?'fudžGS%E v|~%h{4pwWumtju/w]; m/zGp>')/n2ߡeKNq)لYI#0̶ᘟLT1KUVvG;a3Ӄ)?2\RJ/m(~iX#cύ,'0PO`J1U{UIOߌzBY|왁A+=s`no{Ի !i$9mMKq{baӇPr٪S-i0?ma˘Hݏ@`p;8Hs5%7Q,n쿼ḭq'+=be o2bX{U` m V77AQ"7/>)@Kg3> 'i+mXMiã.7ˏc FhUtGL QK@.Hk(}R{g3~~<Ԣ$:y΍2,mOPl^ήzE]-7S~X]ql)s-5U2U7pn'aٗzRlluB#)Jf!qgFRm gW~.Kaye*+_(rzU\U0gvKs t}lb3.^ܧM]wǪ&S;a&48(d6tCSphK +ϧ& *o )_.=aAVݥ=jBs:0͕0x/Elkd2|'ؘ>sn@V͛bo{E$l'M;t|mN_l ͋b'7IPhzT} 5~%xk!!fFh|(j/}[*"UM @<S\p/=BuoHޛ Ω"RC`?INhmEc.&.xAx:LKdfka5xrz 6t]ұcdݔBٶwGf/)<~M0/fEƞws*=:0&Q+ 0:'TLyfw=8a[nFj1,3\eg]Τ} VZ8fA: 43/"5WNl|)o7^懙_ymxqVqPεCg;g5ppX1m银x.A֑\~K;8A|tP**wOh6J`Q'qCFgl`v#7tKZ1>C]NkZVhs+dnj/ L6G 9&; EOi$t#YwZH=J_T:nJRG =;9H&2F^/FljvfsusAnof61 f]8AڢG: weN+x"IH4>d/M;yDr~աHr>5:2s iX2y]zA^t֘gЎak#]Ӛ&uaGfh9pL1<;ytx1đNMmw=%f{y'|2gO&'ieAF&HN匬ѓ0|?AR:MN/Nq팹`Bz&*X{,_v'[3dXͧ}.n)ful1X,Жk*xR59x0<9Ov:Ϳ)$S1͹:Vj1Gy@[M Ǿ6ːN7w,쵫U`Oc7rXCR_!0n0j(v$Lôv`7)q 0 KWUU`q帬yǗ[0&{*ݱfIļ;j^+YcMrF y(hyЛ伸OY}vX\ vY6'ݡI_UE[me"[r`a K٨8_]Z[8|9 sCa:aQr`Lܐx;Ce ?ޢ+hR9#v5pX,0ߵoT[^f›mf } 6EIuR&^[ı{w ZШO[hׁ6~Ʌ,^//~\z²5!%Q0*/p?NUIu$L{q.Y*w}9fe^.Y_*Ub68_u^9Oz .eB؆/xgxJ` f˰H':8L e05xϋqdH*m}aG;a[fUk, ތ4ܫƃML\Dh{L}}soO։-w adlgĻx@aS\ieyF 24'VrZ`ffD[g;'zNerV`@%k)c_p6/Ew/}b;[ @rB\\q{o> XgaZtTo&ik``u{pJbk6f;I`!}mIkSԉa8۬ժϐLi;aLvPUH#ٸ*>J_!t`Lmgirfi@[f&-i l#IXXxeWu.8+I2bHV2$>=V So 57}ό>6b$';Sx^-źWgY(t";+Jl9 $k 7u`v#g#`g;8tod]m;# h&v?$4_j+Yw΃\>#Rlm}ފ:_=174,_HVʐΞU8`h[vV$> Zd@{ BGyΏCHۘp&izf a1-`eU]n8Nτ{&ƙ]ip=yRK4iE3feRXU_kx=(SZm3Eav1 L~dJ8qO]8}ηxaf?gCI_+] ˏ{v( ,s{E-ϵZ^"O1~$HP;|7Oj}O =P|B39aX JǕ%չn?Qqy@n;I O`GZ!"o[>ÎVe3xM1R/h UBbQQ0V}OgXUE8FOM Ӽ1BIoSgǏ4?c>A J g 2A&(us`ijn쵩2t|Z% 2O%`jjtI.<y:t <q+{pb׶ND(.7b%z&aGPkPѫƸȺvip2}'37ghlNs0Z\o{ dz;I[;mw$i?EPpWoHyP)P]?vH&&*L_fBuFO|swjwkLڎ-Ő$>c%j!v>\HrfTST՗ӳ0Qr<蟑ze<נ2y{leO-?\͆.BdCiqYbgrY cY$Ӆח4oB@_?H>H-X4"Y6oP>}Xwݟ|o,vl%AnѸ rfbc;©ŌKgCKjRBuz)n| gl .II_qCpGȈ Lp;X?Z(rS@Ru6'%%V.߻'.2 B6TS; ,~_7Č/pfʰI'i Ε)i'2ϧ䫅+$Ω3p=ہ&i?ê٭{-F09^O%ڝ{h8tаatKx[/Gۑ8?<ʿcwR$R~$DQ(QB%I-!IJIv}˾ﻱ93|g1?pOGrZ+@_Uv ;% b.죦Sdah v=֘[W6ʉ=k{x)+-g ? RJqO%XI_pu T~H2k=Nl59sI]G%IJJ%$% a) ?몆F 2{ZއUX9Vu06.ACY$1/ oĮZ]ʙ=8vx)yZ5r&-t=nO%2?bo]׾@ז[aZG$VVwXX+Mj۰JJo,rzئKΦb{DNxBPM1 KR ]Zafʓl=y awխ" xF$4QL~$1R/ F[/m~/ 2mnHno}ul5L׫8mlzpXd ܳ\ֿ,*7@61z8-\vT(A9T;=? ye7{7֗$f-VηHVT#X/0*xiDITX 4JR ʙKWߪ%ےIL.u&%MFDvkqI: N2AK t`âV5zyfI`x+kAbLmu٠mz\`/!Xb,+? -MqD)N' |Ǐ*— 6jK=_|ш={g`qdUHVq{ |mjޯw\7Fl Ʒ"=-Re%69k`tH/W;@aSO+wW,{z N,vq;8[H J8]%(Ϝ+<|Y|%aہgq O{زgS—`x? L4X(#Yw(ҋcl=4Ҿ%|ƖO{/bˉejUf7?ZР''3̨贆9w"Z;~S#pdBi-Vm5X-ug_:`(kܺZ>8Y꓌iY!H ,{ ޹thĢ8xLmqne\[,yocMib}*IZݣ-æ mv ê+/YH8rr:wpvc`/mg>` Vэr4Xv#&@Fm7*ғVd|_twkXGܝڦS[Iרǂ_ *D<,ZtO7oLB]ƽ'+A0ut6<hJAױ^bH8qD :wY:}X vW8&"杽[qF9^彆`8n+j#.|^|}}{5\mfLm:"?" $Smf[}F Jqu:6E'¤{'dI'3_FwjΆ3Wꆏi\jρz8zkT8, 㫅_MC/:q72G36:{_XaO㼟Nu<|PV`ܽd+دsgF?= !pgP癵k/,~ߋ$^ E 790Ǫ`f&7@@'N}f[PŜChN0>7;%,L"ﬠD<,,~br'X\WoZ?a>F`ׯKi#S`c]Q<BdRtb& s9A=Wbݩ&rH2+a t qz/;LG]c|?kS?(!oӵg9 1Ta= S<7]>x?I&h?AK~$wd HW,‰05elw9|ggZÿWԍlO j(<羹&f:T̗\`xL#<L1ٷj NoJ \Ɇ=n8XSf4#zspluLw(`؍931L{!+`uƒƋ6.f ctכAsqϋZ7D. yV#J`=AT xq.<`%k%5ng.V[\O^ 4zݾl~ے$g~MW`=Bc;[U{g#MR5ob~^-j`&(K˚?JcGgs|ׄdt:kB*Ł{{8gw&`߽$c䅗kQ||}yb/X Jt\x-l{Z'ޫ)<zE9Y/, [n]̆&-""aד[:qSn%W.("̞w&Y!,kB/EL} ;{͡-_>>Wݶ$TM"Z\ּlfS+SbO2{9pqpwӒۡF 3մ DǹU [UT^xfս p>ӻH{!ΜPvTnf*xu#7GS<.uLSen0]a8wL_a?|1Lul?]Dpxz%X|ߍ:T=iLS3͐286:cw UC#nZv vE#b@l,!b>X`mXRزK7|  M9ǥb7?3MHqAH{~@Uϥ5vҏޭ68y1Zz YIO 3$&qٳPT秆UZ ңX-db#c1Wｼ ݉7cm`nch6uTCWq~Y`{0r3յJW_C}(`i0H`DCKy0'3zPJPdoqqCRk%Vʆ [8oHNYWj;/`%mX*8f :G'<ŁȾW8&}>R:8HyH~i Ą ݂yNpo:{Ƶ^mi@/3`9Ϊ/Upk𚗟uzmO.F[P_jHXxNyI V7q\QV -|䬯.-}'޳RN:+:iloSP$?ąȟ}/k5h =6!NG mzȊ[䤿sTƂ H=_`&7fB8!;{&3`ߡ.68>L xiM8񖫂HҽVJ!uZ8㙳n&aOΧ U6箝1$+vݗ:6y~m&dKak< U  gvJ_wI96rF4Z XMW#b78_.;vtgd{L?%$\>b,.Xb;&V>q{chc#0cn@K;߮{ʜDs xwZ|&#Bأ󋰤̡!Vy`qg1s!k?gF}Z/V0N 5;qT+fc=g4̅PWAZth;=T.<,1aD3Uc.\W,dI3:`[ܙ 'Q {+nglc;2q\iʰm!b6Kg^^1?- lkncgFF>yȕt߫z ̏{!!SAx|OK  7C#C_ލK+:_@_PᴐePal!?? "k4_%g2'X='f 7)@NbP%eYIhTxaS,x'5:ö "/wX_qO WbecȪ15h-ݯq! 0hv9Kv渔8X:#N6v[qdk1k &^g/JcWC5 mj~O- )ڊ$6]0tW;;WylF:UPLRrG(cf,0g-ðAUqB&:Äd_zk?gޓCK {믒:F`&t.!SGf:auX6+!*s+GK{΢Vg1ι~L.t_ӕ-@?wIo _o!8m"!+W.OcϏ袄Ls刺8b*8c3 ܋=Mp=/r`o/%^2p,!d9>o3I9-5(JՋww H5 C/!ረ)V 9W.I4 s;Ok='Y9jn$,;' )Fu nnkUB٣:a0.&z~xx{N^+p'Y=88#4UX| SnKց}iK0>XoH,t"?I^b?ݏ] R2_SF2-I05E u'<Q/Bꡪ^K1O.^F+mz[y.LnpkWŅwEgmg%U%]7-5z.98TX* j~LȄJUoN>0Ja~M]3̿ F]?{ƢOfɑ,'qK'æ<^vX& _aߋGOB2w,' |dW\d"(ŚO*B!>G:x'lч=3NN8chJ_t[&xAџIVTH_2+#_ ѡ_xdwwZUmN0,%+oU x 9d1-v_z;0sGJXz3n8d2pFCdN-/h`(y ?/]M02۷@UZN?%.Y$>=|C޽繯 Kx#kcyۉ5_g"#{ݽ5:[xLLjelhL)s ߟ_pέL~$(̶jyPS5Qi ߟI M^\9tnK0Ź{flP#:b?ʼnmF/Ő ˚/]5̙$ڵut/-mm.#)9qfi?bJop@#aʱMsV̭~ w?u2Ñ̆+G75 #QR=;^zc++'?F9wb:V="шeﴐv̈1~ kr57`ˍe0T64'=lg^fˬkzCFWEO=we4ubW=Zw^ QЦ$WcJ4v)thw/r#M݌m%+Ư4opҽpDiOXh4v\*Z> ʕNQ_},)+U{GO1@>I2cſ":arcd8xv{W]> S3aS}.TN=!oQS6kLes;*(ށ5}R8odWmsK/4a_s`Lt 9WIJ̓h0?8Na}0n9gCݹ[^=&X_i4H?hcBujs  ~#6/'ɱ?f$Ӫ᳧"qdCoktKbQR!׺PW{.1MO1`r^aݝxHڕ& /UwWSl~ɞ8T0B0ޛdQhVkާ&/A2.AﷄڷaH Kq&X1=*V}`4pXA&'H_|69[%0щ}[9Նp=K=KFH\^fr0\]x 3OLfכol f~mfJoXpIڥA-A}^C2 "'cwy5{ ;j&t{Ћnͫy {7Y k6 )Ⱦ+ V.Yn'b 0˭P{-X`o'C#]7pSoFZ1$Px EDޑtʽAMAaRKIh3s3F:~.<'7hUECI+PX1}E6&->u+Ɣƽ5둖v0.sv`!;qᒺ&ʨS^'Q*`~IP$p&TW[Ϗc ]lg=$Np{_/`JR[ɴ)rܛF1Sn7v+4&٢t6m [[?ay۞q@z(H9umz ,Cԅ 9!ǾƢi/ 4ô#{AS\ޱ۬6f_w_4NI|(& 5X qT&]]ݧ`8-CcйLh g6^пfSg >$RYN?gx` -V`ddt>d_'-`UCK732_o,FL?K2{ ![]ās?sӹ"hNɆg`/d#,Hs&)nB sX$QKbESw;5Wf`ķf-\\ St_6p{KzK u=+coܛfR>o'>FnP*ZWT| w@t٥HuC?5K_Is/*bݷǽHp3O@ָQoѥz]Z1\M_@I͆J%IE#ɜ~ntkᭊXC O5oE0߼tXYYd (o 5L6;;a: %"vq[ ?w}[ sg<7^Q"AxSy&LoVVDa|\ b&qOIk{0S$s:l:s -+7QjSQ5$=œyCr05(X12{|9Nžo͹$ n Fڰs(B))NI`k*%dt8B=0c=v(I`Ճm|3MѳkE'{e:][̈?\k}+lR>Rձ{`ѝV0sS hCً>5cÖ|Gz?T[Jۍ4hz6U@TChjW'3y}wOEb{U%f19ʝ ݼoIv앸aW'@2W]0t.}-u;?0#+V!lgLkahq%@yaL'O};6gy pWسG{NjN^Ɗ8zWtzNa-&OeŲ߱,kGV_MPK8OŏS,x6@W[j8pSD #v<SW\ 2{MbKtCpp$ܹ(hO-LA6xjRj^q%vwםP OP輫1?&K /lOaY* SO`᳚>pM&w-VoӠ.ѹsW:9Zţu3 al:H}U~;"͊\S,]pb Ϋ>Ka} a@wU&Oc#X0V 80,Q,Ϙ%|e@7.s/3fMph)9`Sn7 iَM^+x oMOӆ%Jq%쿥PzDe,Go/S q (8'X٩ ӻ7Y 2Bߘ?b9g0xSINo gw 8z 魾Xs.P.`hEi5R#\✄ZfVom|5`MǮ*@ s8tLo^˽}2o0oLyZUO>M-k Js{8WeCR?0OHq_[f0{i"$k[&vL{^yx9cO9hs8e3S]mNKm 2 I2H4RiiAcjݢm9lɤ*+j돜鐸Ax?Y+L s׻9@j~N8'ޚJp?:= ocW`ޟmKHcGfȲɻXl'6?k 7L.n[wMBpzz-3wv~khY/.ruV?NQsy=g`H ~0&ߔS*VpE;|7Rb=6Wv4zBΏEś02tƪtu>C8jKS?d[zh6ޟ} qOF҄B"sd{;o9g]5뮗]Xwk!W31>ЅS` ޻ykh`^0ru~+aӊnA'Tcύ1f"'EX.j;.0T ,7jpɵ0) `=+ɳq#XUKk'}xfdI?摚 W,x3LY1{]<*NqG4g]#[" ~*A͙Ma υOYZH N̓6O|y~LLĢiOƹ1Wz\+5_ެ3Ż INv@P?"pq*f$ 42a\a2 kU:|*"xY>b^@ʹ=gl 7sm8'8XEpnӅK^d!i4ҍךb%0ڻ(4y, SzrqÉЯ8›}}nIu.W0x.ҽzl.υ0cC8WG<.W A)XaP0ϗ|LɃo۱Ds%mƟ4}+!7$8;IM%=֬^0;,W3pu0ʿ;׿sEcX#i)I=WF'aHy@ ij^1Y˽E`"8é*|UYTaҔ-Y߷,gTpV'oM>RvjüI%LMy;Liϟw24pL\M9;UxA;]f[ aCɗ8Mt-r׼F[)~&A콼}8XZ ӗB@[k[c&,<-:NٵںŖB-T`wçl6~gu 6Okp"csI!8K)-+vG., r^2~ډjZr.gVG@K5ǽa.pxQsFΝQ7 lNpAT\ؿ.dߟ=u^Aѽ&{ .-O^]9?J1[Q7zuAM`]a+?C'.GAA Io{:w٧HζB qyO7^Xv:\*d{x'ں۹E{^|NV.x@@'M0IIm2.Dž+T@:mvoB,`0s]rq' >Vjg!IlI8Un_ Uصdťf]1u-U<(dt9fWΈМ^hLqҡap4luO eUH!*|0B0 ߺQk{<9mS..YZ4bቾ9 {rY!p|D9Uf(R߄l@UD_U^m;Klµ?]CX|%$zW-p8o1(طiU YR>VzX/k$kQ$خ ϩHv[^/dž(U۞]QcA atUשS?ae\8z͘sIK8zPAo6D g`;Ljfӻm.R s#t2XKp''/bIl9a}jجtcΝK0`u1oɇM:ٸtݢC~R:B2>Z]lZ'D9}8xr-w6]̙B2NH-"$URv!uD jLNv~s8^X z5J2۳l_%8./[bCr+<:$BJ TOqNuqe9׽!"4̬s֛'_%%FvڷaiMqvFqĦ`zC Mib&R>8XvnƘ(nmEmoolΩ o WwEIm%*to}4AoFг|p$%j]ft>H ̓vT,ۘ=+C=B7a=̫-JwU&fXsHڜ}OH5ύroRОeq{zm UQ jօ%6q~`A2J%y|MnRVsϫ-Ƴh;5l8`F& @϶%!o13nPĨI]}>}|d˸_PE뱀Pːy(}_U iS2PxM Xz3k{u|8Y!EsIwM-UQ.()J_Iio5jHRn<,1Q\p:.+'E1R֋EQKhqB?i%MRosWY[B[Z4B'O%_6ה~rBo`b:b`~*򾲊 -հ'sI%OɄMϯ!B_2τ Ha D.t5zkutL/^?Mӄ^Y&ܞ^>E؋3o2&p^ Ce0SֵYE`xgGqT FV4g"շv_ΰʾS51f t:Ǫ29K׽gy}]*MN8ݢ'ۣ(l.(fD4> !&4u;[l=%K:$W5p0b^Hh켲1=`}O0lm,ie@nƲL0ܗ Dol3OWBvY,Od*tR^IQ.-9B+ B_Cn4gJ~7 uȨu{t' c dߌgc ͳ-`DM&sj_@9cq 1J\b,7u驚 wXH;qc ynVW 8`kk=Xq\XW. ^?8W/P`:z36AwwVNYӚԑO;laڵbzrAȣÚ0zĂD>P`H_NO+ ʌ\|33*$E%Bg!W{Gt0l[b $ ȟf{b,U[^O,ф|w<{!<50h8/cjC{kryyR?X.k Ym@S?zwLph{(8Xy:2ZRg^!i8UMG?~Tbs{ #TϸS0Leƶ 3bw&/ҵ Ke8,$}` \Xy ?Saf L{pF|"<uч?BgI:$+\^'Uh.|7^ѿВR{s k˪{mzNPQ 8CG69%c> @z&{;@_B`A^`9C?9bf2 Rc`j>1/s:xy mIRLS7BE`76;ъM< ΣC)3Oݰ+\q]Pw@c**zh.^r=̧p추кZknV_{vBo>R_jŁk,aps p5B2Ci,+E-+Tfʲʫ$k*"eA2ΞQx닙tmk3ܲQOͣY]vV^JV$Z>b%E`H Mw,@ z*:3llm3zڲP {zDLO>U83ews_U@a*0#:Ex a/wJޑt!k|-sU[vl ס'+BqmN)eэyIXhV s$wEwVH=v03#4 3ruGu:Ѕ4f*q!%RQ3*9 8ל$¬`50a$Vqܼ` 8_d SKncOA6#Ѳ<NL @D=A0۪bUI*}~;ƅ&}s< p毞c{i</䫎iц5~gC%gNksO33)^8^Ng]L[i 2!S?qucnt7~p_?DytՓ'翚Wb_bhwz?[`?oCsM|_]aңen.s3:*vl[I EF^g4S}`>ä :pR'd< s;-E#PHṓ3y3Sv"1&&3`Oχ@2mp_E#aeQMyjNW].0΂zo[؝%<սɖ)o( 3zvL¾fo ̽n`Hhh&%cam7п_6g%MS!U3йa2\g{S} &S=N*,]W٦H{aw)8ay+1~y$@n/ َ 4l1}U[泿ݯQ$W&}͒t!SC i'[leDAVqXP!|?V qSïK0('"0V^ |.:c~ҥm$[׼/H\8Nz*`IR-(b'=F>AWN<#,/kɕ\ӏԅnM5P:ߺ5dw4cjk,K3y+muC'aƔ8UeU<-rQW`Zؼ Ve0dHK/$8ٳ5/؁`! Ƨ[(ӡnf~NmwS7`ņPlR6˛d;ěb{̏Wk'HSɒmNyfvQd.IK^.97 3Ց(7bT3zł`ۨymz%zYjކ!VpBtT_ov w$^_ޏ ʍ nb`c=L9/n]*$^1=&ۆT+(ʆ]C1LRxKZcރK̇0ȽHݣi>q>|b + XـNly>jN013ܰ2MLN8LW.ā줁~S{z{ !}@2?.Q [TfHj _t39]yQ]3bmBi ]M;EsI.dD+>CZfM-ӌSWXtw( {޻ǡ,hS[wa2_a9uk.,7nbDZp)oxKjC[cp(i+8g ڷt}1WH ~PL}IWlvF0m9=dq5L5玭 EqfN_pdQB\9Ѽ$hY;lۂZk+yan3 94N{~t{Kq=ά:di"Xw|AzIfٻ<&N$qle%5~!0lqS<,9>i5Z }s0֑ Q5 ';t#djk3ӋEB՞Sp,;0zm> +VI&9=0TKXUg ʎR{ҩ ^BX97zBPBLl'F2/0[q#hyW<]#;H*n٭ǡg3[aTCq{r<Kk?KgrRL\zw TUq<&ZA9LMud:LdτYX~~$mP1o; veXaKgX*U$yd(.3^ yzh#W3B=m̈{܈V'NPF0wLj+dL<$W[^ ?unv-K JԍK-8)) +O|swJi{KX4:]`pɳc1! qraOԗz8ud 6HUK؛mNr8uW= fr4vN&H#gИwX/^`|PT_*%7yL5h-qvA!GV!^kA˓dҖ].QTy?]/ukι̯p9أ6 \88^S^̇/$C~~N8e^݂`XK}G>ApE 5N=ÞZ[߳>v3*;w gJ>h>L_r-4`lJ46wlyqXԾCg%nXuK>7X#R-[~]0ໍ6^?/FblK*Dod؉'dzqAqj>?w~ 3ϾLݜ0rwwXY1̀PD<֍sgC7ol Kg fDŽ^2~[&c!7VKhCv8 dy߁SlnX#+G`Oʝrޚ2 _{'őEOJV<^ktu-a#qzM i'YT"w>}t/a~OtXyS?9cw`F%8ڽgsL\rb6>e8l]Y`Vt_݆f[.}Vҥ5kf+|:̆^e|BITJJK'&`DPd[_ 4ɿޢs"2 ZXQ2"ӛo;5Kj?ī;|Rcнnhfx`4h.H]ⲣ_}땏1[x^zړ"h/<;Ӱkx)='ulL'4jpQ8M%g$+s|n]0iGZnkLXZJ}ցjTIfc`bc78}hDX1l^ǩsOac/^V,,Jb\3HF񉍑xe.I#~?B]5'+LU WZqS!띋_{mhQCl|uWP? e~>̳lk.M6'R\$gyt#;sk }RN{M2Ȉש2Ap=0%E$x͟j.uWM^!nwQ(IU:(##k``{f,!c# =qZiEjDZqRhA',evV }u3bͧqҸ^ufK~͍W[fzy?F.$TG~SLx -3a]i(ǎgO5p6kP{:)(]`@Z2>uNU_/G2U"}mױ'i hٖwDsL"Cay XJ݋c_*R(fo"+M $09^&4z&h=6[_J+6#7|p8_zTAϐeh F7y9Fd64ƭph%tb?8^pNWo^=7%x;Wa6[$VhRxp>5oȋW^35'$G8\\lct&G^vgsFGNZgqW|>T]4[vZHvl;T(Ւ ;v~R*)ÂKcNT+0?j;/HV " w1wJ^6p5i|Yzm86bWtZG\B I||)`Զ(: H 0g;̴ Bd[. sΊ_lol-&48FcIʧX}d\uEni{4!):\ nz3 KG?>Nzo^'\/櫨ɾ`N(/C2^*VGP(/Vۓف^e!__a V6X6QOqkk1OW׉sVcNX=G{E-Fsܐ-n<$MB_wi3C9=pPh˃I=/he|SN}6o=_։*{P)K6MV_ٹn*M]uYuQ0㳸nެ&HU-O}LzM8_w⊅Uc:'+rc4Db¯g &q?#pac bhݩWzS}fO |>)KPv 7GlIK)uY-#xӕaL䫛*.1~MwJ7̾TJj=mGq$q kYHo77$OM8WzAjxO ipboh;?L)@L68}4Ug4Ѣ%A|y]G.JzㄙIlLJ`rwԱRI7mx{~-Lu0b\Q_[mqj[C}jN49ìaF@ t|7 'f CG؇7k}㇧-:k׆v uKm6̋80#Bgl /o2i5rpWN7E;~c?Ypw oafitWֻը nݧD|ZX\7>Gڨ1!}eBKʼn[a=g6|I{ xƷܾC'z&X%}pC؉/aV.>:_cr2SƔ0(KTW!-9?qXIH<*SWW5%J;9Q# U#0ȯHvCj"/]@q 9 :\^Nqrޫ$A^̳<l[ ?XUQ; 挩HXv~x!"NX W~yKrЇoi VCݸ7_B:ji!\#Xy'3`%'|ŭL L&iTS)@u[`= \`g_~$0=PEd|Jy3a~sU8%P9{a68:i_X"xI ^(]ƱyHwަ\tۧ M""pb0;Β6=n8T"gS+.6u߿l~d7i_5yq 9w8MZ˰͟W"8OƆLZ)~{&8z5Um$J/L ^mnOw[\p1s+mk6٤ :4 _NVn(.rr$r%$hCgwvQ6&Fme1KXoK? kNi= Ҡ^j].J۽G+, #cJoq#Y,+cq!Z.P9  L^eLwx 48$,9d s9[һG;! 뽿w]' ~Wt)|-3'7zLU:$Sc04qUu>+avHyz*ue1j&l n=yspҍ:)dޙ=W3+CBKa=WUS;ǿnŁZ0}{[Hׇeb %UM?cjd;07dixCh07msL98.%^jC8>I͉r}V>sdϦa5ĺ'Iew'φ ^# Lkd<K廏uHbXI 럶4¬ XhOuNHU̹HnkO^/ ueĎNQ<\YxʎhyU9V#:?Ii zY*m Aa)F&?UGEWeiQK)0Ҽw -X0fzA0*NJ-e1OzR{7B|Q0OoڨzgNPkd^=O*\;N$;&8{Xނ!i NȳkǪW.N+0!t$v:ٳԄ`~HM?L歧ٽdn@́WGƛ_0=Uan>K?;^HN~Q [ԝ{@ܢŲS.%w=wYjqj{8{ԙcLb.dͰپI:O>4q. `~Vų],ڿz D⍼Ұ6}a 25>==Fsís?DeZzл#eIx֗~}ofT^盟.#RظA8uuQL9y+ &[0e'T̍}''@Iz-Zhc_+I)d7+4?yJ0 )B`i 4MwTv?9XgsLrX(Q+G \Fzވ#STtQO2~3Ysvt2)AZ9)9!E0l6 {'v5V40)vvt6yRm5.YUz(!Wu:DZ4&مi5o9+O<3K+l༅}~U6k{1wUt_>"G@ ,cWچ<%ufG%W2?OXҢ@_+_ۃ\ M9{ݯCrFuNaި鷊,u,LUkYksta6PxYG<p藰 )򖴋Z? \qc0ˊJà~^rֶް郧_ďMèeը~7Pfajh@cRs&Pm0桁G`u%`[Y,(G9IC/9|LTpWCk%}~`5ӾEqf0? hީ;Bڕ`.JAzqtz@>0 Vۡ0\TnL\=>suu?Dh9j ô@P_? ./f?Pk;5c0#֩5(IP8߈v(ǀiK\0Xы_ddՎ]ʆW tl; ?.v@ͽ`K__0>u+o?(.dZlߦȏC 3nqZuGtcԛ.HBn1ָqq ~UI9߬3#4v[*v>@`iS&l32C̍EA{DZaqԕ۝XR]m9u{K8Qw+J}QagPz8wmdG#y[]5qNp | h}e4įYDZխPEU S{Ook@AmA\1E|oi6ZՇ22QEL|p3;H6h`KR>M8bISAz̩=9rGl%S 0qu83ӛ'n\޿/6~(<nj/z`c,e8hv+zS#x^WYOK`'4 #M0tv2϶Ƌ087R':z`)}X"-G!tYaί:YS`"/0ق)~@FkR|䝨P m!|E h,äҖSmZXS/{]QSFq{nQRkKo8¼r [64zy&<* "=cߚ'q4 jv.<LQ"`9^|e 8/`C7LURul4;k>z`zGQyݾfF#&͚/BtIp PeYܛ];v;{b+`0[QD֏O+[0lhe(j- $ESE=W,-8Ӽ4p^h75*k/E1+NQjŹ}B1%R1a[W1uH܋,B'}4 M@JUE29ػ+:54Jt'pt =3J;f}]TCb3VK҃O]skQQRp`ӫD7bGs:KY8Ltr|M\YOV5 2W8A'%΃X .,-Wf5O8WUcG|U5;Nx-7z?}t;H2a|iG2Z<+fIq.t6X˘\U!|fQ$^w36 ha,Wef4.-d~7V' 5Co<1⦯Ϯycfo82eQ']'Ϣb8}ʏ]c"aM$҉Wo!}{1\UrZ -fGό'\DP<%%8wiL*/g+۵]SxDܺ8[ $mÛ 7);sa0"to8**fwGMW`9"zGFwQ>cYNjPY5hsӏKI0ZXD n ?-u=tG$J5(m[|.cs ޸Fu&)-Y*Y ڙc`Ǩ 4^P6yvynr>%O?^݇5h$SB5LUX~]U\VX'akugv6? E$e!eYy;-&CJ>n}MI5zJdWZ/3ݼ'DPC(AʸZ g{D6]!XVY/~ʂ^pY)`Q&&28 M+8! q$m֚Ϫ8=_;f'މު]_aqo뮵v:s}P!'\(~i_8 _^˟K_hlF(tcW/(Bmn >R8O$zZϳhjEN}.,Ɖ^ C[tkŖԀ~0g}3+4S5q;[`a*5&׏9t:=[ pCpg lsdX75$R;\~tl[#" S״SSS%9ڽoA@QR`-u877,^g=.z=j 7u{x u[f'LtӴ&'C0Pndp5 d?:Q[l/b*MacBpN^'`>]-l#fП~ R9x|N}j8ZL嶜h_Ur!Rt8 tޑ~[N6`]Kc_WK}|1dzb^R+ K< ebڗ ΒУsލ] _`HENc$EȪT~*$J*-!EQIBRDJ(*@{^q?\z]s uoMW6{g{;Xi/(9N蟖s}ARb_r=$Xd dC]!Fa$<ܭć`܀= B$iTPؕV;"v`׌`ئ7|gf(V>kp?'c^?CcL&YHVB+u1>^ > SCN?p~B\^ # `u-?g/pL*nA2y|d zjNPL٫W٢Xwf.ǽ=~-֛qck%$?V|9vr\釞^ޚ9*E7{gALd_d$ٿ3aMr<#1+XWaKeLp"6 ݱ+xLH O,"c]RyKĚ}.F2syC$Scsn*!^xUsSqKC!6( b3^8xBѻv*VROA9e6I*ȓ,٫ؗ-T=Mkwð{F9zyM̻|ŏ`SS:C&Zz*0.P9c7vOGTԍ%q=ޝ 5Bї:gpnt,6ge\"m^Six]tȂgslgORd lK,_)H$绾Ng6Oi,0 1lj XUc_4Z[8~ohB-8ZFϠ|MOЀIgo4:(MҋX) IXW%M7\nbg/H߸3G~OgTom_ί\_5}I/O@gm*>[Gdgy - n\xɀ摤-qzJ3 KԯD'J!X7 !jlmS. `F*-~:6/,5$\VيC|{ϛ̳4sSVN e%cZŵg !GPȂ_"MC۶Y^Ӧ47!L&v06N6[͹GS[H^Tpʞ6g="'>Dbiɲ6:V\=&u C`*Y|.`1OjP^Cv3;0u %# X.Sn|;Fj R.N~'y͑,  )^ wl0wg&BH} }n \6'QK7CNװbtm!F'K?wN#0tY)WBGqܞkYX&缏CDO EbyH[`əy/l9O=݋tnV]0KHߑ\unl^5b7X[T:-]9N@c i| &ωՠ&XT.q> 2_^/ATMHhs8F+$:C^ ߚ{7k{HQ=m}zN AV닍#ν>O=yWKݪ^QO)@}-ԯLΚQ=h I_G5 _Ȗ;  }"s7goAo>]u@H8t%)x5QP5&L;c޺&O^lm?'stnBrgcp -X9lc5gg涭'*xk^uAAV9~6IE| Lx\ kG8LRccba2O~j7}"Q'Oxsţrtj zդg4qUx!KRd|Lp?}W .Vn)8m$$I]cp*5t)RfH"g܈uu}{HkfD'n7k1_9sJdw` ovAF͙aZOe6 4c,Sߌ8{?5owy)|NIT:KԕL?)' ;h&k+Nf)3v[d[a%Mjr|i;^m.usn+to{ vjwk,|]q<AIB0tj))R?v_tλLIqkt%E3TkCc9!XmRΟdotvApZ22oS1?ݽp4#J Qw>6 9zkjƕNt76]r~mX5.̼W`>j ̅)=/Ns6|O׾x #Eǔw൴|H'G_Á Aan-G,}y_L.$88l ?{ JMM@ɄI:Ds՘l)Zb;<6y5Oܷ!V[WʒG,G6Ut9m= Pa00WȔ6)ӎ.cD"tyFYQ|xT5l!j@N9Aŕ eFXЫ֫Q}>eYV  L"%uU6Zl%12qГu@6cZty)SrCbHGߒ'/б3xTLo>5mabY_4g$Eꄾ}bY N0# pcz`[z1HEd'C$7*<?r IRe8eir,wUkӵv<.|POr|s h? &9sXq8zVS~Q(I9T8Xuv% q\:~ݖ(} îMo^eҐ<;2MM:yњmXQ˜i9"kntAU?ղa@+w;|IBh8qHuΈk%zqCX [PU+}=xTaقcr.ɢ#Av~p<| %l>?6o G²OBylm ~M\v\HRc.S;cA~Ryt W5^')fwÌgvOM9.dIca1>S đ7XYq==6T nɫ\Le <9l>  [9RT j= K m.~P~`N{# -@ ![`@bSI|$?vW9(e7BzJ m ^AO}X75H]vRA $>ݰWgUdLB;|Ky^+[mgIR ڏc`@Xx 4n [$%s+tO]6xsg^RYÙu"rq0>V& ~6SX%(@ymg?ĤۗղboiP5L}қ3ŚDvC`Orzv鳪k?RK;ʛ->ajL7U?!G2S ޭ)bs%k90 羂~ |T k3m~̋uY7}ݎϽ|<=2x̮qwFzG#M$sq\5P& 韣uWi&]L;}'8 <7I&j-kðeW[q>CՁ:k~xOR 9z7n$ \l*TS3v+2J܈ɭ7ϟD[InpB'ʗ_8lj6Y6?v(qs3v^-v${rl]:hI}ki,fcp Ǩ+XZOXoU ]K%8FI-h~۫ ({tVd$väm)/^6O(ƪ~.ָý`Dzڒ>H!6,DNm.]L#aG|0A(}ct)2n_,?4fBkRy$,}+xe+~aɳ)mjfw.D0 5OFa<ۡ! GPRq˻Cp-.{oIk}ӓkn? u5`gp&U<5.tPQL2 KN0;&Lʋ5(0<\u.-(E6$^9|qbk̮bC=Y]\лW(& yr8r^8RR#+!6{C*`¬|=0g{|ES"^.]NGV)gq4ܒ*'//|,¥&gҨN}(SܷCR)N~>_.z)l'.so[G閿EӿKCy5 ,{BIrSe. ݸۛ9[}Eso`nY79 Aq.0t?B0_W˟Q?ke_5]0cQt7,w-I]tjКPs {V2<0kiOzB$I2D$k\& kISS&`{qC8vFK1m_w:B_?3^SQ`\x_u>]$sɰ8( 4҃k_P9%Xh@rzN|rTGk6ݣ\vw&6G[͏X`O0knudշul{zWf.oYd x%pr ЙR^bEκ|핵>q \UˍEqzY ziK\z'Cstoɯ$s!v:BuwF\q:N [,TGG)H7) ͓,ũKqoY`v|gȉuA3H߼/Al =n;b([^%4{dDJɺl'"az{}$s7Mp5Y|@@.뽓?հ +#e> 4=*fC9tx]3 U.aW ޛuiwNڿNd+NJ]?d Yp#%s?z kՏMG`]aDt7JO+GI ֯y9A9Wqδg|1s.~&񍂋\)+r{y` tmfQ'.ݦE-5:)\w>$;qJEl[=|O)"yE-.l^؃cI]sVȘl}C1ǕּW~{o;̂ 6J2=g5|hP,z JDKۆ[LjЧbI>u(QsIA X9&B|?v=+wb8ܷJԅ5F F0뺱"KW=R0e~o0p<`< co8΂.賨?/ξ??_?Bk¢ȶvBlǥ,Ҙغ%)h~hySbG)ۡ'ƌ, % 9;>i,g zK\8.VUJ~OCpo!0=8S7B3E`VԨ}ELmv)eϱL`$!㗞m3&เ#F(;JkL7Ac(`!M?$ U%[yaԿ<}BKDq0%Bcn8nSIojC`"\f.@RtRGø m NO\7n5 SØt *+ߤ|\퉍aI8^濛H8\{Y~/aƯ@b+{ӈJkG#0n>Q{hDOɮa&3G08&\^d?'nQ O>bUAZ )YFkM6tqt^0% v]5c'o0̴93w>G ocA0áp2J5'9CT #p$B%Y[JWFqī~@dPWj>rN%ne>C|(j w0l>,wpǶ28pFVT Gz. HnZ+w$$'O} ;"''$b%lH6aiŚi!dq^ウoO4>քcV#O1+I/cqqŎy ,UkK%-[`^}:νetYfb?g*fGR^v¾z@&W$^ XlA[ʡ=B۠ZژzfX ޿/d]2` }5I"$TɼTNj;3V4m j~үݱ/%A:7 ʟwmrvJ..pUY#>*/ Hy7v˒ܠ3^IQjP*#HkNKg4Y}ʡwN,J!s7Rp1F/ ؁Y ]كS6,W"݇m[Į -aOvO-cF̦5u>( ^tn[Bz+@lzLeMlq1 jr0gu&Ca%Q KXIv,ն$JAX4y0 Р{n=yq'G@A$(мHoP,c/k`Xܚ_RBؙv} y駦~SBZՈNWKLY*wp\IFzHlÌ3. 㢘nKZFDܥCW9g|Ɩ0^LY6PoQ8:_53_ve|! ,gRq"бkueY<l 6AEY埏p9X2[O؛#JGpt~$*iW8E{V6!Y0`pi/d ZHAO)8ƥXq>ތd!ryUqNA"ZتՎ/IJZ#BYͷ¬W{"8$# |J2ҳXezgm9kKl=`#7Dz&{usWK)n skk&Xǘno Al?A_a z?ɜ ;#-@;-?"D`C%ݎ# T}o%o@u:TbKúw߫[f ^\x'Z~ZqЕqX ZZMΫܽe_fli2Ti못[-ˋ_ГG H35杒 uۇJqP t3,A2Y[s&?_#,+o*XKsʶh6 C2'U.~=\F6 Ozk(.Jgޏ"bC,C̺2'{09YϘuYHas[f>sB{s $8[/F7,i'vq[Pw|Ş[rɫs42 'VAACY҉b ? };]o}IU'>>u -jvADq~/=~C;`9MX]Fb\>__ e[I!a,]G!}$G<333м-p1}-b#|7C'$ɴ$p*l7Ѣ3VjGez|Cr z{?'qϝϰ}?Dܩū{fNO% /H nJ>]T`ͥ o0c 4…+R0uC/<4K~UD{"0spL}#L!JF3.%hVc ^?2'on{/- B?#%1.* Uŏ4`a<hxx8Vdӥm n*L~8jk,`q$>$ DVMl;gn>}Q_xnsSg,N{Sz\WZJfʺzڂ-諾vާh򃼄|-j%j/YUJV!% inWy vTLa|˥8vBG΋%< vC^E*GI9Kg[X4}&NKnݮSE0moi,-Gxo^lS7;#xa6Bfd4۪^H>;2ok>bǡ=,ou;(Z׸eDL'>Nɐ,gIV-ϷL ~W KX||-Sl}̠{(.qv;&HeߨSЅ-8'i041JfI.Քp6ͻqΥLq/=Jm!)t`"3~f977?S|gPD}4dL Gzt5HB>EG첊ق3.zjp ;9$.zZYP<t]Xg{ c)wBlȻޥy`H! /+/B+ܯ:x'2/8HK|Nu{f[ Zp&9 彚񪯵p7aRŔ!hy\lp57 ]Y>UE}^ac; e3Śwfafk S VwP抋'L3mbhW6+Co7;a.{`rl0mW|\4?Cfϸ"+MLepZkJw}`In#NP$sC<{Aǘ~"g2bwV|Z(ӝ4ecM?콷5hb: K5f2w"V_ A4gxΏ7Q$촹̝-'`XUu' lm| #N\Xp*X%16hokuӳ/s#=Psfn=bKiaVF:[>ҙ!LCG0!v멒Cs}Pn%ml{{Iߨ:G 4ш0Dw!b೬yu 3'zƐ꿴a֢;W U7^šehٙ&*Dz?iVS1+QѪWX㒳ʮ~w 8Q\eR_&t0"C*L_*'D͉'p (plxUnM e  >{D<]X힁U8ٽ[GOތ_젫=/~27'XDaҎYpiD9$Dz@'Ln0c喳gk=ڤs}fau?uMHJtxv|3ozdR0\dɆ2y b7+ŃH4٨SVfڷN՛\ S*9^oeo}lu>ß8#M:\F8Pzio8No=P >8.qwz( f:?W<%R:'[f`*'I$XwA;mˇphrz, lr^U+gcoII0rzĵq}-R̫xK8tgYh`xXl9'Dh|C|'OpDLN¬0~YɶdU5f?T+>aµ2Z/F?~*̊]SލD Xr:W| ~#M&Vġ~GUN^W*N-`e} ʙx닶/Tuz/w P[ksN`܉%)BRsעL/>K"9hхV@=}5HdHw[,,F.ackBr$^ao͉cO{_C HOLsK=Hni|Z z:%TӸ՜8#z4QvSU~G,NM~=Wbɷm զM&}/(rkSQজ\ d:9<3 oBNappNjtU)vƊɔ:>k'zqA5Mf̰ro릐 QE hUvTyŋDqfon #L3xl}g ,)$Bpc~1>mDŹ~7VZZ hZSH}%$o-Ж`ٙ`-P^H^iSʹjX6+Rw{x9NFMSNMO>}%aXIz\ʩgm.wBtߕOI0ɢscQmvOA0̇޻/;S3J7͓8IXŵ&X`N')МJʇg}:;Źb^qQJ -Ut@g(X*u+ۦo89/y mZ+!>RIvyMcvER?.nm&Xk<54ة),U?wGnpK'?%b\-}27zL< O"&dST܅gF߿H^l ^ED  W{\U`~o a#t0c ~ e y-󂂯w^m@m~Mmګ1ceܟ`b y *lEoC  X&):GΔ/}fI 5LPn{=$,=6.'{SγM(@ fi-WO~ęxٯ̍LU[=^3KnL/ݪz>O!z\6= W~n>|`p#:8Gޓ0!*1M7^Qı‘rg?^MO\9eLtn$*jsaCVw +PN}jҺۈWJm'rXOR7_$S O0 [~cZ4MV^hD-dcB*) eMKNi33glr|ٛ|lfNM1c*Sl$E gV"ӗCE~Z "WH.xnUO|P&.+ +"+鍞Ԡ|FHy=۫̊]xǚ5S5d|o6wM, ?5M뇏BqÄrL~v&:Iqf {6$'abo K̈́t6k֛JL0qnLP.?i'_s׊dQIVӿIVcvI޾?S[_l.aʼn[,V닗ϑ rzJGxIOv[W}K6sɢ%UͿ:|]Y aH3g]-XW`0"ib}:,6b{d\ӵ'n8c0Co(;}RE6Z`@hV>3"?];s q={No3hTxmT.]NFT`oGt`4@ν0q;T7V&Ʈ1ߌ axoNTsЗY&/w9F?׷c-̟ *L"QW/{%hwe$lpFAk? |* [l*(,|#~@P?K@ Rɞގ\Ujf %/mՈOТl Z:[}1?%,1Lq. ~Hֈlq~}0r#?]ymb-#éPWau!.֥%qש78v;aC.o17n=PƆm:w}MvbV.7n#Y+M1K^95$k ݝigq^부lWÓ;9ܔYr©t@mu$^IuqwABM&@'m8$t3h5YG |# » y- ݋UBŞ`eNE?rEHP xup5i;9ڼ88+="(A wL^<ꙙB׮΄m0v P+3gDE#r\~f?p9A5Le9?5$` H.I;,}3c5%}z{qtA|tS)Ijw #֒Ҷ!94uju!%ݐzD{_`%}&C_,IO^C[lV~I#O/p/Bmty{,׳= VoWÕX$t¶{q_#=$]ѕP)Y#V"b?8TUQ:^}UQ 9п~bΆZ fbepԗ'GvP\X1ˆZdok0>I2x kЉYmaƘw<&Ƥ:wgq.ŌF9Q(~V8ľقt1fOa.rDeaπJ3l0gmyj4qh \Yki}wsBo'DDa۽X?XkԸm>juR`zgУ&!%mԫbE=]_ҕ5i1Y<>'V_y((.ݑ\'KRVi S-bܲ+>kXЕzp.e"=r##iWA!^-ΘXI_qy0W鍾U.zAQ%XN^gG}(;Ecwv[f}hWam[$sb\жT{U"5Y'{*؅C[ÌN?P7\L&Uכ-l２p\X$(ۮd6,*a?Y%gmGG_|7+B*:R`qL(m,InaAraذCZ`5~S^aq/\ JyGU>6 .X`YEo+~ _,z)l5J㠊DžO[CFO)Oea7eLj|Z/{q**ogqց;/.\ mgVo:0\UWO;".M aݛQ7|㱇:NiuHd6 2ȿHݶ8Wi'Liv)fE@R%8x)KyOicUJR޽ox}/QaFqB_lZ7͑i l2z {á1{W;\їt F8~+L_`k&"1'7yA?oweWw?WڗGRmՇx*`~MXR`nb[*I4Xhŝ0S>^G\A mov,SqBbG̼¡z3D~~j$&2]hdK2: _&-kN٧Mr@jj}aL;|ܪ:6yDB6GX~|h>h3s7n)}upwqz[{.OK=ހՓmaus\h|Ii=MUfpg9n(\k^"=m:4o}/l:NK؝ET4dߖu9i|Gzyڕ3II۸BF_kvz1 w;7s8V\n{lu\c`za\`x]Oę/.pV81$=n^CU_+ Y}.8WK͛+1*`OBÆ+~ M*w,bZobb c~y.:~oK #}ݷH6MlX@[>>ncCԞ5]`ڋ5=e&:xAy?:RJ0?iy(xK-@|FJXNCWS5BC+M0?#5bK1Uk!w* 0.0JE]?>9kvRX3~DE[հ뻷z,xp'f>\ṡNjTaK9LC}&"%z'˝OߟVǁΓZ[s9g4Hz: ^Oa΄֐#WPCXI܍A/0ܤ&/v>ĦoU= Η<Ϳk~Pae0-;{HP8/yIf Īv)Bb:w+xe~>AJՉ|% XQSX+ܱcj<@ ) =-X}֮Ы:f%Г`';Gc,f=jv*Ͼéneb;U4dӪ(@%:)sliHF=33+kd+HΫk[5^uKʦW>{ s+q;_l3><=9t-'}b6 U;gaVEa ] y3!TJ 5U0hK擯^@iʗşde2[Bk#x8,K"%816n'VbΈUÀc^i2$fVtu]/v}.AϩmܫX^w6P|^I_gٴrqع$CfѮ(/"JI^s|jsȨ ޽km?{7S'7y @ОG,0/_#SpXgl5~&qT& n^lsB2nк`<;TSXۭj e@%w/o@.z[R01ek5$*$aG{gss- y+ǝF0{ ǁjגp9c\X =#T_֫}X>Y"7LUBGa*5t$<ŕ kOlУܷYXfkS{4Egt;gpFj8CzɔЛ$} _1,tuXһ5' ~_?VP&$[Nia_ C˳IعuiAKح](Ni)} !WnH8Mi_ĚuB=~yڵ hW:oὑNMn m8}Ou׽gw7T\乯qa-4]]f#k+J}"Rey֜{\@:[Yr$Ŧ;svQ^o{{Co~M? j}5 #1:>ߕ &-ۧY lJ@+=iuLxUq\8o Xؚ^,Arh~٦-I.S@gS+V}AYbS8eQ# g`)nq严m~p ֙rŤ opպjbw74?jӐ?Õ˲JWb1*frlnGVNefft5_,f K; mp5m{#_jr(IhQYQRtd%Z,zP,zBXkUÆ@?.ݨXYǺe81MԺ}.dvWrb_arh"ά #lXG_r/~)dbSس8DtBG60/%q +M+пbNC 23԰F}x߉4Tl!LkJf% 0$ܪfoa3C)\s&c[9<0-K?/ } 똜pdL)㪯\((ްʥO> C>yςdDȕ{"ޖTqN-<G[EmqDXe3 DԐv#U/MBwu'0< \%Cq$D:Єf\N >.YqCշÛG¢w-V0I$ f]<_T$\`hnj:qy8t2Γ|z؞ΚPp8m-V^BJL8_g/E,-]v̉Ki.XIXT܅um}TCsOxA0o\X=6 ɹb{tfnH%tÁ$K>sd}$߿p&>?az\+:q6)"6ԻF+ʁvC뗁!};a;뇳*=ڙSH"KU.'Q`f1>mi V_^3Y FޱLY缺eۤu"mul4&nt/yw#?XoRFlpc&.NC柸B,jؖ7Qx5MD8214a_ܚ8s0Ϯr:dc8b+0fEiZ0~NSJB}?j`PAc[2V\x]!{[d\dzqe /R,&G8Xq>3K-6j\OgrcSJN}/ݎK_+5 "E5;oAdэ}7#~B&(O&KCC}A6vjgݗ׻bBZ8SsAB  8ƌ+JtcFOGab/X`uY])Pﮓk[ü|$)0 O~SYͩLvнt{lzg8H'~Tr8!1w@Gr?o9/ߡ1!9,dPB$>K'YZd ,;6ԁ)aUn^{b_.j>jl *oy䥸/Ad85zV'eʦRG8d<<%$+qqｺ@WZةah;w# ĿjyV)я uƯ~o ϼoWtHC'L>PS0`ě!?+ vj`'iCyu11N9IBcq)M|}EbS8Ԙ9R+SIEH_/E=b?\6h4dߦF.5098W4{{ҍC2aęYם)i+Ly]gut5KjVWhܼsXcaܰ#w׉);u9|;f ^BWs^gW% ܽy 7B@g" ,\ZˊKywn_a:k $+rk;y'ׅ>ys`ጭ2!b #6k!Dʥ!;4uO'su|W8)0W~ #S=7cӺt-( C_M\{qtQ7tpxx$)QZw\aj:aF f 6 hcٲ \Y?ykJ?ĚIT0108L.j˗>*9WnRJt`PC'%+]R*LY}3#O9bSh9@&#ص:4tSѳV? cO_A $` Ry^ n)G@kOփ鴭ߵL̪Eó2Nc+Ygt/ߔg^8.p&o9yO\ōOS$å-wW$v?|t$`&Z(yO,2· KumLk ؓr\KzK,c%.NUd_wPեdogceH&oKkg^~mk9Si=p Q20,X4fOkPq.j+~I[{,dzD/̼J}a=_M^8Ly,;q&lF유/vc`ur6[U$^->6?cNMg"rCq[Y, S@0IY-XYI3Ցb{v.G>U] ue "҃H4vt퀖CLlf.wk7/!.[g-pHd[-lMmxbէ_%6Ʃ;RoṜ6h>^3+:8mv_@V|(L/KCŞ݂7—Ե|Cpa}7i'0Ħ;M6Ŷ+}\QhȓdmHts8YHmWFMĬ.&՗[܏W4_|'?G)+hy?ŕO' 0|7?v0{V81~>{u a\ ]!Xt͢U4?~AxSP}BH \MA)͕,y$ٶJ3e!(ιfRRp^uZ-dN ^w7<Rz3K5}WOCVVћ^s?"8.;9a3XjuTt\821ݻ{XZaf9lQmZce]MEYb-IeMCgH7c{ܽ F*rs~1.B(0]vNL]NlXngw%6xQƆK#-c YNly/V{d*roa,K w>JNpF_jf,^m!h;.W%Vha:I0t% HEgGgp7ӊ^_Xrgvme#FqkL:ǫYP!!eS^Y##" 'h4ʯDž P'+7 =~Pr?LI~Z1Ϸw8 ϫbiǙp ôHM[GF ]S`Vejn\`ai}3-mWB ;%a\4TR  vʯ]$3:=NdzzVBaMZKIB:wclIp g&=w nK_z@ &ˊH~G;QϿ~ Z>Ѯᤡ&;H:/>}{r'~p} EZ3a7 ,@-L|W_Oǡڌ1}'.2\zUI6^tBxff d;dE뺽M;C?]d~Ce9ty_єg8c,R'unE^1="N4&XNV=S^E ?l)ǁWKbg ׮7q ?*>J+R1aU"qf*~YxV]eCRHr_c޻i?:aڪe\y 6Dֺ9U'o\?;G9!&sRd՛B pBvT/{z`,.l8&M0tZd\F%cRn7۵ iZ}-pμҳ k-5dͿjmw$̑M cvV#X7*GhЛ,~ =͚_㰕@[Wo?L~'1eR+YgQBk(&x_#O[aMwvttWq o*Ig'f:6iYT͵lGbǢL:V'R͇`3v='4ydl#vl%bq:2mFc>ښ# >;_lĘ*I~6yWo3̞qBks`߬~2\pS087<}יdqo;NHo͛P}I_6?t4ų$f [_?4nJqÔJk#~ZE*,|j5Na(w57>"wR%.K܊^chNpx_JPO Kg:Aɉ }BC"?G__=я10:F-6+5_QbAs8&=0vΧbh_ox~٪?7ܸU\ "KéIOŪ(X:/3L;cT򈀧B0r;G01z;r̳ZW~2.Wf;vZgW5݉cʽo<%ިlG_B5xd(pr5jߡ4pvn؉I7&X/ )RG \v^t1JحZ4]d&y˘L'ȇp)ʥM˕3CGghc/a̖5b-PR7,h} G[+OYm)}gʎr9@|}pB=IA1_R 5X5Geߑ@ %dz2g15ЗUŤqG\0u$ch':' #0{h/KVϿ w{H>Ǜhjdx.0uI(6Ozh.2s=_,}Vc P1+RO)͠VS uys0YWu O4/pW" -aRWf?_.X[XzNd |>[6H+Q, f6k'9Tp`P-uvgF /`˫kvH+z^t VօW 㭃 :Zl"ɼVCcgA.]V?EH4<;3~WH-bɥ-@6s׀9rLp*qL<:vؙc}W+VX-Xͷ iϲڵtqן1 OױJZ:O=w߾<\ )KuW#=&dH2yPG5z~j%&ߐwr ckpʸ6-} &ʛ G&Ad2d 8Uz6awd$8r/]|-'.³bˡM;ǩj>q'X~.¥Mr‚TA&V:_{p6fQe'OzJ6Lyq}X(qY F0>q{B4or0*u&p~(`wVx'H1>$L4t1.~gy?%9cq2^=!he{(%I\ _|5MsqUlk*g`r]Jt<<{#.@9<=@wi7iOY A c`]5d_>F_%1lߗ$'^l3ҟ']:s%'Eaq _ݢU k53p鑠9 O:=uqYX`?܈t"1M7O/!tBd*EOcQ$J(H%I]w'+ -IҒ$J$!Jdם۱86_?~zùp,vnjp|lǥO7x%&: fc09WAU􃱺b;F`8jX_^SzIJgmX4C{-b|_a~fm L=awN;2>( ťw9Ƌ ~^b)c|FƬ ZD|t_YNmZ^{ ͑/D\zlXW;qWoW{9'gĉDž_}s>,&'`곽@s dT#f[;LQE>#2w(bƩfXuuӶ)3',47HE9kr/nǞ ka&ГJyސ#(|v $W]P6 3+Plt7a Ή.e {,G3@%GCK1%X}]OAvE+wZ7dɵ{ $\ԁ,e]ACɰUvvc*Z54AYq53s|C~ Xtsrc#%4RwhszKid] k [LǯJ(81g/m 2'^X=qVGܱ!M~9oL is*8WK'7lwXcA[ۜ Ώ7kp5oH2:[`XCEigC#lGqԉSX5Zj{Gk *Tב.||8t o<|E *CMm`\<5* 5 D^d4l3iLolmf<\7[aN_:?Nũ@eRנq!ǚNƾ28#eý#Xj>~(B}dL>ye `jD6Abnnݴ 6 &8mK,T'n(1`DƅwvhIZ73%/>"vJggpBčj5"0[a+7]n<S5NBU;%|G4-,*޸w)8{!7,V {I:M;]VOXq.ş[Y `L>|d}|Ԇ?] ܿ16mĉ[Vz~4VӸbNId/gh ?zN8/!9@%Q=SJ핤ǑWk7R[`=) ֻ_َu}tazR(̨+}#Ewl?o#tI?zXO$Yhell'\O{R{قs|7fFvT)- Էӄw[>ٓR*0[\.+~~r؆sUqz_rhy7ZȥV7-]c&G8x@ u *-qx;ҼKwGkL-uj>?ͅ`|&5*R.~1K;KkL%- ? /̱;ܾ߱+*TsUݘ3D6; l1AuZbw7+!Г:o{bpw߷Mx,:u:F6/Xy!_<:'y'y"]9'_,=U-HZcOŃ0/}!f t0q̵UuzuӁO'rшƬNWk[N}sn~R2[ʮ椰IE܊Jȍ6cmبm 'y^>6N 奷aFK>۝;pҼ9"'m~+g8(2uĔ)g=8@g~eb߈9W8Y(L\ϲ9~g]96o'd?-AϺW2Ph ;NDZ]! e>]+V{ vnOtih9ĈZ"X2zё"5VpL\u\M*xAoXsDXv3kw8&}u`~!)AWmUJ.4p,~6G%>K a q~P„˗{! oEz"# P _zJo- {?^J"uxʩ[@oVt3}evKo$Xg-2-3nSw16x];?`5%D|'p6U `G?Cm;U w!WذHI9̩.m= u\H ۴95섏s!X.7h$( 3(uNJYűQgmGU=m2L U,hA!5n Ǹ! .3) &%]VspH)=tШ 1@HGzЯQ>7e#d󂻣7&lnc,7}KӃ wm,-6}X5}8C'] y%ԍ2ٻ)3M2]+#agN-6yVzfy.6/Aݍwj8S &U+0$!&_yj՝ϽBA޴jYBB G|zu|QGX6%*Bo@lbܜ%VR'?#yOιbv`Ȑb0maYކ~űw8!3 ' {)rCpY@"Bɛse98FoS! uِc2L%ʶ0P$Œ.Y|EwN:QAW8 J\:N)jC;,ߗ{0?Ou!Xo%^[7^ ֈGGcO0H޲)cѺ`.QwSijz(#t_TB[w(.]"Q zN$2]+}_4}h6c}weR󅰘7EGw-*^5+aKev`9[_C';_y8JFjB]O㌼5w^eJ-bʶ.$V o9ڞvM=Ka$ܡA{?b frMv/ۃ9ua[FSx&"6^Zfe<} I6,̫K.n{?voϭ@z80'ɮ'sM;8yƇ^vݦD _oD[o*$Y=W6yn[0G)m܍&*I38t FY/ ydCf߸?+|'nv|2N$ 0jغ5H(˖S 9RUiuWF; EHT^#jdzlO_&oN_Tq4eOA̟=B[.K_.ҁ~iC !eG2_ tM#5BM8xnZ hR3e=]NaV8(%p+`Qr'*qT{>pk|&l8E<ā!Wcq ߥ> v~uכwvy̋BԁQn &H@էAٵ1$Yk]*dRCs *>B?Of/KNwV튓h%,_~q^k{,!(JQ0ŰLڋzI`ˍN6zSƘk l8,ouJEg8gl3t#M{ʉ=MXήiau =MY s$@hJ]ѿ0woR(}s&'TkL!v+`Y>.Z77q>VNz.9i? u6nb}f핽ڣ !?F8S|Kb:N|@ 7[Ntb1HO~o/;,)oVuWF hu@)O Vd% $qA.9o79;wKp&keQ1"vcl,u`Զ_ƑGʪC glw`W1 2;j%N]lM`E^lO,6 Ӗf oTT9ҟ{\߸aHs{0 %ohԙ9sl,_s:bckS< Oњ|=[}ᑼmuwb͇دd#.U.jw.dSi]a?n5 h]={'گZ㗉cNqSHI/dnަ }l%nhDIu9lu 30c90ׯuZnd|aapaVŤXnx\`/:2A CwUÈc'Xy٪cL!#fzJqm{3A]XH9K~JHN3-솅/Boo ީ]"bwYf]G6/oK޼n`ZtQ܅A7, [Γ}?h, ?-u]Nk<9m=ɳo;H6N%mNꗼORu;~!WSH􋓎wac"kD̜>B. :3X+~=8Gklnl%9vnIx?xWڝ v<1*9v>G`kvWro.C '۹SͥAFWנ+ә:ɱʍ*X1zjץ>[֐'Fv&@PG}.9,w mΧ?&Xϗacu3WH%őYY:zĠ!_P yʼn$_D+Ѐ?C}L{:L.w*?hGK 5<N iC8nO.M4ݯ4b퐴jSy=3סh'MDI8* fz:'(O2aێŠV~;n\jgAn݄qR NI/Ws%IӡXMb(o__7%8$}Qc/,R^tp$ML82^;o>W~èȏo~[jjՂX~֦ ļM;=ccIY$ΪzcvZ]T)A3B籦@_n% ;g%Ɯq=6Z ɟkqH6"O/Jsdž5is*dS}

G bɺr2֎:99,xÑl, |a o83^HIf|sjΘG~zy۶!H.7?o "Y+̄]Xǀ: 2ܾՒ<pD[DZU'ʼn߲>Knk)1 e<7uf%xPR!XA j^ y.q@k;c`?B]wgԠ'jkvrÊCgGf< O8ѫ2zpҧgƧa.2W63m`{Q]g7,Vq[*nwTkŖϛ@=+ϭbSÛ= sc@4}XӜc??'#aᆛXlpgY'njށb3%CX7e"(hDrPx9(p·m!XȖr/1z* &GO>}*]OX%)^ZcYE6|+#C&ztT)UV/'eH6[ ~Vtgo?so:Z)0~8".hzhM)qЬ#>w,fCSV~o@ >6utBW;9萼oXmzn=1>=œ\M-`ϡȈ=ݿ:Ʒ=..Rp+ 4.j(=t_gzJ`<a?5yeج4g2a{52Έ|y믮Mg"3Xw8-X2y;u<{Iܞ;ZWGq-Nu51շ8wNGՍ:ۓ@ =O 2)ArU86].g>w\: %ၑ4٠uRvq$):c?rF'0>"٫;n\ O\ 9c_OEdyx&Z}L`ˑnѱ;|灑FGH^_!ko̥-U1a_g"IJ ެ-`q[OW_rlVDž_X^D9nNTbG+juH.gK+j fA79$hS ^c#+ERTo$u:=W,mvC*<%@v Ohh]̪30`F?C5f')>My^^ j;FD4y1h'_fYq8$rd,t^;-DjDBM\Oo+Bѳ#rU`=j8h x36Lگ7w@ځc8}o2Eg'mCGyIsy폒`*bgY$GpɩT bxk%sfteX) e FIE|N-t!% կ@OEc?Gu2}~"s?t Ҥ7h X D^|EzQ`(sq!s~KeKKKg"A7k,k־݄mc Bӧq7i/TH[$w6‘=quq`0|ȊR"HN|a0ڨM8-}I:G\~v[(l8u3vɞP"QeHOPz4sON:ĭ. l5|7YN5LN*\kYy:=H7c{b)9u,qt!حdDPV-Bh kQ;8H u/I^yM81k}D]SƈfB`(s<;(KQ6Jf1Q{9byzu4<"֋m,+[ OꗕNco3w%l`xkxza:d)*?QŠSiPTUPO",'Ȋ g|&qD$a@5{=:8t1hm3_a'(WLK݃=scU{еNv.pY.xm4T.Y1ɣ r@Մ3}(L:nGaYfr6HTN$UR=[^>mm%_CS0S[_Ԑb7V&>t.̼i|]5r@ P!Yw3$ӟ@>htn$G1WC߉&KBp܎Ly -ˑ!,0)aKSJ)ośG 5>mA}P}jB'*e vM/`MoRj4ѮʲrpX îW&a9zf̾JB}МfcڨNTxU)oqzծht"~ogo4Bzs)*ܠ/i )Å21wNj zeQͫNp%& V.SMn0Bhjxv+ o̳o5*<>LpKՀWfT+/)% 7oM`mmX8TiX7/7]u9YiL2TwgcG0P3$]vtUN=D5;mў#9&~A,V㕊w8{kw7f.ӊ\x&oܿL V ;5#8/T¾>M_R|%Y ΦG);C5]6Ny#=F]} τՠNtN:e9aeDe#r*b6BM˕|g:Cp~:mc00BV/ B"a'?F=L4Ԉf%ٴ6]~̋5o;ȅ[.[Dq,7O9s^^j.M™lj i!(g$h`[P48Qar`bhؼ:qkN[:C''K[`Q3>B^ _`IpĪRHrf2YQvuegڬ2NU+;Nْ ϼpԃF:eHeW[Q+EC$Ϲ.`/ēHvIh*=#rKLxCgD!2} +ܯ] ~ qFLS:y_=n v2/mrpV}TJ;P/էkqqyŊ{f gpOMjoJ7״ G{0y;^ ?j sG0r؆rɪ|{6fﺮL^-B 1r@Q}Kw N 'tlL=l&H s@,8Re1mڹVZv)|`PYc'_Iqq#,_CzL7aJiwfݠߪiPLg JZo×pŐ:_1]h[o8!`^h7Kq8\Gxܹ )uae!4?~HOe$4#38%8o>a ;ZlŹIM{b>cӂh]X^TWs"du"EpiOĀ/lx']~~}v+Xd{f5d\ Mk$R/DBEQн⁽|5}iѵy.o=ތU3˩㤱EJ߬4v慝2X23d }zzL s,QOW੓SkG@ZWWqfy\ FmN*xI$$9Z$iJ>3 F?s4gӫ=$PJpJ?N qB5e2{"k 06K4\4N8)['B?,$aȮɾ$ ͔J$)~7qܐf MC!#8f b>fV,@.D08"jiO2$qL- 64ć_[wn@oKE.J$?ϓf6I=[][VhU'aUJI\nؿ`w{e1צ9 d'eQ~& SꃎA- sgŌ6K1Mt\uz Ӆǵ Y>a|\r-2C~[~L]s%b wMo\;cd:.%K%%nHʇ;=3Ǩ0ZQ3$o)P4HO"f!CE3#…Xn)0H? I/#{0aAG/ xckg37?[bz9,`9!<{(mUK\,$dW.D~ &MG/$X\󭿙,#Ͳ6V9de8tzڦHg> Nߖm1GrI}Y&THQr9< ipaVP1`\uwf/K{)En,o&wͺq0i'!e1X]IW >&Xo{ O7XU¹7e#hI/]Zw'D!wܶ#)=aٱw0A 4QvNZBӄ_վba.lAe2u:ʡm„[UאvXt.`=qyaO'XObmVdv;f kgĂߎaI;+&lb"[`0:Er:ZTNwy;ΟSKYIaY|syɣ˵{eQm]}t-,Н+೫I-0gTs :;o޾rJiMJq81pã'&3sĩ]~PaB;'_'O ~*ݤ'0< eI϶VuՆ^87Sk[%]rppu6 sդR#uuyu4;w"j= '<6 ˧Zdg1Yn keS$qAPeɈdkGnj|#" 'MRIv#%}tY5bVz}I7^r'4ʢ>˫Wxgǿ1VM)3hR_7zሌꉸe@ 1 Z$ҞTl|KyZK &ģVXQǭ0g @ gߕZÜH^&,:@Rܗ<ßoƍ8yL=:$ǒ]ߋ~#K_Z>תΐ!cIJ*5t7jGA'+^'*Ǎw7]'nz{w1~3-\6_B1v0gqvI}1ȣ[1ʋ\^k ¿,HfTW<|lUUl|7#OJJH62}$#+A󒫕Fp˩Qϙ0wW3l{&M&uIZ c#X*5?vVu C͛ |]THyы$[]@j,a>PV-/eҔ/҅% {Vll!NBJ%Pm|*+Ku>"$[*]8YLf?o8FU#_D,w^ K\DP<R/vAF/p#'S˱+[h=U7qTeݝDsX=_h.9kMؗ~YΆ}MJIvBO|䧛zؑ־ǼKpՊ$QW:j zŖw}xֱ X?O53m#:':%tÕscQiN/D_o~tU|NXegbKGd)犹'.Vyz!:y#@?(Ac8Vt3>)UwjK2¢rZw/lz!OMeAxpy$¶M$e&6].҂7]\7ս:/JXm~( /̷n"dVC}dUx]2D!^NP7S*o͕lJcCFg2 *|M>aOZ<U w}*ʿ?xDar⁃tӿZqq^ƛ #Cfhqv7Lȼ?g話})cYM~d8wǜQ 2z[Âb[-FܯP2{ٱxalZ/ *`Ƒ?6z05ig·w?*|0%PJ#+Lʹݭ{ !]5֙ř^ 4)X}s6`}F){%X:5 W5i־:4lPJ;G-9lveLhDO@׺V -y ?NΧ4˿;epCɑ!!hk&z^ gJwAyGl>=>]:j-1-O[lܶymԯb_6F&cH-z: zysm:|閇L7?w hr-pjGہawv5URsD _'LS&̘zh iPS}Iv 4o/"Dqp1+viDDO~ˆڸ!d-r,O4|CE-KpaMk8K⏰Ed*ĉj''_bz`Yh X⳦XwZpqOGINЖDo*&Yg< ю1h0$Kzb& JDxBGNU-t$o4nKlJ%X]϶z׌&'0SbK0Um9Ej$_g|~I#z!9?\΀cg|kLɺ-V8_kN5ő_A"@?W<Ӊ26st 7SeHd=MR҉ vﵸ=wlѤls/ u^}/jR9ρNN&ƽWlONR 髌eh| %dž@WlИM?c/Y#0(tԩC]HJFn tZ>c8nu}I}k{At]|8u/^/| ?1J6\zbE6k=;f7ތj >B5`|r۶><i77,%lOrh8٥U7bfj{`X𝕴PMrɺބ:QYFqt%Wnl' XGog~֤Yl8:vax:0XS&TcrL7b'Y6}jLXS\/A`qwOi蜼Z+hyARfS7(u|ƞAS4 ֗dtyם$u6[šOJD; bD~uA[Vֵn;qRmk PszTfE˛C>Wq]djjUWm4Xum', l=1;R[vAcV%/Iy3+v癚0gkoAg+a7ĮEʾ$n6ELxt%+<|G.r'%!`"g6 hN}!8z6n`v?+aR.xa8UkndF5ڏm[jGH R8F,Yľ' &ir%h8ĕk=!$/?vMl߼Of~ʲ N}oKUr6se؁I|Z]g-`э{jq[b?LMj߰eyO54oTs ~ ET]X,1'YSoa!lcwpwf.:%+'؞es>+'pZW!9,Yq֞ᅐu@ Qu;7^cX ȕq!S∁h=)UUqJd_,D!ؚFaւuD&ioO%YkHpH5O~ܖ q0㖭weO]^c^ֈ&/">_0;\/VDԬY{$yeCLGNoۉo5"غ WL&)wraKѫ4u͏x(1xfqiK lc?$N(h-EAm* EÄķĻ%B[ ) /ם1o[װo6\唁$T* w,=w9$%3V=pbӕ* ifK;o%؃fG.iRPSlS(R M+$futb$ QyXkJqg[f1q3Yz#GQQzT;vbޛsm5 zw~oP*? JEoݨ3j\/zCwzJ)kYqab/]}A/˕J}"~{Qjz"W0+mjYQ_ݴ;$H]ofIz66_0–ܚA9=pS6G%Ջ98lsT{۱A|?DzievU/=u A}W'Lqs3%AټgSQ/!C?u?ݎ Fplݵ\ЏWn63rk*"s91;D?ʟG <3)F y8&}^ӿ{?.Vw匁C\c_ah2tk w}ă// p6^\Nfd(,"*v"{&|x cq5|X]s[na,;6._y7I L~db\=᎖ y]sD]ʘYuϷ'[()˭61+=rJ[ =?'Mu ~I>sXt{::, <׾oݝa>GVyIL'$MM`8li᰸3OqbJ\d-"[¤2LD`[F^@^zl6sW<~URƑ貗6p-*}0 ͜NNt"¸g8=A'J!(Ą)k3.0m$MjxbLX%a챺\LфVpЛݷ{֭UpKpvn=dqCv; ڜ[v|(#5^t E!u@ܹ=kX$ 2ž|OἬ 믝kIݮ?i{mڴg'h#$LEE Lܦտ\ِ^ɝзqYd{s^)]uc-~ oþ1ؿ0Ju\Q6~l$ɖ{lu]Voac8aWي>|-= VѮ2Z\ַjk(OM M;q1dmXK`Nż;p'E.oԧB0;zdjQd{{j L{Nhk =hsV9qHGf}[[qpPgys.H,x[M7¸rԻluݘ0;͇Üg *C}*;nhU]B|, .r.Y\xk٦I?VpQThl 3;-{:7_땙 㽡ŪZ0nUR뮊{ ]1J ֧ڔ_W'P |#YƦ}N]ۃx^ao:av]w$%i'ba/$1i ZXgm8ehsj=$vvxʝR)^L7? *~у+P 5Pu( H쿘"@Z<([\9H/cm '):M˦5vNU:2Ja4pe#9CgFgפ8I+F!23u]Ty^Y%]ݟ?7#4-;dQkE֮9~bz⼗}9칗-^zzXs4vRɾy+fq*KB͉YR.=[3TG8hx&wSj£|5wl{,>w[&[`3T O"Uн^]ەv7ȗ?$IϑC/odv)i.S> EqcȺ8﬎& gp`PH(wv9c Sj5[V)$Xΰ>'m+-K`s9'an 9C1db= 6ުCz_~x= n0]' j'>ǻgW89[)ڷKㆌ^푑@cT"C9`:KH9}}4`KWe&9iyx,NT!8_{SN*llI֦yo|Np|JВkv$qD:8]Q<G篫*tci;ӻo} D\[.5aN8h9ZÏ(-q~ ,?Qq'~~9-wC\Bʈ!8"/tKzbWZط|,9׍2} 9K\:nk;. <%o6ZˑoK~cc iO}V3X~4}HLX\  _ʏt[fX{})/<PU4JV\y](OAv0'v뤯0} {IA8@7_؃[^U:8=ǡLѷz-G]7LD ?{#a|ЙjLvl8Ċ߷qEiS햚Ό:Q{g܉s$2'(we?.dUaɝ6'N@eyg}Юyc5,V %SŞ A'aԽ.Lݞeo GS_+ʩ\{]_GlU.)& 7kTHn銻A/3oÜxo1/.M0gW;&ĉŽ)#9..Ex ollKYűO6S{a@40] N&kUIŀX8gu}[ X)pfZFޟ-JP>＜sK=aJW4 ]c7`D|s1 eiХlnli#g>)tD-۸cY'81G1d< CЕ}'ΓeCpUC+yMWgLyC_1?ۭ܊!,A:+<ǛEsi·yXQuL4u[z Oow>axsq\Q_\ 9wl=sz˭EE4=yn^`fa\y4EWU ~'C?] n15Z兤$ޜH; ?y+sfzI>%,*<$_&Jr}10!ng`;IP4d|xfװ'ܻ #'p"S ֳ]{eEAɢOqSɌ$9?K~ ΏPw^X LEäI$ϭJSԏ~=0neLaWoA  ]*db˶ǔHΫefp\ʪ]qGq`w׌ 7Crl6SZ[$a%f/AC;{_gXo04ԞQGzuQ%FqƤBN||M%/I&xc{  &(.vTa|:9lT rwqq)a?"ukΏZ`-? }Dz >nEү~?#}rT86t.|܍Ukc[Oġ_(''D &\*Ca# KgJV;'Pf0 d}t^[mϺ/IB 9/$woOiاJe u嫡,鍊у'C˥k?LLu⷗ys (M w܆\*ɒоn>JٿٱK.WXeR9WjQkzj*T̚ Jan󂿋aݮ[L1g&g!zcFc|*vk ?*v,gkCrڋxQ5a GWs3H_YR ;m?`AWxG2pc v8wNaylz;\n^$Asc繇apUx"L,sO[6cʒ+\dr:Gcyb@_W&Yn:bw!`N桽oo:02 UW~^öҭyH{ʹ"#-`(Gץ4,.=԰0/?V~h]'Ɩqw]ydNh?~djoN]$k+ ٻƜWiL%ElXORWFbu|wMvIaVX}/~>U*8z #{w< U6Wca瓝%?T1/N[ ؔKO4E072N '\g`?y v 9a'1 fk2j&l]`?N 3 !XՔ'[CjуW0'm%nL͓j[֓/6A +6 -~!_+IHtm&\>񊈵55aDث:?fys`~e;<0/7$TfPdL9e7dUvb Qi)G, ,=)ChO\{JhȫTxqOHNdX@3^vO3OI;sK  򭺙K'7^ z]éCk~EEQܐ SBe?v%YXzuo $Gka\( h" 5o$}Ӈ4't]i{/}&vpЭ aݼsľ xκ"H@\p ض*_e&~ApB^_Liˈ$2Lh]ُO-8c"zN ze?Rũ'g7dM^;aŕ8$laFL[^ZL6My #Mػ<-*_z[K< =AV6JG~&-é;_s&Bv ř̍U,/NRg#&:3^`]ׁ1Ư$^S ZkrK ͆rE/wq䨫ňdi_~zmc0HxmYWzޣ,9JP5/@:OQ)ލ<ۨ+ 6/7*7f73unHUU$f,LCEY7Bg??p/>vsV?s 6Nfz;(<\z4v /nߛqyUmu>0=UYKu [gU倣o׾IGT$`4]a}#1{zR$ԼpiKQlT8lz{Ong@$[p:0%9iM_d,\ X6A{m=d_SqͷvWUߋ9N]&(%gˑ>_c,Yy?;|%*&QaYӵ]q![/7єW:ɹ$Gݴ:V|>5WG^!ZrG=Inn}Qьv]q2;Rea84^J䷼Cw1!ewr/ mNL4KK?E#-j(dMK„󷅉fz6Wܿ>4 w vW@9[ǰ`fV&ߗobZBS70!{w+''s?>.@k֒ \VL>& ' 9 >vPNt U#`„z-,4v m/,ԗC^pžcbl0:H_4X:8M7]Qʷu#|'x(}bH[H](*W%Pa6~"5NRTH(~*'W<~lwV'0(f? JdĎ[0EC2Nӂ]&&cݴ)(-xF'*|| ;Zc0լΦt /l6;ܜys qQnϊo%|Xm?{B]sR{\}}L>x+od N|ڗDfp,`4vf((q؍*Ğ-6OSʅ!G:S_Z=_ki(-GjNc7@ڑg77 Nu ? c[ybF)9ި(!ui*"k*3~U5W+1ɿO-א,"Ozٍ]w̫ yle1ty8V&4Z0W82!eд8/7 =EnИY{[N9!\Rpz$>H0KK$fB8v 4_)ȨaGqdhmWާ̝YIׯmVgcZLmX?,?kJcS< *+z5f27U?s:Șa- cwU$FC͛$a@u9E`zl/M{7 }BQHkjm׎ fls!m|?8I>d7݇Cq9\[qgaYk}-߼ c[WŹ1uOS L%7d;B0 >[u[$r;6*ɆzAUw8?xl2. ;xHЛ;/`ܓZ.Z.,g0A᳃yH\zv%Zosv;WcFeI@]oc#2|mů\G^uCBl`'m?Y}Kʶ-!wsp;iv4ɺɓM0=Ng g@4 &eԏ8vtB(6^+Yâp JmE+qTхG$ꊊ}<ñx,fZ&xE׿/'m3ddckZԥ0myʃ݄ՙEȴ#l*Yfڭt̺Z@ Y>Z̓<Ά8ۚ qzoP>]k\J,/R{8GAgni?ؔ?eכ7oTRj`4K8GeQ:"Fp8~]Y*Q]iZr ځr@ekvt|mȯ@U+ʲ J^ۯIxsh%a'vӏs@F) \|]R츱yZ'K̜;̕9^Y8x4tNB 4 !9ڥboņzWHJa;"Ka>9`ܛ%+,C,9XQkI~[礎ՒTrVgJE320ܲB>LG,+b-m~C`GwCOoX݁sty఍DXR0R-"4u줓홹SI?ΗV$W+|WqW&i,\OLJHʁ_}`n×ZdkU۠fS'<Z隝E[BڥrqZvgb}3nЯֳ >q3Qxd?v܎)[a3T3ɚTv*.efصii8ȲY-/[|pڊ*&B[_1غO<߆0>|KjuD=Lզ\Tϯ)֧`X?8p̀h#v Z6 +jxUJ0#n͟|AOOĉME0Mw/of uSvOIQ7 I+g?hd4]}{esa193`5=|XPrЅKRh0'<6M߁!G(q[`_I1*8Lc Xs%; &l<:qUd1B6]p==ҧ'/tþIu84 |jWFg'G\\Y~,vbc_5vݰ[8S::^4[fBg>Shy*-YlctkJq.)jp2ۃdۮT=Y)حvWml^=oNVfh1J5CIyo vamdFhU nWQ3j/+}PxTF=&qcQ8k3v~蠑&.\O7ۇ=uwYv4ƀf"%pk`]?ŞNhh5ܛ 9 O&va}3˴jg]SD D'~\MT/D엖WiW6E֙p%B֞*a|M[تt"/̆э;^:Uȸ,o7S5ڗD0O X|,[^j䫇Bs:ܸsŗ;ҡv4BYǍuvd {3;OK`A^4L\=9 na%96C.߾!zLci 0- }3̅2SH;iu] ~fQg׌KQ@;9ObAJi\~;9MNdatH(4kșyv?œIuG(IR^0 n(.]4w\ E=WغamsM;⡪;͡0c<#'Ta{qk )Kӏ8jGN Z'^S M; >aZ"sʉ;0-o9JN/777ly-?ΠMH?g'B¡: TKYÜKX@w2&^̑Tb5[@@L ׋__ȠN N#ϑ&7e (7;oY^PcY'c9U~ ;Mp5 ck6YUl~)* 7-DdO!L&0B0Up]n^?/{,Hb =u*_:j8嬄Mz]ǎWEshH7Ѧiv/ŎQZXB~,6;s}*<=׍i1VL7,O%cŝrغsLշdvhZ+dYk3='c_+ 1c9'*JJ|p7Rbx95}2u: 1csʑCٍ8(‘(ԭ󣳍ZOY'^|>Rcg]hh|MN6Ɖ3R#Y=(#ʑ7qFAg=JawvP'x{:k܁{o1E@缕Vd 8e`l7̝fw㨻؛tS乿w۱fhGhMh4;SK:6C/sٳf8ۆ3 ;wevC!w1S: '?i Ӫ=İ79ЗDwFNޏ>f'faˋ=َ2#3)`6@m/jp`O(t Tp\=J E4t:p}[ח0@b|UrR0W'Lݻ"pHhxM]zlN731erTk'Y dƥ:JTf&)V`I{W׾핞P/Ra)Em_mp&&ݸFK2ڴar[? 1V7JV_6}#Pީ2"II'NK#QX~fF2^LTAJ/력VŪTa쟽ָUG:I4I@pwf9f:$ M'\jqb,.gW*Urp&Se1(0FZ9{q|~؏S!? <}Uaٷ\+NXxґJ1;R!z%lQL08ĵ泊g;5Q<*8_w$+^1vhc ~['Α,]ʀ'_O2+F_FaN!jմW\T. 폨H0Jf9`hh̜(~n~m1Fsl9$ Y/ߓ5UO/RH+u8,s &)G66eCbqN*;H a4W?;.hyS_*6Cᒉ_kwwXMB#n nuDI ߺ`q^"D4ޱ.+;p3; [:]݌c_>,k5sf&ARBCmE1QWa(8P zkM. 9R|ͳ♰3T,,**xurC]í#O9IΕHhݛ`ҤCJ(%a@d y&+*"5,H?Oh7짿\-w\b Mڻbt~G|g>ka >_(jjp侯oU/m֜666bϔ[ZX㣮Qy_ ,局*6 iV:&Ƅ5J0Zs󝂥_ @780ӎ?[nbZI/MJ9k -<}6mR$ҍ1 V'G Vԙ5Ǫfr81v@fg8Ö+',S.G샷oզ B`їW @;&{Yrm$}|/'g7vÕ^m'7k! :rPa{9w&^}415$)!x&5vA\NLtp>CBO4aTRx_u$sÏr~v轘&kvޜ 3 7]+8dC?O`jSeK[6}iA2zJP?1V%cþ 8S6Tay?/qr+NG#)ZpO tjPp1 V,I5+">ƶ3ơ|`R-/XV¥ ო@_`V!'k;JF\cQ!H;YC}c_N5DbOH=ud [VMs75#ˮc"]Lﾻ|?Eu84ի`?'Вf7hg4*P}s$,m739(DU 5VT+\K2*4y)awUA|#e,bű+;=o/@ǭ$KQ MX jvr=ad΃9ڏZaՁ!M]_P>`Ͼ#q)@ReCu↸=w51;&4vI@ۑ LfHK\F|hb'\MUMLN[㓓JO&!c)znj>eBwW6M&_dy͇\j7Iq%p5}-N]6ۍċA_ c>|MV_%*aE+7͟&ypa9.)z}@_ WhCL0ES0udJ/"+-Rc [ly=Gڣx~SHth&aӬUG"허_ӃqnoW6uqr:\)/M0Z\2 ٻ_ւ6l/T $*cT\Y8vtg5χɳ!lFu gcUΖt 1a~ E+cXJ)\oOL{<{/-`Ֆl*_J l_ Ux~3|KDko1ikӥwYPf|Z.'r^5! fEajYƭʶj ?hCĤa|0Ȑcxf'v76\:3R7 cb9=C G/hJnihu4~T  [k;n. Cj0L|iw7K -.`iּ.a۾!Ha]^#Fr~S'!]ѡO8绀>-Xd #N%T3vƳXtĞϛ'jx!R60o 2!rO/̟{9SLj9.oco]G?5/z .E:|Êl@^?wu Zf&3* -ڂ] Fg~BUw`g߬g3(ڢ}>>i#EvkT>Z$V[}w6o=M:߳Q=Ē0Q$J$Xz=vŎʘ=h;#tya!SgeRvOcWMSkz8{!ΠFϊIPo߽M5Dr@\=v9 { \/*S+VE,:LMCqa;Ua{Dx;sxzt]?'"qw[-r=p8+~헣 oq!FpfmE?`]e$Tޯx(⠝B2~>z?.&څ:.?"=:tU'oˆ`bȥPzqu?\KMnN?yv uJQ+6+>r~䋄WWLRF`u]yyB䞲uWLTKw9Rdm,0oxF~iWBc%8[9kl>d qkAEL-QO}I'Mr\pwZ2ߦ٩C@W ~AYPN-B_GKDJqyJ䄸W$X_ӦђtָP3y8Gݭ칎W/>rFGY8}P6 .ڴ3lѷW"^T\8攠'{|J&TLkjc$737^v_8IRVn;,,ao׻Ko`z3*om,tF0函$Y'pߑ@j5 ^ CUc/wc*ЯOqsOaiY>f؞oB`DPvYUZ#,V w+$/p^ջʇ'abj.Bx P ox:[mA K;`< {gº}~OB5cʁ0iho]Mw.)H<).5K{2E0\<"Yb /c7%Ʈώ8u4ô%Jto11Pdbo@z_{|2v ~E0Dn↡7˓Lܹ8Pn8ɤ>_Ʃ??%)/4 cpuJD+fOv8c;Q_4n+t/G:_Mzhy]4M0\}mf3NzDKaP{w%Ͱ8 &].myA/`q0`@ "a^0ad}Xx}+zoND#)x>Z솹Wx _aDSu /HU`|f/q[F7Q 0&u'&6yI zc=`u9Iǻj[;8* 9 am{ZVd#5~^8I҃^NŘuꈖ?֛ap_Ҍ8Iῴa;DZI=y|d:IL_%'&K rè+y;M/^^CSN/H{}!ӎd}_8q  NHmxIc˵)bs88)gvyN`vk#(=;!K"4pט䷲0׹=JުҶ(]G4q_\ . cR\49L/gV߅Vōz}ۢqLJq'U\:NUj ƻb~o;t+$LoxSpG-&) M5wRX%lZ0^_3 kIi"}Z.>E8dd_eLoaML/L 6^UU c>X[>3j]Ms'LK$-D)efWQٽ߮n/S} 9[L?S+ƠtVlv'թyDJˇ`saKXI.g`ժ*~;<>ӓdvv ,ZP=O,Ҽm;₲lyXq7g(b抨6fMy$- u0j濴D#PI>c^{`tݐ瘛//cpf)0ßdfT^V/+GɽMioQv,v yJ)9{pðt7zq"Ҿa$6jogԑz辞-J8%s#(YH1a{`n5tP.|9;? pp+J,y6R'ԂAc規la<Ť,Jۭ;q<2|?7vx8te̤YABp6R<[]4 -o,Us_1C|z婙8Qq+v~:@)K 4-a?ksF\{iS勍@[`2p?H!d oZM0g_Fi H?i}=TeInH71ɃZ^,DY384!/I2nxTT[s%*%{&UY$SAGq?So\U\zЮ) 30+%]WY#L魠9k.pyio]kՙzh݅wq1afhe90Ϥ}ՆHt"|]쉃8LZdƟmRf%܄#U 'r} *?X&rwf}XƬ+4â<R4u.-v"(01kǂsڱyƦQؿߟ Xn~eڛі`ptKϦ7VpEuWC'ZѾ?r}1f댟e+E;±w2ZY3fp6OZ` 6s64m"}3oL_/ƙ\ ZqykS{;Vix#̵ɔq/&%_r ڷNq>$UȬv:`mnm֙$ӟvntu0-lꏺ&N\rk6lgټ8dl<6iH2*GyxG0}~H;?N1҇unn8Y1괡Dµ_TvOe@EfePC8&{clVS@]iV97}^Cf U9%oO2׍ӂNa@wr?-α{ķc@x5˩C){%"'ǹn.F(%|XKP~<ڄKT\=fw \%8y1-}7},VDmdۏS"CEH=s}/:WdZW piV۩hgtg]^s?i_t1 'ёN d?EX Ɇw[Md*%ԽŅ$Qʖ|x|ƴR K;>493ƁbBXKz-}7GQ6cVx.Adcoz_5rQ8NOa~_/J[jГ_9O(u[`π矌I#/k{]#͞Mk[ߺS$_Ń-`f;=NFETz'uēYqEA "{.)0v4ǓX\nM2ӻ45[h#'|Ya#|6Z$5ˎT{GjIr|*q;+(Qn2mˣ-4\.aoLu~ǎgA8&rg:W@jޗ2]pMW4(m|%W+ CCQA0YGf> $?DsƓ>COg hL-Xu*YYrLIn܁lVz{=-);/,AXiO0$y`h:iI[H|.rAJmE`,~cV]sGLX7} LQ_d͇HeiK iG6c~> oR/R L먄s[B nCíI =lUCuo>ړ>hq#~^I 0bd6UƩ)ߊa*8݃z ٌDFՓ |@=wEWOU<3*oIVv=tqnY!?O>- B^lSY})Ly:S:,j0zW8T ڵq h<X'XCX*;K\+6h=` K金{ ]F-V~Nek݌3;eΰ#m|Acly:)V$G'sгZfba#XL4# au5}>}mq^&3^.oiЇw5ҟTB˥.ԧ!U>sT$Ŕ9 /$4|LMŏky"Mۭwm(yv,@5oo_ {~[BONqVwNl U[>{+TxN@$ԡGP^wXٷ-8{Ы`Y۬{; #]`1|:eGص _{]] B&-[Pꪢv,©[4wbD[ VJJl f^j.?)_miKPhPY.mōMe9B{ $N] !]GqΦ/C8%:Rzޟ0/Xډ̇w3k/* $WrbiY;H1)nza# 3 ql)CP堫'03h ? !O:L[dƔF 왉(q LOoq>u'4 Q騼X,N5NǏc%*V։=~&8dC#w!g.da_Ǡ?qKcդ巒;@7ټiz&MSH}]p\2HڷQju ȸh`ɦ_%Koy./P9pfRȍS&XX6_I2g~vYc{)4dܯC9ݚi LnʌmG8U:}pZ"Lٵn^ wۗwxch_g\z݄2}m^\`* M/q#ƿ$K:;S5܋gU*7n2^r0vjoXaUo7XlϹ_f=d̺;7)qtp݇@{[oJʲ]u<"͵-S2$M^|ǚץ c\Kڦ4N[KBkbT N~5y-C]Tv&C{0T;&7"mT= ݾ~SeO( Uu`}_%5}7vyHQy;(E0q( AOIm9TB =$?3}UԵz$N x:c%438D=834;z nj}*>TcJUxDU 8"wFg gM߄X?swn4g7%M'1$"Qݴ@:\oׄmQnR(aKV$?.dEv3:~ꐲ.K07t^"C"v̹%/epȡ$d~%:F\d +7͠~e0/; \:8vE k4l݊4s ]8/\k4Ү-Nu!;Hw^v.w[^Ȼ*0_jN2v#ct`V(<3COZ"__ĕW\~:IL@o@Jh1|l]W?`R} y ߁A5 D3 Iׂ.vfG0y8>N.t0C`ܶ|4N]2톌\J]|paJ=oX]ggpYFrgJ2h(,w|nl յO ?i]A1L\!z`\{^qetN\petv-a*OzXLW6=SnZ|2d|bjcqB9%)xQ{X::2oo#L'+K?pƠ+NH6 a$y?0H{'y+Od 3SQ1γIa?#qiW17zZ{NZC<Ю@NjIs~S >D3AtKnŸHO p_CpRu ;oY$oS0xd`xJ.Wp{K8鯯n 7.9'o_1\FN?=J23384F2VԢxT ns!^VbD:cYn뛑2 ѓ$(Cʒ~=LｩN/n6@{oѣ fG$ `࿑)4AQ=u-$EDF.5;L0j*^7@CHr:t heNP6YIy!m(vݑ ]'w~B{Q2$tn;MRI.L)on^կOJg 7: zzhĢ cxє^D]%Hg6Ĭ?NPۢ6=#=[!;yEdxy6Z07|I2),$[=Mr}RL!KJnkn}f0t46cp1gέJ?pDμ{HƉOgbQKl E^N6"a:[u ˹^~; KAh/X+ 'miʍ/oH76Qih\P.Fg/+G=1B8Vb; y//݉')NjL0[dNMV!Yv<JcÎaUs? &~d4!%Ϡvp~#P_[ºǭ2X)GV HXjs߀w wr2WQea ݽ8óq_MN>!\+U|Wb(GQ1k_(_J )H;޴aU C;t&+L+u]Œմbh4M?0*ZaC&)ݱ^| {SUAͼ"X8u/ڤ-)WaYT\ކMׯOB o}TSBztmm!~D ɐd򢸩 %1Pc%r$rˊ? ?Fz.{{@%L1 .هCyfP[9҇/z5c3[GgļFI/rkߌ<~nf`mˁX׺8t>N% MWd⻶/;+4*߶FAn^*ttd5l;qI*U﷖ۜ%pI[!q^X=6=+ĉIf =QMaˎ!qˬDŽQ8Us;K~Wtm8꺱5zTci'bD|)n}nWd)C1L6([1\k0ZjoJ A0kW--ZG][bQ\3hZ*(cݛ :N*ms9S+ c+A+5E>;*tnNdHMkXՋ=`uǩO 0X&`f:9iZږfB;K#lM  fj0`մ$t:>I(Z%&?@rHCxTymPZoojǏbW$g[f$L~&ˍ6aR>eȔ:ؕܧ3WַZL@=%O4%[<1{Xv9418 S/GUtݥD N@i* cD ,k!]ĂdPE:8ȈXhB4HI/KA8?cf,Ne9y FYR8ӖkҜ0eZ5Oh gtIj@%x`/&Io84c6{ԽN]c萻w$Νs5mNe$lhG{]wk.`sѻs'7*sooAmWE&[ ®3H3pl!mΡ m75sI~Y/`*pxۚu}FliwFg[Usw%R'XciYxW,]}n`ʟ{!Jii܎8c<ǻ'(L;znn- 36GRpDhM谪lMoM]R%;g"I,~̇km]XnDyWH0EyT #cm`Rc|0,&&^$x,m($X9xt O˪nJ>zԕk!1Quߩ6 Yt3#{H2)Nw>bkyH /ˡo/>B+ͦqE@˧f[> L=c?} q컧qTG{2 gaɷ#YZR:ԫ:׻.l廥 KÒ8ߕ~̚}[fyx2Q`z8T\y)-O[Ŝ.׉ej/H[%} t8l:7i\OP%N  r"\H=2\{g=}wR}>&M&8ZuHFJLc ~{IX&}_ku\4_(6@p; th xjy|mo0[co>u(k R]zs0W{L$.VMa)$Niyc/&zڕ̥y ˻5|wz77 cKtlj5O +`쿔巇9q} kg*;\?e qcS;H}0oF$t~ n fgnh3<0S6ēQᰨW.Eh+daYaiP^9{nUqu)jQUЖ;?fBP"W.Kﶏ.9ƨO6IC Pyc4[0qjDp^ӎW76fitٳ{Mtq] V?I rk҉qH3/x(χux% >.$=+U,[EGJuX [!(_5^RӝƢ<$Q^'q̮yV- (W6LnG#B}Ge[{wgv̋ Gv]&gҡSUi yC ce$Hn3tcRJ2<٣+d.2;a^_Й7NU͐־.\{F)\)Ԡ Ů.=ͻ#9}}lp5͆LZH.< -GaͺH%"z)\hljԆO7[`ߊW 0?/ CZ W6ރV8C9z@B%>`@nڧUkcT49b vzUɏ47A1 h8lۙ;+JP!^酓/ZfL蹉8B[2{P)mG] O;yqehp,i% +@4Xm\cQKo%cg:cGlޛׂo`gU *QlV0=a;0k_ w쒀D~:&NkAuqҪul{ ۶vx*"Y1PS^c]O·6ā,ngwV.U jv3@ufV* 7Ns 3 tm AI7/Wxic,:_}nۊ'X[K ~'ړBbɿ5[%碢5vLH֨¯˵}v5P ޽=u 5/ܠRmЇbZzpiAMٷ_3 hwZP1+J/ģIw_Ogt~׾0YﲝoB4$aj8M:nIo__p[^oRիV:$8r<,Ny[?1{ƻj}@ٖP'X^c`]uPYO:,~bh?MÏ=#ٿwu`8{0UŻw8aec9Ϟh+3nha)ڹG`Y٪7V=aTioKul?`oĪg#vStv38.[W. "HB] ҋS6#X-t|&c'M$;pmK{R̊U”fQi1H?cqs&a1c\W4pVZƣJڰMn 5=o kK4 ÎgZNc&Qm@}m=Ǒ(e@U}I.]]*в e5jLNɳJk4Ώ7acۺ<amPo"+lM"#?ncwφΆV8KD:DW հ rb ?=u]".k?Ʃ\w]w`v?k)8*[&>zW_#EP~BMbJBjoܝZIMXTn;ч[:F e& c*V>|w2V>\R*@K1ѥGDjӯ#V8c|'@<'=e ş [o0%ELf{Mru)n-WO; ǛE]R5Vyr3B#yPҚ{W3J&,ː>xRJx-W 8z7Ry8{D[}mG[Ic2ʻOZf0\E0*.툛 wN$xg$@ｹCn#vMT +~6q",j1%Γ_KϮɀ0I?~_vpCsFqAS_ط H}/&v^yIJ3۪s{ma95gZ9u4tyNi@G3h]1֕=TԷE7ط1^,9ֆ³?5b ^)U;45ָpU?G&aBI%6a&ck Xв з,Np"8.j;-~9 5V4>1/m(:X]8EU/}|kN{ XĶm PڜQX<)rdKU=q>Ad񨎅14d[o=yk/Sc"QP1:-_"*^ [+RHuEJ^(NNONlq˓eC>o Tz%|Z]1ᛱ>=G(*;\PI4P|Hs'(ɟ /e+t2+%<#Z1~g]oW5@RNu;z`҆O熊|iY|\*L ?=]J`5 7^8G`jBͣZ9( l8<2:jH:@r+IJjWb6Tr&8`dZZ{ĭ{w-?+vvzlvq:X/ϼI.{U[-οR?r$H3WIKkF^77޴&z9Y-T-P.`O-kvhFV6F5jM8]&a:oY^$tًb,$p̮{=Ұb[N_-mp׵[1S{86?FcsQ,p`"pgVXUN~ ?k%>6VQqS V_Z-Àa`ΥV~QK?wz9 LDz6wKеJr :߇8VjhKH\;eøY}8z"O YNX긓Ijkf>.^#{O j^J2HL 2< u%8;j uqhA0&MIB4LS03kZR4p]U˝y{sסIY*dzg~q'( ]k^} < E~}0;lS0i఻mնx ©I3W2<):eu8k{A֖zfc?*? Yd,C5e,5v.['Wf |[~ee]h*t}w>wf[H >"R/>SCY").O{_vfXCp&Pi 3:zT06{,1oTyiIf.ۛ25 @{c(H;anuy/$BnT\ B4d_3=ٳ-/ᐅ"ej/M7GqǞWݮ{&z'fqxO cC\S} v7wKtAq۝AʐFPz:ү |l iB>vwUp)&-⋕py/uPw S69b3 lk/p LgаjkV0E^[8V8ۑLF,;\8t9-ƅY`:<V(yl5+(!3TΪ"-eTuh;tW*=ۍ#e#2%F }0Mn\kA?qh}W'a4ٹӻ);jn p v0nR=P0C),`Td #3qڼxNE3U^AkC]k|pI_8AOXYoФc]` i{{[`J-Lp$aU]0q[NO+И8.هMb?thM un$ogF0qV|_O2a7 Z _7W$RN\F XxЄc{\Z.HȾOByTZ.ho_g Ӈw)O2u|xO&; Jn¹rmov >_v^8`}qg9&jf#0N΍׸*lm>iW$>8mLȿuA i|Grs=-CfϑЛ usm%{h U%bsU5.\-9[YԱ4\A^hƟE[Kq+xdbUjܗNNvgVbUyY&؝ѷv] Xب}lBWw*`dGaQd59l9RfynNl=jV}cӗo1\MH= ?7|y&NlñE"vBZ2CjXӡ:f,|/R{&&#j7G)$#k9wqcNsj9RlՌrXWsc.$S~ E٪r`3ο;`j&K]мr[ m{ =tj*&=psvq? +8}nGW!$OmH?ڷ|`꘠&\Nںi[*u7n+p"X^ @gY̵3!Xe8J`à4#<"GL%.G|,^ 3^3F8j2;0lv.ӫbwaS Ҿ=窴If^7qPzguIzۖfEzSNqeh%_(O>c͋JOb람:cxWqleR'/1{ 0oݧ﫨XOe/|D۾KGzg&э"o\P |qiny.Ѣ8T5R7Ilxl*5F:yI1a=J~(J jAUj.l}>Xrjg߅2X|j&A˿af1%^V{N}V(ROr}^ÿ0MrA6Ԁnҝ+ݍi۲4#By -cY+ 0A{vvi|6Ll)Պd18ّ#S/{A0jYu$_dvF0Aey*i-')\iz|WE֝aY?8jct-#RoA߻^i(f'YXA`&7m\ޚD2xW GSiLFӀ;(B>һo\ٜR\<_8~I'ʻO*B+_~^LXֈsWgFQ2;[:~A rG]W)e_ʤnSvs'qRK=UOXiؑA)%@m?(_IZ/L,`%,~*t~>9 fSd٭v&-sFc⯓qQbQ/J`ٹk8}gQzxJu02х«jSHu"lع1kWG(BXVjE%Mgɋ[ڠ cpy;B.܉F{vW=LΎ_ YA< ¥Y{7"MBW*-t r-/wiSЉT2JZ8L/ॴTU-fꎭL&SE'ʪvJZ /٨VްotH8tmoņ$ ̺$_8ݙ?Ae$w[ B'"N08c󕻲[/  N&)GhUu݃@G(` V;Ocz5$(Wfvse)fP`8RKz$5Rp}UUw7EPl0z!D0=u,"YcO%`;[sX2v`26@7nbo;XRxFՇ{ػ<VS-)$cXk{ţ ?]{6| VKﭝc * )foE1-LJd8`dxL$`u d "}vl6qg|n§sBk~-r)5w ^QJǺ`ʅ\fRu]y_$ wN56z`g˦v8c:ftm#zK66КΔ4P3+'4EsOI,$1- L|׭%懌(a5%.Е5F[<էl M'qf?wE? rہu<Pv᫴J&F*=4~3rTj/qxUmuDQfxk6 a/esNJs꾉#aMXּ;jPh2{ˆU|:T*3ɒvlU:֎==(2WQ u%SĐ9SnhΦ#7DG3pp:*|}GlWzpzb2&T)-wY#D~:TV6ZJ*Y'1)C)COoG}7tE4d4D\w`$U8T;ıxB[$>  Y?RIyZ94]fSt5Ygo<0'\ 60(PT^/ٕNR Ml*3aAU|lfҗ?Ԧ?tT`.t[M,~.q˧q~u3eS|’2XO,\lnl1xnlzsy$ŵ̽~rI^sC1Ne9˼{- .0Q{gyx3ڳ`ڲ7XH '_CHM ?a X|p,vI4OdI=yzͮS`˛qQ[r_) M,E^>-XiF&U: b<} +.~|r%).`U}[iMp_99(T˽: /UWUK.2/fp,XxкP*g~&A@vX-erYznn썝)`|T2q!>+v'=}݌E-zsa~MXss Tj6.&؄fML`NAjo'ĽdR_& .x>I}j7즙_n*Y[n/h\Doҧbm]$#[rv ͺn]N$K"8>2s:pZ! eLʭgڜ0o8mnzψ7rGB8;O$+eB8w7QS,6Kֲ`b=2 'k'D<0ޣvo9*sggvi70cWQKg0h_ DRA7 ˺)TB:Dr &><cYiℽ4'x3w`ҧub^zN` ,lJCɽW$6RPR5v^ФÕAWi`ʼ.=Z[Ed]]…߻Kފ{&GzHҰS8E|'X]q/tNC\ڻF 㷾h7ڌ>$C;\`)jjEx{WٟojyfՖ . !3C/4_gkS^o:iV×yv`~M.ך9ٳ{t38w58 ,D h,%9aB:G3Y 6PkcZ3Īep~A'Hq~fHƲ_27~as*~pv]9ڽt5\VzT[r[ ̻[o!DpGYLmB4~qF"d]x|&<>ǾX0"l/H9pZYɘ˭<N{a-8.Z-aٻ_v̵{}xd}"V%pp'XVs}zS9령k"ΥJr{6Tifs&(9z-%yvc̈Cdl? w[~Z0q?W WcūYhPDDZ-Bǡ?Exf34<ޤqSFqkz9TmG!;'3U\A% WgQ˝uN|I#x,enW[Ci!q[vMReCWю=?Qb5[q?,^( Gm,VBKH&w͡UP=v7[ KOM WЮ4}*/ZXT9~Mr= . {hWְHK뭷oNDB%wSӧ! ք4gnR~EPĬW_߮!s"r. )ʃTt\R=rɭl+ޠ"9 ubb7W…bBE-Ċ>,ޝ"333kANꑲbT.֭C XZI]nLRzھOcqq{..qB\'n4f=%;qLK2`y(A9('S /}`0V~&:Utcq{RY.nw[_0eՌI=3gAjݝ=R*{n LW93EB. lpsm ʉsݢدA/ٿ:C8&t¯DГwqn,3CP t47Qnk׿g3+~]1qz:ҟQM4!~K mhg[4(w)p[b')υDK6[\*D^²%؈o=uE#o]ɤ͙ laLaWL сwsv滿`Ku[)DgT)#H ;j=v5)JZlqscU[sB+bwQWPTPq]W<&_|?.6ދ4IMIrMwLӬ:e{]f; 8R"q(N0Z@ꆫϓWlK^Q rլMm! oC=8.Խ0~#{8`<}`(m|We {*_FaCz&4N抳&XEmV=b-g}#QN;v!"ǤozTu9Okh޲a`xw5iȸ9_Il[/BNJBl &sk6- ЩFiቹu WXI<)EbėB#}ˮ3.H3Pܴ1z79H:{~]Z93G.%deF[K*>$r1~x%,茴twq B":aMwcX0L%pR7 `ͧuŚmʶ8TێM47~{,dBGq TvRH.90+UB9gYE~o] $Ή!k"a{сBK8K U@ߍ7cK_H˨6$ K UJr,'7$V]jl | }nF,,tԥӃp&3I.qgKެg RQ7,SoqfNz}f{A|=ҞgĚ]Tj.ӎ$|8Uw4='Ps)Q3Ef}xA]~.Df$7@'ҭk"ͦ((0e 6Ε~ yr(g2:WzS?5n7?ҷXUC3cX'Aqi{$'' kpA|w^ vȪT/< ɭ@~-b:xB,*T$vWtD9VIp0UrZ\eU {E 8k}2VKt_Lnqrᅼ1C&Ecs¯Y&8cYiy-\zbgS _NX8ÿa[ϫ٢?ñIzl܏T}J*$靷 Nʇ ah_sWlQl"j7b/&1o[J_]wpT_ nٻkAOۇ5NEQl+͊O!<&Yc‡;q6e[cJ;7S7g>#u!Όp߾E4 #"Fmd]Nߴ-_5uzv <0y>WYJ2NS⥛l\9>=o Ε,`uUkΘV\1-Q=5=-w ޟ󥛔zllMK"Mv{@5XL}Z. ;|p(KO-~3b0jF~u^SWM%kÒR {[J(8x< 1\& Y#_BЁY$&#ؘdk.lu[\I'vd^wAdf_d LO+g{& 4/2oh÷r׸i-kN͟(1;C_&IߡFu+dU٦}op-K͍JuƁ<*')*&e-5V:=u C>y8"v}o5r@@#_fipۣeCsTMX]Hn]}ܞNbf+Y8|ݔ5rgn>7V:خ_q\:]OWH0rֹ\AF+=;q5X~W籍*`.QCjh8_9#3%gd V+vڵs~-zC3 k-up8ٮ9bA}Ս9sO[}͖*;/k ' v3^c妯aw8ά[FUCXqs%)pA% nQ:L>h}UoEWI>%mQ{ΘSuAsը jV?-N_|,NP/L XlcN@yuۀyS?JYkŗW|5eWH}"ɵnv%(,9-ηr ^` |]2ٸnX]"wڀ?sdi?&co(eaObx(J}W@3r5ϰMN!k3e&CU6o4߀f ru*o(^`7~JwA+'hY;(x\Ԭ 62q`𮀴楪$?gI_@]z#Ik<ڣ* @%-hЉ>({2?NuTS&)Ά`@X腇eSjr2 ͛pOm=h>"vo,cI` y DBkbCdl*}(;/>ĞMǁT/F_h6_ӽK<Uc) ̲2.7 e L~X_+[8QA3ڙdt,27+ʪ$QJk8&o,S?< ssEpM8!K,l`BK!mu+Ll>db7%(F*܆1oG!Qtp{7? ^翇n@ϹݜvTӮ2@Cm2{i[\fm"Fqmr]O#0c= BNw˯OCyv"kqi: HI*I$K7)?|1\8å_e+u=H'e9>s@]G5؟\19NR]"yV+SK0ۭ;r6_׻h,qj?)Cyma|쵑fAP[sO/%8JR׿{4o3^Zҫ 4ůۘ(+rm('zL|ݗ"~v4#ijϓ춗yB=m}cN]󞸰_\g/̯s a~xa>S`\`%Xmez_0u8ĺ`|=::\4tL?G2ɝ{ N5u/XG*q>CAhn,+(6rI`ͺE;0?:*׃vB dghG~3'Łޱ#(,0?Qq["Rj!Efi N7OBƸqar}!;J|ϴ$%p)9>)ə G Y,m 2}߮'CYnPD48A!<}8_ I-*أvʨʭ A\8WVH 1JJh5]`R֍u?^|sL}`ՑT*g>.&*SgpGG$q}d)z?~}S3Xho+N{`b$e󹫫l 6rQؠ-?w!˔9A;U1Hj/s{ a跈KRKvE5_%C5Cm.@2SRd6.L:&=A1C6OٜJtlUDžCI͞F%ͯ} o298M9/mΪEZo"bۥUFBcgQߊh,ԝ?՜ ؕLb]-j[u{ölY:xLAq'#qrc2U༐3HVVf@_:O1$Mǎ_Ϟk˖izCY6T7ܺ_0v+@eѳ[&6FڸǟZR+F? JS4T6%쌀.'w.=ue0.rIcgHGHwoa xi>sbD;䠕oP#c?Ys^|cXK6@<8n+LX᳍8WA[WLϐhk]7 zN U1*+j_o@GhԞZ_uE k^n>* Z$XoE#cL77w08BhEhb(f N,;7RzM@˸ Ӵ2"(7ۗAg"`Qߏk$瑧Ni`Ql庽N{[zuV2bOlOc_ ]|99 ' ~.J74٪]y>~J#W"rʓ\tM'KByIA!Cu 0,ៅ [ 48+qTك~97WCg_˛k ~:s7>`coY00xl,fḳFOQGY8!?C.ɫ3qNuo?R/9bfwSE nK# H>)]tXŭei[Kr&C3-ڍx10tֶmC@X^ގiLi8 O?y \f^7x3 ?'UgZ#q9(S3;86EWRw$XEẅl7_y⼶NKG<̀K,E,7!#\݆ \_t6]pJá}eޫUl+kL=(7kwi8RլgSqCU{Yz_="332z`x$5Ԝú.l-S͸t8&;WWqSx0δAY tƷ=:gzXMu7d\]M͹j{oòEyzF=):TNR&#a{뾷m#yr5V-%)qyL zntǺa* E/xjHf-ÀomԾ8oN6:}y}j|c@RZ]pqS gneZ#5=ӻKgO Nkna>Ŵyۨ@u=V6|Q66n&OV/nh<C;.>BH벯u83is {{Z2V5t*;,e\f(%:§Z؞AGHCBxtd 7x ykcӭjmH+սPC8*xlRtjKD?gl}W@{P8`dzȻ`l*H9ݙnm9ǩ<'=\d0nc1~ `fy!ӕ~i]XK۴Bg!c _ΌsdJFC0GۗqRjТok 'uWn=eO ߠxd`yϙw辉V&XH11Lm);<{S]ZL%-F`P%A(?^[J8{uAg H]?TEzaqy݃0kIVn-aUi#t[.uW/7gƶwq82~pS⩟tV`!bc.J$J|YRd_n8E^ȩ  74?;L%~vGOGܿlCd  Xi7,;I 5}Ø?5IsikDVqtVC+Xm)9]peM̽JSwEr}͟ې=S֋Qֲ /Ev_lҟ>kj¾qA/:tƺr ߃[^~N߁9{4X)oCw$>? V./EDĝF3~ t Lh=c Yknb˒MEmH!-De[.ހ!~ɓ{iG #Pu֯%Sf[)K+'#2KglV'v Y.z^l9 68 v6I؅Բܓ10&hb@å;onZmclW2οI7Rf 8OS\nsXQ g 8y;2Ul#—X`CTBh*zOm䊿K\8T6V^`*7NȞ$6.+yj+F%v@d@[+\ځ0^~ߣ9ܞJo-ݲ¥w(#Ew). ?R~Sb݃y17Hǡ7Qğ]QlOR+k?yOTz 33qг#OnDp*+w5c-%~ !".\Py`]9=;%)!5J!D(vl؍%lJ[{0zn+;'G˯pTu#K#SԘܔ 5"6t9w+9}>mZ,'[[~gV؅~AV0{(O;J8R놪F%%ER8.4a T[_ mkW_ma ?w<4TpD(vEir4VED'Ǝ {´(d<' Ywu<,oٸ֗_ee`Ⱳ\ʅVW&vHvh{ފF>3 C;,E~ys bM[tqǟƜ\<8fBRT <%Bbt܌8AF;RXfz5,;-^aӽui0F6rt!vDnS]DHeSša;w[ϝA"`,|41y2[Xbq/VuN|ŗ6&)X|bfð5AcixX*]8UЅx+}_' ,&u^b{[>Gs$r̼OsV[/@Sv,\?ug=m:(V82>dڱ;h"YgAC/L6\Y+DR_]7&ҡ/EaӢNqm#ʇT]_?ɯ݇IV7,2=bV}"AʹR4:,{o: OU(Ï8>N^ǂH UpnmazH{_92(v6OHäG^:P-[q7 IťF*P{T)i?{ (wCIEx{\Ҙ:z1Ipk]3$듉 n+Ofi;a},.^ZIn{GLl{ǃ.n#2_σ^Һ]$sPQ Cͮ_uEebuC Z`}Iֳ~7 }'?|'kvLCdʻv#2 (:A6'>PV hanJrjlayRI#0NID]Ud2133OH; w{;k(@{wsR'' E, "Svj߄4NwK2ؼPѰ&,^K_R!9'TܨTU gՀlڻ`az}aa)lJ&؏RA>(qR Fq@Y(r`m$VP?:d=f?dKxU*tj韵Ga18q( i{{{].*{:c6O=9`ex^l/;m-1[~uH+m^Zrf^:G)e8Pզ|ϡ%RVV2MJTȅ?88K_5-[HJm&oD6xPcB(SK\1=ˇ/:mǜ~? ZayV}`8q?gQ%o,Wvy6v1š;gqnlgDXӀ6d=/*hhe^$'vnW5\dkq?1Pg:Uڢ. 6ZrU|p61. B´p_y>9hf=BpJg\mFcn`DiB9;آ>7UbYp`|qX@pg-V=_VXiU+[zJhVg3m|5-_(Xl ܸߖXSV#d]Ï`vZ4 :kH^oߕ7fhpw+_?W?3MG0b4~*,89l;X3Z%عf@rK,ɝ}?܆wN]%Y~^ aW|ɚ\!m,;a|&RGWȩΜz]sv0Kӊ5!1 Z߮pdh).s°޳Kq"&}[6ؔtR Vk#=ů"$;qriV-2q.@ 00^&~e&{;36~ ι/)#X'>T!8\ݾ&%yY޸VPv'wwű!`?7BG|/Vh튿?? *N=*YtO^x ==`6k4 g!F+}f*L|o9biC}7aOqZQP8tw5y0.0c %"9_2埝դHjޯ[XV?Zk`,$Jٛot/a⒤u?z46&LFPlO;:}y0ƭsu .Ǵ{lA9@RźΆ-WqD ɮ=є3%qu}3j8H@DjfmV<76Y`G*;9z L~U im\06#;ЉsmǑ6# ` ׿CpcԴ@Mflrt^-:0b\Rh (-j̊Blp6 IJgϗ#3Woݵ_~[{ e\/ZzxTcuO0OG#Ste\ {3XwOo-~&qsmp:-s˼)YrfЧvۭ`yjT}+ݱє-{CAnlY']EWY`pXt߷\+_QYIG1Or=Lsvة uBsCζ\XTBz6;|cB:6s+t邍8]˰dieT9uhhv^a"a_oJ@{+8Z>irkD R`X]F?s^,׏ؖa׏ġ'U3'+- TrU0 _c-\Q9 x55! 2D'6 B%w!vb֧=Pb&!} 4*I%<{r,M6YuIQo0Ϯ0u3v(Kyy/9XLd-gh~gCG3J4ľ R`D[:nb 0V6_Hc;&0JqM.9z&5/;]p+wzkԫVBcᏛ8iwX| `,*T6J^A+0. |܁=Y /T>vw@,4̷\cJD0Qq <0#(CgRDJGgo/x$LɫÖ͛Þ['#B7A)4&Z-}zZFd5ʄ5/@}NWYDu76巓sf槃F-CU<( Nvჴ'c:МG|^!{\-C^0k:ۥ"0b9;HP2n 9'(RT}2|p{/@bW54FlEӿJ4i\*kWXEFA/ ~bg` cWGSaZ%'\|~QVotЇa^׭[;~aK$LveW vbNa{ϧ%Sg]HƙI#~a,^]8l V'0nq2OhRZ9ģAc4GXI ^ $+Nr(]Q ] ؍PR?Vh;,.N|rbDw+,lQf mC T1i3&- 6 j~ߋ}X$JI6V/BvaYܜ8)e v~៥a3#Ll(>EypL7U$܌͉=:ƷcWHe=Kz*Ӭ5{de땃q?sN瘝c~pCV5鴣h!4[ lI̔n,:k ۊs7a9+Ǫl]'{m2zZ(TFl2priSsuξN3J&LcZE0|CS.Ð-&PRj61m,5+Ra:BBRP|r_[,n?z0 <_jb3fr|Sئv̻casekv¬Rbwt$/*ӁZouF?JWBQ7@őhM:M_fl Tqb%hs7PZBYk"?p}q<L>oUH+ s48V= /s.:'PƒT4&?B!Y\e8n9)LcX-p`KI})$~%rGT!Y,^>F_Aq]84x3.n-Wa9)epRvFOq1a ;p(Ezږ'Q;v8#UzJw9j?H]6dxtŦvwuqB>[/vl:zaAAɕⲇjse0@yMS3 ֨8(w[~0LgEדY8ׂi9c_rUйxdJ0_?}76D y'KׇM;֩Mdɩ9d{1ѧ>cۂ]S428jSXdq~A1Po9 r7~9O>&Ao[,H]?О9'AAGN 6?A$G8~<[\ꝱ1pJ >sGz{nzwkZ\~b'7k1 bm/6qvK}! vZgSyihnzϺ(ueCoKB#8腅}z9VnʼnV[MI X+.`#{{⌫9fy{X zK65Wm*q2.iS,:~ v m2)lnՠ h`/~4:HF`Kl8~y@GF[5^=ܕJ6QȵB\{9OCN Hڵ RsŶc>25ߋ{A]"Ig7BiBZMw{~ ̻G@sbZ 8+bЇÜWEYKmRߚęnJ'|+Ԙ|7v@B.ʨ k*c#X- ޵wG%63s+z83@[yToi)WT]Hs'f~ LѐƾCG%&ۯ/RGCOxZ?d~jRPƳWaܣۂBcQٹ|31l]3SɏhbEMQH9t9Hgc> =s*})"b*վ"8%ӌ~GZl}M֥)%W ~}Bq{زCRcQw̨0?b9DRZ~v,!'lgKRǥ[_uE?u+L` Xذ-<#btkW/72.6AqJ[~9@av\>eP>N>7̓򱧊8$w/z"oBZ¹Q¸9iރiJ9鹥w:afr8!(KAч2<:Ki;>q: b }+R>x]NLN$WT;[{e.qB慴\&NgƦw'B`ɜ%.Կ,9 IƓִ97w q v5JɊe+;}BǴid ]zဓV{cl`{ GT4BG7_(N4WDґv;9N~%C*3;$B .F ۿIM 4hLU:O3&ėX@1%0o?db9T)Mz/2{azPꔡAK#N1f-CGU0:,rЍkP_pJo1Qb{qlpNHl6-ސ|n![3*O ;>3/oAsЩ@*rPZ넸ؖc>\D5G-d^QzZQ0lėC7l6.{C'9ziQ1G̢%>~W) &hWM]x_4Yh0J띗{N4k7 ql^zmdԜɸApwŵ4uz r8krQ6'jzQpM@'LK"6 =` bךNC7ݲm>TO>V A0<,U$EP(2Ae'Nt8jyH_'6 t˞붆Yb75~~do ]%v٧&9~=ZmL(?e".A ݛ΅qKlgn2Q1&.~h8r:w6f=U79a`"k cu`كCbkT˕dpJ3ڊdC{Vo\k9 B9O[~WLa[v$*~4bM$>r٧[#] }*>K@. _``n5}#=dK|p]od'I w(Hҭǝ+{Qcodk]8c#M}(NR_żϗlZ;.g JIV|OF˞nf^QojQصpf`|~6>biw%Yny{1%XGmƷ`=M=+~#(Hι,|@1V6A 5I;u+NצiY!0"Xc` t%YNʼn$@ğ4c5iű[ga_#`_i[BOaӿ)64~EgN:5Kٟ= r!~P> @ל<>&*^8(Bv<%ؓLE7UcܠǾWX[8us &-.ޑ#rrv'-Ҭ1w{Yq#JC*XyVmOr|;g!zy[VİhzqVH|W4ڗkL"MM~9Iq-5m` Cem 2ytaW K.X~5?t^ػL^^2X8L#/Y|euZ=ncգnY'8.}KqpiZړTn.%]̹_ UR|$'qtVк OrJ~]`4XV#;_e9Vu+~=@ۿo",pWYDdz,8fnd3qyHr`Y7 c!H+09"K#_~S|Vrp&ց7f82!= _- ;.[#٤ V8XmSEtl# Z/zPhy \?9It]ˇ97,K&85:b"!1l$j~$ӥ/bu@31,/j^+9Te ʇrz+$~ĥ2~y0i7߂ J7霩!m ,p3H$,sBpDsmS*JU| ^kYB̝BpwxX kgwL? =[a2ǩOl8ٗ0diIߏ~~M&X6%iyHV=]ŎSVrr,zE`/ ᣣ^-nO<z nn.I['CG*tC~ Gn Y{VCѡuEqnUȜ=vX<3?cਫ਼KOwK`ϝEw `(}]wpn!.wh#Yq-ꅩi*/aq~W0}lt6wFZևRP,w7[J t^{v2f(NZnO-.asw1,944j>+2i~DpYdz͌'9,2O*u&20s:#ebxlBÜi2^rb&hsuIv6L`T)3#(Ec{oܧ~c~}@_0QvF\8UrS }݅}k|10Wy",' ovGȆ4cե"O "alTdV6o *HĞ#h[ʍdSo$ ru$Yb&oK|JǩXGq: eC`@i.sǁ+C9 zS&*A: w?W1a2o XB\mCm<ͺC_a Mo;qhLr!eD\Ẫ@k) MſŊ +r,N^Tg_2/^Ǟ"F JuyA81Wȥu>{(V-߲g}On/%(|B}Zɱ~'#n[j`Ϟd3Qu 2l6/ιlQObp'WŮ`P~L#yhUgvl%`yG^WQ/UsZs}SxXΤJ@á+ S:b_bi;E8EV[&XM~~׻噤)A^N"xˢHtie@6#;0nFƃ;)nvdeQ~, 6yU0;zcD6@vP۴)^?l~Hi V  G'30SOl7@kҰ ~3y, -սģ_`*Z|[ 6[5-QO\SN|3 #@j#}R'ǿ@m!bYn4;vuK@L~vRF0ņ"֛ýqG5T}TuϯcψGɩVcs%gnZ/J-T}A(hY%$e_ VϮfm̶q g~y^nLocH)Վ RB_^dv`\`U]TGot+Lde~ -UY$ip~<O%-oºY>ޞ78=3aŕayM ˠ,;o Ra gK%\" 4»!-T lڂ yUYggLϞ־k0-wՏcM#gu693lSڼo)6?1ݱ Ko(Xjwn1V]L"^4=XjU |Ld,%w mΏWQ;!ھ/u:zҿph$Ϯ8U?o~ RCXNb3Th.H&(sn<nKڋUtW!P_[|m VJ3oNndV}]n!wZ)6J&-'NQ}c=,$n ׆9EKU(oÉkw `NZ Гd}- Y>`dMw xD &6>_ EN W}I?6&iP gVp8})fibjφGElGH|KT ~? ]}3&p"bUWϖ`62[הJQyYzRjb[W`_2f sg͵lJV w'00wHݷ="Or|v^u90[{t[I*aeiIBX0{~OZɫxyP'DcdJO]Чs\C7Ȑ ؃jV~0Ή^]w.fwj>fqum/k0C=B8Q,|U&eS麩MD8;? 4'V&`]6 mF!0.<:L/}7Zq^϶%YI̍)\)wH1c]stm}5Нbq{ 8`{5PTq8;_|]Z-"IxslZHƗO!XWŞl;Y y- LJb%8H-%t2r>_l;Tٝs0@:nz!>0UGB3pD@wթpR !Oy_N UcW. H$0ژS/ K+w:4%j+}x\8uc ApT\<4_k{Rf$잴ЛYD 1$Ͼ`ǩj)˾q1{ Y9E્f/)8ɹ[è٣R`'oS?a)g{I$&;y8p`by $#KHxu{$ /,vj ?,+5SV&zA_H[LǑ@ޘw1}D};V^淧 I\u$>M`IYPzTM-D#piu3נÀ{+T}7+"ԏcI !Nr0FKٛ|e009>cxΐuwI H?dhag>d{RPK:&~ ]Esb>8-7 PwoӅhJEt!q]\FhM`̢"k'EV IPX!*4r['C`Fc5]GtyEC[#lZe2PܸEN9T*mOn~g2?'N<*/nJIi=B\Y`x!jVvo;cq~OߘBy=1 XL_dNPk$K5; v;oq!{JKAI ׅT>!?ZF=dBNYuc1dOфE#0Q{j?̾w^qs\ʭ$U97EH.+AW)tl0ԩVGe?Gfbׅ 5ﱮdVlui\Fr~8 SGS]ϳRZOSuj,4\ruC2x*MMa߿DX@/u[Lp~[D-L ƚሓL;U?oXf>Vy:hx .N ]TƯLFvgd~g#+ݯ;QXD"F.pS۶࿿5﬐(Hl JRlÎvͼNa9c|l+j1NC6v@ -O*=Y\HfywL&;J5Ʃ2zѨ:i(IfsD_<Ŷ<|a?(T>Uo᪝ؔ2)ֲh7Uo ]!NN^]1}{5񁉯С?(cR*oFgm&Nv\jEn n=g_'*ĉv?R0vXZ8۾o_ÚCO2;CoX_>Ԛ-K H$-*~O}l:S.uH>⭆`=˂9ص'udg>CD6TUq5F7% APw~f'Q{ve tϾh\O\$ ޒO$g5Pn"plhd0!m5ү"+5Ϸhb0(+}b}*y|b7{zlv%J4.:Յ*|UW35f%azT;{C::㭝Fz2CVNgzVC$y$ u`HE)@oO˹83*T;j0Ay*] xp<2; <^XZt6,5U&9r2_-aLR-v~+n|rCp4m*KT|EpM>Os<1ӈ =<ņ3[KR;Ɖ ;`\9rj]r9la[*ba;΀kyIK%l+a\]fLJd:!Qw l0Nxٕ^p,^$E%ZC5ިEl_K/J3g#eGD6@ [ q ^+ ݵ6`ډ#Püݒnuepv|4 r$nP [ 4LeAB$ }7}~yb2z֭5wN7Imz |svZq$l^pJ/{ yT[@AL5w3- oD?)j KDЄtal uiQ`mk_`@b$cǃoHto^5}z $zbgP= U{ECk +Dp5){`;G X[ajcsV (+#92K5/=w=f͸_rkxe~4+Ty%M+7Ҡ?FH dJ2:\kWeĭM60or8̑'h2/.B18'hzvp*?/?i2ť75^: ͱUfHӂ:owXurNsf\J!LRv%t^ĥl>O 烚zeC [m(rqP*,*8|,1n*bdsIӟ'Y}!t3-"=9΢( W;8a썇3\tj3#/OE:=#x }go$뺛',D(Пi;njE%E)$am?sbX#ZN 6cIbsmOpZM gkb{g7|⛉EeqgWA O#9jv°pԹ61"c5b5)dy٧tE NͅQ$]?!Aߵ 6*n{ L82 [ B%_Tr wSpNC\mOz=JKafDz.O y3DMaZDjk9䝴[S c3oܾ{afafdWy?q\_^' &.}TF5rze(^˷Oy^__Gu W.JTTӇS;ޝ}1f0G2GrD0DFDrh, _coCKE(,ep~]g!urF2 ϑ˟9[A);I8’x}9il~v+XCy5y_`#}ۙck0["#^w/ MYf hh2|Iܓ^D2pz1 7vjaKזFq1k.Oo%4O˚%! -..e*:}x։ ,Bs@Op5#~E2dm [W^:? ~Dg&|nEI78a/3}nOMXQ ڵ;nn]m;3 gI(cAط>h}컟3]X~4ֆ9\&aErqiy/A?aEƵ2}r'TDnݰalwaOčᐚ/HzK3Sc%!,d olJؖb`ۏ)Z) {dVz Sj&4 ;Ht s+FX`=*b8<"s0 X8p jJ2v7t!1?VNYĺVޭccLKȸWKZ+o9۹~.gnFq^dvI1Ie6kpHE zb^ԅQgaOّ^]}j ֋}pZL|P:+cp?±bKoY)Kؑ?.A=-jq S{ "|w #?0ecs/uKy|&K`Dgb쩠] ǧHNJ%a@v}tai" |(R9"`Wy}0 +W”%u{.SI!?=5yS>\YY;CˠdRTSk|}sp_SѫhgNT+{ckW٭t ; z8_41߫nNfEmXf}s~c3m? fa\˸EPZK}׶$VHRr΀ތ3mP]p$a^ey7ҚοȐ'woE? D)Uˀܑurnq hʌRW[͂ f? al5[sXcOIeH&6w=;N0=lɪKu;=`םGXpYą/ %we[/,4h9I8tam.,&C%u;Ws^)\徛Z?νW=QGKEWo~3$MeX ymbJ%a.7tˍ899DT gVAv>},T?O[| +ײw|SOCG-? I 0<'uPe{ܿXE7ZS+n#pD[A!Cl3=oƊi4jdz|`ڎ'lxfR|A'4\ָʆ]S;kpݙpأ}tpqpx[Vyv7B`ӹ/{q6C1~YZ˟\;h/&;qLR^ hWؓ0ΞRn~Ptܷm#aAm %'qlWNme\ cK%Ɛjȍ?waI^aPrɦÌ[59c' h-k(t&1]|%k^dN`_- e:lDz~q8%6[\Pl]^7nIc.f ]waR5.W>MEg?"pM~`xq`Qx~] :n242'k6QհK..Lǒ~2."(lg6 ̒UގOdڑ;ϲ&Z.tTldr O VN2۳s= =15CzeebrftSIƞ+ażT1gR!;8p9fdv {TwCM;9Bo$`;@ws:$S!% kڟ>Zb'L{~sD|ZoyXh}hU-nՃ]vnxZ e׾'yW=yPʿCh9)_4:w;p8kbݓF%qI8w]gF͞OK_@ݥ讹 ڇ 'i>`}Q0v8&صA0tp:,>hn\\V f>5wM?uRG|9A5[! ZUsm A=MH7b%)'YH/mUzG3Xx?m8)B#e;Ζ!$`iϑgpAV=`x_(apM}m0t$Yn%?=,`OD͞,}^CmF PԆeݱCdR]3|%A>74;[*Nx #Nٹ|ʯN^aظ7 ߟwփd?q#`nd4,DxEL.ǙN}1 Q8S0K0ȷqӺ:d J{dgknhtb!fysK51\.Ǖ_(9tuNU< aK{pbnSk KvF\l?#5Ir+<=LnʰđMMܟKN,7?㎳ gm'8ͅP*%m*XܵW!G6y1R0zCRVьRo9$SX"Y_=wzO FZ^y5K+W=wwQ9Vu%f rCZ=avajDN~kx GKwDGhWj n"*öP^#PBr8fLB~|[ tUkaPz&)1iyaMx1;Gſ$&ͼ:d\(kK.&.=ܔy+zNt k+GHzw|@U.:?Q"bK WXayC@…t0]j?T5ɌmHos6; 'lG'AK'VX{;dˈ=Vcx Z1h;v؂]<.һ>Jso6 }1շPkVSn0$쫨'jo J?|7qa^'|8E6cV+`yI&L0hoq?RR,~Vo/}Ng+FP{mT'FG;OpUaُI&VsBZ{e8o ;̖kF ffq<=2YJ փ8 m’#"&Ms}$IrD.]LX:q^_9!jiy|ąO=^LmmH4mH u?ɇt0`@.C YYxGkq&ޗ~'K z" I6B Ι?rv9I )ɲ`A{Ww,Dsρ _Sd2rfl-s! YX88+d9An,6dSeu7VoO6L5m->AI<#VÙ7Xa"⌜;+iƎ~Tr607fHE:G<= }:N cC9D)̏h7OBPv>VS#N?髾-!VrjkԓEuKI!*#*U3X,crQ[V n$:M5 J~>{s3TK鷃饿qhs$e%Iasv]GC?Ta2C BC=R(qdu|ہ6.t^o>R Ӳ嗼%z4_TTqb:/iEooaLƖA;F8<1կ3K_ qXvZtj]J *G2{v-gmmwH.1m3"Pu\{#a.'_[67MZ/؈`d^8l׵0ۘg*0c~k-^ܶZ S8<~~X0/L\_{2 _Be.B)e4^@ԗ$zɳ^$y1d_]`m30W0~,;:4(X5 AH'J<*#֨]1,@W}t!;.+{^.# { Cvh}EPR.݈%2̷%>#mM>>4?LX D6BIf}z֍  $޴?#<՛Vy[mAp,f "Fmjx~cXs~V˞]ƟIX_~,8pNQ3]&k3ӟ<'p0B[;wI\<kk^Q6Iu:zZ`lu )_ٷ R8> 򹨏'XjHkE KM Dc #[#'_QwأrdAp 3_ *^.Ni`*~b$n~bP+ceI%6wt>4j:0TZO4<^o)k,6,uR7(gTɓbw! hs-cCFflhc%EϬ)CiHϝWli&_P'%(Nó@M XpbOmC66~RHq`L tK)fPjÏ|+{a`ݲ#qoa̷Bw@^v\ugߒ,x*]}|W%u n'~8Vr_iSK?|+RϏv(ɼa~Uqz7ڝ 7,2~[YЩrS.~賉KrNj #0q`x6d$E07B[af0UTg'~]D5bDSY_g4bY7Zϩd>I_Ŝ܋0^㸕/27.}&;G`e=r`os;oUz E '%T+2UŶ #k#[H֖krZ:Pb&|!ͧ.)E/1 h 6H] X*wU"m-Svk-_CGFlSklRE{ 7VP'^y=Ю (׾%6oY܆PpTE lze @%IYK, +sNCq1R-4\Ci@3ZjQ9L^&`T|yotCյ,+G>uR3gy6>G_TũuAtM0f'N `9 M>B8otkS؝E8NWA@϶pRVł^2Eϭbhzf*.g=/ rAg6<{XB0ZckyW?F$m} f9Yoc8gK־K@;n[([|6zu7*uXuLKbN\.CU܉ޫ}&/p :̘2{6WسLjHҜv&ꗘ_.iPU yal5teMN$nж"ԫjeV8iYvNLдPޙV`z]@rUO=fUE p['<.o9k}0o}dvw? E-#y^X!Sw{^&h̋C~;${omI]Uİ^qxyǽt3ߛеoK1mӌR g+oZaYh%B 瞌 {&SLu }&M7A8$='1;r҉GK"EHV%ϓP`0<:"JpYb3k1996x6%VgBta 0w;#>k.Do cn>=x$Hv6k?WnfPy+J\7}uj[IJ{krtz`+c6׿gfc#u l:|Nֲ9 8y?`}̑.QXyIs|xZ{IkىBd`nWEygdY|^?yySs+[g&5e@3Sy} |m< 6vէ:Puy|[Fi,"rgt9=ß=E ;r g*tXv ŕ3纓`2_䊇"7\MR$V6lwЊ+/F5ּZ g?{83fD`+͕v0`S .ehdQLjOXsyKE+t;w]q_ϰS34=DBkSjBa#O]sDÈ+xX/5*K9BS0W?tәFL=Upo'Θ>dYJ.껬7pD\󖤰=0 ~d]=ﯙi}&]XUXZ~y?Ѭl?sh+## TӴc`sv \&cmYUmL4Qz4*{4aCQ(,s'`e7g@Cw_H֫{ZBu$Yw$kp̄([u}ĐV趫<|[N7~NFT'YB>ym k^ +qа(*(7^AJN0'ArG5-&Cq\.Ӏ=..dǨhll"lw֧H\Ή5H_~xYS/ &qc[ c`p Ո#egriɔx7NH6/;J6aˉW,AeJḬ:W2b1N萆#LMlm^azGm-vټ:Utw2H kvwjrC))WGXE?u?](I@ #wDZK}>f9}2QdI mya }Xr;fQ+w$ٛMqܬ31BhrBaL<>+Z`$DW4 x{1wƪgVt7?' hfSsaI~ur`_O|3$S5;~8y?>]{$<گ 7yd'`ώ4TlapL6AC;;Ma/g $˶o6q@gq[V7(|w&}*5sjBčY{5._Fρ~b35*c&:*Xf0sw\{7C˧ܰP%-]JuV} ~!{N8YUU˰taR=,ea;Bp FLmkUv{ӯ#N7rz?0D;8`/dXr6r̛uI$ =3 ͐`\!4#1M0˪YƊE4gP?f{n>kWG*'XO 9CTql_IpJܓ;TF1MH>n6,0X'(r{{)WF3j5aDɜ=dְc`f;vkgOE:sT{M|*"s?t.UO=)PGP5T:Lgw8#%p4"dx`crQd,ZbLJ-aNZv,j 2a#SH[TR˟/]?K\&0iU ɑGH+jUcmAҫ$~Ypg9G.AdU)lh$؇Gƾ z#<@Ek/M8_g.sn\׭f~0%(ݳvgw=ص! u_ RpE({<. fW\#"Up'mXL*2oz0{ݾM# HjÆ`(lL+%"[9߭Cg/nfk_.]-〩KL<]+kƽie5c䰭SLj]`NޙP0؅~w)|sDV#6#㠃Q=޾>0=/,f}:ۙ!VX4܃c)"{ݻfPu%M1#)~ߑ#6?0'đawp]X4vz=؍E}Gq1bwGƬNjTzlN;r˔>NolSl1CzPiQS#镍HHN˸=qARN^CrMBђbH_2a)*iwXJ%DLkfWq$/{a&5u?}U"zitID\W ,_W-NKdsoXsQ6ź0")^}Db}V>z>t*٬TĞ>啐."?V$ 24 _*$Y/ZjcHwwp:pZv}zt8dB IxS UڣOLMuI_TrzMw=@r a},c+^.uC ߌ4v8 mi۪hLYԓ3H 6]ɲN!Kq~򇂎5y' ֘j:`.rhcRKٿx Qvل3Fk9zݩNl6L::qsbJGrJ6Fz0E k,_ScZߕ˒`a3<<nTя>~t-Z]ԂT %UX_3]s>T U>!B8u:kIho*5qZ=F޽=Cy֛YzJm#}}Q9J/ݫ۸@rg {9*a)NCڇ>-7u7|(A _[yV6T-J kNEڒPf *hx"bEU7:ЌQOZCzQ_:s' bemx+z:BqOhy$4LpӇ~ځsS-9c]ռUN( Bn_7Xz󈌏Zę wgbGm g^w\Rĭuԋ07f0yF\|'pF:gLr{7ȥi+2<{\;j6b ծmG*N=+j0b?CN;k`^2o$:^{W -z;,,= =dzU!!]D^07f^ge, K65+v)u ]w} ROKάr~~3\X@Jw {8cd5_8uyq0 zN'\_ k77ۄÂ5SoFſ)Tu|TVs-~hM+N8Pg":߮<És٧V ;JyJ}sj͆:87W?ݕYPSa/H+ cǩR.<>tgo0rr9ye1] ҈3>!YkzIv.1p_-yuMn2  gXg8%U+?jʕl*_f{k ?8!Wܒ JM$SKs8n%j:]u_0w6m|$4x5UtkVV{7%P/VW2tzMSvB߁>8؞urq!u;YA)}Cxgk3U%Pdgܟ0'wmn{mSqzf^+][tAH~|0>wEҹUn.>髇0y ƠsRYFZa;}{8X ;N^}mޘ}voqikjԦw`gy#E`t^ X47Wz\ /60.vnqZ!rC9vG.1|e#5vlJVc uK硫m/>m\؜bm:'T]wBDa+Ӑ*@$LGltRdi:%Gr[͎=Mz3 zWy@&SÔ dQC0߽>9z9^0Mܟ Lhq7n`Z7;I݉[uNډK8+7AUc+չIJ904ܺr s+DndVc3=ځoOAԊ`|r!籪k%䖶n 9JP`>vI} ੔%$egEnh]fYX`tlyG.w,25% :<ݡRm$wmsT0*VԐZixvs#!HQ0zl8?sѥjk? gm/Gh!mC FxOe}C3j;د]xQ(TorOeuƹ=G- ,Ĭ݁w82Iņr]~8֘jM-L pH#?.<&xZEC꠿G'dslH%9=_O°/a{dh8mY+M6 NL䮇z_{P!w!Rm01d.ӂG}U2 yUL 1ێlGRzܵ8j5]{k ~o{4cS!to98!& :aK(8޳*!xf/0i7`8g|Ȼ{MsOxzqq}{\zmQY֎cJ~[#m:Wb/m$ᢆ ڊ)1Vyx~X N]hcOmm϶X#p& 6Nռ #&!P3έ-U JApyjLz`?[>&ɏEևU~Xt G<*"j Y&cTXV{/d?kb3+S?U9/brN3.Y4}t0Ԧg'{B;tKAYY+#{~@Mr~cS8V,ܼ'JG6DTm=qɹV}ۦc.}<>d #aDZ4/:l6BBQS.s\Qv,Oz*F{4YCߵnt--'&YyBBMzXl`D9E$OuKOZ&p! z^@2hS;R'3Kac_ڻ?@78? Ckeӥ7r67 ̛&_M ʧUOI?^.gQ1ʰl?-;p93bL]1<02GQY͗Y Kٷ''~uexA|X0Rw =BzzԳ9\| ٚ.YyKWqgVI) (.i;}}l/;#>9cUJ8/U[7RQ{͸i3֙*j*ygßB[מ٭kC~,VR/*$~Ԍ!n4J`PؖoU쟘xo* E?V$Gr0UAI'MujCYZݕutWğSIWB]3dKΕ\8=؆Kۆ$@(zGRn'.z-vr5X;%]h˙^W9"z׶#j+~`4mgbcY>qB*բ@c;pr^PL% U~j//Ķt7 <|r`ftZ9(|]r|=B\cѡW(oqI}N,Rψ,Ǝ̐ -۠GK08# XfN1 pT ~ M:q/?tC~h{1* k޿aŹYoK௕~ :[h䤣 @Z=k!۳h[8]"tdaBj'yt0L[zۄ3:?eժ#M{'/M.ɣQ,B6qsw'O~9\m [8'-]Fu>O:G勡+Gw;JLZ×fTa%O$aS3.Z&vjۍ(Gq\30սSqO2 -y]OF&߱|tF'fw4=[z/`\(@d+!_ GV.(:`ymu8]}VW 6/Ƃ*i,)0pEC$RKg)@إݳ z"^ jdn+wKnӹym$Ad]z8aW\%qKU>WsLAzj6 :O]`8~ytm4 H[L3_)kI)e?+4<7=Wo27 hH5c#!6Q[~Bȸ9a "Cd{`` 4,^)}^e79bݷo ^4uӸˆFfLR0aI!10\R[$;wŻpTE7o|rveqvZuL_eUTynnT=cJg֯zBt!@/ߛ`,H m剝λo8(lfj>Щ{Fa]k`4YMAcovƁp88A:UeE<`]UC"I aK'I = ~}PjSc:lшttpIra9_LtT^D xk݋L.G ))\xm=ez^D376CVx~߆Y({vRu\Fz%BtB}*m7J0z\^5P滄=}>vI",lwz 7.)+)sNmP6)NWMpJTo\U%}U sZNo8fp/;$o`+ޘ`-OR0`8^h5O'簻ΊXc) 3FzCЃ-ź`?g^(tyFp絮%0kٙ!?6YC?|P]0LOK\qG؏!Jd S~!qҎz=0έ+3+nBǥSYHϮ01bϘ\6^[7oK+oJ;Jpz?J0(ftTvŁ:,ivQdʛXG;n?jm/X9T]"%C !*3d𻐲Vh+:jOP3] O$VC {ګ7kW&pCxhMl.bdrXG$|:*iw {(*V`d_Ӟf/ak4$b.kT L (:La>+gz@PHM_74 ^KKhj=a YdXA͒FIu(4 |4>pۮ=E@;tԺ?0`yBayzNc4vjwx=\fajݷ2q8]4Ț ݠ*yɗdR]O%({l7z7oet\ qH5>Pq)?=©L:Fmnv>5@#jd_5 7\M0{")AO7_,ABB1'?rz[?(\MMӓL>·=q嵭/bEHbN}B/b[Zͪ'o 7󼡌U>:?wU/&5vz~5Cvv$lhjAF9WE"Ѫj'tv,g\#I}[s'.I4Q[Zj+ 昜0|)e U2ex8b1*+*?^߭:La)?iMqRHEŒׂm#o0eE/[Bwy>Cns7r m ʍls}*G[ҹwKH^AO]nIǃx3k眔ɵӭz<`"ЭAR:]0.ycb~[ӱ8sR-!yixv/M07ѧ&aޔx Ih£+mMi#`_]P&~.^q0؆BǺ߻懱,w܃"kDHV-Ӳtod(zm:;qGQR^g Tk#nc?#?DDn+䄡L]Wq~vEhn]Ì'sד͆T/HkUVbzeC T[V꾧;@OJBql_s~Ac$ż)=5 j>:& ;ٳ<1zbLPsN~\ s&̉MmCXqjVN[0`vI 3,\a˴ǮO(aNh4V*1қaX[E}t}M̗=L$GAOxк$뱱oq`K޸~gZqz;8h2 2<0(\'Wv%<˙>)_]Y8 h}'Z7KT(IkKG't/ZB1Gp_`Ț,Lmq+R2kuoĴ0~RyB;];χ|6Sl oaT^J4PBax" dˡq/,=fܣ93H0o֖Flh9~%"omC&Z h~FՈFpZ_]wvqOP#X[/c C_-nB]D ۭG.0\eO^wblHJ`fxP9V=.Lvu8zaM)7j#~ }|krRdz*M2EyņBq‘ZXOq<7Jc aw(7ay08d)+Jt1(0z'OHVg|̧>-/ϐl?4C5۝ag&7M/rNT hS) Le~eB{n]1s9êE쏏OPrj>i'zPi|r\"I; '2M)޺@};&w`S,xޖf ҩ;_[SIl:Z Wr4hm- 罭oGW[m=GMq!}lhN)痟^ı]Ank0Dq^gy?ZL+58<$ue]> X;pqb'KbUan?|u<Č!ly`KĬc;t8f9=˻xacaqס\aT%3+'B0[kw6^)_7Mnv&+L'YI>m@d9ԼnA mg]5%z>l“`[rv(M*^mEq;խGF*uoT N}Z q9ķs/z…^S덷Tc >AcF#"gֽ%/KhM g{6_an0(ru|eU?ʓ$,287ֻ MEaw[1{X0yܱa*[B2 W 7 OEJGHfEÙ!?I'|ga$6Fn >;M 5}bA0v~Y>)seW/_8:mik-6݀,AwFM:lh%|wvoWfgqƏakD&u"fT4 ZHT<X!69~@K{P>GlD9u!/M@unОd>̺[ob*dvAY"AM:+\+)U Èw0~yv9o5amrA~Rsڒsb;vmF@L/+L/G<wnZ-Z 3,Xeg1D ^9Nt$Y+~bdwV5h75P9DRX$o`CkHOq&~7)%!{ΦENܗ,|4FNv"Sgu NiHv,ʦ>ٷz4z .fW)d,J5Ñď2$sSݭla<L|,G|W f8şՖNJ3U}Nh M}pސ0 [ym>/<h5b!gɢ˔#ĺе2cNuL 1:6G-qԹMb;Sw<^B s_t,;"x`ZP{Oq2+wB' 2r 3v{G|vV"[۪fb?fI _ JYşܣ\PCZZ( wlő,:$ G&6)6sC,z# v+al%ۆı:q@%4&+U05l?M{Z? 'ˠ4;|płcQ}zæ#]lh TKjֲybw:WQ7bKa6O 6y 2z1:!N{53gP+%Z%,yj[bhr뚺q_~@ށUZ #vpBn`.f/djݚ<޻Q1IJ[kr@h%Y6}'|.2׵oil@̗/Y5s]w%pшыmo DZ coG k6V•}lPQadqT9*d$j9؉d;qGȟxpjp0ݳFEp(+q:b9IC߻Z Yxc=iC"Y\M}{{z]#lvtnu\E*Fq*X޴00'O9 aϮS 8I 7.˲%r`abccš+/a? 'U?(Jae_`n| >9׭}}y@ZJ藬jĕ`5xySYT.mV΄$X+k[qGn0Y@EFO`ݵ;R0E!N)+ۧv[&a$O)@c߳ض~` =+Қs|WyMkFen8&k[4V;#NUSB|tX:蛣y(A2㋈{Ϫ:L)r×)@t&@;E*f>A_z+= -S4}"j#Ⱦc *P6,𤋮4Pq`<όSQleRq8|cNP{n|VOb*4tU8o?xةU'~C<0ՙ"iUb'{zgIY_a$!rV sE&޿ o}8`]HTI&}|&. QDяΡzLW,$9RvF|FƂ]@{uY"L3n{^wOE_ z2>vh4"={Z)2 5&6#<AQAH:赫<:?-񣌉_ }TZTU )D`kfoXm#?loR(Jr.B/~Fͭ"&AzyܾsPK`H;]`>?ۄLzy8 K@5k'D?eEɠnW3$l3U L_zw=5]]w#7=RHRrB^Cu'!_~I]YHCk A4 sf{,^pC||}S| ׏~$ ?[Q0n;FWtnT;`>+50WTKbz9=_tSq`>3ks/l<`i˭7;6H0G `Ɩn &Vd[x<CBvSh&op>]ꝡЦ0,<^7,OR꽺CrLgLC וq#SmlXg 2Z5o IQd- T=}#%ElwJaWj%_>llJs p"zfJ2_q`}N3 z$,gXOU\J~N foxfƽ~~xb|k@ۛdM B2(0n i&f\qf*.{9hq~.8{iId.jIV-3 [ڼ%n!](&H~ Ak;'7qhd ?KL-U' qfW΀'Ҷ-Dڱ )ȗj?8NABjP>^[5#9,e.!L[8}(~`0U7L$w@|?;AG\`_z2wo9w.$FEA˅fiotGu U?G}'l3nIP|í럏) mʋRc079B_V}!M[4K-,ů%6 bEk|{'^\li7UW9.#7;) %P'I ;<( 30wOvu쮰Pә̓!O`r}PwiE|g$˭@bvߘ=}}y0{ks<Ӗi#g}? bɺwű}6E(H^\\CpNnI=׵%p#l/vm W<=g;lkXcB$nL9Kiv &vqL/ZIPVnz].tG.m@{d?4Kyi_T#^ǗTؔXN]}/yYةкၸ,nql i}t{aOr'qQyquWm2m 2 M:@jBJ7T"W83%a=,S<8 e=W1ROω|#Y x7#ܽ=qKe/]Wfc@m`*GqջrTq7j0iUĆl|IWiu z A^hHtNu}AyXzTLֻ#ЭR,JT<E+|v)wm!(^Uip|ۍGpEp ~M\ӡ5Ӑm&+y߯S $w|áQ;ZJ0A~}(;,zT%q:;fl8Qc~ʇ+{;cڶ8@7h)RCiE %{D5 6@KYf"Jb t,')Oi;lb σԗaNbetvUSFXA &&Vw@U+RZ R:䙲D)}y42.(f]Q9_U1{Pt4n=ڇtO~L'j`1##k(*@g Сb߼zɁ><¦~ᴚ-32X>r{/0䀟'TǕ6)C7Z%\s2L+ |@!)}SG]}sձI!j6蹻Nu GY.2^r"N4?rE2pC 3[|}t/}fA+]}]UY~"8+mi}D!|jx^aY!m{B. z$Y1ɜ|(H4G+xH6OvH^-W?K~T.,o~Vw%t4Ɖ;+TRn Ǭ \6^7xBr iǟDd|G.h_ _Yÿ̇<`mS.޵˶S%^t#&29jgL ,i߿ Sˑ#^K])X &s$8vxF'"y^kE;K8E[=tY2*qX3hXO]xC'7<[Y u+WT<_^5\7R۵!MҮ5d&- 7:nP%xLWa`yN輠@?y!+☟t蟄U^:h<g6?Xe:0+fب ]ÓmqZwe f{bl`FL|O:z9YƷe'D+BծE, ʸgu1- o%YNYȇ ٿT;=mr L4> kG'zl&)Ic.gO/z00gߕBG(_y~Z0J^K0[ͅW:# *8kNw`J5z GCX{vIxjF+<x jki13=yΕd?1eF Ob}7<'kĖ'܀aSnn P#U6*cT;`/ֱ7z Wd?ۮ^ MmRI*uHϞ(IJ]VteRa$9U ={k.n:7w8Ǐ=IR|+$Q'i!)BR$E$IH{}=~~.~_/8ެ[||OMKrnڊؙS^naX~4pc8ٌdRS @kpDǁ`+n:b[9#W?iUl24oIf9& }^r#۠^V_uxm43:sֈ{@6\=H޸D=RMqg!h>i2?SSxɆc{wCv!n47LJJ8bil sݶ~y+53Mߌz's% a?а4 *ݞ*8q#3U MBR^YzB8,%G%вervJd7V{>Ihח^cF,==wٳfY7|ȋhj #H"R_ıNMW9_lŞVG`VgegPI%z OяXk YFFz]EeERV{Y!goWُCZTC1#~-n:p>$#L\"†N#8g5"qˁm^A}2_f.W4\Ͻfkb:JKVŘ @;~']OLSK%W: .3; X5ڑuG\ KVXI} hyzzaVqeN-/T,],Үd ړ +rAk>B.Q*.4gA*SS4`ٛ4z1X2Ln$X2b\`i3^l*>xx=,Tf2jeoE1=) lF&ZP%={;ϵ;d؆vv]W 2,/4\^[znj"/xuK\dRڮaQ0{PqR;dLfM|p%;zZ׊U~s%S7Ws(8gxl̹]fX ̫sD}HFAU|^ TAv>_XvIdnKqbZr7vǫvK3y6@cУgA8ay5+:X͎S6ռӰ"c enθ{<*-2Q#X]:x`+ 9NGb5b9gүd[1ϋ+/y2, ?=q UrHL T raڥ!5Γȟnрha.Ma<껝TٲO7Cgs]/Ob0ݧ}eu[wErA83_hBǫ8 3N`geh[ o[|If,b+͔(eJ3t\Ǘ-8 ^؋c<(6Yf .ލ)1,M0tM 6<_(+= _ѫ K%n >G?-UsxR7e:?CUwL.5ќFd^!cǠX-򞍚14{`Ť M2ۍW*,q3lR݋s?^ԇZI9:`Z^a-+'qgUt4x|2-6()F`8UfvT f![?ҺkF," E@ZofCqX { ͚ m[LC?hZy7C\Xǒ)PGY#Xby*R8f${yq۸`''Q;.Y?HE䷧9J`I6m -lLDW̦lu6ܱ0+[XaW7nzp}Yը^(ۓ9+vLϼ1h0=~0|C>hL}0|"s qsQWXg\a%BHb w )ѬRSLs8S*0:[jC▘X$`Zf̳%X "t)l@s[ %4_z=Ǭ_!cD.O}\텽׶'şѹ` fgk5z 5?xUa/:a2q!"ݗu(5I|:OόbK)9XM9)@Ohf`6wz)DڍL9PN 9n'IdKod[tò8y, #㚙G=~#JE]5M5ʏqF-f]>9!酓f[ϕ:51Gaaw@Lض!, k7Z󾥸*,Xl[D5ZL7vTs%{\ӐW<;slB߯4a:U|G [3FN2X7}rj~gw@рSx*6=XzӞK.cqLr;WB_+ BvŧlVpdܐj2Po8hÊ]WEQ,GY\BG2pz×AdWžWB8ȹ-\{5?a|YZ5kl;t1qD7I;FAd"vْ̪gMT xjب/u,^ەFrdL[6v0*p~ ΖD)m\984޸!0Su _Zx$7uZ j^8;K42|9#9 R+2qBA*YrƊ .̍ː aGȅ86[~@MQ"N!cc~mw:oc5Y=~~eҚpXL?2 o7"`fotk\0!AŢl򇬸dSynlf Lݞ8 EzD ~&Lq)(\|pQ=&ADW&!mIjDPLÚ7e_r}t/L^^|ׇμ/ FO,#H/bbҲ8i U'`FVƿQ0aiRw;4¾QCb@mi&${)BS Y濊r_58PXQ%4=B[VN~E"!eM/V+ 㘯U9S^lqKf;q՘%Pd~ezԻ~ :{nsM n5YiAA|Ŷo8P,McX`O{IH1N|v ktRV$Y݅z YdAHD7iӭCFP`FGϵHm-SS[0z L}s5/\]m5,J= V90{k+ՈCڞ,q]W ~DE|tq ̔ !Bs]PoUqW@ GiN{[0yN/3vnk!bg?'p(;{rҢw脩ş5 !:02m}z{Xml]5WZzo_G2ocw϶[M9JR36tUR%=47nP_6$8aޙf=욲^w#M &eȭ^CXz2iyMdҡs*cGC,պ0QC}gWmX G$^ØGW;!I~m̺%S &`e9Цi'k!`M; 1$9|Nuia7 U_$UX ]^9-!BH+JٖT#ӎb5:5G1zi2ֽy@Goͱ8%\]͛`g3Yev}%Zɖ4q 7~ࣸͿa4ޥ"V[2<aQn?W/`IYA ?y SGnHǢgP`rt_I[z (E% TYbr\9qrhLA)bm^nc4V({z_ͬs\7mǞ,9)lV`1u11bqʃk絋Y$#P0`yUw,v 5`\_uLJ3v}ք\(;14<5.Ky>*e 7[ QZ}T`,~6rضZ'Wvlk*nI 1ܼf FȳV6z`5݄8Yp `pT5x'5VO~}%`Lå_VF?yb]jP-螋SzwXa`'?OKÂ:KȱU{ L%qbYcs~~:;#4+3O 5[qA`~Z^5Q7bOC͕Ssm Q #UH9϶gA*S|7Ef*~#KPzrGA sDu( _YQ'E@`z+&>сPcp J+_-"-_Sd} }rd,D.2k^" xLw8%GA{>e,]nndt#0dh+? .;u]ƞ5-lO)^y/%E4SX}^U<-Yȸߒ0î+'{7*brH.lNFw%Nnm֌)\qc8@u凧fT5%X]jx X1!H?-cٷ؏ޯNJ+!1{'Ϸ|Iٕ~ϾUQv2(oڼ,,_C(HTTV)if8wOw4Y>t"5I~sj4"8vhC!?>[i_].w*}HCZ7*.]4; GSt1E뛚|vkv(S`՚/0eܥ ,U?WuPCBW v5 dz *}|Pw=Dy3C @)wOf#,xsNj-x$XV~e*V{kwf0j_`隝bo gs4n',~")kгYxHp8gc/sǩji?~w-$A֥=E<!3*cގYI+,}¢ :r)BwޯoC%Bk ɭFAVX;`/ + b vnJw-1d6*KDp1y5L0*L{|Xo>J Rf3Y0Pi_L SOrP ?¨lYf-]^Xb]~*o7t+γ$Aخ #硳7:+Cw1`\ <?ߒ5G%wgUBD0Lfm $~8g4ny{A4#2Ү*'CNA%p.:}f0}(h8L:s19?nx(TL!?2ЇSշ;֋kHп.<?F`W0.Q+d&B5t$_ Zkoj𐿗ahzr:X9X(zvB >|U%I Ö/I0;#fA{r&RV١) V_Ca0(~LS+ 8t-beP*G2s?U- ֹ'g;y;y /?I&ů@m;vl} n0 a[9``g`wXռ@EfG | ]h4Kr@~\3n {:ոkτ6#g V辇ԾuA6seUDuaC t0N 9f̊X7HI'SXuvYb_ N&ۓ›viS,Az̿JBѦXkC8e^}.HJqĿ{ 캭]&iW_ ا(dn0gBfK_p灖c %Bzɨ' O߄5>w|U܋䓓jWQ cJ&MzMf}jSw)_7v9l3W$Xt"sЦԓY~R=k/*ty䞵NǁbZsȈf*~j})ɼ%)0{6;" #Dzhq|]ί;&~YZnK>AĜūi噊aÚ0z+5K+[ɫƧe`9S1ٙ'ߚ#}Y4pn^] ś'c:`;׶6*[:}'ɬs&Wcmu&w:x@sǙ*`(UTt(E02[iKjO%8eokxϺ8bDH_҅q'p!(gHn~];=vmz*RS+ύnƄH[wkɤ3CO Ψ$7H=dG&_=!o鐆\ΗbZX?)'CGKu݊Q_5VeUQlSUoߥzpL=` CTwsyI vl"x.9idQ,<0q4h+t~oх_xi÷!uoՁ7>$^$BЧ.ll-\q- 7pl{m\sI t:ìb/`Ule.\) kSL7Z|Jm$,&{C~$ڛ*^\ ]u¦v $m =ak>MJ`Eh(!#+52bĔq˵_׿DzM0ܷ4RmD-v[60⦵- 5;?AW7N=2*y?c߽ l6 `N rEV:li %n<ᱧ>BkiQO~JEL*:K Z`aRX%1.#y!/GDc~gKX<Ve3~[A߶Ѯ|jGAvY?tXvA$+' eŠ\D!yD =+SQr07H#՚]MeK>0w?dd: \^# fX/9 Pcem4uwϩ,(:|iwץ/#2 ^19Ņ=* ;goi ܯ#C&&@mCfcz<Jdd˷>ާBcdmUvvOZ"\p+|%Ff'-'s=6n1>c_{͌sXߤ,vonuG¶$ w`hh9hҥ*mX ow Che_^PI +PǼ;`d!l_S.bۛNF~>2{\S=G(5T)4wWK&MsR .B6 GHMpyWB'L} 6eU@`~rH=MN1uuVǞN!7U7tXw"m:**HoLpG)K5+\*r!?J3k4WDXc)|&3z{NI]#P O>z--R=#b )542۱צՀ_U˸`F{^Ktm{iM<17kߚQn9eC4c|dSB6Sw!J4Jr^=I*];?]mk_@~K@Y2ҿ3B"eV;GiO$-F#8g{I|HQ';{;?p/so<ډ=8Io)3MNv_ͷ)sMyШ5)y5ٕ="#_rE_BFblW<֋LҾjzVr$(fTk'-&0FÕqxrS|* 39A~ uɟI`Ϛ|[Uvr?J f2tlh/Tl2V_+YD¢ݡmH)|27Y=z:xzkce_@T1&} &e1 "2, [U/Uf$(av03Y(@ MTmxww!edsR\&=0,foyk}`pgl2V>Sad6,Kipf,Ԁ '0{itۂŮ_$WMIr0ƭ'dDqɦImҘf"jc:x(Z3Ө?׌Om`ט: 펂σpv|?vJNADJ^ 2 )\ z q~o ̥CqqOmAd ui8DV jٙ C_ SlaBv~ f;2h`ޕrػ8whhޑv%Dg"_`WpfxΏ ]^{Q庸ţX١\Wn^ ׅkcV*؍{c;awrsg5RZuvbcƶWj\=s`N{mS_comC̻.iJtdS@*k->lKg;{H?IJn{ ݆Tְ[@g^OfiU HTo8VI/Gfɱ!(|eo?,(kBGq9\rq> ;zC&L9%mf3QyA;m BFY1 o5OҦ:eqt@ fY߽8jZoHŠ޿]'pnK͍8kgyMP P7 ga0{~Sg1Mn[0{я352E u /Pq]v1o ljф>ґh K;asy:oڲn.˝+W`.ޔyfi/_C\0`p,I;>=gv_tuUcw;|;2$:! tݰ,Wr8hG|HǪP}Bl;Axo/ +/stUu?=hվ]D&s>Gm fؽuWN 1o[0<{EA@1œ={p1־GI΢$ljy`C1Ɔ ጢ¿_ᯔ6;@$p=w Ad)S?#7 }?VԝÞPv=[wB׾zKy,,cNFڣYJ ?vgTR!5mfM}ISKm?y V)wŗ[G95a'<2gnh}z\CrcL ۷Jǡw5/Fا dY8־{"OCUlԕ~ QRdisG'&`4㥖|f}%$^X{qE1gBMGw\ZM[sak.L_Zy6Y .A΀i8hW,'TBzy6ΎZۢxNja"#BAּs 4CHCZ`ԡ!{es%XئčK/iۏڕno ]wV{ʶ 0p}W3HM {WWzx*%pP^O] VHݘgMNbT(ge;>W-^YDO~CHpJI$f 1Ͽ;{?\ t't"2uLC ƕ0php= \C ˀu c֏dҸsfӅa#߹βǮ9%wO^5@b<^]B^*֝uGzrܶS!;=Cݾ ۤa_J t3e܊]!e"ppK-0e {9)G;hcꆸ%aQs9)잺XB>}} " 'qT x[f&p#L0.,;i?46R09$y0:٪<2} ٱ6+3aBHgqX8l,Z>/V)cǯ!s|{?&s(ɩ6?qp3.OrPEdÓk@׉?c8J?a/0' $snk+6FZem*S*zF\x]%MO|iB+k}lMӷvv: 5Y(PI7A6ە!JFE3K)g.!JFixfn?:/["^[#T,((nn9O7CJdћd5z}ַC굟s[ SBsD:?;#VC)qD9=r&S'CW'ljkaPŎJ>rcK’2}I:r?] *Vא>ʫL .7VM!hD9s=T2 /ם<-ͯ^#+83; 0sҗk0C;;W\[64LE}'~X$ TLlÏRVGXz>2>_7ypTc~e2WR3?sz lS\i8{_ؿX`-2lxBI\b@W!#/RyuGZǮz'2ɼ1H ])X-!+~ sYF@$z/4XzzB\?mV]t5ԎA F8yb]v>\84SO5̐bKtp_V$Cc ߝc0CF&w>S46顳2qf6ee3%8dwhl7I.HʸVz;\ ԮF`̃Wt uA y aMYR[{:0"e*Rվt[`/4Bu8ܸ'`Flav1w0 H$w^g}" z!7vqMސ[^w$a DĒ'nw_[g-%#?k8"`VfDkP>`1/#qg_b[Ⱦvt^{^+Zn%; H1%6%U`6MBem%y_\yk*_]1 }l\/A'kN)Ր=6X1bi5J"yt2AGϕ uZ ӌU$ߕ¡42 6ٻ3Tqa&} uM*8~G$cPW|ֽ 瞗獤f[63O\y|6֯/L֏иr}EX%Tu">˜1O?ͷ!Jz&8LG4iM\ؖ}ڠj}UU#8+we)k`f;mqɤ Ky0қfPխcB_=4 ׍gJ@}u̴Mff| 6>,mH:AV缾Eb0S)&[#QD?d{g~4,y]v:mÉ{Ю:/84쐉9|B* ["tV4 j~992 LǒNMc2?+g9-L3S)JvjreO>k06&K<s60-tFo}qgٱ&5=t_Fϼ/a/qglmΰ?Hv!.נظXJ?FTE6d;Jfa'.Hzיo')gYǜ|Բ܇2}ϋG&0#pNIoBR<E2)א7EZ'`p|cG`] MU9j4Tqy;w?v]cΫ#YYjY8kDq sk3c?߲mrHa2s3Gy0+_vo74ע5I7cE!yȼׄ^I$s8m4 f=L KLEc235KJB.šFCr/nʧ1wڝOuk?뷲\l^b_z Zg }RgP:Li'cSe> NpEΝt7߮+Ri,\zC:yqGσwTz"JY,/8~]kT#=DS ݷ_)k3pRs*왂G}u`sfSmcv_.{K՝3<5R%]]g|\.-Sf4i2PV}4kt۟4z{~m{wBu;^@ףsVZ0Hh/3-"moV𫳔?J( %+U2 u1)OB㍟V'쑈KȆNU0-\֚Q/:嶺>LU3'pʋI0/ Of ؃2vZk:r2,49YcuXE-Wct_/l8fnN&>AVsd;.-awOgQ 6w#T޽Qo $5}Mngޱ~e]El oPd+o/C{+ףu/ڳ8*~ewWis't6) >APs%Ql}\;5X}LI=B̲~[Ȅ΅lSVag*!xVz^n}9tFl0'.AKx|TaI{2y ͮOFFTqq1}Q t tCq 8֕f v'Ck&]þ|0'X1Nq|k_F6´g7s݊GHջBs5WT3Xc('y,lS)ϲ$qα}`ĭ9b#&))?6F3A+5j|i1Fq< 0֓M`Lf54v|gC=0pmr@meyZstF&1 &nVV#娎_悱v)Vb%zW5 ;f$L@1]N hX87 Zړ Km96I&?9VpЃ7Y'iJ׊982`^C5572W~ (ɋErgF472m?%A$ /z8[hog#=CqR6smŜCͷ-{\K6ӝ`Ro,ro[b^LBڞO`L˾1j+~ srsO twɆ^(v5.q{mNikځRFkhu׮k_KVXjSel[ƢLxsK_gS ŵQgvS Qw)،3PG*|mpEȶvZJ{mG+ppY]Ç0=^Mág"/XW]FQӯ~{2ef cz}'\:.%i`F|O.@LX~PJ; {Obɚ-3=UGmIбI;S[ypts0{mY,d cie#mqbυ]řW1aG_b\д/'o$ 8)]dwqnꧮmq{`#.?p򺂾jt.X(jXK}W\:;s,$XGmL5Aon܆R髾k{X [w.byAHgvHsFI[UaǸaZaKR{s+Nʘ+z.0:]1TXe *u '/UC߾^{5B8ZQ5C[&zXkt)S+ c昺2N[S=n+8gOGvbMYfeϕ[زtʙ R{΍ag`yXʾ;$o)a+aB8e؋sؒc4kKEͿv X/L9AdM*oWQ:7C{kL~x4XTM[Mp}Ҋ)(L4Fz' 0_ۭ>xa(ss7zǥC,s fg{N[(8Y*"':g^#m#_Ln@؍0j;ol /D}P%7;%8M␕cw,0TBOǍ@mvkIOrlq`I[f+ f;;ԯm[Ocɍ)X1JlZ];i!0-¿*wߕYL+ "|LOW{p4>4ǁ,MnTextٕ+2h2910'*JM x7mŲWNIEYU?ty:jI Xǧ| q%àtSDOWІW&x5qD.Άs6ovNDS*z3ys00ƲV~q0xqYM}=hŵ69H (՝ĽWľ(g~}5Ƿ{*jo?TmT/ E;iaXX߱՝v2wU 6H!VRk*g[ RD'- ƗX@rU[aHl YO;lfaX%&y>j'wRʏ]: cwWbεwf1WnPgy9D6&k^.[jHœ912F?GDx!9<ݗ nn@Ѯx;$NY}(w\w&9$MGvn1k9|dגNűʡ] 8fgKo`v߶ H;v , dbәd8@喳p N5>r_;4o }z"~7s򝓚B Ix*pteֺx3^hz$f9?+Tzo8-mrٿI>m'&1j93<`Cjɤ1؉ih\'2!]aX6P~^195 kdar p ٦ |# O";i(AgMKΗ}i?>hh8w2%bwWr OXc3X{nOil]sQ;[@3}41ɧ ך0o񢕍8\ S?:pz1{_Y|Lp g6mySG$}ƚ-JainHtQY*G$oܗI1scAO9Mq@.(R=3߾ukL#ln0FUz_&D. 5?U:FN 8N&&ط+Oh{N~y;m~'Ҽ9ỳj}+S`=&e.;>gh6'6O }.R 27S2`~5 Oaùi2랎(pȅø550w9yHlwypHrJEҔY.ÒgoǾbTmF\ Eྻ2|Vf7VPdȬ9Yw #;NQdW˵Pjlb$Iد׳"#J(&g -vW+f$K PbC%\vj^/̞D7o]%`z߃|̱:w1?[q4ۼopZczQ;tm=N y#t^'V.$k%@krab)Yltcw؜ uj?=${C1HG3쿃OH~6͋C3}Pp*5Dr9,%F¸LXf2ɹ5Xnp%'pk6P%B p Z<ˇ j&=E$|?O9^R!Hֳɒ37s Z'1+ )x\hvB{A.%D{e%U}CO앁sA<\Uws>~POhŁO[n|cb0Ǻ 0W&ju|Sf{FyC9lZh|ݿrl5)jvzzշvpΕܑ+,W/aq6{6)6^t.G;mbŏ$!oG8v}ƣȔhf,{sfsVϿdqf4$~v0g=<>KWrH/qԙ`~z]c!jFG2w,(d ,dzBڬTꗑvJmI2(j>:FC\ZF2 2챜Hg0sTiH sx Aަ=ðӣclI{O |]>,#Ew\w%5BsaG|9C)jA<,`*1Kh]2ZrnX@lLU(6}M[׬\ݢ8opaz Iϫ@dضL}]o}As_]x#0IE)gMq0`Uθ}LT~/\"7{븠> O8Yc\/ĩ8px-Vm)(LLjī:@w(MZ\RBB &V.DVdÎjj =tN.1K8xՠZfjX8+hV/lt;Qʡi]w'礱_B߫]Y[{DŽ 指_ obS"vf \J0E ْkr쁞sVٕMeEET' ZBj@", w߄ڃ6:$Qg׭Ci8Q>thi)j`|cF<f%f)΂ܒAQV:,3`>}Pꍆ^\B݅~BW}2?drv-,O"P;-b.Z?[+-$r)W}Y0LQO?ۚmNc'dgq䫫mF4nros*Щﲿ~;iuFY{ȉ8Y+!envU -O PۺrO\F]'4i3ϰ'x Ng߁J7`+C.8/:NxGg]<eHSZ[Ǿ|J^ i/[7L9|,U(~뒡׋75 _jznY%)sIv9KJh'HR ތsό\X\N<@\c8gU7 ~ ]0Il^$ >ˋo;n|X sW;] |B&N}"~6ym~uNȦ:<#Ռ`9RqMCa*Lz7uN:W{dms)8,êP!t"uׇ8Ҥ6/c2\ݓ߃?:?umj z& }N)m$ur,'٩* d2 7Jjg` m#vX`x'6f+tΗkB Y8;͘~%9nܹ̝0΀Vޫ6aGv@_WY`0:(=YF۾]T~=>0y4s]N*$]wv ƕo~*_ZjI`?rjkR7kPnUG-3/K%ҢW& Ъh_᥽dΠ{ ɡ_|W4c3$&м:|^і{ZmT(kk}'_g~ZÞ^B.tuV}%v0׆bz>grNkN c ~&,vPDOao~p\bR&]RsЄƬrb ,Af[REm?faLs>8P'.c;zylƤUOD"Td_ }UDBXyQe缲V@=d>v0y=f[FOS"|>\YW:t(Ci|f·8tu/_Ty76$Gof.K= 8B,A 0R_h<wq׏;B1@5qeY1->/ 7+b|-mN3!FrI:' |) 8\z2@4_Yl٣G>%x,*-|ko^|cND_ Up:hjI$ :im@nQ~.,F`* ]gao_Ϸ0|f f=+ыFo/=B`ai@ɡPGEqYP#3 w w`뿢""ҕi|VpћQ*Za= ^Mcͷ*3}dDžk׺ ቜJP8/S:] `Y*o֕g —8#S@}% \tm&&:ҳwC64v(׃nKwcUZG[̠fS7'JlNg8~){پBM(YZPr O;|% |l텻B7+)09s费BtƝ'[#pHg|3n "32.޺:оt6*" &.CEӽ{¢^|ʮnB@1b>JnG/|5ѽm{Ҁ?_qCNcpQcH+(W 㤳WOy5>|y 5g +B7~5TQOY/DR}8_l.L}<]^MMy`sǨ`(h?[FwRqp}KX[+fw/̢?wyX r=h#0FhFmt+{-ا4?IxSO%>v~{ؗ>>ɯ/D+˅H)o i#7v\qޥm"H}ACpFYBM*-p:î38!Ӊ7^-"Vtzxd5]CG)dhE_;K!gɬׄ>HpHV&'xZ;CTt`N30I/8@euhLtŴOǾU͔:A=^nB#N \e(Kp=XKf;-~77 ma?h}OM:YSŅSoq m2fynjgB_b\tt9=&Ԩl|4, :9٪+a[`EF/1<'rX3qW"PO$PV1cFOVSAHg jQr}"FpF36ߟґEŒt{=CiT C_`ZBMۉ^xRM.}H}hW&yRE9 , v6Bb)QM (@N_eI!:ño5柾&oeغZiTޥߤÉ(scg7礝^ u?k1Grx/ Re|nU?^,U\|8 #dMpNWvߕb%ޕvz uW@Gk!m`$wf石q~Ci(ZUUQ`\ (Gy`=\j:R Nhg{!M.Ck3(VSP36RLd6{x磽j]W]޻sY~悰:c}lǩ1йFABSL Rau'E}|q;le$Hc6.`lߩb|j_D=TL(俳nNq?|joˇ+9!_LYcnJd"oDF˰Lzg&bZ sNīNh~~"R3Э]q~ÙWiͤ}ۡ)m6CO(+KǠ߅y1-:wH,wzܗ=㍑fv2Mzx݊{UtO L讼kGYhZCw5LnbծN lkͮE )6sVR9Jv R.XN=3K l5vK~wvO[?26g8K%o~\H:&0Ӣ# &ܹv~7JpQ#KPɩ,':s:ysDv+2yOh<ʧ*fβJ]NQ)?Dbrv , *;JPwTj4n(!!eѿW%FG3|s]+]K<{~;Q=8Hsy(Ñk|X Mijvȿa L1†М8q#IOU+2BVvt@d,Zdq:b'uы(UIhR']D<N#+{1eA8+rWqoepJ њ}vсR)V-/{rHubh4=sQ,H*.?[*H@vƋ/\3*W:TV6 eK.[cgf7?V=S Y>,x;C)žǦ ?nǙ޺ pV=;D79'3WlhI0Y@R>TbOrtN˞B^ϋ^lX:[kgWNۡk NQ+&0k-!؛1r\;'K7 -7LTHV4Ec-:h# /O,sK`8E=ݨ,މ>ıvVAu[a {]KX{`rӞ8'&dyu;J!ˤj^U1$=j>!Rn;Kb3UPl[kV~"H#ArS;vRt'm/j-Zx?V"X_6s.W ڑA;2y2$;w^/(X˻M5>x)8{aMO?;쁓m$ҰMnwN\MwHHkUovn63 Ã=^PPi!6YZxΌ Mfwą-бj&jGe6 Pb8-^ em5ׄd4 ɜO?Cx{p$Po3<# A CviӫMdy<~6 &3sl ߑcgS}uL ?#1>DWo$QYt]m';Ĕ?OӖV2B Y]?+r˼JSNIrء)]%K.͏a~nzm+uy?ZAJ$n>`DƑҦߎaXԁd/`)Jp޶#BQHp ʊiC NNES,x >*k6 ~XxUmm{ C8S-6Fݜq9QtT>n>RTTHTB%mHV*HH$Tl{:˱y{g|sYdg9دԣthzu`b˷W>3h'.YtmQy>k,nc9k#rYF{"NA-/H\60Cdo1Mlx Cǥ~ۃ@]kbvŞҖ0onM0]㫶&c#҂W<*q^CNX&_o9IBH:0/Г[3`/h2^xa+AƧ[@ЋVof-Cuk iti@|->_)D3~O('o'y͊Ϻ6龳k`1Fݳ#ĺ/i/+/XJx'Ӧ7kq%g0}FǯLjү)ǷU lZК˷ō9[&!B>*trcZ`KИ)`>@`0zkAjŷL($9j>ƆsN3yl Kmpdj>Q{:ddH1g媪6s1}cR8?MI`[n҆4l{a|*B<&a ZH?rЃ- {D¡X$2/Uz+ E(0P H#>Jfa˦pzfD=ٌA7q+{=ʱ5^q̞Ux묓 LlۧV'Dww m!K}0GM@6:Z J⼛Uaz;eNdVQV!LI7yQ ̪]sV8|/ 6w-gq~M}5z)~egsPy U&.8?Ӥ#+Wj[ m73g"mVaPu rt֋ZÈi—FlعaD.P±q{bmG<",g8| PN> ouwZˣuTkrI\)ݹ-#س}EiW?~1:rZk]ܵ^u{6,|t1u5kSkV+B<{ &Z?UF^c4XLq& Kvݗ4wH7N .; n 8K;頳~/|\[-fM-Pۦҙbngr{ G8sYN[ ڭ3Gz$.4`a4壻#_d0iKK`cΫ8S~1}W! ݿ< fç.. YG?$1f [ n\2>Z,[ǐ _UcreY,Sp^ 7z^|Ih u&cS'!d9a\ *>l]b30o&P*)s"Ί 7ЏGrCkrl_oj؝(|[UdUOd3>pY"CCmʎnaxDd0`R% c"'ZAlpuH|[<:e 4ۡO25OzAFH}$f?8(k/'5ov<Z -\$t7ɞ%ݴd;oW៨@eauDCym;b )#E:Z2t5e*~:?g=gwwVS`^DRiw֊t輩sqZ*Iu_7 쾃 XÖdBSf{1!pkINdI.ap=ۯDԱ@K90TJ4j? ĥ詜O5('qmڸr-,p-k_"~pEH`}4wfyU91brp(R֗l]Sg. Af{u"hyBƮfgU/d%0wҀ`Wn~m,-9/Kea͚˖p}Qm`*kl (N>'}ׂ2yC\ȼdSh'46EvOR?M,ap*ƲXd,Hj*͡.4jWD%.ťSUV]dO 7ܸnv8= Wa9Z3Xr}.̈gëYd*$}q%)T9> nyhD )fW_[ -nbӨ&6>N=v-(^c/ sX[8fG"͑ISTv篭kq~ >[όZvp.69<4'#2Ww&$-Nf=K ;rT];|q>tE` &<=p$yégm"6N=~_ǣU/O^^gY&aPk̰dNgVn$Ag%`wj)pVR  T 7GccB $ZE/ּN۩c-_ݰWQcs3 ^յ},"t2˔GǰkQMo0LޅU)J$5[ε,cA90M83`8~%NofSZ&|rjż#d+B:@cwqLFQ? /Wʔ"}Pi*'&O bq{ 8$x$m*g KۅqltȈ~~d nuץN͛n>[̙.,\"Gy]>亮sxCY֝.A9[2~:Lӂ~gEWj>q 鮪ցDZ.|M}xt\Js:kP }Ga^@VBply5 u^4EL e5֎?FCYzkW(,_1=Sd8&LJsa1HcHtH@^kQndaOoDy|7 sz~Mg!~G|z?zpjxdM9:ܖF9e^V$/]؍X%w\ G=!}K\Jk9OfVyׁcͮ7^@}ixV,^r7S*4'Xm>Jx' ӧv6pe^h )m/NV$jF;.6Cado\d׆Sߜ&ׇLOɮ`2qGTIQk%I7la6y4XJ<j|ЋCo=7z]%O9&EU}9`pj>o͇=Peֳj2J`/xs 6mhHߦuSu!n;ߦda!ꡙ5,ܣ/P Xkrb% U5Me]oY'X2N~3-oIs%JqM1Hq &^Ǧ4I´Íd֫n_xYAn0vl_S/Άc3OlR}$޷1$w$NՌ+u=J;\t^YӥPXڢ {RI00f2z9~N 9G0P^ Ҥo jSYp1:y`tOݿVM21v,ف3k4Yq-K˨d4^{?~q꾾W4z+suBFtGpќFuF݉7^gWh7oFS9|K`54`~P]Ըҫt=#ah}SYzuZEk>YJ;”#aH`i~Zכּ% / :;{2Z q| ƾZtF{/e`k Y/<̓};A|g\;rm%|z3DiZ>=`Q߷ K; *gD8eAfެY$X=MiO:_Y@% Fvޝhq?qSw בԠ_P5SFⰬoRwp@^vyriw&PUضp|A@iBEe6Ktc ON!EeM5V_:5C/]>0:*{q#DH `T]Cav/C Vc9ּE;g|ybif= Uk]ɏ{ (Q;?^Ã^+^%7LkF~-GCTp57B! y>8\k  <)CpW%CLW6, {GX+-NPvӁl0GUtI :՘[p2ƲasJȦ65# ]0fәXJMĸ owLzBIBgŝa-4aYd+x37,pጣ%ȤBnjZ˿Hi~Tuaفg0 yM]F܊كFIeܾzE?bȜG% |O1;;S=z`>|OdՀ`u 9pV~' 6e#m[S/[3/ޱ/~3|n )ބ%rDj; H-ߋ 0h:}LWՐ!rSt7' !3v7lcf_ ة1G\lq:~#iR.K\PEƩ!uO1O褊O>3=bܑ!tu!ⶉ7xaFI7R}i<ث Sȳ{a7f+ϸ!9i7oJ1#6M-'>.Uٰ|Q$`^\'fn[#FŐHf]P:*]$ݺ}3>)pmy=F aɴc L7˥}=pF-BS!/܌ۋ1##]njgTȬ Ţ|pD뿶~1C&yd2\u۫c݂Q87Km:*=>rEp75q[=Qa7LO+ka^mc=$SG"nq@![%C5Bf؆0:t'rM"nV?2[oZыoAאǂ|VXý3i=O߃m[.!EN"Xie+C1Q@?徠M _X6>^X%oOm\%¯JW"ywJtU0qF{NHGn}=?CҶ#Xl;&aՉNo8V4܍þknJ;~v6g/'D5~;#<86%B9?nRȤaLI}/% ]Bɤic1ZG>Tudza6qYlwy 89O#cnx^Nlƴ^r.B 2AXCǎjXۡߎLbC2%wXfD{ ~+ oL`0W;vSOJLk7i, 2L:GL($PR ]RTy]~3$ uoř^}ś w\ׁ_ _ϭ7 @ ndi>1l 6*\(* dTOOaԷ0Q~g_(+jAh S 2p|M=~lـZ'KptE{FѬ޺zv5(M123 ůͬޟ7?U!r<p"llRcbXN 7 D50mm_|~@PX~%{덴X.'z$ުCހ.>x]\De#ezT;8c3B{*wM^2'`k:{ $VQsdvo3a#=b0gG.F FZk]"`Göt}4y0>6?,dS-~oQƱѐX&); (To6w%G씸D鄌o<+0=.FV3Ձ%6]j[yJ6+M \υ];k¥N=aK^1H 4h)3[ - NAoLj(׏Kj\\Sc+B[ZԱ=~,4>OiN)Y2C23Q+&52(A0V\}xAFIu K-&Hh**Ӳd)f̕1 su8gaB_eOi,K!s} f%X%؆WœK .z4y|0)vz=E`}8v&rǍW:E1 ͮyUL qX^B_uB& 2XlmlɊ n0U3Eu.|Wiʪk*aC/m(8̓e/>gM1HEq]^(ξ~nj97~R'Y4?T`*Ų%tqPšӂ'fEj`e r񽥹MSGy13z02xsD \XaEo^ f2BXz閚q`ȆMAfJ˿H8xr,E`ử.u˼A*S $![X紽xzVN'`4ϲjw 5=lA$H#rƞ;Q`Y qlj!3 K6!Q{V c o%v5z3Sl̍xFOԲ\b{־i[1F8]eלpbAΧ0@8 %gO^WJw~ ad/l f~o|\|qz@8$dvtʋAMc8.=^~"2CgZ?`P`S|h=[rŶ_dx 6d9S m4 X]3 mZKJ@RQz삃wx2s f)H;M.'-"ɳ֤bBM` -Kޢ{)`[dnHieV]}L5@i}yC}XZb/ޖ/BzwCz#{a2|F}h 4ל(0=I=P &'eC ;yt8̳Uo+:kX\PRGf~'LAh+'kn9`MR`5 威5ߡbcMt5aC\6](#o3!\? ?7#ջw B]ֆOq8j->ZQ)#: .t7δgĺj^E{~26)}$ ~iƆ nCs!|.lzi+;T{{uߘ0q}}EɗOpfN7bgs0`Nw5p@z+3oŇ'}8kڽ_- I8`xйX4iN<ۣPS4/B,!&vO^&y_¦pǚa[j,$"'Y81ѻiuwըw`X O5~qJ˪Gۭ;^u r2}|%.`w0K Xo^ .Q jޏf9aIԕkukޅ2읅0}.`=뻋Cd:OaN?$H\zrrlчk[rLKyjhyO_{-l6 Oc=Ds|{%g!:P@,flFj-GiqGBFk\n'irI=0{9[Ggfźn=Oe6GXƑݿnu-ưc? q%>|/}:$[@ξ# d+ +F-9{Yz ~qR;6<`mCw^굵Qyc_.FHQzcm:סQ-(#sln{kb5ev_yKV 2C;R~7ܾ_V闙ь 8l{y하 .tž7K$O*H[e E_ \xETEpgB>|ȍ?w.t Oƛ1D8.j&"5Fb -^P./+>C gaqDȄ$VMXjizmtUMS6 ݠ|\5Aݘa =;v]uА "v~j>F_nþA(8gD_U:<ìn&nO`ŖFi)* OiHswj -Oa hUc0 iGx`3@ Z]菞$3Hi`zɗ{]pKQh~Ty#uճ)jӹ6C+0 {]mqtHg#]z!q7p[KfM8uB:k>a=gnU˂dm?`ÍdVwCQ 5 @%.e4 MHX?-\Cu.+3"J&5ܱ 'p玳nH?sK?;žNxp80-yi^9alb7_p'8IVxDf%wh$ 0yaU]ry6O{0| Bp'$ݺĀi|O߂J~e^`Dha>| fy#/~6E <0u^?"]33en<_{U ]E+OkOI2}694^\y';=׊kuZl,}};=cth=6~U" NJvrp0LQ=*}O %mPT 0BZ8U[U sҞٳ3/7qnp=;P'qK06>H}z`2U?Tݱj.|dž%qB$]N4e>PsىQ@Z-lו8W`g_H(ڨ)e-IP}~z%!x|!'Sd{O’CdPwOM2vf1 WIC ؒv&N2bI[uDcگ[[oo[*ȷ9qbn,[/C}1,nh$F0/0Ʊi?65ΆMgTF=6btu3ts~+I?^=BEdx D~&?ܽ;Al"Ž42p4%HǵեMJ*}غ̲k82Zl5g"G2/EKލ}âُ/OV̕-gs1zm;pyu%ǡ*N9byTߙ& cJ<8)?}w2SV/}MKznҕ,^7)0B F"7;2`mu8f9"_.'V Y H}7|  71B@ {\xH}68X*d>?| ƴNo,_ ނ٢aEWq%fr6ZXIelTMk:-KI_{wdžwQMmonӘ4xg7dp51oae,Hzv7SѺ#P[\s¬}(WӜZ[kSAJWjXӰZ.h!v` ߕY}R=Gq(QN"۾ܛ9eR.rK4Ghs{&"K5isJUFΊ ,^:|,6=uNs"PZQ)nfM{Q {"AJdҝZFvWR-^lIXiƁ ;XӘlSC1\m(i&b_TLO4. =XA6 k82+D ؾ? dsW׋!u~1ek&lv;?ߗȕA;U^.]wuB$ד8밪.UGʹ6I^%L?[s]?mX9`` wHFJ^h3# /pb7? 8<܇ `v2_f;{Y]C_r6nn1&;%Go2%HwB,T^׺Q~G8kqxh+x ߇هӤ`T( 慦x~=¼ґ<84ײ䧏e[Ca.S*Sj5 gc .~^=c a|X{/{o$ hNbd2m7%@鍦C\0|q`(;rîal[5fzC ve?kڡ+6dYƯDjc Yx?QS>Fށa6pqg0t H{U-@#a|>]_& ˃l失vy)-nTI_++՘ZСp<[`˄IFDCpڵo2 o7J''I@y`R Ny4NL֜IFE.[L6/Z\4 d牵.3mǞʛ\Q\y6r9]2-d€ىdί*]#tK2KfWdf-&6*dy.Fչm-l@=u,M'C]^5W/~M\ =vZBGa1I=*V6LhJ.ґ3.5̙[S&ِJ;8Vazm+l6(Whؑ3^ߟڠ,oU՛SH;QyfkHJuz2*ˏx/EoCA(K-k+BIV76x\GX|zjq˿b@omG0+*N><ҭgkY',YP{IQlo)/,|t]?,/9R3#ҭ./I+{JM.ƫ?C WH5:%Zu8VxC[x_Uyy_5s Fvv(w|pO-pI*)Gϒl; sLjx8Euȡ37pώv\<"O`Sdqd ϯv|qMد~~';T޻N^$A1nUZsZhxn3 q3zC^2x&A ԰FɚE8۷ L󥹷=Hݰ(+!b-%js~(ҔS"UFH"4,{}="~k}o\.ak+3G2ZL͎ \rz_?پs#fnW!ZiL}:\|a@ɹPW [er֥gCɣt}¦r`q~ME-Ejcl)Ix7_cM:=lO y EO.GBOZBJPmyhB(f_Ă4 8pMe,y4zod<%[%V-jӧٯz>-`DYg/RrK۠kN~ yz;?LN-kztQ8KYkkÜS=),Qn1'Ԡn# ]_ΐt\om6T' ̻6 GbLʵ%K3+\nzVI7lꑛ !דOЮ/Nʚgꡓg$":c1c)\q>.+ $|éoC,|BsXngR7Q28$%yS y )Z;zrryf4`n\=D^?˒#"@-JOՎ:#P2PoskA7Q}9%Ύ]#V=kW@ nuk3y6MiŘV撘*倩;!v}%^~JSlK:szb- +}5]s&{8(踻PT &Z)P FusQmW8ZKvɬJh0\ {ҏtk76J9̈́0Uu4eYJ0R\p MY8pW1Q[x3d!$Hwc2< ] /g!3E;~ I:reJV;⌤=X|j~'R.bpŃ}ɍtt߭ORNf8~ɸW pG.nu(пsY/Hݢ %6Abb]'e{R'ߚoI#}U8vɧOPYS(}nmN3͸AlwtyhS"XP38pΝ,o[w\f=WHO-^4dcW\^i2 QXtڐ=x!ʇ'9K>uܑ7'} z&}ɦ.dvGxvBśO,['i%1owaא4|T&)B4U3@]ba6BM[dw]Co!jqΘK跏f]'#!]A?^+bǗ=G1?砺?+M3֘ t`= `Q*gzhߚBuϝԧ0h0Ȯ?;m# ]|c \#2u3f~0fACʣ9'N|@;9:g++m v힭27ON y $pP&vg9v'SI#]4he'n @CYؽ,v=0;[GVs?Dq?ݘ[G9 KNP\;tU_RNJ>4Ș#m|FRޮ'D0Chڪ&?~~ر(OJf۸uJz3XlΏu1yL36@cߎ "3a̔-/#sz}'ṳ8Le@,mK#yM!eOZQ<GL 36H\ 2}iX{o8BmCp's~< ڄ}Mf2n6aޛ-ޭ];idV.-z [& SNQ7z}rU?/.2/ smS2kCg[ Rt`k=[`6eLÂN y*p {SF6&߿c:*ӳ&q@'aTJ.,&ETXDZT˗Ӓ⸾G, ^pzG[2oaKù_͐v\}vۊ.&bw 03-UEktJ$a#@Nh=Dƿb1Ŵvdv9q/҄0˿.T 5έuX5e@'kv;X8p]| m00( =ª,_B)w,9PT$8Vi&eX[W-bqJTŀL=1]bUaZ~ދ\öS3$f7gሚy8=D__^|"[ jbcx)4E2+W!UTa4{N_qɁ5aC Oj\?,C_ j9ӵk9S$GKfqn!ʎ 7^wpf㺧eK:K.Vp_`y#r?܊TUksuLna 9yB၅;{X>e=e51Ko=`? T6?z(&/gf)I3?h|h sZ-8M }Hf= ɤWYp&/_W3;VV 8O#WK4̿ + uU:д)5[iސs5vMoo};i?o*;Tᱼ$L]2zboY?eϑRuq;\'~Տ0GII ")g9HM*O9P5-%p$b?]J{vsj}P3o]{C:4\| =B iކL Xa(\|z\kxڮ}6״'7Q0Ƈi"iI/M/͹%K"-eX` )U T.k>)ktA AN(`{мDĞ>* b׀``5  Bt|&-wb 3cKW؞l d6eVV}dW*qP}r^&-rYv^&־P|OF;InCwY:J\lSeKۜzyQ *yadֳD EEpPIUsZL6sb*oDq/o"+??LOpQAwf RTN\eUS} Cb*v^=3g4)47@z {Qd5ؐN6!{QK"6Qܸ4p}lX78uce"K$l$ XDRIԱz`U@B*Wy,Odo 9CQ,Rj/0X=g/Z|Pq GȠ/~ ZFYmN\{ɃPGF[dx=.I2B@Z?ۙLwlG²OM N w=8D-!wuqcW[fmVpmڞR6!4,l{5OuxE\C{e70@z ,My`ތ325Opl68L}+L& [r%pFq4B ΨI`?'6>_ǵy{1ll_9:ʑ. ?6=d 6Y\Y zּԸ_Tɡޠw;<1XگKK$/@Onz˭Dz, j ~XU4< B 6/h}zbvǦuC^8#!Ɋ M7G@aw1k 0Z}W޿idG_@g9oV,yjB %n˞s'`ZkǓs;Hbe6  gVUm;0i>% 4^:$?hldEޙ{p=fAWr`n̾73*WC匯0'\~Ww?: gXݩO_tpW!m$<.: M&XYYBnf\]>[ 4*w˓K6<넺ZcF&U܊mzQE#VJ>XP !8vfU=Mxgl3X(g.) /'5cWj"0ʜ]9,\z}7SÅԹ~E/ (ݭFE &lqO ; :NN97G)6۬iKxCg=N8쑖 4IQXg.ZaF*CRu:=^n ~71נ/WX?*ҹL\?B? \{qL6{fG<0 =vG iNJ?7abK85j݌7i~Uv3k a}bmz+(? <ߺawJa~(h_*Gʿæ mx_%)ݙӼ#G d+t"[,'|u3pyZ.y=#nYv r" %+H Bș`{~m*wǵvsZ(Ngc'Zӝ b[wVx]o_&L=@黾;v׸]l2_ΪCDm(!X9v<'!>Da8Q=~fQF7u(-iYxK;[<ǘxZ8ʘ`;6v[`>Nwx6{&s biJrEP~neWs$~q[4\@˝Jq;;oaRBdxc/kmq6n}c0l%޹1YogiI?A )oyi X0Oߣ CR]OR۾6`?I~:l+}ڞ;H*G$P]廇_+@{4ppR䅔oC6[FDFyMaְtm5{ѽfz_AC-u) Ł=`Cpm ,$tqE6( wʿ";!#Uzë>sHfnd .X|JvZ8y!2nB| bwsi::7yb WO%Q8XZ ͋)AM2/-÷s+yoN>(BϽym!c{uHez̦ KLjPVR]U!͹9YQp_?_s θhYiIe2bwu[tk, XҶ>wϨmh.=Pccu "z-2kM# y;o%ޤ}Y3>|Xt->-ӅwS:(4q"}?3ɻm6pK@sY}ʅ:&n>]  vͧgj҃=ٲc:0 \+ĚGl V8}Y i*tkO#-l2n W Ka$@l^!%c'mCFaw2Y MV]B?%?N&5=}Np i^%{`aQf"6(dgz҆?3@^{A4dg֫e[jĞ!.O2q4kXGӵy@~Q 8gN+(/`/v*d/K„#^\%w>xbGNλ(-&>PvI=J}twY)hSht':x2PТ~ǒ`/x8 _`b!j49FKH Wc8Jp٣@W~òA:ң/.;r|M=L2KI@h, _Q  ?~]mlWw!UK~ .~3dZرd+avKjb$ *~uAq&{>g\oZ*pFZȷ5csc_HCg[ޢD9HʉWAz_1*_ Oa7ʱู۹՜P '.\}/%&WhD쇵'jaHoR̳+SlN`$慼.VHS"{$)?y mj~_#*6o e ֙+&Š5ojq.׊/˯Zs(3V^C-ݧ ?\ aETR >TI -Ŷ=4Qs(] L#[a8?c2PӅNh((q ا0?~9A*4*,ݽlQÂؕnz59mO]A0NNѤc*wD0mlM+5f&& .aJwI?IrJ"=v:ېdu!gp?o5q?+Lz3)0j$y3zngsd-3&Ws[ bHHnH:gB9b/>l z.puMªWn] ǿOaTҚ0ѥvpuX]t-vh};΋d1ǧPΦ5/k JSrf-./Kϧ)[Z2ϵ6"nk &ˊg.C5me;5|o.*_ L7HMI#8)g-FE2a@8}s־Sʗl&bf;0ۚ:&eebqbTd#/vkUVEH@P+nʒy~ !00n2<ޡF^N;oi%k:8e\Fҍ9`iJ Ϫ۟N=s꫁ǔ "=%7<.̑/ p`-tFlMG6`;u1;0M;q@QA 8)ozm= ¯YFC72|p,NA 0SA$f;ݏT¢<@oX%6eh6KW8|v^;{Ç=#~8pT&w ̖ >sơnHs\o!Ea28c1e=vOQ Ȩ^«)/OqÚg|;`n}&)_VXwⶵg^㤶b%WfwRIe^/DTw=yZln7@S喫Fk1Ӗw @K8,؝[ѩoe\!曉W=ՍM($Lգ_k7äKIþP$*,HcKė/"+O#QeedZ Wƅ֒|t2Dג5i0`-0]I4rln.@)0:ʊsv%XKojƑ'^}SeǚOw/ąGM`a r뇱'_|odWpFjS_akn_̮3D@{5\U~K?nCκO#`a-ٿ~5m'$-IUٵ5wVƏ˽k(ߠ[̘sN䆡%K70[ C]j/qv]W;o>vL0 Qz"{졿!M@ `C+ NX'uC0,zHscأ} p+?~`;q0J-ݩtt&8-G\Oڋ 9m%#k?Y@oDr%&tSqzEQŵ=UFK),0 $H4*5fK^03x>^ciIM+Axw0jVypٺPgN%,{Qta^@NQ۸噾@x{HEuh`9|0}u︨w.^} yp~{o9&~XC9:^j?\&*hVf l@'a/C!tٗÐ:'N/8o7{bԸŏRsIثV Cvytɑǐ Eyvo P:wj`yDa\up\H&Fw|+ɨ [ eXhƃv xsc5(%>$Hy%+@3|6hn(n0癑 )33>QaSUǘ L_l&8x{^ahۂFR _{!!"_&oo:pϝ^|.C?3 7b%S;=07J^/2LY[j!C7X"e'aTgcvGPV7[iгEo5dvSUVb.w-w}i!'Fɬ|¶T,{uM9 x\rf2Z76Yn8qd.[z~!6V8}}CN4>ł\٠ؔp& FCN"OXz Z\:){6C@=kYQeדU"XҙSludVg7aGXwqU,7x.\֛{fla^vMf9o6Tl .xn'g.kU=]sn;)] m?\*&8R &K8} ;{o..'>j@ʷ]8lgoU'4cR@mqW'$=]Y^_!SomTDWM;YTB8v|j*J3\|ǤCZ%ϠD|~'OaT[TM8C{yv_+\:] G閹ߚ]$M=t- EY|`ڙn8\;F3TsVKt[w<Ŧ s=|K-aEfio;W0mM> ;OVƖ$>]ޠ8GǚFZ] >O!i Wdǥopl WL,/3i;P@FJ O 1XO!sҶf]j̾rY+X\r Vm^W/e};/ncndRĵSt2}u$.&b|3oG&[ž+ĸ`x޹)yz ؘ,k Ya۰6(S00%*~&B+v͒*ԡG&]M*?O>q;̱g09rwoU/^=/z_ ?#{^:c~Oײ2L6}i]sGF (_D&yV"il"qНJU DLeQ8nxiAhD(;r6hZF;yTnd¤ER?=˞~8 p mtnSL]f᥂C<.-g#hxD5k;O}cX7"k "6Cvd]I{o뱾Ǜ5~{lC?Gq.@:҈•pv@InSV.~q ٿ̓g{cw=V9xg6oZVn^%cW Ҭ,mpA+p*sj׏(>wN4 el;>|2Āk9H`ךkzԞհ#X~VV6g7Ͽ،ŀ]/L{Ő=ۭ7-WI{#s47wd t^5Uȼ#\O8Y]kq-98FJ"bvݡ !afYԃW\{8s,Xni zƿR#G.Azug{S| g'MÕ{Ͱ"56y1b lsjvWˇƈb\9qi4)?`1$6 )mSW2)q&).2܃~96Djɝ!sksfC\(qhP4G9},زn}YM(;{t3Nn5|UlJcݝ10wㆠ.Xmu|lNH/vy3zEg`.n0l%C0Sn 0:5/n)TWAAun>dS)Iy !ȿ5G?wfs<'_}xBI! ,O 7T΁8+X<~?b3>ٲ5B}'%E7ؓ6)V['6ÛI/x̱ ^!j;68nNa`Oq k@F-bli;7(aoWanK;`lMkߩB&`N*3\299R e  KI\IƇ3&Ѿ{M{wYCN{<җ_D=ysM8rV&wz PG4yg~>VLo ,Ѹv0RtX][R)+] нq맽ys> I#+ΟYj| # HGs'ӯp DXz_ h @Qz`J[bdN77aS?}9n ?a=|O ^'e$9CB!DGu)N6n=~욄f7oX emĠČ!k5 ̭JU_05`4- ؏y)j8/%/ě@=xవFoy_Ŕ?U[[S=?F 1-5kӹ{OEoroر HkY?(nWcA;8Sw0JE''FF2=\Gu-8}zzt7)[@_ڇم#>.É.`\yۿ5@fG껳dA¬,%ZnI@s{|;Ni`/Nm5kZS`d#|`81q@[{ l,|WiNH[@aE0Cj'7bN{S$?N^۝֖BڑuLá0>})DPR -cp5F c!&{lNU"Isl~_}qVZX=—[̧ oRw> D{\RvV =a̘߬*2چB؝CwoƅM4vt`?ųACCs(.\d}⎫ :6+̽' Xމ$f1parUfƧvOV/֍cF&[=*PrGm(ha#% P h{1RoV''?` DrN)._/>? O]'3_3:`љ`E!rɮzRI0z P&f3-l=<{"BM'`&\D8mxM[MºaOC`kE +Ec ^A?b.'VOx?c'{)-iC{Q5>sL ym7KI8ٱ\ _Sq܆)/8-K[O(<%yn΄bߦ)F6x3`zn VBqpשq470|_H$>_wmƶ$̪ܒ% |'KIB8ɾNjZ>IKxB8t>V&_mV]pIΝ^R5; }Ex-d:87 B7rPE@#w&)+qݧ:=ЮHK`u8ˆ?9']8}O% p[x6|%ۆ nI3',qQ|eh%}X }ۖ>/AR = )R [_o.m_KHeS<+;.BH8k6Ҁ'o0bf5dȪV5ƏY*;nC$X:=n0^ކ|A|~cTĄd^aHQQ`{]kSu'efmFolqT w}7\cYj[!I|=!*ʐԕ1z;>Å;5LKarCWdziZyHR?m]^2zgi'|c%SM+g 䑺2vGƼ%lo-r㽦:8zi 8qW GD:tZ$jGUMu!L3( iڏ|Uq%bүmKj[_Βm$>(T2ܙ|yK> ,L2Њ) v[dt 3;a&b.;:E2orxaS̗b;\Iٱ]0 ZnM~SqC[vbEP5^X ݾ}[w]nJ\q9F1ъӁ葌&蚾drEap 9K wBu[0nYh3q>| 0pb~/V>ZfR~O>ML\LNG3!FuӀ [=e[?\1Y~] GD< VӖNgjH\ ~LpI~?hl< 'pQJhc[ VAj koD2~K0sT%n4~[;B }˶XV|8P~n|XqV=ݐ%s1$v%ZoFOW3w J8vݮAda_x؋~IXUO\|ZJ18:]cJЉ{%KcrEt_]'aÕޟ>%Oq"E^X;=R,7U寛ev@"E_svS/ ޖâXYÆ̾HzI 5Il9'ê TwC_賶#)V<ѓXs7|>%ojni;hc?3߮t/S{8aD%]ֳ FrݠsN>Jih_ ͥt{81o::=P]Wh8m(TIAd[X7Zz) 00߄|KYvt=y,w~C_CHtpےlm.4נ?m jέ,3Smh:n#kO #='ݟ,D^vm&PٖН+$%׌[دe ե ;Q<Ɖ3ߧ-zac8fV:ޙdH}4woӐ.Eω3"Tr?0\Lݮ^El+x>=9ĵ̼ +*7c;Ǡ\aBfe- >U SVڪ0 UF=5Xaiӈ5_^C ~a|Ofgx=&.y=8Rjg\%އ(ܔL]>o^#]FHKFI=("]zTEDVz0 6M”b@4vs B^}ʪИ9`'mg/Q$@qK&Н4͒ی3n=7i,Bo_ 9[wLhmOz1V  L eDf}}{M%xY`ڇiI)g=~G$N]Vq,>:7$`(%3i*1!kԒz^_ nߎ+w%(㖽WӍ@ VǤ31J f7p (r:1{qSu&OdZ@߱ı{O=NBAI_{ݧd-}0з;Lz__ 5H3+¬F6md:eBXߵFdD.jQ+:Vs6cgzPn)_OM|'/#sJA}:Auf g=5zBupBWz"/`)&.Zf#G!脼V+ȹœo۸Xb9$ կnӁٓ@fTX@9%2쮵ޭNLHp8i? V/w1 :4>-`+<j5U|nd܂ʱ@ڟ!KX~Q8SR.on~n#UsW5ΜRtlNz?%;x luC'0{$ҸoKCqb<]ɓΈfH{˳+ԱKl>Xʋt`pS2673fJ~F:gB* ajkgqԸu,[moOb|/O}IA'xp'z PoEɾueq/vv,;ɸV 7kՋw0wW@m\:W^Ñؒ2в_(םO>g?09KJ[]|a+K9.w:׀\ &U xÑݛ6XiRz: Z?YâY.c#4JOγN,E{H ?1kN >IcCaNd-?"'%;8e:Jb?_R8/{[K _u(P ]_6LX,;p!8 kŔ_7a[gqn:j)$7b\ XlVu_Nݜ cqnϘ=Cծ9x;H7> 1y^?Ŀr {n쿀Yo- \tˈ=/@ۗ=.` H1{[l^$Aɘā?HKP8.gfZ31Iná"8z f(f aj &%'lH]+d= 4_M9RNWԖ:5ͤ01&z0&9{99)qc3\:LW0aBǢcd ߚb?-i5,v=EH;Cw %"{-L\x SvYޢ3>ah̙%<p?#^*kV /dؠI}./zT ,(ɄBkHyx+m\^zr$/}ՇzsU`#Bj kIXe{r);ڵna@^D3qݲTHSLbwM1GKh%QR6rm8&lc Ab U : l]q7[&LѰI;ns{8h/Bg{4cV#XܱiWQDD~ ,@{t(O!R/<2W"m O<n479H -& Wm'8@,&({hf8moVv $8 7h+\qHR軖e`=%Ds;d՛߷.5m+'~t6"ݯ ;w󟆚 Zq<5? ;+>%(L@]K (Ce ]-#λV8C߭dyi,7[y%csEpmP̓z(zf[y .>?\<5)Gd+wlqfy)8|,HgpCǙ ĚIilӖ0=.)ValHEVtѮBXtXK>v_iv '/($;+!InObR=+ m yK8?-wb[GU4ϲƙ&-pn˘"ڇvaOe׍`2qϋn7Y+-H踲㠢@I0A2:`֧;_xs_˜8DstG+Lv 2WΈjN5^=l=lCտ_"އ#C+f6lgʴHan&]3/hr Xll_E\|9FüIbp_JQ8x^-! 22.W|%9y2e, &Mɰ.38k߷o`é ({->;^;% )_h dVQ8 3z%ɼ zn~vO`̲J=Op]i3P3f4>ycC- @G-kX6aGrpWhH>WvAdI7zgߑ7 n_!3y } #+cҧ\G/aU0V;O:fY;P)S 3r)]@-M}Sp$j̕,YRI>IKyoUt-`,VX?dCP"ҪMF_{MuU ζ QH;$RSڈm/o)#P ?iIk; G9q䍘;;`P]XCiS_N{t ojakРTYf^=۱M~߯nf9יƇy B#Ȏ-zW$ټ+WSneZ|x=al $Z bo8a8C5%]qٴyR?4J}"g+d8gVX[VpGHK2RozWhemZ3~HgTMOM ]NШsMnm?N:?]0ms70>ك \Z`QA> plR/'q~(ǦMv1 u[7[33A3CC2 nC>:Xn*#GV=l }%r9"a*nQ6cɐTVh޿j`O7OZox)G%o~g3X3?,v)b.X'l(gfƣ0cU#c9JJ!φkdrTdg\Wհ7X ͖v< $담׃PqsSk2'?:₆oΔ͓Y`kTy? dDRq.wܡ0-TrǽK9_Oom#7.XOx.7bݛ R8&0u ?V)s2c6kyJ+\9{?}yXذ#b(8WWEG}2٘ Jz|Px/X8إxY9oEl=lxJDf0r͑hǎT0xl }_MfͫDb3'R%0SǒvےrO?% EqnأMldd(,N} ΅&@q^p?xd^ll7:6Bmv{]cw2.v{A0hg'K1vq ef\vZ̞aʫ?|*@=,W a8,d A0f c |5ob 6}c~i+3}{ 2$(u,T\5G\q}Ʊw΅s|L<)Ŏ`z#vHy}ސagfy2Ǭi(#Kq\_zuhYK8rvz)hw>ߒ /Pr6Ӊ+*²PQiO,8 #=Ü[ A?FomG)vk3[XmPuJ,$[Ltп 0`хO )03)?2q~ ՅòDJnkrtN?*6!:c/rF~_-[:)|ܝ}yL, óPstX%ɬK麐ʘ3'n#].ՈYoNM^g=|kshk+P2c^F΂^\tmrn*\r 9qGG#6fUV~s$` ]Bk"(93U_ XBкAD#R'elzŽ{j N6ޡ6e>6RyNkfnjiϚq憠KYh.K|X{S^;xJƄpy%\6{!oD"Ÿǖw۽ 8qaUtg@=;<>Ӛ9DĖy7Aw1|kqĜ`xwxVrOIAϪ"d3s߷ucO럻۲]Xiir*kY=傈ﶞ$'jҫ&k%oT,p7cFb lG17Mtrch>nz65k\FfZ6\n,$nl4{*xņ/JחVL/Cob:ϕ6j遵cVEvKy>7OHA|dwƐ8)jI\o2lųl[S[5[Պqͺ<影\QHzI {[[O7vu.yg|g[>FŴ3,R%lNvoK0m$=$ nZ6MB vw ߩ*;9X_RDc'msÐ {W _T[zZ>/4)4T07H3lzMfr:QCn5եEe%^{0'[ZKlpKk_;k/DyG xh^ f3eFMhW| OIab p tt0]ܾq%~Te{L6%\>IACp$ufOȆeL=÷ /"q!w%H,ڀƴ"3KE ]U}at^gFkBG1M;ʓX .Ԝw7ЧP\8$ k뜘qe!=B=<8L=/*(hsuZm]di6PS sG##l@X+b{]zds7KAu˼\ :+aX>" G+gX4 Ֆ+_cD*ʧk0cY8ɸ ;2qߛ X|9l:h( ‘wzhRb Ӆ~p뗙_␁ZiqeSrygӄ&pք(5BWhS}6$'YI**qQuqƂtޙ~0T:U<u*F2$@̷M:|VY,\?yK:vLAu*&([G 7떉ЭS~*Dղ]UC"!H:6P>0.~^1ýj+œ]@_M»'k]iu12NӉ'@+L;|V̨iOMR6ϿF3 v(iKpc'Hzur&{1]{[Xv8Ɣ7!k88.K!6Gۼ* $]kf^`$,{l7-d벨ߢ*s^?vdu"ϯ oƿW.\oO& Y1Ή>GNqM\#n-'cn7R`.hHui1ڒf]Q`H3'~V4S߲^=U;hA(; JufiL)+ vD&h|6ɇ kbF;Kzc+6/c[;c٣|uH.*,?Of_rݫ _`E,DʤlOzmԓ6*W8#ISqۋ N 9 ӛupsV%OaΓsdWQzR.vnnk:u=jaRɦĶM<<hBd0tbw9GDnxn'H.J=IF0,mSsjt3X@d6~}c>&Nnpgͫ6l쏈{k#M`ág#wLnBN?,a&!|v $,Ώ}rW~0,q%˒bSGjOTngWO0V5{ĵHTzxĈN1th>էHO%6Zzݩf^}AK6A,qwvG<|jzZCrbUgrYIx֩ʼ<[L`YZf=~%o]1yUz^t\=_Bw^dǜ'+_`hhÍwU'=e 2cqϗ|m쪙LJQg>vZ'ÙW@mQדpWXjdC?uv\{{S4W<ݷPy!LЕoUmLscTM^ѧG/m2ms ח />m)y/͗]TE{w&q"'OY.H$4?a׎m EK|v=tKz*:AH>}3%]:?, r{]SIᛷOLͽJ{qHQK|8DX} i{\U6 H~ 7|=yt˗S-kiZrr5Â71u! ( DwF9ns9ߛ^t"/mg =!h=VbxOnOsQHX-ð>5_.pRkNooT, $UW *UEndž|moߦ 0Uedm};$pޥc|pP@ᓆm\%Iv8.Nj\/8?J3{y=5SK0td<R2]f ֧zװ+t3GF8j~cN޲zt4bXfr~'E[Iر52dzIkX4U(sRHSz'hH4@Qhu>zHD}l1ꇅ:يn:.:E:N] q!醇@!?cyC?L6,W' z.֘?zg8]J3xZJȦicҵ[,djm52ER]EΟ7z|bW&mȠl acsiPo JJCl2DpXggm\zĂ̈́VjCRֻk 8qoi}0v+Y6f >^LIdcKq.xq;[\DJnv!*%XY]ƕ9>_HY89YLJZؤkVk #5aRRpWNS7ѫzBм^x;.xvG,6Ìbn]Qu\>Ú^A{%| _ g* 2׳r1<Ҍ)vsR;B:i8A㋫jF&Z,ޗ$HV5,R?P$\9Kf ?wa^m/(˜^00){>{͏tSKCw87mȤo ѳ~TS>zIOx.#>5 qT:(z:.GmJ韝d27ԫ3jlNPSS#hGwYrX]ϸ|GE܍oygN18B35LZZf!cwEMapJO@աuS"SCQ@6i%p i# {ߋ2߅{/aa44Ꭰkyb81[p]W=X1J\yϪ{vG!A0=Fۍ aJ"@O{&}MYU#ۨ=@ f5= Ot'r@7,f kEbޔJCA0‹9&feG)γ8XPhxR G-*qǞUkSnaBXRW }JZO_mT39e'\k6~T)tg[|ʤ#npŘ$'7®/qQQPDh.5\Ѕ:C0PZ^_|vT'b>3*Ws3qtPY0kק.T~ ye#_ RSw_{z#uݫ} Q"ngxҴev6ii"N [όؕwCF)V zDz} hB =W{BR3E[]qGp=+I0F,gtsxGH`Z+D~S`*Vzw)Иy>26>&",ϖqbmW Jo?r#Nm)!<9HLC&B\&'2a#пdar._O2) ZJ'O8ʣ9wS.ep"ÍU0z) 9FNepyTXSa%/v$%uA]~ mzS Vҷ?l5>!g:͞d@0%)YŸftLlQ3# x}&VtO29|%0y(Oh%~(KcGÐ)O MB4[!7aɷ7 7x"8LGq,ũԔG=/}A -2c t,@aڏЫL76<A;`iip]"7 3S~&1'O` NV*;gzFON<sۙ;tk-2Kgd>tuX$2gt%ռa >鲀0!%Q$"?$$E݊CP-B&Ny@bo}I {J+©k0)pVy/lz,VmۅigMl֓W08d)TkjDT,7 JVPڱFQq%Q)Yȫ[p4r*~>s(Wo"߰.GSP-U}^T' AQzB{ոrc}"⤸~ |,+>DzH:qNmq1ָ*Ԅ`'P@d[җSJЕ.{v&kaɾ%h9k6?~ounY )J صǸ ̧>H07﨤zɿ:کUt%ͷ!JW+||{^P| # t[Nm̭Ғ.~B84#jW;in~+8c,=s^e}™h1KR;X#/SkB^.NրKCA$ѣ~-]t_!-tH*D"bH;o4XbE]D_9H1G9q%ii1Y<43qeX0=z2qIɯ4oS8]4g#jkkob\?urvV۹o#Tڍ G`:oHpBqO7N|܍gy~=_˱˘~^Z&ԌL MUe`Xe8(._,#qd J-|,$Hݽvժ.aW +kIOC aHSV.`J<4+M'X>̕oÀz26_'=s ҅ SmPc+Vp/X> 7F0L! 92hOZ/k b|d۫} i넍LQ4Ǒțf=5YA"Q2 yHzQ;"U㴐 Hkj"3Z%vԾik#/f˅UP w?̻#-I}_qAַAd^L:e-J'EUkSLKVqͻwӤr ޲[l.3aIG<(1#8v)ƚ:,읗jbG:%=&N!OWZy]gJ*AEdoVUI%O V^;YѻtEyxs`}cWGٿ]GՀr¬[~7}*6_56гSa;c4% |Xxb-GbLz&kH9tU,yi0sE/:a7d[rҗB߶b \9" :nir3a&?Hs 'ޭW@ǃߗqP3OlaR}Yg& \ ${^^s󞪽Y8/uUWY_*Cn\.=-Xz.Nw:?迫EBKk冚7<k-b8hp<>s+LF8\#)ɑ8Wh3<(bn$C.8̣]h%$tz¬J >jD"xS> 8|+RvGߨ1㮃dJy̓d[F1zW#UoiGIpփ]93 3utx vJqFU,crtiCnv4ȶo+q7y}e[~ %ŚUH9 |o 7Srدiy- _n,<'XvXaK[83z5*&sAaN=4*;rB5F;vop@ږ̬a2擌p3E]t4BqeVH~ʺ[GG;d?zs}kɯ:'㐶m8r4)zWh0]IBQBowhDc U(2GV4$ݼ,38CogGu:JwZ7U/c)Cázo<\{PAs+k9v˨XNfoӍzTc! ˤK'Dr?attLigrJ!8ߞX,&U&3_To Qc2c;f,sku%qBد?_4]0$C򣖁)O0"q uքFS}Jks6RtOak#X;US"%l1U q\? 7]<9;/MjB+AooC׈0鼣;h%ut)e{2DaZBNJW/\ث1CI` -޸j)I0x9R'm\5CbRƞ`+}T"`lD.4HkjE>E~4uaW*_iP0;96񄇗 ~bɵ8˽o/WdCЗ#i r4jkƟ'ރ $XݟQji pG89ttg '3[@ǪB8/~urULd?;\Z&t'Zy蛏ӈv*c:&F&I_xԩ+nTA5y1uvoaIkPk.X h!{'dsg9jealHw6Ρ+».s+ďg6γ݌}$z W}^fWSGM}ĦBxlLg9|L2mw!uM,!ed枽~@/{ FjU>;)\M=Y@܋'Z2Ssl滝ߖ.L'w!v/8gy8}TP.ο4?{st58]A Fh"AJaTSEyo;Jd+"pw0^[^Kzgp`x著;p&wg )δK/b;pf>Y)9ޞt3mUO.W2C9#a^&1>f)nMY/l%{"pK{r"vFjH{~` \1KGV*tUAϟ8J6ArKs2wah܅x@ޓ&K&Y*.BϳrRar 2=p ܼo3A7si?c%N/SSXʸw1Lj8s ƭ"]9u#icy1/\ӵ vTnj܁nN8s}j'e?͋gG+r(]<¸ B?El!U7v>\_^ `5nsP{;I!B gb)r2}>i/׭1﹛Zִw @%fFth\\a?),6ps7WܹF0-?MP\tlǦOm} U}qf+ D>% _-LI+Ԑ"1Hbn|Dqػ]aiD=I D5{73׊!8U J1<>80)Cו5\\AӦ:avG^Tĕ_da]{ v@M+0^`1oJ:=^,ݳĠv0nv&;W>T6dsbsݓ[?6A",a\wKg촒qPOHG D8SßcQNŇ{$X-nTUD߯<8}EML .sjoqNǤP(ӲXG~^GRTᠣT6f Iތ ^kX7ʑ"* cMa^71gl=IL3 jևbHي3AWq1b0L|,<>yAFKcTX$ㅂzۨ`tx$T Li7K8@UA:3u*,j27Kc,ڟ`!Y ~wGt._"Ӛx>Q0m\S7ibZLSnOWCs+t8VE%qۧN}ڦsT&UPLo7k-M0Ⲵ,~ungd4-O쿅g qpykڝ,0\iKBq:LiO|}X+&* E#q,h*tѭB\νLf !5 Ty宇 @[^n E_lQu2SQ^ M6^$薝|PÑnq$D2nO-)Xq7en4_14O&ж4DE5n!Ν*|.,6qcr0]҈L/<_RZE PwSҶV9˿O0Hb)մOP cw/,uq0{ VvY #cb>u= :8XX_t8_ѕ6Ozԋ5ycӺXG+ `uҫ]ƝyW>֕ -W`ϟu.v[+~72ARD@l 6~?|$GG-G|6(pw/uoŔ& lSVu(\}p^6[;7ϣ!PXZX~3_˻C?[EZg3!( +gujӬ=طՐʖEszMY\ A-i26^ J8#6rpz֫ep̗@]}K2s8NNiO:2b|*s{8$vpaKHn#= 49]w\@@o(:!4A[7_0͛?@ t:6FKcy) W#8\|^=3{AG;{s^'ӵJ)-`[&ۢpk+zq7~ Y?~^hljG!d;_}t~ Eˋ,8< UI2grx͞]0;ZYw^g 9nXbؕn o.9K _h'&ÁøPF8N1)hyJ17]o']aJ'PMH sU% Kj6Z6,zŗ_:hCga>+L?%j6֭ӴեvVi16z\x^)@8)RkyإIP9 Bo1aبo*xDFp;v3QWxo90q:oכ}B>?:a{#i(;hRX0HJcmE>p'W'nj>W43rCk r`[1.~L m^Q${_q*,jWBG~J \x"Mm`1(>/xf`+*MfV_M ;b#i֍Z*U#}&530wxJkz}s# 8^xAҚȤ0Im=Xz^4L/ޭ7`yF;"=c_ zRM< qcY1["Hc?߆#_WJcwhvh+ ,߃ϋsK$3vvl9,[K3+ Иyl2>$g8m!?nZ gϨ􁚚V YΞ{z:dtrqS;tH^|CO@W7ofN&$qȶ(hıEqI5<|fF'R"}bx{S1ͺ]59s"pLGJ+cHjlZ90ߗ 8\/N:~K!,3O8q3cFvNZ#3 j*WW~9Zϑ8|`nɚ ^:_Jok)–`xEyV\~ndug,дy #|Ҷý-x؆OزUM9TZh٫=l0v/8)v=a*1*ϮI%`,*u_x&O#Ceev2L;8ଵ)L-|AЍtoUݕ4lhvq{{e%2]USrTh۪G#=k]oq_L'|zo$Yᶤ/@k=OޜCXӇsO;2`C}U5\4yRqFi,X jtFG+> RcƋ=JG(R,te%lYͩ8f=rkk\ԲRyo$mu?ܛ;{e Ғ_pi *n"3ʰ [x=dmrFft͚4ߡ܃eMuxǞPP-}ݎ !<Ќ=OquctW9L%gӛCIH' 3gpі^qnxkLg*.s,.Fb̾Pޮ4S%x z%\܇},6[걞L; Lh>)4"EJ۝-jiI3rgM8vnQ\?4SH8Xe{ԧ8on357DYꏽx[eD49'Fo|F%<7_SsKv̟ >n{7Rힳ?1Gya3+7qwTXᅴE>qK);c.ͯòh4/nަ)G}(TErM8Lm 2usލ8Yt)Ϋ=aۃGY3Bcv}6g"KJo/mUܣ[W.TMq3{p3ҏ`ϟBwppVK{dyцzoܒFp=fâ;G-IWƹSJ9aݽw@%YK.T^^K3)Gpk Xe/WkGmeFFO7s9x/H\ʼngaBry-qNY\Td-# K|ū-A_⧃NmwFUlz(w#ND$`:ϔF%?(7 ]Elas)\FE dK(2 hSfX" '4A7QUſ(Gfrg +ë`v7w''+ n6 YcI-/ӹf 3 OdViw>> |av>4ʊd@k饫![OdEn)c|Cpip,ʃc+jaiWXo@FcvZns8aYy|0@ 9}2PR)> _9sOXՍ-tƞ:!9Σr&j#g =;%ZEgsVF?qf3y2^EüB;ظ3X&|3lc ub%ad!ZZp/c.r_e->]Q@;_f!Azlϛ̄"o}8fO_N|",ϏnƑ.]XW6lZqf6 \F*|+; ̧]!CB7r0tPur'p&*M_&YÅZtǫ[j) 8'G#+ ti'=ROUaFL[=Zpǩn T);ݣF…)-0tڬ9!bt!#a;O0Xۓ 4aDj?1?Z͋߭,%ͭf^ ΧšmC|jwCE֛b$-`q r G|{!jg1ׂ~;/:{nQaCz]z8,o vƧ# H0yݭ't3 ;>%ⰸ]iYL=zqhCxL ,58;U DTt9۱=x(@r~0R"NJ#I'`1n]EQ{fdK]&3`.?$( Gc빯CY&0$Y^qO?%dًrm|q08#pjKj8ǣ).dkaA1̴BKzU抭|a{lA:"ljXQ/nIĒ{C?qP8> knpL^n dújd9%'Xqf[g-,$p(LY+iWSߑ0#O %%3\u2 =/$Iyn@w+WlvR.g4 v+Ž%o2߹=jx^b]fҖ _vF5fFY)rViÚй馚 _q.$oU|"}x#p))l铢Ǒ&Q[R^\(b,U~e6"}ȩyb C {bB8a3.Z)2 _+58xr-xCZ \}9wƴܗL`hj +o xmJ鍛d̷/BпNR/h|t6ի"da2@mR+73hcžD-@Oxp(?,r=\aw$nkV:B Aڭ'i#׫$!-;w`=VW1O$'^;c'UBL7uLsB2ˋ̃Xv[=t(p)gςD;}Λq]n uw=c63RB?9 VnwH+/!ߐƅ;`=Ij^*1XӪ!]kqY# &tOB_6,<_ogOŨex0FM+qMV*y&%Nr͛o~06N[:/[/j^jfNګN`[2qELD;dM ΃}0KԕVbS(˹dYpgrq#HΦ5ez!q2(x}wB.`j_,lg_=v_t!҆$g6@# 7. $!˘U;Ѝ,U5{*:_ljz @`>ƘE5`5ٝY_^k-6{{v/N}Yˬ|7 .Yܰ^ {T#a/ ,\ԁ_!^߽~tky+ q;|N'V8,=igajpi]V#G:ֹW}Jܾ7 ( Ka5HzOUEk6rX?ӧ]?p2oc)OXw.޻s`%E.݇ӻB] 3Ku N#n2 y].Э8,փ&7}A@_ںʊ\=Wzk[^8wڢ=i#gj|jmlWNa2ApA|V6ckbY_](m&|>S8q_Λhm9v}sSp}j U1bVO纵{z3_|MVB~^8f^'gTo yuwea]=C5xB*Ӻwn`V /ȋ fl "#8Bz=՘{M&'EkwiysϹ!5󬚎9֕Ei7soq~pt|ƹ9>Kkx%6`| Ӛbm9ؑge$NP`a<Hl5s'aTNu;m6C9Xؗ- C^Bމ2vB֣cXװ\ހW%CamՁḴRrӰ JQ9#},oAg8TNF1KvSfhruSdÎT `쏰Ng:M,_usV,iUP(-&?;BbpC:̩0Cln8q}` MڼT&FG\7.@dAwΦ˝]t=n.U|űG­UXzsdn9LM5kOqǹ,lxZ:qnmǺ^cƮlhDF0gN\=t&#pTR ib2KHӰj$H7LJZCډJ{ m`) tl(tMR66ј wׇa\X@z`ph"ùBM`B~yʅ +`~ΰC[[*twz՚qe0Y)0-" >Ls_E}̡f{0;Z1LR 7Zb3=#J I.^c&8\>r4+^s{߳dL}#]P#v }V8Tz3>5Vb} I*yj;M׎6O2s*K 0x4o ̥3Scj]avg{%Nɇ֭L~KX! tfpi\hd<65 ?G#3uM;8K Ky_쬻qZI)$8Ml^|E1\cbcJj%-TƨEzG M`cXzc> J̇HΦIǶMϑzIS)oZq0>AV݌{;a~hQg\̈"n$&w^u'i2fP'H&Wp}Ő'6wGRRed'PIR$iIZB**BPI}z_~tgx!uN OҸKlw,K*  ?P^R۰ATEum׵ mVu SJ2$rqb_Iw6]\.>RX渶拵:Ώy=?QOzO%rd(IS6g{׿0ߑtg=TSɤ{ `Q)OF=ܘ/壟>Zlܨ5,t30_69 .cQ1~+42";2;۽۫oAO Ln%K"<"ytJz%D1>"Wj"] Y-D\oٸɳ¬YQ3~T v x[=6K%JGŽLjVS)m-0s-fY1h mV.3PH@e,`j|<#z޽ ׬!\wq z\H06ÑJ2mwgY RK*U 6'#0fKqX+9=#3uD˚XQ22LRWh{ Mf|rN9<w^˨_yY‚fu-<߲r;gH@N1fgڢU N:f6C `Ö΢ܰ0D\{#s-`l%5nl)V ޾S)V]JЦphimL#HɛS`yM0ٴ՘`?gێ|R~nW~i| <ZSK_a\OAK<,/xC{ſNW tvqAʥ@-*;N&U=mj ܪ&|s2Q;D-MVSaMZN(m953YP V{AO(}ݽ)ˢI_`c)N٥RA~Mh^kl{yGMLes~7"Q='dX@o~WDAhs^&koY"9/I% \׃OMN_GҚU8?wʺ)+:]9} _MZ﫱I{sX4:nW9[NI02'ꚪXo))7t^(k *V@a`?0!WMOWKIz5kJPN ~*MFI<{Lm2'>) {%РJywt(38Jt{ڇ⿷XW {$^NЛ%/T)٠o%D/4=S'3ig_I}u}^񴽙 \vY4Of#RO }[~؃_1ؕ<K~tKlh2,1qm0~gZ X>=dAƩ8t"\z>ߓXS*uĕ(iTE1/vwX*ןWZ V˙V0=YJ ax&t%4f#xį}EhC +}{J8[W>cZÎF5n`_MWU|?a'odoh X ERvg?5n.{ܯ"r=+L%C߿ +S7/iX3wD؉dWeSE1G|! o0?{oI8㷳DG=*bJĐ}0*p9 2ܲ9ŖOn}* $)A]EGL?!>G趪oy"\`[uM$_*Yn,c33{cN!t{d7c|n8pkFJ$;\]"sGI>`Ǯ']*`.wlQXe'3b>Iqٽ~ؙ2Pqq>P/2*+LtPgLFOixJŨkWZ W2=iW<έ_Z668{l ւ6 GnJB|]jU3%X21-s}<ĎzE@츾#W~kLE)0O<,ZÐbVMSdaŅ\tuxTvc(~uXMy. VtpU6X>{%AwQVf/t[1X]ye;L:yyA|/1#:7jnBe^5 ':n%f?{PV1W zXcC8VC&$o2ڢP3L?t`b3\ӂ%mSzZ=/j-gMOqF\ K}oDԣNt#ͽ8vK,4 M5Ēnmq^aJl2N}]vQO fAXss\{zOh2`XVf;dg]d#!IO`ErYbh6*DUjpZ$|.i6ݺ )!ىMFĖӇl 4-y\9++Tԝ1ݢ;u.Tg=D8(ʹ}W+q:eszVFso>RwR@,! +c9M$ǡowŒmB8CO"3hk-!OowJGLy#t"̗x6Z.G'Hg^tB<\zG?3u_qjK^5 Ig$_ii?2鋑9Їojb-o(ݻSyԟ{ %y#+H z,3m2GTlvUضu?|RX)Kd|41ާXLͿ,D¾f{_B %nPn5Sw|`|܏`x>kFSD%eP~1\SRiX%d 'j0Sԉ a2d^b[ QYk8rښ5v |8)E"{E^B?gh>*4ڐK<_Rxɗɹ_0=/X2-O8|y29 JPx]}М=թ$NC0.A"I~H+2Dr^ekVx, CCt9j{le؎?2O^JNjÀ}{&@t`#.c N\ rFUIC̺s>nZԳRUu+A[j4s4#4IU o+cc×p*+KO„i%}*< ;k?snl|R͛mشfPv*<` nfϥa98王^HbV;YWua^r#?MWž;nOwzs2xcfn;R\ٱ!=T[3uy}R|.!WD-Ľ-/>Y w2ף9`+~(AZw0UE_f_|[~#ŸsXXʭytʒRe?δ7Iqتc v zGG14J8?@r7֦HsZsE|%}iMS_?~#oZ: = dJmn|.J- J\?L6W0=jGfqǑJߪ5?6d.q6#zb˜㭫"`D~nSVѝX7~~R@TJg4#>0 co`!9Ѧp4+8@2%pK}$fOt-X@j"3?*%%p =IןsJ;lIXһi 3dÀYYkVYlú\T{\ q=wecPd< MˋÜpgܩ W.uàiA NRoAqh>3#=nW3J} qaϡHǽ r>+>8ӝKOe`F0)=-+xpm)J9cWO,t=:ެX3'RBLG:W߭o-w0`EK B>%ksGq%;J;gz$3pF8_*vڿR y6.Ȗzdf ;=.{|`tSWs^Ղx]иg!ȱSWăj&L?!!m0KvFZ 9Kḱg%.Xn2dzcۃ~n*De]ݰWSO]1OCՎc×ae`Lʥ$r"Tد 60N?f|yG,[p]ChÕE7zP6$ "c~>|Kƞ귴6kx@T=ɰhwq:Fe? &]籹`(w`!7;j zҹS sʗ<<왟6'paaBBwr}Ґ;Uei+/`:X=z"v-򞚫fvQ.P?4꘮ 6YO>BE؉' [Y:(O岩Z1#Vad,{V:i!jSHzy.δ a}{u+C b gԢgx":l%Þ~,ΛǡzIi _}aKa?pXN΢Ʊ (_!X~n0|֞P#`;l)zLrN#٣JZO`y[ƀ LhA `iw1g0yKv8N >~_å&2MNfмE6y2:[qM6o+P/4 cQ?0Djj ׃dE`ґ2TYwXRU8QsfN]b˳LT?GR /i V 3~jYz(T [;XD7 /_\o$+vh}.z54Akc.+U,IօqmVΗ\t8a툼w(L9 `6VP{d".#vWɭ$u1 -/^ӎ;:N+LJű j$}p.if8G!{T#[bpݎM@);ɖ#K§Hh;TfL ׵@ª~a ĥ?-^~ AJ|SNBXwz1=yg;kY&[_H$dZ|K)&cB'[N՝Sp2nf쏛y&t=`Lx( Aof$|V_3dw4(|[ގ7fZ"G`]tT?Wu-.:>/ږ:yw6Wqn`=1PE^[JX3:6-ƊL54JzOD=}~q\ٚI8xo;H $W/L ƤX;H}52tc'̡;Q_ YӽO{SgKn(Y~ J?GRj]x?͈&¾#e춷pRZʷat;9/A %/a)vƅ;0՚x Ym#Ф8MmT\Iy T3]%nM{{s;T%${v:0ܧ$>Iozp%N3kX­ww2;߹qf.ޏB-;!#۷3r?ŜNAqH Xw9o~A  66.+u,ξr*jAJd9ߙNЄ ?AOoVWI%-ZpXas'̐>xn?~89=V 8Eнߧ`VY:9neʑr\UPw8ʸS ̹SttScUBG+ȋrtPmU4ujl#_e WBs|Rn2Z ~jD,L<~}T{]hT|sLjlWUAXr6~pm^xR*y986ft45{B : zwF'ױyofDy@DD'g9 3=HQZNm+\"f=-U=[>|ű˔=3g,oZՇ ~pY' ~̟GDaN"[aؓ ֱU׷q`P-sw}J˜HF1ACb-it}`lL?0#`)WƮVD"ݰ/11jSL3WO MfZ ; PV|48k^歡ea*"Z04SuAx|W;[v g@tGh;v˾wWY=b^8a+t)wfgZmO}=WK}3ڽ{}P6Nul'4A״k i_¥sZӖ_2؝]]GXJNLX ̠1Ff8@$?yFYirm.>p=!W8FQICpZv}<$dwn9-0234,d!9~9 xwTt桉h5oW nB4œhDS89xp8I"EH3 3<GZasƷ ^yK_5˞Y怀*8r!|JP~Cg7Bx_!hZߏ>|*s^:|=6%Ǥ:\Bp#q|iVafdrٲL`rtԮ o?_ys_$%#7ΟYZz7eB8hHy{FRE-wܺ0˸3>SE"uّn%6[ۉ3b|=4iHFԤ0V~2/+I9AVQ#*7N!%&^ :V0p dI JaAh+pFJ!ߩ4R VuLrC6Wf-^%Rm&U"O.|Qdx1Vtv+'."6nx'.QJ!< Ռޔ8qt[q?KF(}7. *BhdT(_&ؤhhq} e}lSS-EŽ-d`nP$ (G B)7+i 79ӗꦠ!\6|z }?mh2Dzvul<;-t)eVm}UZf{`i ͬe_^~X2ׁDaI:/e銶]"30Q/`seED+Ҏ5.`5`2etx.V&*dv^=zu4ԗՁ6?u_t RHwNtY#U?,Yoq~R)ztjGqnɃ[pǗ |4_}; r&G|l ?g;s>O:O* أ-n  lm?H̬ptg:DR SY7a_e孼bdg'OXycO4onY.=Jmt eǙFi%y/mqRpY% v_6}YdjFz l}{ ]V8C~~kt-:M  \ XG7"[8ʿ/1w9@|(jޅv oۮ0$dv )t{qS/7J̏{:{݊)LO17\.'TXa5c[0f} Lrދ;hs vN 5v7[kIT1] ,zkx_[N< ˱Z]/w cp+Έlu^0Ữo&U.̭ 5M18&ܣjJC+/Uŵqɜ%'#L0/Lן]p~ O^>=!_ү+8沇xHBCjn--X޲B,OjJ1+$ D*l~D ɎfL 'R*lӯݽFPȑLVضy37 ލm0nv{AעAʏdҭE["XYb^<; cl W)=۠$*7,ZBU<%?V[ʢ^c k:a ݕQJ >' 5q)e.PՓ;/c`ӣ.CbL0@M#ߓ)yWIE0_i. nAf:`7uCؘx{A{4t'E9pޫX-ly{mc!3{:.м0Oϭ l#.戔N2%qK/L4w26Nsk9+ $Lw8UQq"6+saOa[aM X+ZKP/ 0?t C~,/v~= ^]&8e'0Ki{wxfs+Gs.ȎS,io0*茋Z~V5ٟOnN&{Κin6Pr^ł YУ&;#MEb?#U| /뻓ItͻdE'+,*Cf?6;o"XzK{ !CWSK1څ`NʗA >}aг[s_vau '\w$<'Z,a}%a[l/ rk9}DG E}*KkC뮝B +8~zQC &')cx7's54ŕ Jёs,2OO? k<@ ºFf֬VT.Nsv?kzcVgǨ/tD\YXIY#bs؎N|"bd+0byC`QA7c AuI!پo\16rvlgi6U"2Âӳ==˩|{o޸đ~Q ?Y '\A ᫵rPyiQt~H<~ )\O"nAyB(.-X퀎,#N0W$w%ݴ O8sB6~yq𺟽{g:qJM8{dIgLZDZb/3Kә̾cQn}Wܼ/|vRzXQg?$?|a0hTecl;5}%kW$;Щ`z/7 {1߆seTa()S> וwTLyx>r5͆L;%P.w3Sa"U'M/r"-F6L-F|wo}͗EIuuvgXGm)Vs=fڱ(N =&HKKACMWaNSmLq#i|f%<ǰ&z@YHgt|M[V׆Wς}`Ni.cNZJv|쳝]Y~ .e0w1BsJɇHC7.$lg̿ 8S}߿Я6%YeռСd5`q"_/w&{?3F, kaҕO)Or(pqtRqt/P(y 3H_ kKRE&Xu;-I~Q@GkZGl Y2S[SH זùiY~a3 hm49b-<+ +l`?[x81o/pډsa!™Ll㝛D4 Ʒ6-ٍ} 1~{zBc7. oc;R>?J!/޸-wτ*nO> \lEqksOAh0J̒`&^bah:l-~"ݻOFZDeOka`۟0QP4jBkԵ+[Ruoqs7BXrpIq9k'k~Vᛷma9ITr;eÐ9!~4 vSl|+gp DO5/*EOŒ3n@utE'ߊsbVeȽfqx^i ?X|nE~ \6=I%'XzvHGv~#t͆[`_.q q?o*ISR/q.$K{TO+'#..LiŁWfmaN.C+:iK v]%q3+%bN:'`6pΙfᄏ/0@9嗋*Y8*M`f"3T"z WҿDa]Yᦦ"Г{ps4L~t! 磘eJciqU B1w0ra^"Hèq۝Roʵ<]Ɩd3ΗCMJ-4 *ݒ6d{$L E%j}5[.ȣzs#wI{t }vᆗ9|EV 8 $zU  C{E~6 aH9+oChrkvM**U zw\;3bUTtcB6,%xgfFf[fnr%v]}’lզ LG?+yt 6_ױuοgxhzM͂>0_T sEtF EԻL1cl09F*Znpf䯧?@%r5CtHd_yL{s ۪;{Q(fn;Y 4 9d`]\R+ZոG݆d~*|%d9.e,@kk =q@,[Ä>*dG cUbk(k UWp&yX%~-OU$ty[]* aqp .B|В]O[ƅu0iMi .*;{¤Ko^q?\3q{o_o]VdX׺gw5T~7/3q"6HKzQ`Z~o幠Ie>(MxB& %luO cr048ZL|RVIivk!ϫCIfzo9*aW =pNQ-z Vr+HO>t*rnWF]d,=ͥjEu|8|l*p$۫,^̜۾F2aù#0w{A%=e, 1(*{06w"GNO EsUo Ww>\l[EjW6o!vVQ&tBBDPMrr]~C0JAJ4>lR(~\!};Ʊ7Li!(LJrqb1LOsÛG<4kˑ5ߥLCw;p A,V;* T~o wv\V29#& od8|gk2J@Ϝ\LkՒL9sc6$zkcN]o"̻y`q^@7SrhUۘv̴t·Q έը}($Mz$ 3fW}s&FeKC‹kέ W?<Ǫ[JkmA̟PkQb͊ئtaϢCbk\TlW-)?F‡aaDbO谀dOTo85ö'?z=GreYpSU qð唚6\n #6|wUux"#ED;W5*8G i9f8Ţye&jL`j-L Яaޘ{P}]8W1L%0/lXӨ;E9ۜK7q/5n.LwՊ3:- srd˥K6Y(R5U? yzdkەa+0b#ckeA_*㴺՟~?wΛ(rDŽtf Uv_R׆Md u5ϼXW=\;!ZL%H'kr6x:JMY˪kQ7i`F^C&arŽ59 Y_=Ϋ_j>@xO߳;? v\Wr,L&Ou.U> u͙ujLca<3>ʓ;6ÌF-\;3G`.ZjX>_N"JIF8gkޓ0 6or? {g9h[w acڙp`,toϝBы0cpNA+A2ifFL4o2yFMG뚩':hN!\{h]8F047vMO;RI* z7xS:`탹;׵0lV0Kf;E2yftfMM*; Zũr]- 2=ͅ3TҨgv}JC!\N&΅ży^9 W .mClxm4_[& V Z1'2|1[ }R?@Ihvxklڷc6b͍߃Ly\i+C"< t O?%=Psajro83&mxb'ۓU{yqtV=jQ% '{u[ #Ҵe0kSяCVw2Uuƀ +}2ݜLط'W zU'f= dbj&KS$S=-d2^]ơnlQ3mo}"u }A;ĵvi-:ߐitFHnw\ѢN `f,5} m+ 8qjrRnc,c9Z\G|bu= ~j' E4-.w|V4wR O9N&s ոq!USxkaÏ=qnxH>8 KX5ʺ|Y1iL?Gs0v[c~Ey8eG=? k<回!o Wg#1%Ԟq{xsc5 ~vsVat]+> C~tƱdmhb֞C( #IkT㬐#uԻԤx^蟨qg?eaq|60²:$* &\h ư oa6^&$=)z4 ~=+_ ¸U10Ym#w|Q~r>-*rpP[g8mR)s7gc5 db.ed*.l}dVT9,NW0mriEfJk65P| F z6${mYydG{罰G8g̲V(EsHX :21qtǒ0Wo8s~5RϾ,\2u#ƋoPu2o5Pw8줵`d O#ȫ02܁Pv R•k@o1Q fW8\5¾q}?niCr3ײ! [woZ##gwHP5) Y<`LM,|/fgWULt>K @ۑjVGi@Ƿ`z> g^)3î>*{G 7Yƫ1!1ߜ6qv7/.aV^oY(}%NXmZ;Üj?M(Zb-+=k/AM`ά`n}>1gUCwftK/tnZfaƁBv lr&= 6 {>>QOfIu̯'9/2SsSꃛ9%`xZuWUZ}VH;O'7<Ń-i]6j.O`5;fMzc"0RO{{qي+>8sE1`zT?Ի·ܑH9>7~֬V^̀7\E:0_0⡘߱ǁh,]r>k<^iaw8HqnM ўշa3)k jlΥc߹(Xq{r9[f=&CȤ9.gHf=qO%Lږ0YeR+B8xQngQyD07oyBmaaaΩg)c 獿]IDG{v5mwT=.^: p*`&ȿj1͏rY df[QDºk?FaY$3}^l;{X~I#݆8(h/#0d3)ԫF~7o0'Eo& v$PI˺| {e:N5"nj\Coo髎h%>G9 >^ ;LG ԍ~±h]3M!`77F\;9 yc{#ZGӚ&p`LP08 =G2]-R y㿏"H!qzN꟟%aO,N~Zsw4Ǩd&֔ T/tmQtFJ9>KǛa|S}#pʇL,i`ػUzSʼn8 '՝JbDʣ-)8cO qU\מǂO80[H&3̜׽-PeՇFryLpVkW˜_ƇHeLbck9u˅wZ@ʑaEf?F:~~"zG;E-ғ;F0~ÊR/ۘq#KwϗI:is%2]qBC/u=znHl11獲&([q2[N`W_ʮA݇PTmU>RLæ$grOq4eNB+];)!|<)LdbZFDQ*G8Q9iG-96D+FzJ9,tiM޶e.ٞ <1=/CWlje! rE_G Fq8tlTԾfb4vͻL_5:^# 006 ze c{j"*#I{o, V\}T#ߦ[h|l.g=L, nmq' =[=lS> CfB-3~:xOzT*`h#/ekx.C,>]ram0k^?Onv,*aS׏8vY0[)K@S[aYV,'6)ǃa:4 |٩g~7RE\Y;,ɬcpWz[^88G;40N ?Q4 FeǠ֢T6XDYhPFxmXT`Pp&t|7)O øAiR>9&@9jy%8v&s|a(Kؽ&9L\Mhec:!t^ Au!38@Zơ1; .V f܄oQ0^XBZ3āJW,~:@O珞8ѭ ,M%=PV*x_ӆp&@"&6=8fo{ Ӝ4!jᔸx%Au9~1t\W?TfD;d}_ -W\~MLL) KIt}HX{o9*Ҽ&Uc|-Fܓ$lG2oq Og]S_nK%?  KJڠ1y% .q[X!4T㛳80sDpqUMԕ &c8c.4>oLB& vl˒a8tcfE8i #o[){OҎBq'.+UGqPSg 7}{1]@SyѤ .=G(q탥*+}sa~7En/Ob _q,ukG~ uǎXSC3P3VK$\x5]lֽc;HLut>{gҶ> ߇RTqFШHJsZv5:],2#8mWu|+A=B,,/u͖Y{q8._$du,_2f矉8j.{4K8 srsi:%( ÍM#fSLbdE>z}26ssC-K~CzDƜ.Tt8)؊snҘ 7aF׀H,~%cY'az簿:&"p;$i n!5o`8h2OۏDM)\i阧)$r}./g|YL>ܭ3Ir/֐z~̅lf*J]%턉ئX =aa±܀Sӱ@ZeO0!Tuvht9R7 ɌɸxPma5'`㉋NU'u\gvHũ[Tmd&oAr~ߚӞ4BѰu_mU# u@ȍKоC XBl7m/Vtw$aӕ)=63'??ӅҎ76_z̾T^;R{b&]ه PF4{L\hp_1}=~Hz%cIMpQ\A* ϟ܌ #^LU?{a4Nr3Vvc Q#\c&e: K\`_nA= h/q}pf\n|[%U*ΗgmqnObs/)9k9ХOr0m~r־:HUHIZ}Y +|ˇ3]WGuLzw(p|¢fA! 2icމrkd"٬#{,XyQ2TZUR|Gz[ kSj]' ;Sub]/Yve^I[jn0!Mk%\Ո~\?D qu )4Zo Ȇ՝ kt[afT+{>'vq56{*zSwRǍ3C{rx\f*\6=ROŜv'&֗~ʷM#n+3q2^ߙT2;{ XhjDZ4/ pG:ҐzX0bub뼛$=,uO7pjǯ0x-OֳBԅ#p;s?%x_ e0d32:'~ zݣU8ŨՋ Cob?>@տ7*ÇS_ (GD %,&/ ֨KqIa6M#컋m'{g|&3!ʖHsl1M :Yc#J3e``ϸZp^~s&I!}e>"o`C{y^8/&I&^b]i9hhI?S,bRې6Kù2=AS=)aSoyH}Xԗ?6$ԩ ʛK/i҈P WH(uWKRׯ׉Zj }2]Z̵S HSgC/҆?qu?!xOϑݻ`r*cI>ߟSݛ,nL]Hͯ+N8E8bT6'L ?;B)3GF~72]]$`&K5'!.&3 ߙ=gZM5a kJgI45$ƍ?KGKk-v8W~Y!R?Wns+uu%eo@An?XHzc"ZY=l~YX:#-̞6CK+ XquvX[y':]AXo`_8#׮}yfl_`}7e4aSȴU!+D_S /QYI۠zMihj6hkOO?`~xl*_yGzށeu!< pŦ#k#&hscQTEtWFe^]`1|?p m]tZX5x=Go%%aGr`Lu$FWc\V̢u0lpCgO8ո鴙"4qeRN%Ї8Fn\ܾS̙d_K?//0%`ky v} Y[ɌiE[jpV;| AQ۷? @-io㫩P%'v&K [/̈́q@Az\r34 Et"m챒;%8՟xgoFO;{)-n'T ƒt)~t( %T(VH>~j^L~U%ZSw P8|MUyD5Roi45z 8Z|S2d1,޳.S?HحVyvy!d>W] nx@+=o7D&AP{?6jt 'ÄV:0ܲ/ޝK;ƺ5(({?\_)rYu[pNnc?i˨'7O>nH0ʺ2$rM$`ffq0s,V\3+1@gp t *XryR #l`_MVhL"8/9[o~#W$2YoLfLk1YT25f V%n cd|@ٯdŒ&ʫ_Pq{N1Τ jacv< UmjS ?T}(UV4KcNj+ en۠w@;p>lC_52c%9VhÃn/ CіW Syz,Vff)ijφ'jr3yL};#G& !,sIy>3u3zƒU68-؄c}&r,_?7" Jco@֭nq"uy%Xk AtG5 )n8S_훔8&@Eb2V̝ 3wUxDf4)s"UdN-*^"aJ9;4{9$]x>/m=ˏ˾ @aCM1.=]a;+Dp߆ݏ\ax 6 14PX#X\ F#wm^Ko +^|a?N݇0)*ͷK&K`auμu&y6 n\9 Aj%*P(,aa{b) TCbޤ62+|(6vِo>g P D˵~ MO;`7D@~Yj%Rpy:_eUX8]%}H<# ?K~\n?8pv@̝\Ѻw졖uFmp&p @MJ8g(.`Bb黏 `OHQ5 !v11ThPxudfx_`V{Wa"6>r$ۍ[<EcޮVC\%,a-{.K5ʯі`,a2\>8z93)zZ8L74 \⪕@OD .J_?yamѽlfL=v;}_k;ML戇y-8=s ;Ap]}IU8fP`Xx';hr["Jk%޵edB§Vcgq=Iy:jD`Hr吟vG33aY <~ ^s |#H#G(#oμ]ZrXl8,adh{uY{9mƑݘLчc+dLbes{^J BB2No2z yWpj8&dN9 W>-?Ͻc5e*߰Arb/3tj s1~Ǿ-kXy~k<="XvyQ~ 8_pbC'p)Nr$IQi޸6.̨i6\ߜS41 O|p &nOƺusF)-\;5_7}?%?<Fc*tb*rC:Kl ;nHFv }K? O(o0ijha2C5;CkAhb^Rm/d޺؊@ȗDMʞ]HIap҇ ˇ~ލ3珜$GN0DQpf;+/q1K#'H[LO 5_C#W͇0*kǿVhR8& )7bӼK=5,H/ݷ\75?gE v%`R F8qHu㱲g$=G`s/sL6~Laqm q5lܐ[ 'e=x D+t{c-@*G,7kJ-+cB۩ú<Găդ:Abζ| =m;k]}x{Hn]7B4nI\*c La6qnm+0MHƲ.d rCc32Z RBjc(F(e"O-a%l>=9 Xn*90.pn ̨)S*gfԊ܎Tu;.pa&xÔ鏋G+NycsvwpQӗ0t4st 7c ӂlCOqNRޱS*8s$˹ISܯKÕ9W6{q5,{>2^LwR] :;a#%.\Tݚ+6;+WOoZ^]]}Wod CߛdSf2H8>p?Q#dԶoV!1XnyfwVԋ-r/˲fu~6}73 C10#\>:x鳅$ެmΊC պva0:Mb.dV߉{t~N8AG G1$jΉKCb.mQw[Bq厠E8k<1w&oHH a!vaC8{2G[GâvORSß0QZ*K}c?J F"6 tLfНN9?0ltl3t(ӎ&xן9CN@NrZ[[ {xk:6M<<`1eE]?۵]r4⡻k~7ET-I{4ձZqhPqf' y`pXBcsRA]_~5 E@7cHS?x`:/d|9aеk*a$ô~g뇰ӜBf6){EAw7fd`_}RgU,9;Q⽡ LN20@&=#y ,e_ǩ W`bz4m[d 럄|m҉4縋2V. Cg%/n3{Z"܀oԏ=Rq4L2E5esjz`j5[K;۪`cyn_) Ƥy\.˅͵@Ks:Pϻ''6 >F|d*SO±g7NCK~JuJoE fL_] oebik; 8:CM=>n/APDu>Lwt[ϟbKz,$>F@mvEsVVx7z.m9GV ZYPKe^fC'9] O򯝑o˽,15d٧g1^YڡEnѺ>! n[,TBm*m>T**) c݂.Ȱ mU7$soPq.m#Ӊ ĵ($)PxzԾ3 ;D#cQF r3J‰q;YKE]Q:b{=Xd(Q3YDЋ!qLvCALYˣ;wqI1(6h(/I$ I"*R} VQ"R,%IB(v.n 9s<3mC!/4ƁZB)X G*NZv( n邾05g5gqzWn&kb)Eb=3ڞ˞8qiL@Bז(d:DEv\ o@7ʼn*;\w;J 3uicGL?h|N_RKvՌ+maΘ"`>mkl Nے7u fzL.a-GaE1qt>qiq 84 ?NeMM8&8t}6KSU9%_:0^r8eK|~vu芽k6+BtUU{_3\5[y+&_rX ?y?|GXzR/`$8ݏ5eTX.h"KSȏ--7|p𜫦lJ`к zT쾐xP_dXNa9ۮ WrI߇ 8r\D@\Rܯ#F(`Ml+Ƚ=q ]G^IܛEk/2|bIzf F[*a^l5B \Xhei1R;4qgY sQWעdo 'HS \~:sշ0Y`3Q0/?(Y ͸}b~8)mC[a~8=X`+e' *(I׻ޭbKEȯBSO/I^ eӮޞXt?sga)t[}I,֛+'EߡH[Z` T!ǷEwLdns)v {Cܙ)ޝg$;F//!-W qQCs}:}nS G_ W6F!_Nfb^`X_EjZ jc6<öut6 G㾯лN9uO0q,Zs^Y4= 3hW :<[%E̤OswԹ~?,j];RS>v*[/{[p^nQMua6+Ym߉Um;5ڱ8BN1`ɆVtz}߱뻉܇eqm:?kJN >0S=IGߘ["Fع@FjgbxvP廫TflTpf?MX/`n:LbsLt!6l 3r#o%J}fD^Q.͍|PbO#^Yܟ`0mށ3rXqWS[o}&5Pøp!$5* 6_? i'F~\P5-:T ^LnQM^ϡJ$)=Mar F0O&Gv®)^{~tqB C°hZh ˎU0u)X hŖA\?cq.IvpƱ<3O6Z2 ys2zqQ "bd9Xp6rj`YpB* ?VӚ26BJsϟULySгYMfdVgИ-Z/ Hs l`XeE>Rs Y|-7LֹiMc=g3XT9뤘 -QƆ/`K:~ٻ ]R):֦CQz1%y/Gh-vU:Wc<;MalP\84. }@.S{e`g"m V[ۺ 5i`MA6^4:ꢎ"__zIa$<%5pUp`9鏾q8rDAUFr3r+i9fx< tYsr⦃"tܭM7!{xՠXʼnq@7HHϩ?*ЌсU)?_dy;D mz]1eP"éu\swW,xYs_`ڝ@!,{i=jE/\"乻&!9l+= u1L 6?~/Vj}ݶ2T PW`_0Șy7/7)L{FE5W V]HUj}& Z?#H {IA-CAѿ~9\cVۿ9't+] o냩c7taὮɑC8Ty5hP[&?/xb5ORaaW`Yq)%L ̀3n_us$d$`߹b~:Fs/v`uv3Fza_i_pkC0?Zlk%wYRu8Ol,UzK-ư?~M&Xâ:Y )+\@>5 A¬d lZ|[D Fq eGzu.9?һb8Q& "p"D?zX-ZSol3s&sŸqQk<9 7zv WGT|Tl }Ƈ>`A廰 v7:aG uΆB+S1֐|d ZuzϞц80|nX(`x+'WpiB[XV +9f5ֽر?H}\~ 81?k}\@!-OCwb`9)Wa 5*cyňOaL'z4g{Y`,<>˃ !&:۟OLuY, ҫaKg 2'FϠ96 j*gl/')Ena ӱj Zۚp`,/qSy:*MAb~j0Oܿ$Tء;z<7Խ!aF x 9h`;8=+V:i\b4hIk_8~CqoMǾ7LSTlH&Lw_m$ ѻQm9Ó{{o>5k俨:hpLt.ĩuy@Y{d 7 Cr/n3֚8ׂfzᒙ3;74sہe5.g[WԶ.QZf%Ve;L]p%bZSz2jk>DAhME!1YݨUoe~ ɪSnx ^g*MMkOcia%0c?;7°Ctfl*-Ł`C+8vm;ɷ= N\op쟡aq ms\K:F¦?0A#i#]$dzY&KIs{bo /؝Up3vnO<^- Bw߉%n?x;-K5tn0x'=q34q_{>mef:x<#g>iJ9h|Q]JKx6؟Tavb+Gu}N"]$ LVE piނo)SV,[Ă}| n7z.C5%]vέ |$-D@,9)Db%7u6Z-GwKq)o6׷8fCZu8)>XX{+y0)lz6a6~ 5zߓösN+Sï?-:o\+z0Ae *$. &tI=,xա> oHk̀i;} 8*Y<f~m Mš Kal hM\lysBa2JDLBņA_ߍHͺ}K(Y>׈[)*ԩmV8^bC*#ïNօY·juʟ"INQ 7cgȚu[S.s3d3þMߩ9U8piwS8v{ N9 sy^%RQI@SfwZ!7^#GqOxVcrв#߆2bcҎ_#4A~s=H6CT#p 7`8֗8dӜ#OR(8AbPdfCS q.\P88 q֊ {>lЗF>@=C"\^ǔ_03CrԄڒSֈ<5 7. <ـ[>f$~6\:[Fa.rOJwpc$sw9N ~]׽/$,G+kzZR.x 3o_͛bhdZOMQ3Fpl2 r: ("fo Ȝd g s@dbHP l+TT^] i0o'F=i61sNy 7{_$fs? &W+ .RnOoĽ8~>%>~8O i3OI7ߖ~LMbTbaL?P,/Dl_GTC~Guz6PJk;|ۯخϻa*Yٙ #Eo/F2QجFX66Xrc&T8|ŁG2(vϰ[O{N;J.}G8+}/J),;徽ۊ/ b߀S% wa@-(,fn+Gجp(^՛&}=;X_[žR ,V8!dj&#WR &IwS98t ?q{-o,2}N f>#`zO} #ڡsmq+s}ohwiKm5!VOZ0I̽AGݘ3+1L+xPFhJJ7KI0̚{WO/n (ϧ=~)GVϻaa y>G? ?-0AL{HelЌˁ6 '!&(TE=O'Y, fَ;3sq ??+SX|,̂4Oۢ#kJ0x!2wYB"Ђ fNA3lOIy4 Cì8w3k/^\~*yQR8 Ķ?if|OEżF[u(Ub #@#֩a6xjd(ý9%/`{fN8{8zNoS韦=v&R{D,Uw $\^Ʃ \4&?@ʫ;h/BU.!=#W G%_oNn|ꠏ]I 6[jǟkT 6Fu)IfiBT=;}} pqYMKq3g}#H85gk MhiݲÉK8RgR:Nhama5ljп A!* _ֲ. Л\sK8N-p܃ַkQ=X2À1ے(E\ugϢݑDʶ=M'*XQ0oĜ‡/iGZ Lܪ̸GGO_@OݬsB[낱뗳ޮ1ZBˡv m̢Ng_,.7tV>Qw2sH-) .+@HwOs`r Tz= ^+-#صZd zv42A|0/0@zL AV:H6i%U6cɶHB}O?l~7:ź;oz xAs癎&9| /,ɻs#$`܌ggS 3-72s:Oe-v",fD,Hc:0$0sL~v:mؽyx8 9D+z{zRѽ@OiDv Hq#j{g'w.0ºȗFIeX +ox/vX;䴇/Ԕ*8s r aKEAn|Ձy4Ψ8r7KKc5kJҐ^S/_J9EC7?6th>WR-<7F!$?n|ai_v uzTys bZqFOepLi7ͨl8@:Pv7$YցnMޖ (OY~%lpÖY3|'gjjg}ٵ_Z~p1Q_fx݉ :]b1X.U`?n=kEfAZN˶RzaA6poEu/&}B mQ2j39k8a_{7n.+*`MqS̏&?X)W͟V mܲ lJ A5(뿷V(Vx^7;e+ɊiCoHm+ǩP8$%' ^60NJ)ۧeF;iAg3~ײ@]|E$^(!”ZDvWO[R q/DX;Scy%@:'6]*LG%qM/ՙA>js!cl<g7݋K"ai9-{%&li LjJYYR(!Ox|Gre;M-?[\ف|}0T,v 2FqGKPr;"N 1d!}qZk `oizIp;dܿO*$Ա#x~^ wDkC-BC+[DXF] zQeWyÃ+03_h6yg{*W:}) **msI灚ySiV@F2_L6QzkfA^*]DŽ`>&a+wg95+@ʷw04P^qy_ J(+gtj X_W~Y3V~1G{^`s +7Cߩ΢BXqh->_ټ+o@_ N;b$&͓ 7/\"IO<rn 6]Ne}/.'Qȗ,c5Ǘj1wT5.peټ>OywϰxZhBQO:PzʦmXq$e>/XHeGƭu$ty G~u^H])]i)8QWcZh}:n0=Cϻ>ٓ]̇ jM`C`=-c#XdO >0i=ـz #?m]2A;w͝I5vlx؏1 ]e@ -˭bK!' , ;7&qecZҿ"d~=b#@ HH ~5x]-l!k(b-F v<p%]W |(֗ry\c>_Yp6aCwWO:q@uT%t]Qd y~U{Q64R0ӻhxXvk>vMu346H%>֙0 26;r[}}KA-kaO])7[ H=C#EŚ"l ʮynBL) ? #URK۠/!rNp\!:~ ĎHd "K"BynuMIOyWfej:7?1 )vH-k|'y,}4~7u$BT}BpANv8yJ?vJmhIBd؜:c٥y!*|!h;5)=^{NMx-aW/̩!]:2oT vPq^ssz^cz_f[#Bh`äO-V$@Mp#gBAw0\EP pxva_r=`q*lwK\xxe'r؈h:BmL'pam83, 1h7Co0=tOC:A|X^p5 Zjeq9;taV Ry>e񁾣@]gGkb1CwNG#}r;١_AN@C7/vsJЫ>=܂ܝ>/@Ix/6t1\ HEي1Oaƺ\W.t8XD֯Tg_?K`s<{QٺGٸk,$q!cwV]+ѐП!îag,ce\: S3B3{D8iB.B//ypto˯_)o6k^בw8M[$%LNEcdtxXۀ"PT$ b/Mn.5/qkj9,VɅ@M9=[j'N]@Q ͎[:PkptKi܁E%Pefm7LUOݦv#nj+nm6$vo^C:@o06cCP7˓ sǵ xS6]r̩Q=+ڞa{[CYiЮM*Rr^M6 Du1'z`H+_L?ߡqDbp%޽Jlx}5Y=1LaK0g?=6y9#H:QV>dνՁ8G=8Kz0xD˫8"q{rM7-'_NwIJNؒ`=f= }\0h̄ӭMM;@}}9PBrul޽$H+܇@?պGI47}kg}p*UEaΝJLU㮣Xϥc;,Bp#?J ,d @wڮ}Ӹv[ D^˵Jc\oi-.O0Kwwкm^P\{_U#9 ? 2r+.(&ҸߓgY4 j^KhO~۷2|0M? ki1H6l1Ě׈ Ҽu_/wLTֶ0|͉]f*W#gRt{+81%wԸkJMFajj ZWbp8~k}10]gkk,6c+z&?zG)#+f}*l .2m0U7ݺ cHul6/.RrFйgCѺߐ.$Rg/]I/) LgC$rr{cm5U]Vxf#g^r XNSyEfOYXGl?V2) 63~KaSX5, :e{TK٤Ťu/o3)8`8߷a2ׁ(]3. 1ʼnPH1&/'m~^n>WZG}ѳ1=|lo 8SaqΩɟTRL"%HpayoX/* 5w˭Q&c0b83d셣J 7cݤ[›8fp*+i]Wvp3ِW }jJ7b= `udL:7۝H0(*ATf;P5q[/jr3r[:yZ!|QJ-6f< Vv!V8);os?Hcϓ%[6jCjg^X xjm?3p^S\P#L^ b*&ItąKw9Ϝ an7;=%*c% 0_S잔Bថ5e\Vna[X?0Z<{Zd#pQa<Ӻge'y 57\r?z.j圑<<6O>3ǷDGvZ!Lxtɽ!CCn~VmA"Ԛ"bB71B>|0' VXcGU-DIf-qZKuy6G<;p\_NGx41|i% +;>θK}z"L8,x-KeY.|$8RFkW cUb xc {Q+)LDu_eߊ Ɣma>&͛#6_ 7O~1q{=K{Pt(xk߈cwYKegE9Jrs7T?wFʲ@N q,ӓ'`ߙzXU &/qvWӭ_+ӤqThmW J2Ųd3$7b5ɴU T{оP-;ٷSFPA%O1KZ)- o>|/nĺg''8?i}G5 zsOЃU+ +eVXM2zPٶDL9缲0KtVy챷뭚`^%jFWK=_Ic㑪.>apiO.kR-,Ϝ}kޫf~u eYU#P^롃$]uKh./w`7 ߉s;?%8\xvnEH<#v*qC}SͥX+ U{VW^}ޮ{;*v+vdeH.[*c9x/9Zx]19mjM/1;?r#`苬8.pX)yJ2Ù?w;}` 6ڕLN*2BM-`Śb?> Oc4.aT?]Z!L$9qQ0N ~x% 6[*¼M<>`=ֶ`p\Aq= qx@P{סbBU]0[~uywLHnLJc~ĵ3\~Q^sb}⏱ƕ`}gI ca8I{G^ؽ)8hZʚfBmTp !s6_cL6lE͏>1!o^_ ^o.go^)T8g7֔3E4L.zn#IY:~Li ӹv.-24 zЧLTZ<$;i4Y~Jn&6U`JXzλ֨t}(R]UnANU7${yT¦(wAr0[̂uG`!|cOq>fqOV3ڏ+}z._ -hI s?RhŢ(2AΝg}K!"uB;#7rՏ(,>FBeqZ0\:\?Dݗ8U_}8+F =okzԨ@5;s1ЏzM^)9LG3HkOI}ի6П;t^!dL JMÑO k<q`i5`;tg}XK۰h*#d+нљIpU:,V?S۬YSa~nU}DF UqccediGL2WAւrm!f:SQD`Z*t``[0ԡek#n:v~ |L9'7ʹh%CWƼiؘunI&}bݱHY䇱`}[K|;ȬD@hɦ- 15wj>/.2W<.-!~@dZvƍd[O =pwƱ-Wb=bϐ)H'FN_!}K_= RQ$q%m't-'gݸ+LzՆ3t8$}77N6&@W^| >,zbغNZ]v=J'/n-aм[sm\n:U?1^f_V5NR3M{*.ƧO`а't#+o`OHĮk.aoj{cUi NmKֆiٓאZV47򛊳R{"QȳVqO‰W*a@S2gU ^L&F~uyi0TCh-t^e:g񅎩c"L0;WfKe{|F``&Hghclj]\u{ItKun(~I=*Ma~ʓL0 ٦NpT!~!i͉`qbDBݯqVELNl&aP.ۛKX,{k7l^?}d\ m[)Nk~uą,…'fda QT5l\ מ-\쿀4ѕܓؠ7k =^RmqIUx`1 qjbƍm̈?IϰN`s2Yｻ79k9Aƹ;`Ќ}` n: ڍJ៺0f7jhAK %֏auH_{R_2Q[y*&e\N,QUc׃3[l1`txs8N=5&U*])y9qK!J>>i.}V{<|4=& \y8b)ݹ%os kMjlyEaPq U˲R}N/ Z8p|d in *!wq`z$?yf!qyW-U%'_X;ǚ*+MfV|(v7rT\u|iG3J8QXN _c_`lvU~ d-lge} ƫϝ7o׷A9$X.Q<L.uIh{SNo|':~ RxoLa'PBne`4U9AXe\1yf )<b(b[\wk!QXZ݁M7ũX$]U2CMd,qBIxA Qvs RDFXe(ڕf}ɱ3OqU8[\~NA NJ8u?dx.n" ,נc?jsH3T,8%2⠭-6,07/ި ?]կKr%:R2Ū#@gJ@f.YVbLMHeM0ldF0+3poZk) ך?Qoh bݖg6ЯoIGe kwf0iWu ܄­ȧ{e ;^B@!`WGAz0n P}@ۼrvκ߽4jwHgƘƶ|83Qa1sKU].f,a?{qX5Y&h$Y<@]`Bfkfz5k`nM뾱:XGno+r7ϸF[EaK s*n໤DkyT!Xz֞]EZH>$>'aժ[!0_:hԥ%76{ޗI};ymk;wb<[-',E|_GuԫB;߬xߎuV0vr¿staV=[$t=2WgcL8e2{߮ _jq6mm 9uPڴ% s73cR(6g/ӻBhXņ%Y Nh_8lO'|܉JƂ3q3 McGۉF2Uϥ?DŽefI𮻃`xb? 0tP6E&F—?)Hܻ[!+{w \=iӫQD&>ƚۯ[E䉨Cq #qD FmX-Ճ,z>N嚎`oaurJ>UkeeUohȤEt?0ds<ܡ:8sSp (9%:WHaxU*=S(ꝍC:k^ښlTqd0W`˝RiG8Wl5u57N8km Gs걒5iotd+}ǫ &Jw>$vUCcc4mC?T \Z8,n~P'Y cㅜF:.$s{bI#$h5oݩ2;'5`&ԀB.~ Lj6͇_V_J \/e'fPtŦ[-whs; `? i!K,51J7xn{NlS]aC Q18Q׊JJqۧksv|`-#K!oqf{Ma4&_†Ich-ú4b~/ra6A=6.uW<BEoL /a)t 5{B6_{^:8Qs(?Qt*:e%p1PՒ*}.ϲ*bԽ:*hbI/p$:yvV l^7 r uTa썩R}C,:]$B\OT cO>lXA@.X-9sƞ*k=jUϗM6oSHA)źU9a,m0Xtͧ6(ļ1gs;׆a7ITVֹH:AXbpPw'N>]"<^M ^a&Pq!/V_pƫVtNm>Kni,#޲(M4~}ϙB:Tk4$>L`C}H йw `xbߘ\N[8գ/AY6õ?VbM.j}vKT^ZBΕG(zUY}% 8SzV&.ԑqU5M>i'dR f _%%1>@IEBc*۱Qd=D^8ϋV+MO >چo: _|89Z. +SDma%uhV4V#-|Sb{}"l:pvPPW: :Ko!sgI%7#Z:v%;`Fw^ݱ yROס+6 䋅dBqbs,C2y`Z ŗzZtf߳erVR<)d aRpKg[882eG2kc6]=0̩A,evJ eV|᪂0VÇ*z āsJtŽ!qgnƅI3sz0^e[gh+8oӓXY:r8'ij#SjĮk1$hՒ r JmJf K6ܛࠐ~'gفl_1|Fċv$fZ#.*a+:Hwv)^ٌT W+4Ȉj._|kعK(&Ρ֛ς F)MqJ,pNά3|6F^9ԇO3`lu7m"{G/_} z{iW#qcbo-vMx'uh{#uoEh2|arXU8I]UT'BE[r= ?åƶ;L`Ml˲Tw.[Nu m~|ӏ`VvQ[4D'K@SEE'tԿ 8Z=4-w$̈́cByX| g/^Pʷ>\M 1%Ɖ4?y`?^8Ø _eOEcz1˭.Ǚs:-=K/a?ɝȟBt/51=VPÊg׻I4:Pߟ- ЗMjXsJ$oO_Jkq:S@6xJ00nkE }M&}6f]4?Fq+33r%P|8銺Ir9\ R)h1&&ljPOzMI\, Ie,:+9%\siUnQVʬp*)yz6zXi"U~ {Ő<ԡCA<}{)p#n,3)A˫޷(OD H_á&Oo55,ګ!l`NsjQ#u?$+pM@-vZ4_'gxPl N.bYCf ܟF xVn [f?n'KutB/K}qؓ(*T+N_ OFj/\b7.x34&gN?)켹iqaLPIEw pΌ(77BvWu h BE؝1X枋FgO;k7t.?u~G` Ggh}ˀ+%?@Lm9ͬ8v0g G_6>1\U} iS?!]*A%TttGhV'-lx]UDQS:?ݐ wx>QQ0R Q8a.w?fsQgy 99:zykwygqa?.'1ٕYY|yr7nzϘ0cG]̟\SF0;v#tol)p5VI6~gX*؟_ `*ﰫ5h ۮ Uݔ 23Zh.O>=-s{ 8O:ДNY7Լ,&%,x2`.3<|TLrw^gMWC,qO$P^lz! uml>5mHgvx9% \& CINp^X sHE_I,2u@ȃ UmHgA10au/$/ a"ް8j²gătGZLh@Z .H^7!WO`u`[8z$1m(8ArKM8)K i4_%{ =oiG͍U썇j׀6!*E*yS_l6֕٬ >=k@Ǚ-˅*>X=1Vx/(㱹EiH"522>pLrע''zKm#99_'!F!ݧYax"sMB%w!e[1Xdw +OӮ#8sޅu6:u@&ŵ4a[E)_s#1T2sب-0w-$m^Dfw.!u2l@y#8.qEvC!`C0T]8jmN59l;-s_(G.0"W~Y(~w2aUݷSx{ +N8 UƷf |.)9J)д|"Lj>J(.;p^j(Blds'y o?|tȶg倁#C 5}*~FJH|D!d&iCx\E%\}`P*&\˓Nn?e +z̉"M<ڳ+~`{E/4ME-6 ]nso.y_].~$R9yPe/jcuAS'byZ_]yg,[`!+!tlm)m>|X4 NsCRħ71w) D ևMOfKL3Cޱ50B(aR'L*3UGGv]_Ky~+'#t238\Z+-u5w XR54m°*@1omx]nGge.&>@!ye? !I*ǹæPtC1ӊiA?H_')3'}bR@qXnIV5pHzja J־C[eqX& "7ClC0EǼ̂3{ ЗlYc8pv&$=F/[}.TLESہOxq~, 2!ص̲>=O!txS&7K* g|:vq>d\SS[ o;-9cbZh1[gК O+$ TɌv=Q4;0BV=X,epwll^Ԣdž };BGQtO0ptI?q+۳L!ώ RІE'„^_0Ϧ?y3 Mؤ/17]Re}UvwjbmՐ8ivdK0YIPC@êِx@ڐZá:.֕^]KV.B)Úje5S):?->Te>hh vІ3zK8V>%dюRaO?[Y/PlupP@̜e- K/cA^Vc›^&ALi5Qx?^YF39}r 6;&RaZU:6tƩ_o'(gp{gG5\=}[0mbۄ`)u?f0cx,2x^@1XXq uko3cǹG/, mxUJnW]!;fx  YX#6~1 npe1VA2 aV9pwRYmq4؞ސsY]qLL>6?L? Q o/$"末X!]HOۗ`ϑy |+䆳^(|,V.!_S+ĎLh̜P%ڬmꃏ8'ac)h_w;Q6N_ninÔNWʊЕ=i]Ua# {SDL7w{{cARm۩.}Ml|[-eH Np,ӅUpVӚq]'ʵ\kˏ'6 S$$%.S(k >ca@XE0>?ĩ?ꭍV`reyWl1-Gg'. yRO_v -ǜm_vWA^e?|W:;$φܧI+Ask{t< T3"F[G*- >'HJ#ON4M{Drn3.=xG%Oqtһ 0:-^"3s? |.vhс {M< Ҿd^R?=φ‡WkN3? +§+@2HfvH7Y@ X,6vܸ:+mkl> |py4/G泧$HHӶ; B~ѯԠJ+j'/X4Z!aX`b1}|% M;&a'ǺpÞ[GˡI!:NK<.}7h|T_3lFR a~;p(z!W;Golz;Xabt0bWۣxjo¼ũiʋSGWRWC)Le]P}΃Pڶ-tai2OF"vn5mWڰӁn813ĻiWv[k׾DU »#(% {Faw:6qKk!V#^G`rO籊 ʖ)#r̸( U76J$Ȼym>լ[췑h,%H5w\V6lSvD`Wq_:T Uj*%K=C(%E)ї7[¨Ϡ((K*p95 -1]G3;([,8N%Sz( Q*ϿM ݣKi( CF}}]l!us7%,ghֱ潧{& \nrzlgԗ:v랁VOawa&.fzV5q.VMЫe|Wل}D 6QPfz?2!LuAKz ͍̀ z{,^ΰtrc*]烃k2+c#v3{e7T(Wjr#6[vsWb7kRs|fh{ɖfjYpgp{ c+W@2`/9Nr*􂉎U*ߗI4B#$wlܸbۏV@W{a>79 &*`'Uak ,c>ke%{NʑgUmY`8HzpuثJu~F 4,bN*xv3 7Gj |gF<.eqx/ c~]=})MJDB' nxs89Cڄ2lvKSf֊kH}[Tץ^`_|ѕKigz bEAlJWAer'^Ηt'{$Iѳ= C?quu}=uvg`c)Rq6{A<+zoYlhgT+8?\ku^/j3]!tپAzl?tQß[JDYD:c4[nYF7̌%6*Gn ȧ ,n5`' /pɔMa{i6^ f__=w0G~T KOVEXVe7lZE}SL? g=I)_=&=4e;OPsJ4> USW[߯10A2ٵ.).]CpӐ}2:; 3\wpeioT?N!:dF:N:?)" õETKr$1?`*_@8/>*=lġ=Rb;vB`K͌(L[6`4>Y|l's ח3sx\3% 5Hbus#ʕ L>g:cк'm Y!yVs:("H08F0_=&cvO :m;K0׺U,z9pX0ZT#ieZD=]$Bf@elfX $ĩ/{pȏe5/fCgΌL0Ŷo2Z"ް6 2z8+}L1z^8XUM9땤ckyy~|˱]BX{|8f+Q޽7]琸<۠$B zߠB!+$KÔO_ 8\4'R|sk߾a܂V-:;<7ocukjUQnI9?VnIS^rOvw8%_mN)b]o.6ew!m7NǓ8yKC tuBL|wجxM%ve=xX>ŗ1yYx8 + OòSYEZsOo@ڦBG0qiXv/#&ц3 þ: ޡP>Pu}v20>UKI0-Pk*6̒O|5l듯qV@( R`KH'ha3qRyt )+dcoP0O?gDzIHXoajzڨ'9mw=~NXMV_TTf{(WT]WT>L<7;1Ghxb\t*0;yly fzqcy%a?7_atyP F6=[^< _'Ldr &AEu´s~oM8e#M'8YaQ(2 +6{eq^aYK@d*Kq.L}ΉZGjAeƘ!e|8ޟtcuu+Y` ]x_lqBăӁOi݄}Jݗ|pD>5`.LU `u\f7ej,_I~ED鶀uecgGj\a(tjG>X5pjz|12FV. "C 0:+e*;_gv*=mRR.-,"akťG8^i^T˘3ђ |og.-.Ld ib;zS!pM7_{%7'}<5I`( =(z%* eyK[9[&J@(VMv[kBٽwNbwSqX G\Uzk~3Jl0&j%@&z*osaAB#[iK<\ArՏsB5_;zvyԩRz pāʫ能 S ?o#2# 6 lmcx7@0Z wvPv +yae* x< ^>YץkR]@ו< z}K}N~9%Ӫ*Yˁ05R.۰  A*{.zat hn *%'$L&S?C05?`|U Me.X{]=qQ((o+Wԇ ֢XܠORqzpN9wE2h-ٳƟ|ңi8 7'L4/ <=`n26Rrph?5alН uumi~Uu]a%]'Bv2UG&XC;ٴ>_xM1go'vtlA3Rzj{ 5x ;NC[ |qjoApc;,r>Pz!M:3V'QutHO('jkNGZ%ڳ_7L1z]:t ؝a[;ٓ,0*]n/jI#L BrK릿բB皻v5ox髰sW^뀳BZ"wk#X?;#eRIQȺ(I*RTD䫌 I0*NNO{o9<~_?yps/^tӯ^{1LOو.cGB-jeR k|Oig8&Ml֮j I9uL8Lz'UeC5:u]{ H t)*~R' 7ˆ|@Wr(_6 cC#)"΄ a_t`|P;#K;lu9 3XpEAhCs%yp~?};MtC P3"xs"'=q{QRRZ87zzzj_AYN" &vcxmoc@.!rt a))QJ&bYpzo{g)}ǡ}M: DެHG"s-XEl9@ M{y}VIX~A+~Gäه B7uf&MtnTT׵3; ͔;"*!hQV+dn ^>IM,r--oy8h8űĐ.R8C#lf^SuG%h$5BO"1zG<=y~cتL?yeaj&~]Dq9 Ct3FWamMTFkbE*=g3#XzHAx=-+qʌF[Zon\5Uַ (a;R4b خ\1n(ۻ  x/-'l}+SKE-19@m+W?hb?5Q/;*x!YK^Of^`q,fՆ`LL\IP:VyQ׭W'ZiDavx,(Nu!8ihk ,ܳG$8>8t[ gzyRZMLK,Deh%`fc10! a?'-bT+Nn%Ӎ炽 2TmqƗH81־x샍Yh̒YڱZAʂd5un/'j5KoDx_{ܦWɯ X A]Qd:Z2itMmW 5efd}OHYbdm •}I Ð1+> 9W{sc-Ʀ`y"c%Ut) Nȟ;6LA\|~HjE8=|i=|j:ۋ܉̩iA鯰ܩ#U̬>0$AyFFve;ZS+&#[b؜caYS!iT|Jf2S _I`I)+2x3=f [ gA<}6TWsKǞ_+&< '/&i]BLpub2?0-Fq,k Z\q&B8t}J U7>O{ .$!o \#9kUY]E}? *|v 6^ֶ`e޲e(Gݏ kv8b4|zW<:7vhpƼXmW[79 8pGExvznuRǍPr9>^}%o>4]x=d&.|-ǓwƜ fU&H2aQ2=Rl6VP^Pt||<aZWC^ nÃE`9ŃP("ZE fsL{Wۢ%4 ?_,)Y%ò_`\w P#"ҋDC2b TX\lq V1܁jlqݭ c+sopfSX(IuEPN{|=@E Œb|c9?:I/y0.4ѩS@{[ glAfl;:I2"L8b kPT3t0*VwOf:Ƌ;/Ayv4^+|=Q WsgHUB^aLv:Z˲AT,}sLyV$Fo z/%k7?<f;d`u2&~G~ iz)Řuz{diiң._cX7>P-ίY۪ѡ'~A8zYf_:Dx| ;BwZli埖Z1V 'xrtlmaYx0u-^ΏZXp1%3U]oMRModa_jcNM r^Tp=?1@S&r&gH%>ɊiFBz82VJ[ă.,p!`jM7=^ضt[v@kANSvqM0EKmM5-q/ʵeʏ3gZ:]2P ԭ7iIc!{L|vlW,ۄatqS6߾(3Ugނ:m7kEe; rO{,Stf v(U3yzҎ~}t_YI{jxptyTSE[Y'<`ӪZ]bI9+Fߊ%BS(팬k~/}ԇ*sr78>w2iAvIFυχ"EA,zSg62j#`7NNId+Bw4wwų͞;W~]ct!тRAa)(lqƏ &cїbpjv&!p-wc>}~r@ẃ+G 'UlO_.O!iY.1YYs`8Md` Cl+ǕfحK;^ #bx `Roøj)U_87pZI ;^n|_/Wieg'nFPWAsC-e۞lH(mCw5.OaP66oox>:0 M þ|hZ- _6:R`r hgǯ Υ;@h$ܫ,Q8a7dOv3s"/:e8[|yrnZ^:MFbEnw`Nų8ߟgq!Li[u z.֓Q]7l '̠oKqU$`ے3zv65Im#=*p[L<=*3o8lZ]Gsv zO?p+6&Ƹ'.Jo-=`KeR-pBV^*$X.*-20-Wм2{U3v@/LGnܶPy24;;C35\\t!12=/mD;_dGttzQ8̯foJ dr8t&Eua]PsO=r:!5 觷iwVxT@fҙ5gK Dw* dRCfy k|6>?:Q _-(2Y'-a~vԝ?ZO[ENkzHX^.נV=d#Q>_qF\ێC\\ّwH/کk%Oa8w1zë'\>)y6$x-aeIWLH|vl/\S,F Ȍ>:;R3~X Sw+|=:׽6G'%د&.x_ 8\1y)xSjߴP0!И}c?cFoaflh~&'rU36r_JLO9Ly|V_Eya.sY3}x?9CRP$9\:@9gH7s;ԯM&7Ϊ.c ˓6SI D~q$:1(Ti +^q}'_VPKyLp. 'ZJo|r:0_:Z`?^"HOhpW, ?Lf )]OR]7G߱6]4.DGlĨC?Myp8܆oҬ>ö{/M°j}BQZ&Gp Nل:]wxm"9MjACVn9֥EPvpsFs# j.v?KI1$eò+_o6Y䔴~.@azD n|e1Hb/2IERciuB.V "fKO,Iwi'Tw8WAQBz8Cf`j֪_ YBfղ .+evGaN0_x|Jnn'kCXZ,ҍSTÊ߂PL>&%?(y'hB{e8dzФ[COp _}jlo}if|8n OWGaGVK>k>Fga+偦,mI;[=q2lONfԈg50%y`i1\=vU|ܖhmb[:r=v.y FSvdf;T8 ?%u`8LY&nzsU9jWiҵ'?sM0;sEq2i1y*ޏH,g%lP֗ L5[pyzW{q8:,l A`;Ά}Y 2yT'eȤgO/lԁ'X!{ )!?qV.u&7k6^ #O]u~ZݳV!4鬇QX:)sY*;,q{+*ErG0Ƕc޳COM1JFO|۸ۚpą|l#o's]|SǑ2$}}dt+Th]Ћ2Xt0j? u+w ˁ*I5=jq֯ѽX*l`X.{>X53r3Xϫk u<A]wj䟓w3*H{%V{,vjYSIw̓{#u.m*WX/̽ƶ_HE]0fl1J3 XVA_KIۏ%Bn)ߧQ8z0D(Bm`xI%k %X-s7#jlM=&3-7B&?{(E촿Q/6_ qGXigGU.lz˟H08t6!a\< :f_$0|Iܘh푵Te8tW4Av]dRt= TsLAaf@0! cETĤy:Z|NŢ-?G뺍 ,2{~t=vbspж%XcO0M3kԂ+Ń9mq7%+$u/Ep!٩c0]mA_K$Um^v;urcuT;\5㿶6l%/a[_6 ZXok9'Zb~4ܑMUkUa&ݩ9 l?ʲA0ql|aLbd4RTjnt}~tIC>-]`b&4;FHZ=Yr1%b8t)0y_6_ם j5'gz8ۉΩK6uG/C N]V5Tý&> K]h7?;b"mo 0)=﷯|v' i .pC;(Mqd>*;a G[ϺF~nec0UlR:bө9'~aԂC+OHE`M~T\>o<ӑV0&}6ea#7pPrAǪ> r (|;C+  ]W꾚ON8PU )73FLB?6-vl]P'qj̻PM,}] }@c /)8]\^;O[/,?X-{nBo{󑊡]Y@.$\R_Փ @NX>ҾPtL(t ͎&LcŎWq?c!uR NMa8IU>혼xBvyZq|ځa05}5 Ӽ%" Xx(Mg1YroV8cG/+Ly׭W: PLa/}2 -Xmnv9`\ l*C3!Y f %9=7g`qѭq%Z1=zݝ%2n2>'5 yU{6r}gRڛvTNo{-fm l+j&U6;Ce$Dn-)Xz+/P]їSڥle1e1l6po V,>]֞/fPQկD%wⱩ,*$]3-Iw6=f*8.g\ {mR %mj0|*xtH$üX¼x#R{%qm;77``lHM0@/: KV嶇_EUhjLSN]Þ$;#dfk @ڶ/̖m1_6 I0S?J^d3WuMʣU"`N "Ӷ~3_Z_; ۼ—/lRJ4*<}B{MŏBOmW8@qzBMqv81ki9SSla5Cc2T'ָ7w_?5⿿n~P'tPu glӁ' w`Yd"_t(P4xW0c@hء6Fz]dd\.sN7G^uqX&=]"oݺnԫL&N'b@Ҏ_(~~%&%`ʤ]]ΜJCMd:T_,5xs;a`u,׸f՛̿} M)7K6ckִ>\O)~O^͢ڣ?qis'Paq)09 '|^W!Łd0 Wzxn Ӎ}q-rd67#luW-VRی*SF[G2J xnN 'I3.?]8,8<܁5#_)8B{h0e:)qc<&NX7*aEp\Vtm:)-'g^;ûp:zU1%͒`٢c3j=D&}p ^KZ @- w+xgu?]#?9a>J\'uqEg VIy5-xpe0S q㵇w2).VqrHN URG θ+q\G~5˜LE*TWrۆ.`=7J)rNkhPvꅟC@S;v9[aݯtnlȍ\._on"A-%2]•d*"g?lOT|7j _ayq02]cBzy=̰e{~ ڨx9-jګa.Ksclx~5n[ #{a6YDiK9q8)﵏z]TpsB++sqAJ^Yg\Z9kB@[8xUzԸ'Ʈ;!ff]Z`ش!6øf[vn X7yASNFm6&缱?\Gtc^4 4D߮ 51ng6 ZN~&J.ǿ [0]I۝6.ȵ|3.8]k2fX=ǃpQz`Z7&T9 TnSݱ0j]d#Zե`E=lXqn>l ~'H̙1j@*U탥o@sCyUᚳR,=װNKf78Y:Yn}J>Lo*K}-/lϚotwFk`_)4?~zkxYhӌy9y=6ʋ/ñc0(Z6;̗Vq(ۗ%VQX:3 ̼R Mg5?#0fɷ0bo ^:ʐ#n#t%M^fpw0 V ylf~A|!RX^*hjFPis~Qwxl$3$.b:BN* !juh}'=w8Y[]x>k=4O2+kc-b<1}W{j?鮜~:ߪ&l?6sÙ7YwF!} PAHOwț ݸSlL3jocLrn'gY#i w>yro$n0p0O~B0Zk]y(Οím+ EiBEO/c̮cl@U*-^upц q¥68v2psѸІB0X#na|~K gCe8#YPuǹ.ϵA MB8|`g!In`W 졓 S:9$RQi}DŽo8^Ncy-,[t|J:劧>#/bI#@YuycG|?߄rcu<}H:5%bjD[~/Ǿʉl|ԇO"M^-b|'?+:hg$wQ-@ͣ<ͻR~#~O"xSw&,4s?ejc. . ^ll#~HwR9B[pN L8 q<}(aϠ\U? m?9eVq>[\iHa㇣ݪAcBde?%G;QFю?򧝠J=(^ ɍk*l~w[0t[oS=1iW+|fD#6o+T־4Goyؾ8]Xw'赛"-\,a߿42Q9LW)b\/z l|9 rRB]}&,C:$%7[Tc^&-IU 8+ PSS`0{c9 t{?v[ԳCiW^BJ򗰪V{Nzecq{s2LI fs6&0KЏ h>Rʗҭ /$G*"Ӗӊa=ƶ >w>Tӊ¡3f9N-ŶRYQ*TmW~@ P%| hL 7ߙ#Vk H<"*sނ{5޹1e8L&U՘Cry,XK攉qf`tug&qZp+N})β? !MqCג/W!xٺc97 #LI{DQB,iovC=_-%:V) z8j|Nd>8#msNrmzmwFP ϸʼMPGf_]yNiBQX$+> 39;%WODH@ˏC'yT9y }7/>;/HB{\enb>/D $e{Ry=.e 7pqNرLq/L #^L2sL#7_wZzTJɌf] ΁ ?<hȖ- l|K? MisaIJ++Cd,)*m΄YX'0Ƈ]yd3 'q.dmַn|-Pcͭ]ޖ0t=uaXmW̞P荠cѡ{+:8(V%LhYՄiғa&HKKL_ՕskMɤlw#ڄHV ahT*FT3ޤ~o'$]e3cӀbrOm%oj`M,wɖ'aO0J(J7>Ø޷"D+r^ja^24-ǒ嗷 \4_[=B5Z/>p6aK ˠC^>4v^ dj8fKala I{c7vlɎJZ> XgjCaSZr^}~, 1N!=#N)|: K]'bpNw PrJh#բL^u :) ּǺI8^veKHfMk_Mksk3ZD k[#W^Xܡks̰pFE՚L3@ܢX aMcɬ,jbgbJ(XԟR-z"U\>ak^tuLg-Of㰒M~V(އ:6$Scχm-)".77gg?Np9x {G -MQ8r#/%0: &s,CW^=xoCC/zwHN=dհD/>e Llj;:f'OGOzYGF&"C R')_*aL͉E𔉻g7oӻhe; \[%A U0WS~<㺊V~[q!sb>.LU A9aM2dV"rK1;( rOj%Ňн9Y?đq"x]/51佂0yȃLv lšPO19 ~3O=۱gߚ=.?-n"8.5}EjYܩX1 /,q} s :] g(O]T!?n_#O}G̸,a~i=aXfrw(Ѡf6-jeM::X*x]F="`e65iżI-3Ewiq:ڱk2q4+x?[g>Do3SEi2g԰}%7 |x#~J@<): thbL"(z=OP[* V#_MŽ ?6Xq}o'ֽܓ/<|[e#^}&IkI+k,E=~BKl#E>gG/NJ)˦s8}V?fogxY|%r`-m/Am3/ruXԍh;k>kޑ&φ<2 V4]xk!d[eiPr_-uf֔DOFNB֯F пaӔ?76ՌSߠ!9gh~~H=c}s9,iUi/699kz:BEʫɲhzq؟n`|ﬥp t\K({*4ڇ`ذ'G ӡ-dtkMƈw9Hm$0#&w7k>LEE,L[@ Q w;_ 97a˫)>jr,badw+8x|/;%Wa5} oՠƫeGâ?!Plɡ`|r+J-~C˩*d)5Թ_Gg&j $Yion*}Ԧ7|qϱ 4S7,`O O ~+?+HLEA*@:R8"x: 6'9d f?? l@Zm9)65_mLtzeAo`7_鍜m4O$Z (ϭ_y"/.*\xPjŃNx-`Hw(mrե%9V4?Af'%/>e{,{q-V L50*v3`ۆwPt߳mW8pp3Xȸ: vyfu\%s':O#W<:,^֋sQ/K7GXjz"Mfsj=reQpldw;X\n3_i=o hrĞ#cӔtOQx\"jA%_Eu!f^kLoka|'3G Vp= ~qjKvxsl1zuI2ˮ5H6WXIՕ'g 7J'0&!SQz:\3!IU>Lr1}׎ <<`Ɵ_gggΪ+1uG8⹕` ]y1) ~bl8&t&,\hWn#LԈo|O*S0}G>@1tZcFdp/y}"v-Y$1;'E4j|uEe*ɲ/x5ϭ EէSwmI?󆑗vvìŕW&.W`}"珼M7?wêvOT.B& k~+W̽23߾ qE6AXMf/uڸwՕ hTG(RHqp? Y=, W`8?^7y{ ؃5=ӫbiphN?&3)0+YXHa\RAwlqfǦdDkеۉhՙ8@i+ݰ\FIcE@B}[9? ԫ}owy\5:ag)8=;m?O cbGzS\B :*(uK"TJ9x <'3N+}/B^n$vLߔ/N秨f 36IFsok2v18O*)LJݹ C_V^BIox߹&;23r~9;o{!Tv[8lIOa(n`%[20xE2_7P.'0_˗([hn`<+>;Haj*ؤCf_#=zH&N+o8F;sG0:o Y}r#%2vt[L9uNky.6@k: .=O.UtcNB+-q,ѩ8PuCXXJ.j;0}g[ڍ1>y3@ٙM0$M? ]SCN#56V5R:(+kk˲9_ b1_4cuʃSr TAϰ1(]Z M#*qjb; Uzʷaq*mSxR 'xr@֌V1vOPJ/7Xɤ%gc`aIJԉ+~<^h& Ù&j +/x64O%;V~NUB^,;Ա Ormo$;^4F3uWOB_Ua6TYuF4gCliI5]O$.,ť<-ga$OHL{? UjP;»vbC=*}ut۔O~rK'L:v75jg[e;XD`WR丐H&pp*#=۠#Q1k.PƛŚSo1:I濟ėyW%ԀHym{Ō"#Ą*2,E@뵈33MɌwd_IVťSo|ti ѿ߹0\t rݶ[P=8h&FO A^,CG/׾bjޟ#u(>ǵQ}a9Eb mF.ʲOGsj`*ru;L*< &d2;+6doo蒡S5;ƞޣKUa&gQ@ڎLRdᖴ}3MX}kAqC޲R_ cSRҙ0b V &89|W$]~= ՉO 4`<嘯E/v_oc^ȼb'4;i),Q^8A[ɬ=/$Vx`> po$gCgF9Yl2^#gTueW8 'q|S+qJ%')U=̔ uȷl3S8pk $pPr `1&V=auUX 6?7/صS$vv7 ]U(и5n@}.}፣28WDaYʼdf'yTq@'.}gq'N?5w9۳F>s;n_dHs!d?V_K sh]Iµa. Zwn6.'݀f裼ڽ O|=CT6&<6S wV &鸰zW7-0T~&3 Li>st!N;^p ("c6SW'cݺbChl>}6ZW} K)31we=\[Uޏ3eS6U ~7ap8kߜv]\^6) zH;#Xtk32q3a\XJ&$4^-A5 ҃)cJw` o0ԘCeoкn ,W?8< ?{vO| K\QuiYox__Uru\;,%ZG2 o [!_{$O*XJ[+D.\}7<1 LXf؉%^@&8AhZV~+0:8P aw[f * lGqޟ.Sܒ >kJT}5;*(sb3%7]Y%\P(`V=o;M=/q0܆yC^?[ŻL#0v&WB\:@ap'~t9g$ar73=Lh96`Y5#U)$sA_Ks`}q+ z}pq8tuR6w[ym{{'G92Ggz{n]>GW&_' /e &U`iJߙ05^)lEпy]Asgt~1-[ZVN4dYdi&Y$eq'=A}Q8q"|uM#6ysX 8Zc]0~^\P]u-%xSHrzT*G[d a<=y0O?yw}VS_L-1& MBP)!,լ@0?Mx63dP|!I G?(8mA>PwmӃT;rE,D̗duom^}X7iV?djiFfZ dߟ>n+❱_E-8x|b&{ Z= V^SV{dK%Nj0)n>DzdF8oaTqv#\ G= k >X_]eEтzJ 8R7^]ڰjO5 2n+%FItThkeR2# t-z*㞛 O`).*lF!u8VTT=:|%l}}a"W)*,(nַЀ"ɦ8#Bꐾ;-v_6'kG!xu} }a=U߉(l񪘝T9]}(g0 %~L*s ؍$o ًw4vl>}c)vC@<9ko=],+k9&2goP2AVdGgxUi ;p1hbwoƮ_ iY,z6#ۻKLoB8|w0`x5c}2nY۽M{@?fub\lqXFSed枒DZI].{ 5S~RHn$9;e#H$&S2NCqB-@~о,^s7֭/eQy-U{&~&:{=DvOpl6LxXc5¶kJW~{֤d ,_1 m%R[qJ0T;z6i^dr oc\V˶Q*Lږ/nK4 BpG *n> {[ӀjtT<:_U!P[xVt(ib7_lMabl~u*>@U%;OQ`QnY6?Â>}0޾iniQ=\m/"Xo?ޫv/ 9O8.tMG3֒7ra0Ԡ`{_#<)vv׮*zٔ6/uVF'[a >JMV; oTϹ9/OL_r#al/kD}KjLՍ|J&<)Di } 7A{!c(Lv'$NW лnho=\Ώsy{XŤ*Tq]Citnt]7PMjv4 >n֜b=f1W>KL7غjmib,|/Qi,9)z8q&,&?Ak˻0j%W+*G`={H8R9rA '7%ajC0p֖yq|]nf,X>: [Ca,)Q8;`$.2VBA7"wٔpXIh .j֋N`t?Y0۠~Fs [6fXu{N5` ͅx!_ϟbH:T.6?H/V2OCWˡ7EnAI='Nd .R ,F?+#؇FTj 91 Neމ~;0axʕ ;cW>avie& ۜ{T ͘^W# 7}琙NGYL颫{aL},_NqGf8^~ێh'sBa2EY1WSCO'zA p!!A'<G@ دPЅQڌό0&bkllx:̐p\~ ݭ.02QcaAQG$:r`/vlzS2R!vo~'n+}E*y2p8oupߋ㹷-dfjí0n*&q!8@' No5gˬZqz)AR=< f{1.Gq&:~l|ve ƨrpv6W@7`|zwBR( ޻8~y+akJZi2PWbm9wL{`'|P_Ev?? Y$zL8W̲OjqpJB~8dS#gH{EyXKfo;{aizhy`0ǵ0jΨXOtd>%|JIÓ^g6e| ]Qi) '4׷3xrj p$@@K6NmQ^0=J||*.'ԁ\ja/D8&] 8MMpOw ßy{̓~)5_ZG>N?a.%ٚJ²E:a.H(㻶68yAoq4pL(O?pBx),Hf m &@2oTI(`z.8qr9hJ&mE8zMc_ &A%'#+G9oZ~S{HSCәe)GßNUdZA8~@v 3jVbS:ǿ1"}ARx=M"H!3x)}"ؽ7f@Q i"w4j"GM 0s! ,W#\:k{z,t1Ffu_}nتWc, 1.o[@謁i_Y~[;vK =$@GBY ނRG?n 7Yz΋)ew?Eلɣ 8촖vzpT^Xrް{\2 zK"!iI2 ȫd`Mt?p .})>Tl //hf3x: m׌O ZU=ksG=נ{ZGʻ7Ǻ77DD`!H~ 2V~tt7pÄڵ_8[8]ڙEBApuxX亴.^q}k:.aI#:sB%/i ‚_>X{tq3,JǑ3&zAv2RNy(g<4zSD7|}/PB7Śb8k"UO˯߻ 'Qwl=K龜OL_<+H6#eq"̍ߓKtͶ$ &}IG nϬßeXD:$+sJoPf/[Gase8qouE!y$kXs" ;Ɍ.`Q,- z WwdAq@qMt/MQ%'=Շ[/8k͟{W9Ƿ4s$`w#`\x$|=k_WBvG 8 ,X#t'}% 3hF,|xDցnO!y5X.06!% Zuiװ4~s",-񆉺'vB۳B'%,zh.Lv|6N3!-H#>s.MH 1uT-k + [Od cWka!/@mjTj>>F/!2FG>flj]R}u12C}s+ř|ƹapx!ӖMOc;;>Lnp-t3L%2x=qƥmОOvXdY#(Slw<.j9E0;*`V fQO0iN_3CS'&\3L޾0yԅ]d :N¾;au^8Pr@:vW$3QV~퐐CZt1Fm}/YXij{ALi0MÉ9I>m58.yEW JBTRJ,WYec[TՠaDž8oC̼S6-X| R A.3Es<fd9;`tuzdz|#Z- 2-LOc߾_FGw|,ɒ=oe8~zMI]#yT0dlL7ߑ?TXUKTݶXqҢgϡswBXi. f5n˲\Jڥk,ncd ubc;HCo#}>_kWZp;x;T$2oxEr Fh-Vkt[cZqZ( k_TGX[ iC,}h<ιVx{(-SCzpGLZ6Gr_꣇%M1nk,-,)ngkt6N*o/^Pg7f<8 jy}6n#Hurī,m^b6-f)*PsG~+e|wErd-9F/aa)9NG_4quCNJ@XKqrlMU_YV76? aXt㌮̫ǧ݃3[*8ahʰt0RrSn"ú pWe l^n? ;:Ӧ1bgH0Q%wj&#}* w~u td`7G~~m3P+( d܏z=(RgTɤ~mSЎM NDKudg]f{'X4j)@? xP}hR k 7\;=CK"^wNJ|0H7Ҡk4mrWȿ;^ƹ?w@ρ_q|Wֽ[c$U E uƑt qk5VrYq";IZ CӸ쿋"p֓ջYйC )/KxNjQL/ YsªQvhv0بCsqD0:$5wlYhԂwiTI?N'y`ʟsviև_v;:7[jX/mpXT 2qmHN dc+sJ\`\ȕO)9`btfu +0Fmƽ`1g=M!m3w-4!Z w?|U63 i,_ay3BS@N(uTD&ˇ8:pcEÓ` $ a *'z R6jgin;2xy۳Ez;h3}F3P,,Ѻ{q6N ) )qKHsV|yƿw@'S"vh> &ПgÔVi>̌];D-7ץPi97|.@_m mNy6 u@u+0R6A5C-Q6)#>y,+ mLP>b}32>8A'~Qfƍs5 ;xHt_rw?8iOj',Jv?Ď=Z=~CETn-G/qm f_^9 #AlAs&8.Ò~zt ƌo7!j+C5N8XKTv e<칍W¯tP n`R}z)iq|W'ѿp`\;vX]rEo kL"bJZ.W7y݂厼&Xh>%2]cX$G_ ;F`qi0* mq1Qf$tMR˱IV\ǹօ8{J[h#J׭Jn¹' dmGOVV[~;a 7;#m_!!nf߁Gvv0zjP}›k:Th(dk6;RT(tQj8a+4i{ Ӳ%l,LjY,޻:`ֆ3 b7_5_UӍbHPr#:3v>6jX %](@?ff{|xVq-5M& <>}ʬׯ^ĒZЭ 0I0}#kn0 Mo (gbe no=@z಩̨`EhW9V \ogL4]wwN{[;B0(yo5?:їȤ (ROY9&ua[?Jc?:ÑuBX>'Ҥ.`;oeŜwtaO&x V{o^nFpy52}`Q,W^Uj*Q(OGS;]z(\ЬW˞=zvyIluô3KܨwB72=9t'ӛotGLدU{W,L"ݾl #\`I'BU ƫ<щ#Ks+ (f}~+d];??7?mzmz erߔI:fcz_ǹu9:̜F5RYݷXn}MOedށN3olr/Cp1dh_dkZ l8wt8>~sXTv]0y8$ASf\xT;.eO`g>6*HxA0g]|QmLs,{X=.yv9Lf;එ!/{ /=C K6;bJ$yнg͜)ʖypa<.t(^IL҇ Ocf"Хm&<~F:utN좰k<5Q#h;zl W7en Pf¡뭑Ҳ[ZaALf,N4;m" Y;ĵhZc,ӊd4l)n5ua_ܝJ#6~Ϟ3wÿ1KB ]^ d3^CK*rx,Xٶ8/ amdОZ+vuJ-Uh[yM)Xh$u0|]l9ت#@x_WLS(t%E9ٶi_놪JdP*H)J$֭h^u~?xyƯ”)zrp2V`6^ddbkkzLϺ}3果4+50#g'C luz0/Q~oZ݄_y9blHݹ12.oS9ٰ'b{AUR.Li*!YY_}&+l`jdi:o`/ U W>[ah]/ soS{7^> I=׎qƩb28-aWBƄ8s(As7S?q"]z'&v_w@zx,P0~RWAOџCHyɹNhx~F{HX+-G:̡`h |$/p6 ƿh+πK$hʄy ޗ 3ʎg G0EYT(ۊ~8 U;;:y,|D7E0qT戩k4>5~>B`%,\wJyoRxȫ[t.En q%0-6ɒF65t> QUa ˹>>@p$[\VzU$8Y#-Q'/h^Jӓwa>;[ukz80mk-:} 9&lamu{FZc6ј̇q1N -!=  ܫ/F9݃r9ϴ{ *mpjU[y#7[/.6vaS0O2NH^9sy9<ꪇa 8xK̽vYg LK#ߥr^w: r 4W(yd+%8T l%n58>vEzt< =Wg}s]w?;ugo+:>!VUc$nx#ɺ"L[>$aM)^ z db[U=k,-3OMy"d ҩ!A%!3[wgvI]\Nq_I&G6E%zoIIjaQ'DʆOx^pľu6190}J[ʣ$gL0lCSS")0oB<5Y#9"ݩOU vXꛡ0|<{4C98#]e lq~ 8:\yH?C0{{/40 Nݼ ['ާI o!dTt`+C:űFk2뺚%$n6cNP3ҟK N-LJN6qrкo>2 -~2زvsޒH hŚ7*4=gO+3I1-=zg=D7r!v^iR1iki~tb% WvWLl>EUy /ҩ(T M';,8`Рls/ iEA&yu/; -X Eğba {%&h.~~9yB&vb6fi?8e-YEs{w3?jϏϾ݄*{ղ㚪+%GFFU{`ږϿǑ"iq%N=/Io鐪q#2G2o'$"u00&"[`F-d Feȸ81լv Dv=ٍ1wޅ4= 2jO `ܫ 7 f/_9.>Tφ~M+~v,w679agɤ7o*s$pAbWޘ,H4ssk/أ6,x.d>ҡZ0jS0 ۊ[x|dᐒە(5׬u 6$ Gh/$Mh~> )X\sw27>y_9|^uvUڱ*d~g_ge*oy:Nq70cEZ}%Clk~=s׷`be8u~? `sSJ)dRYv(Z猵YTdҚUnk*)CwK vEUݥ!'ܾwɫ֫V=V } K)$sQW7\ 6_߬33#w;7"od5y KA\\pՏC?~C/ eo3Am:t(q{.Sbhwm\OGbRFK斔CFgbMS;ڷ]sP%j,ZvhŁ6)$+$Ct'(P-=;>}߻gGdhΚ$2V':$ٔaҪbt_&#?+'g#y-fm(0nP8WF2U 7F7fL^#j.c7AQw 4>~TU<۫*_{Q @L'=YwGt_-O*cP Xd%S*|?DWEaf@-M8ƥ_v FEqW7R/gih3oCm+v ¦o;7GkKڮed_mz!gL5-%Gt2yע`1=")n5 LWWdTpI=Կe7`nXGu(L6`TK{SWHՐ«\tp1Qu%C CQܝ{fGk~f2?k|z3dҭad !cdN4|Q@|U u6}Aln,뇓Eg&dܾ/bVSU~=Yeqo$ R*Ldi.&# g)K ^ɭ[Z7yynYr߉|t< '~yk@].8Uy#0;v޾MTɤAˡ0%Kp]+m7]8)m(f&KyB{4ݚv>\DjBpEf~2 h:%~]s~Joz5jEKKk.x1[!)s[ u=BׇX|unUG=o*y]eHO(ky]%_б4\Rpgvxá00h"1 U>癅!g{ZߊaIߓ Oz:e>k@Jq? j9K:Hf+rTIW{Vq}dvʼnUjO8GlCŹqYKt/3ݏ7)-Z`kɑ/"6F&9"sطe[r~m2G֙ܨ8]y(ѓ M=o"ov1(-Y_Hu2&s簩D}k˾|.#h=tﭶ|%x -T,a䡒>srgB TXl=\ӡsajZԵ׬:$Se?*Cu=O8=?dpzXk4'_L:]kK2wxO7W=\V>, na͚4q`*S=9Z$%]Ŝ7-DÅdNUwvK7tK'm!M}&h9h1yHX`ɍ6-ZDpv}z0fN`ɮ641;eqj?ΒƆ, C͐,2ױ#8ZP*5]?Xڹw@e:ŷm7tqťk0My" YۣrFa%Y< NΚ@ֱ!YY9U}SUXHʌs.xLt~+won kxζAiofAДND'CD&zqUʎp/28KJ+MFxã=ß߉\bԸN4\Si "ݛLLP6Jk?f8ꯏc~vnE59}vAfUNlmm)3,|=H{Z%w)̀s#.vlD#L#0OV;G:o{ν8ar;G ]hoj&`k+h޵8.ʇn 01޷/sRZ2~Lmn8g'94Ms썕:7JsCmK=&\$EɟŪ=(QV iCqTXhzo<ruж[!: FtYP~̳cX1|O&qwpÐ {&&ƆI?B}#(hyE~SCȎ^i+Sub(᧎}!PmD:6~{dLZ4~^@5>8]}@X蹇qsI(0}zuw^rFfR'Ln)hU'OAUƵz1G)-G9-zسs@$& KvDWSqʅ~KuGsrkUMGq xY:u,z/XFN4lK@qp#V(lc*rW/U[6D6W5]:d#/̏`V;/~m7{z$D\'^Luy[CXCUZ% .9]gy>*{wwC :M|#TUv:8< k:SWO9T?L>h Ih:̷\P ]sHC'B6[ױ`j2gAݥCbg6e;; JM|#>%d`|;>A5y5 )\jynt6(6CKOڠiǃ^ih2[ںWDѷ'a;eк7Ht.O/CpNZ4,^mE|R})O @aX'~S2o|ys f- 4$`yg:J':(C^O`9 ]eeqwB5p34fJB``?k?8%*O {xo)cvV`sԊەl&N',R$sg!˷wXߞ<ԥ¯pWE]_9aea#@/^H{1~;w"]KZqA֥hZ`lKzW#;T+U䧤|@1Y_/G! pNr-{'[m)}za.(3eF\Ju)wyU>8NP\Xzߗ !@8g< Yg쟀 pI*] b\ 5*\R+R8eݨb2 {lY/K5`T)ȿ}+^,lS](A&#n0l9TbƏ{Ze+nR\0o"}DlSC*n jIqkqw['U($Ai#;OFn~-R> ?&4q*ֳ{T %|߽S`՘ՅL*N\lz-I|qS'em G HGGNbm<9DA8kA-|?1)@@c!Wΐ93"3\YW+'VB]Iݠ뼐{gp|{g#n{7~@a/^{2OUa ﳔ-z!~&aspk+Enړ! #~oS(eX(ZjC<EB:qT''v.YƟX,tjL8^hU~HčB4?zh?Q?ɂN9;(IcQa6&,~E+t薬!sE]asKy'9q4/-e_䲷qq{y2|V¨zg\_x.&kI%ᰎ7FwLKb G@Xj,O}]!}w,AUW<|d;xI sҺ PY<s7'w&hHa>]?qt0c9߆Hw sk4K0[5ϼԃ# hm(H>ĉͥGYؾ[0zҬC?77.{%uL ʔ7F@a TJCЭ]iP#v2 /"?5oClGH|7Ϳ7zc]je\M8 Ej?|y[/hakcCRǗbu{ɜ:RFI28o7za{Sq6Ŋ}O/yΟ{NQB[>eBR?n>EdL*RWrS9W ڇԎu vY\J6MMĩB81"E((@-čFUcjGCҼ 3%FOdRH8?&vWx}HzX>Dl j؊ VYq  ;[ޑ`& sAЉaM}UdF2g[̾kݱ:k}Ad(wESM>Xuݎ CZpXf~.~;xDZɅt(NC`n#aObDZuR%*Yl|̶ J |3]b^/ʨ[+ X3za^A2 hu)+BmpZ|IO)r Cinfq'qYOfB%ȸkM|m.ňd3 S{jO{`k&Ȏ+)XRShYwf`*)v?q H= KV{Tz+=%]qLFL{Wb4]ZfSTk'+Ї7GCKšxХ.#-`SGeWX'TQ삠T' Aʍ޶XO?"]jy`˅3G=YnDuaVy1dB?&įz,XGijvLxaDu0oұjqS5ZuzW6ʬ'oID:Bmƣj MõF),hi$!ř^-ڥt7ǝ{8y-m1Rf/Hd =Bnӡ[ ,Sm!h35/֒ IS'N'%B qά\[6OnC(6Rތ "ut%XLp¯PAiW4pz .o/pzcf[B=#Vd^&4/g]pa:0>Ad)N)c5?UpgH/q;lݿ*m*<=sDo#L|OUnqUn/POmf.a*Pge 6XMΓmq x8kGYy2{#0}nЏ۾dhÝ05oP1ʋ%鞷|QIrv]ްhGiůY7cI_plc8}`2d_5/vϛ理n<_?:#>`k?NCAndnDm0ml3E'k&rNJtsB4 pMS( [7HGk&=`Zwu}DWFI\:TF& ? {iMp~jI࠵з׮_w(-8f$ew {į,Z8>ߦWH'暗T~XShC)Wr0٪;9 [wT6X?4ͬM}ӡGbyo؝.Ԕa0sVN zŬ yznzPDմY+<-OHgK F_m2iUo9 tAŋZѸ!ށ1پc0~Ɯk`A<,R lMdq`C>g(v|-kF̶͚O) (g=#/x&nFLq1O F;- l"d_xuh;wN_{}_*dΝ]߿awB%L<13ivXhhN#4Xqpb12Jpͻ='a}/h WcIby6+dyVɉio5 cpY/NƼ^+ T| MlwjnYYpҏLJc2W{6lo"^_ZvRZG lrJ0'#tE}Xb:#Lx2zT)L:v1`;,,D^}[彀xCU%W9(q`ok,%My8bܞVq3zSn¦Vsgz?c{v5GV ѣU?}+F8q 4.b3E: FL2gߞ Ehs"//Tԑb}|v<ʐҁ7Ut@7'Cm4 ?'sKvU6Bl[-uloX"Y= }9$7T9Cכ@S L9e^wi F-),{(y䙢!!Ea^M;W>p)?iWģO[R@ꑛb Xdu {k'87 JX;˾ JGyٍO^q^`*d !n(sK]:1)ūTgrL|5VŝVdˌ <-307ԔF[8%U||y g˫W&TX/yad=:cFn_~XopFh6U Ts(9% 7[uΫ T6duy/=R>KIzFAO+= R4m"=ZslfH|aKxP& .lF^2D+1Կ n׍EfaDNxk[@VQnT9"l"^*Ưm*8gJj( .|L I~p6]PqLx{_Z].(\ʼÑ0v'kd jC#í&Ec8❧%:'^ȋ`;؏ JXxݕ/!A"?X6hϔ&0ؤ= ݩ?HI{w~UOv XM` ϚvF8ME&jrS myxڇB_`N==0r?w q; !-]p'>0BrSwHP!%$}u.8o+LN> 9ANs,)∵?cj\,xPYMp+JQz6m5.ڭ/ $W۟X7I낀*C$l~]JCzitq<$J| 3TzRdԑ5W@uqpň(ʯ2'o)@-X7&Ɯ;sF't%9,-%#e*z.\VzB:GjP8Y͆Ikg]C2w@i{؛g0B]q&Gr*`ƶI>t!! W?XOMd1#/V30EdR畽}kuك_A{bj&N~u`OUH"}D)FȈw3? R$n۸ .+y2r 0n=筃W$܏ߨ^y&GƉ0o='gYmyY;ԀC Ex8Gwꨌ05ۮ!EN An0,:@wλ |f`u57<9PY[ Tt.V%QRԭ`zpT_} tN(¥hiLfP(u}4ɿa|Bp\$. {FXwص!wW;B擬-{ߣMVZANzem_8b}x)O{sa8fn,P}覂$7|2T珯d_]-%ƱGT!@FTN#zڋξ᐀a px>q\%@9)$UBfeo#R3Y _{D׋\A"< 4[fcA|e:5ƍ#o_lO='qIN %m&lCRX_cEP9_Y抾%+Xףq#?7+Q7 җ̧K\ 0p`!erK TϮ][4>g4<v4<ߕb$AؙH~'逴tvl[F%\ m̃l2twlZ/]?.Oڻ xŸoǙg+G7A{ 8p0combǘJAӡ@z}`$RڬߜXX:Vy]H %k=Hs<<L3{lU6Nw^a@yU/  Lqū m#]ؿf86 ]p}ֆYA.!M7y .x=u?8qGS&8ǥM{V~x 9ZuMܚV:xld=jZFq.'id)ssţH ?15q'H\E =ߓw8 >wz߻ZRܵ@/BvC>HfV͇+gY_/o<_KE^:ga{9`@2+ )5_a m 4׬=shݡ{/q[4wCY|r1>I9Ua[Z8k`~ z}j9 T>N6?\./„&P FS:׼c_‡6Ns/7T Px dCi-ILf[vӖ" ěSzͷ+4|S O:'Gc۳CeQe\/Rw )z9\>Cb sPV˭JX;]zt"%5AE5Cd)ÖfdY9f\:e8'AvF3̼ηyп=/}DO. _0p9v ,X,G㱇s0~_5GYdm/Sz9-hFp 5_Tvc+F`;yPn ]:ko"V$WWv2Rz[!i0欠a#M9^Fb9ڤ7 Tf2r WR `idT82Vjjϯ^[+O肃 N)VQdlPx12m"7_ŚF`/jڝƲ+ C?F\:9aHͷ3dǯtV}wY}2LJQ玴YX8Nupf)GdRsӪ1`qzUު A'?emb`(q~Ӿ;heb zxQsr}ArO-i\Zqf7wXwLۅt|֥=qʑ! *?{>P ѻM!/Cp6m;Ԅ_FL<٣mVf{lOsp/j W +!<'%9);&aZ%LVm?L5kkfpq.X€׃/]?cע]){}wo2n)UO[=\_"&'*;ݪ9ִd Ƕ/s9\i NC;_Z(N?v7(yxq Ʃ44M4|x^ѱ&BMmzg96-ObE}7%>`Ɂ=Iܭ{ֿ[J#lQXs?나e~*) Me޹4hB&(ev]Gcj܉Ö=3G?CFWet` $m«"._  |{ NKW@_gXr˺=L>|=PQ +6Cw0gbl Dk6E|a䢲6AIϥEnVx>ė4ɤO{Xck1sLsfm6lĥ0c/MCMit`f<vGFƮ̡ yaXd!4+6झT]=#h*9R0}*6Kv@ŝc+=|6&G1GX>߸h@*ϺWdRח5Aip2\,pj_lY A_=o[6[wg ,$ Y$K N`oId> qKY\ 2G' 6¿Z^U o9DwMF<"*X)cŲ8>*I?zq5t)1HO@`LK=I+6Ș 9H,#޼wg|tZmE5U dK.-!5P^}y]}ۮs;[ڧKUDpQo X{#K7/{ |Va7E>udHpуMYhLb{'Ԑv֝d_={!dnp l -"=\#bK/ehFƧA Tmufӷ3lV|~[:QOp:9V{ UްBٻ@S X_>ԅD{ɘL 'K`pIAf?wf`ϛ*7Pj2P3[~E̿ $ KVVU˝}.9RWծ4`8nqVFJ RC:U IaE+ɜ:ۣKc% 5(%qjbF&Sʩ=y9u_ 86%o .+`ϒ3h34O VG>48w t]+! NO]S|569ҔKܵhCOu{N 4 Oj@WCy=_Ft2Osa㽞 + yĂ iY!֡@ca&e{3G8Zz5PTk_%;9;qԋ@㣇ф5Ӧ!$XG<>hG<qW칋=ݩo`fI}ȋg;^-s3=ٽ62n#x tmz׋ 7 ]=o.}6Jwytm֥C7'>{%#Lbm^%,6CqB]z.zmv!?SKaIy ynMw?>SƩٓpxz-,e\8ܼ,p41i竝q3MsJA ;)xُ(K 2dx|7Y`} %ߏ)lGTz%/%by gx},W-'k}8`W_l6L_ގn< [_\[XĚ0~xۿR%jM1 RayD S|VLW1<9y_f~dCW\ |[/\Fq㞶me?#sKΌZsv=0:BlB&o! K@z/J)y*c'-8zg֎e6hZ%aim;ܻ ;'%"3wME&7??ƚx}EOӆAgC k.ÂL-ol*/ayws`56QL6tt0yC &?3Nö#o_ܯ=ΡHa*_L/h&7u^]B^yZ}0B欿ezH>r[w)dpM^o9ߦ},v% x)t| Ցy޽J/ȃON%C1q}^[^*Mq%#fBd- ]C׽> kM{8ix텹;X-)w o0_qѵƳ >wn,^vdxE&8{غ8WHyaw)6Jm˞$r#rVGΌO}6U}3Bg %ef;=0u$c[ `fcSh/TK3csАı9஗aIҽJS!19h򊋌W)9`=ʞdg+00D7zKتmdɰ5^%zXIHmz hsN@QֲШ05wOjկxi~ =elY)عS[7Pu߮?HNǺ'+ R_YQiQ{P=̛YN8y/l,~>Z}?4M )L){%̖zĦ'0OĆ0,jL;7Y8@٤HC&tK!) ,vMӀRum;>61 s!p쁂о|>nšV(^2֩aƤJ,Գ#v<{Wj[tb6e-S|مOqGЯK# fk68-@ h&Γ+U:i(5>Zʱ`GH0 Zp[V r/L=* Wx:,z3 NZ}C ۾heF໡Sg$\X>X$o }Z\i'Шq+uݦ'k+m¿կ#H Lu0=]r~/6ج`6_MO<#B%N]y[z N4g%FX٫wWa ʓ@480:bD=RX+Q^^<-M#su@|d5N.5)Ǫo[~/£L2ž]>aR dx$ōIvr"ĕ9&YԱVB$vvb͍[%\qQ}Sro~%Dd'Hl$NҊ -"2 groups, whereas `group.partial=` can only release constraints across all groups). - https://github.com/simsem/semTools/issues/60 - The `as.character()` method for `class?measEq.syntax` now accepts the argument `package = "mplus"`, which prints the syntax as an M*plus* MODEL command. The `as.character()` method also has 2 new arguments: - `groups.as.blocks=TRUE` optionally prints multigroup syntax in "block" format, which enables users to hack `measEq.syntax()` to specify multilevel CFA models with invariance constraints. - `params=` allows users to select specific types of parameters to print, making it easier to check particular aspects of the model specification (e.g., `params = c("loadings","lv.variances")` in metric invariance models). - `net()` now accepts models fitted to categorical outcomes. - `reliability()` includes 2 new arguments: - default `dropSingle = TRUE` is consistent with old behavior. - "total" column no longer returned by default, or ever for 1-factor models. Users can request `return.total = TRUE` when multiple factors are multiple dimensions of a single scale composite. - New small-*N* corrections added to `chisqSmallN()` function. Also accepts `lavaan.mi` objects now. - `efaUnrotate()` now accepts summary statistics when `data=NULL`. ## Bug Fixes: - `reliability()` and `maximalRelia()` returned an error with categorical single-group models - https://groups.google.com/d/msg/lavaan/rPVEHUQjqVQ/SQaMrgn-AQAJ - `reliability()` only ignored higher-order factors without any observed indicators, and returned an error when first-order factors had categorical indicators. Both issues have been resolved: - https://github.com/simsem/semTools/issues/65 - `fitMeasures()` for `lavaan.mi` sometimes returned an error # semTools 0.5-2 (on CRAN 30 August 2019) - Requires `lavaan` version 0.6-5 - Minor bug fixes - Addition of the `plausibleValues()` function to extract plausible values (i.e., multiple imputations) of factor scores from objects of class `lavaan`, `lavaan.mi`, or `blavaan` - Full support for `lavaan.mi` models fitted to multiply imputed multilevel data; resolved issue ([#39](https://github.com/simsem/semTools/issues/39)). - Full support for `fixed.x=TRUE` and `conditional.x=TRUE` in `lavaan.mi` models, including `std.nox` solutions in `summary()`, `modindices.mi()`, and `lavTestScore.mi()`. - Added the `omit.imps=` argument to all `lavaan.mi`-related functions, optionally excluding solutions that did not converge, failed to estimate *SE*s, or contained NPD matrices (Heywood cases are a special case). Only the first 2 are excluded by default. - `reliability()`, `reliabilityL2()`, and `maximalRelia()` now accept `lavaan.mi` objects - Added (S)EPCs to `lavTestScore.mi()` output when `epc=TRUE` - Added (A)RIV/FMI to all pooled tests when available for `lavaan.mi` objects, to quantify additional uncertaintly in the test statistic due to missing data. - Allow multigroup models in `plotProbe()` and related latent-interaction functions. - `standardizeMx()` was deprecated in previous versions, now removed. # semTools 0.5-1 (on CRAN 25 September 2018) - Requires `lavaan` version 0.6-3 - Minor bug fixes - The formerly deprecated `lisrel2lavaan()` function has been removed from `semTools` - `compareFit()` now accepts `lavaan.mi` objects returned by `runMI()` - For `lavaan.mi` objects returned by `runMI()`, the `anova()` method has been updated to behave more like lavaan's `anova()` method: - more than 2 nested models can be compared - fit indices are no longer an option, and must be requested using the `fitMeasures()` method - Given the previous addition of score-test functions `modIndices.mi()` and `lavTestScore.mi()` for `lavaan.mi` objects (parallel to `modIndices()` and `lavTestScore()` for `lavaan` objects), the remaining "trilogy" of tests in lavaan (`lavTestLRT()` and `lavTestWald()`) now have parallel functions for `lavaan.mi` objects: `lavTestLRT.mi()` and `lavTestWald.mi()` - `lavTestWald.mi()` implements what was formerly available in using `anova(..., test = "D1")` - `lavTestLRT.mi()` implements what was formerly available in using `anova(..., test = "D3")` - `lavTestLRT.mi()` cannot compare more than 2 nested models. The `anova()` method internally calls the `compareFit()` function to compare multiple `lavaan.mi` objects. - For all 3 tests (score, Wald, and LRT), the "D2" pooling method is an option, and there is a newly public function `calculate.D2()` that can be used to pool any set of Wald chi-squared or *z* statistics. - The `runMI()` function can now be applied to multilevel SEMs that can be fitted with `lavaan()` - Known issue ([#39](https://github.com/simsem/semTools/issues/39)): `fitted()` and `resid()` methods will not yet work in models with both multiple levels and multiple groups. This will be resolved in a future version. - The 3 functions `measurementInvariance()`, `measurementInvarianceCat()`, and `longInvariance()` have been deprecated, redirecting users to the new `measEq.syntax()` function. It is much more general, capable of combining features of all 3 deprecated functions without their restrictions. - The function's primary purpose is writing syntax that users can read and edit. - The fitting of a model is optional, and fitting multiple models is not (yet) automated. See the `?measEq.syntax` help-page examples for how to fit and compare several levels of invariance. - Find many more details [posted on the lavaan forum](https://groups.google.com/d/msg/lavaan/oKwP0_6-i1g/i0jGCU-LBwAJ) (the Google group). # semTools 0.5-0 (on CRAN 1 July 2018) - Requires `lavaan` version 0.6-1 - Minor bugs fixed - Minor convenience features added - Redesigned `runMI()` function, which no longer produces an object of class `lavaanStar` (that object class is no longer supported), which inherited from class `lavaan`. It now produces an object of class `lavaan.mi`, which inherits from lavaan's new `lavaanList` class (see the `?lavaanList` help page for details). The reasons to redesign `runMI()` include: - The user was required to choose among available methods for pooling the chi-squared test statistic when fitting the model, and the baseline model was also fit so that incremental fit indices (e.g., CFI and TLI) could be calculated. This lead to more frequent convergence problems. - The `lavaanStar` class could inadvertently mislead users into thinking that certain results were available from multiple imputations that were not. For example, the `modindices()` function would return modification indices for the first imputation, but those were not appropriately pooled statistics. - The new `runMI()` no longer includes the `chi=` argument, because those options have been moved to an `anova()` method written for `lavaan.mi` objects. Additional methods have been written: see the `class?lavaan.mi` help page for a list of methods and details about their use. Additionally, appropriately pooled modification indices and (S)EPCs are now available for multiple imputations (via `modindices.mi()`), as well as a general score test via `lavTestScore.mi()`. - The `parcelAllocation()` has also been redesigned with new arguments to improve its flexibility and ease of use. Users are now required to provide lavaan syntax not only for the parcel-level model, but also for the item-level model. This allows parcel allocation to be automatically detected, no longer requiring users to provide a list of item-to-parcel assignments (see new examples on the help page). - The `OpenMx` enhancements in previous versions of `semTools` are obsolete now that `OpenMx` provides fit indices and standardized paths, so they have been removed. However, `standardizeMx()` is still available (temporarily deprecated) to provide standardized mean-structure parameters, until the `OpenMx` maintainers add that feature to `OpenMx::mxStandardizeRAMpaths()`. - `measurementInvariance()` and `measurementInvarianceCat()` now require users to name all arguments passed to `cfa()`, including the first argument: `model=`. This is to prevent errors that occurred when some previous users had passed arguments in a different order than expected, which should not be a limitation. # semTools versions < 0.5 Find our remaining version history on GitHub: https://github.com/simsem/semTools/wiki/Version-History semTools/inst/0000755000176200001440000000000014764374533013054 5ustar liggesuserssemTools/inst/CITATION0000644000176200001440000000267614753071257014217 0ustar liggesusers year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE) vers <- paste("R package version", meta$Version) url <- "https://CRAN.R-project.org/package=semTools" bibentry(bibtype = "Manual", title = "\\texttt{semTools}: {U}seful tools for structural equation modeling", author = c(person(given = c("Terrence","D."), family = "Jorgensen"), person(given = "Sunthud", family = "Pornprasertmanit"), person(given = c("Alexander","M."), family = "Schoemann"), person(given = "Yves", family = "Rosseel")), year = year, note = vers, url = url, textVersion = paste("Jorgensen, T. D., Pornprasertmanit, S., Schoemann, A. M., & Rosseel, Y. (", year, "). semTools: Useful tools for structural equation modeling. ", vers, ". Retrieved from ", url, sep = ""), header = "The maintainer and *primary* contributors to this package are listed as authors, but this package is a collaborative work. The maintainer(s) cannot take credit for others' contributions. Whenever possible, please cite the paper(s) associated with the development of a particular function (e.g., permuteMeasEq or parcelAllocation) or tutorials about how to use them (e.g., probe2WayMC and related functions), which are listed in the References section of its associated help page. Otherwise, please use the following citation for the package as a whole:" ) semTools/inst/examples/0000755000176200001440000000000014006342740014652 5ustar liggesuserssemTools/inst/examples/lavaan2emmeans.R0000644000176200001440000001046214006342740017672 0ustar liggesusers\dontrun{ library(lavaan) library(emmeans) #### Moderation Analysis #### mean_sd <- function(x) mean(x) + c(-sd(x), 0, sd(x)) model <- ' # regressions Sepal.Length ~ b1 * Sepal.Width + b2 * Petal.Length + b3 * Sepal.Width:Petal.Length # define mean parameter label for centered math for use in simple slopes Sepal.Width ~ Sepal.Width.mean * 1 # define variance parameter label for centered math for use in simple slopes Sepal.Width ~~ Sepal.Width.var * Sepal.Width # simple slopes for condition effect SD.below := b2 + b3 * (Sepal.Width.mean - sqrt(Sepal.Width.var)) mean := b2 + b3 * (Sepal.Width.mean) SD.above := b2 + b3 * (Sepal.Width.mean + sqrt(Sepal.Width.var)) ' semFit <- sem(model = model, data = iris) ## Compare simple slopes # From `emtrends` test( emtrends(semFit, ~ Sepal.Width, "Petal.Length", lavaan.DV = "Sepal.Length", cov.red = mean_sd) ) # From lavaan parameterEstimates(semFit, output = "pretty")[13:15, ] # Identical slopes. # SEs differ due to lavaan estimating uncertainty of the mean / SD # of Sepal.Width, whereas emmeans uses the mean+-SD as is (fixed). #### Latent DV #### model <- ' LAT1 =~ Sepal.Length + Sepal.Width LAT1 ~ b1 * Petal.Width + 1 * Petal.Length Petal.Length ~ Petal.Length.mean * 1 V1 := 1 * Petal.Length.mean + 1 * b1 V2 := 1 * Petal.Length.mean + 2 * b1 ' semFit <- sem(model = model, data = iris, std.lv = TRUE) ## Compare emmeans # From emmeans test( emmeans(semFit, ~ Petal.Width, lavaan.DV = "LAT1", at = list(Petal.Width = 1:2)) ) # From lavaan parameterEstimates(semFit, output = "pretty")[15:16, ] # Identical means. # SEs differ due to lavaan estimating uncertainty of the mean # of Petal.Length, whereas emmeans uses the mean as is. #### Multi-Variate DV #### model <- ' ind60 =~ x1 + x2 + x3 # metric invariance dem60 =~ y1 + a*y2 + b*y3 + c*y4 dem65 =~ y5 + a*y6 + b*y7 + c*y8 # scalar invariance y1 + y5 ~ d*1 y2 + y6 ~ e*1 y3 + y7 ~ f*1 y4 + y8 ~ g*1 # regressions (slopes differ: interaction with time) dem60 ~ b1*ind60 dem65 ~ b2*ind60 + NA*1 + Mean.Diff*1 # residual correlations y1 ~~ y5 y2 ~~ y4 + y6 y3 ~~ y7 y4 ~~ y8 y6 ~~ y8 # conditional mean differences (besides mean(ind60) == 0) low := (-1*b2 + Mean.Diff) - (-1*b1) # 1 SD below M high := (b2 + Mean.Diff) - b1 # 1 SD above M ' semFit <- sem(model, data = PoliticalDemocracy) ## Compare contrasts # From emmeans emmeans(semFit, pairwise ~ rep.meas|ind60, lavaan.DV = c("dem60","dem65"), at = list(ind60 = c(-1,1)))[[2]] # From lavaan parameterEstimates(semFit, output = "pretty")[49:50, ] #### Multi Group #### model <- 'x1 ~ c(int1, int2)*1 + c(b1, b2)*ageyr diff_11 := (int2 + b2*11) - (int1 + b1*11) diff_13 := (int2 + b2*13) - (int1 + b1*13) diff_15 := (int2 + b2*15) - (int1 + b1*15) ' semFit <- sem(model, group = "school", data = HolzingerSwineford1939) ## Compare contrasts # From emmeans (note `nesting = NULL`) emmeans(semFit, pairwise ~ school | ageyr, lavaan.DV = "x1", at = list(ageyr = c(11, 13, 15)), nesting = NULL)[[2]] # From lavaan parameterEstimates(semFit, output = "pretty") #### Dealing with factors #### warpbreaks <- cbind(warpbreaks, model.matrix(~ wool + tension, data = warpbreaks)) model <- " # Split for convenience breaks ~ 1 breaks ~ woolB breaks ~ tensionM + tensionH breaks ~ woolB:tensionM + woolB:tensionH " semFit <- sem(model, warpbreaks) ## Compare contrasts # From lm -> emmeans lmFit <- lm(breaks ~ wool * tension, data = warpbreaks) lmEM <- emmeans(lmFit, ~ tension + wool) contrast(lmEM, method = data.frame(L_all = c(-1, .05, 0.5), M_H = c(0, 1, -1)), by = "wool") # From lavaan -> emmeans lavEM <- emmeans(semFit, ~ tensionM + tensionH + woolB, lavaan.DV = "breaks") contrast(lavEM, method = list( "L_all|A" = c(c(-1, .05, 0.5, 0), rep(0, 4)), "M_H |A" = c(c(0, 1, -1, 0), rep(0, 4)), "L_all|A" = c(rep(0, 4), c(-1, .05, 0.5, 0)), "M_H |A" = c(rep(0, 4), c(0, 1, -1, 0)) )) } semTools/inst/doc/0000755000176200001440000000000014764374533013621 5ustar liggesuserssemTools/inst/doc/partialInvariance.Rnw0000644000176200001440000002437214006342740017735 0ustar liggesusers\documentclass[12pt]{article} %%\VignetteIndexEntry{Partial Invariance} %%\VignetteDepends{semTools} \usepackage[utf8]{inputenc} \usepackage{amsfonts} \usepackage{amstext} \usepackage{amsmath} \usepackage{natbib} \title{A Note on Effect Size for Measurement Invariance} \author{Sunthud Pornprasertmanit} \begin{document} \maketitle This article aims to show the mathematical reasoning behind all effect sizes used in the \texttt{partialInvariance} and \texttt{partialInvarianceCat} functions in \texttt{semTools} package. In the functions, the following statistics are compared across groups: factor loadings, item intercepts (for continuous items), item thresholds (for categorical items), measurement error variances, and factor means. The comparison can be compared between two groups (e.g., Cohen's \emph{d}) or multiple groups (e.g., $R^2$). This note provides the details of the effect sizes in comparing two groups only. The comparison between multiple groups can be done by picking the reference group and compare the other groups with the reference group in the similar fashion to dummy variables. For example, the comparison between four groups would create three effect size values (i.e., Group 1 vs. Reference, Group 2 vs. Reference, and Group 3 vs. Reference). Alternatively, for the measurement invariance, the change in comparative fit index (CFI) can be used as the measure of effect size. In the measurement invariance literature \citep{cheung2002, meade2008}, the change in CFI is used to test the equality constraints for multiple items simultaneously. The functions in \texttt{semTools} will show the change in CFI for each individual item. That is, if an item were to allow to have different statistics (e.g., loading), how large the CFI would drop from the original model. Please note that more research is needed in finding the appropriate cutoffs for the change in CFI for individual items. Are the cutoffs of .002 or .01 appropriate for this context? In creating effect size, a target statistic needs to be standardized. Sample variances are used in the standardization formula. If researchers can assume that target variances across groups are equal in population, then pooled variances can be used in the standardization. The pooled variance $s^2_P$ can be computed as follows: $$s^2_P = \frac{\sum^G_{g=1}(n_g - 1)s^2_g}{\sum^G_{g=1}(n_g - 1)},$$ \noindent where $g$ represents the index of groups, $G$ is the number of groups, $s^2_g$ represents the variance of Group $g$, and $n_g$ is the Group $g$ size. If the variances are not assumed to be equal across groups, I recommend to pick a reference (baseline) group for the standardization. In the following sections, I will show how effect sizes are defined in each type of partial invariance testing. \section{Factor Loading} Let $\lambda_{ijg}$ be the unstandardized factor loading of Item $i$ from Factor $j$ in Group $g$. A standardized factor loading $\lambda^*_{ijg}$ can be computed \citep{muthen1998}: $$\lambda^*_{ijg} = \lambda_{ijg}\cdot\frac{\psi_{jg}}{\sigma_{ig}},$$ \noindent where $\psi_{jg}$ is the standard deviation of Factor $j$ from Group $g$ and $\sigma_{ig}$ is the total standard deviation of Item $i$ from Group $g$. To quantify the difference in factor loadings between groups in standardized scale, the standard deviation in the standardization formula needs to be the same across groups. If Group A and Group B are compared, the standardized difference in factor loading is defined: $$\Delta\lambda^*_{ij} = (\lambda_{ijA} - \lambda_{ijB})\cdot\frac{\psi_{jP}}{\sigma_{iP}},$$ \noindent where $\psi_{jP}$ is the pooled standard deviation of Factor $j$ and $\sigma_{iP}$ is the pooled total standard deviation of Item $i$. If Group A is the reference group, $\psi_{jA}$ and $\sigma_{iA}$ can substitute $\psi_{jP}$ and $\sigma_{iP}$. Assume that standardized factor loadings are from congeneric measurement model, standardized factor loadings represent the correlation between items and factors. \cite{cohen1992} provide a guideline for interpreting the magnitude of the difference in correlations for independent groups. The correlations are transformed to Fisher's z transformation: $$q = \arctan\left(\lambda_{ijA}\cdot\frac{\psi_{jP}}{\sigma_{iP}}\right) - \arctan\left(\lambda_{ijB}\cdot\frac{\psi_{jP}}{\sigma_{iP}}\right)$$ Then, the $q$ values of .1, .3, and .5 are interpreted as small, medium, and large effect sizes. For continuous outcomes, the amount of mean differences implied by the factor loading difference given a factor score can be used as an effect size \citep{millsap2012}. Let $X_ijg$ be the observed score of Item $i$ loaded on Factor $j$ from Group $g$ and $W_{j}$ represents the score of Factor $j$. The expected value of the observed score differences between Group A and Group B is calculated as follows: $$E\left(X_{iA} - X_iB | W_j \right) = \left( \nu_{iA} - \nu_{iB} \right) + \left( \lambda_{ijA} - \lambda_{ijB} \right) \times W_{j}, $$ \noindent where $\nu_{ig}$ represents the intercept of Item $i$ in Group $g$. Let the values between $W_{jl}$ and $W_{jh}$ be the values of interest. We can find the expected difference in the observed scores under this range of the factor scores. \cite{millsap2012} proposed that, if the size of the expected difference is over the value of meaningful differences, the loading difference is not negligible. See their article for the discussion of the meaningful difference. Note that, in the \texttt{partialInvariance} function, $W_{jl}$ is calculated by (a) finding the factor scores representing a low \emph{z}-score (e.g., -2) from all groups and (b) selecting the lowest factor score across all groups. $W_{jh}$ is calculated by (a) finding the factor scores representing a high \emph{z}-score (e.g., 2) from all groups and (b) selecting the highest factor score across all groups. \section{Item Intercepts} Let $\nu_{ig}$ be the intercept of Item $i$ in Group $g$. A standardized intercept $\nu^*_{ig}$ is defined as follows \citep{muthen1998}: $$\nu^*_{ig} = \nu_{ig} / \sigma_{ig}.$$ Thus, the standardized difference between Groups A and B in item intercepts is defined: $$\Delta\nu^*_{i} = (\nu_{iA} - \nu_{iB}) / \sigma_{iP}.$$ Note that $\sigma_{iA}$ can substitute $\sigma_{iP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. The proportion of the intercept difference over the observed score difference may be used as an effect size \citep{millsap2012}: $$(\nu_{iA} - \nu_{iB}) / (M_{iA} - M_{iB}), $$ \noindent where $M_{ig}$ represents the observed mean of Item $i$ in Group $g$. \cite{millsap2012} noted that a relatively small proportion (e.g., less than 20\%) is ignorable. If the sign is negative or the value is over 1, the interpretation is doubtful. \section{Item Thresholds} Let $\tau_{cig}$ be the threshold categorizing between category $c$ and $c + 1$ for Item $i$ in Group $g$. Note that the maximum number of $c$ is the number of categories minus 1. Because thresholds are the location of the distribution underlying ordered categorical items (usually normal distribution), the location statistic can be standardized by dividing it by the standard deviation of the underlying distribution. The standardized threshold $\tau^*_{cig}$ is defined as follows: $$\tau^*_{cig} = \tau_{cig} / \sigma^u_{ig},$$ \noindent where $\sigma^u_{ig}$ is the standard deviation of the distribution underlying the categorical data for Item $i$ in Group $g$. In theta parameterization of categorical confirmatory factor analysis, $\sigma^u_{ig}$ may not be equal across groups. The standardized difference in thresholds between Group A and B needs the pooled standard deviation. The standardized difference in thresholds is defined: $$\Delta\tau^*_{ci} = (\tau_{ciA} - \tau_{ciB}) / \sigma^u_{iP}.$$ Note that $\sigma^u_{iA}$ can substitute $\sigma^u_{iP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. \section{Measurement Error Variances} Let $\theta_{ig}$ be the measurement error variance of Item $i$ in Group $g$. A standardized measurement error variance $\theta^*_{ig}$ is defined as follows \citep{muthen1998}: $$\theta^*_{ig} = \theta_{ig} / \sigma_{ig},$$ Thus, the standardized difference between Groups A and B in measurement error variances could be defined: $$\Delta\theta^*_{i} = (\theta_{iA} - \theta_{iB}) / \sigma_{iP}.$$ Note that $\sigma_{iA}$ can substitute $\sigma_{iP}$ if Group A is the reference group. However, there is no direct guideline to interpret the magnitude of the difference in measurement error variances according to Cohen (1992). A new standardized difference in measurement error variances is needed. Assume that $\sigma_{iP}$ is always greater than $\theta_{iA}$ and $\theta_{iB}$, which is usually correct, then $\theta_{iA} / \sigma_{iP}$ and $\theta_{iB} / \sigma_{iP}$ ranges between 0 and 1 similar to a proportion statistic. \cite{cohen1992} provided a guideline in interpreting the magnitude of the difference in proportions using arcsine transformation. The new index ($h$) is defined as follows: $$h = \sin^{-1}\sqrt{\frac{\theta_{iA}}{\sigma_{iP}}} - \sin^{-1}\sqrt{\frac{\theta_{iB}}{\sigma_{iP}}}.$$ Then, the $h$ values of .2, .5, and .8 are interpreted as small, medium, and large effect sizes. If items are continuous, the proportion of the error variance difference over the observed variance difference may be used as an effect size \citep{millsap2012}: $$(\theta_{iA} - \theta_{iB}) / (\sigma_{iA} - \sigma_{iB}). $$ \noindent If the sign is negative or the value is over 1, the interpretation is doubtful. \section{Factor Means} Let $\alpha_{jg}$ be the mean of Factor $j$ in Group $g$. A standardized factor mean $\alpha^*_{jg}$ is defined as follows \citep{muthen1998}: $$\alpha^*_{jg} = \alpha_{jg} / \psi_{jg}$$ Thus, the standardized difference between Groups A and B in factor means is defined: $$\Delta\alpha^*_{j} = (\alpha_{jA} - \alpha_{jB}) / \psi_{jP}.$$ Note that $\psi_{jA}$ can substitute $\psi_{jP}$ if Group A is the reference group. By using this scale, .2, .5, and .8 can be interpreted as small, medium, and large effect sizes according to \cite{cohen1992}. \bibliographystyle{plainnat} \bibliography{partialInvariance} \end{document}semTools/inst/doc/partialInvariance.pdf0000644000176200001440000062323314764374533017761 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 1868 /Filter /FlateDecode >> stream xڍɮ64𬊛$RAS@ yƢjq%%wJ\g_|Zw*MLy'M]}/.xK2Tk L:w=0^e"xu'LLrL3> m?\{HkJ6B:O) f}?o.%%+s]^A k+>^$-@ʓ=\B KJeMt,k"5J滃[ <^a0R%Bu=.FUѡc ,t{UqhCT'\{=kp/U[S-x߃ =%U*_2TEepť إ,wtikSى́JTK+6ū,1rx3HƞE`Vb+6,$K]w(3iB5@ L(5`_׳-`gw QwH"U oTL?kR>6=O)pH"Kd~~tu|G F<"RMfQN $**y0h3`C) dy$Oc~I.XQaRM[?G U@E=,MO4gWŷxz@(9dP7o9QhH-ReV4:TW,dC|i qS$$MXՖ&ɡ d<&ܢ2-&=esUGi@郫jf sդWH.Hw9b37?wp %J +\p ;x\w, 19J*]WP _+.e\B=["(cr.Q30Ibmd><OhX;SUSծ H:.4Ӆ%U KSN}!)Á_\~ fl:)3:rȌu%BGxV.D 4r!K#{`*~TJH&cRIA62bȡ)RN _ЌZdDΟ.iVjV!HnUsk &FDIʀkx#&l) 1^KZf#XoJj/3o+ 05 M2ebpFЅ|8?j,bwEWtgjhuh*("w?x|U1"ߘ\ 0oD 14p&!D ڀnnh3h`$ү+/ɖP"k=LH_8Ln*-1*ͥ:0Q~1  HK$tP&k^j zH/\iui/3L0Q3ĕ˼g9Iy8YSVVOY Q4OSgـH 14+B ܧmbQq(} ,N;lE\qkOق^}Siކ/o @N1thK=b5E.<5Eגe:DYޯ؎$ I:Ie ?~MV59G8O`xC^wH1 aPLJחWHO…xOSʷGߔE,UC뛛gޙc|x7> stream xYK۸ϯ-T)Ʃ˩Mդ27Zp#Q$eg %r@COf*i% &dVʼ+2VJESlPnmo@+z(᭪yuM>Y-j_Y]+.`r~fͮ$R 'H$GqkuQ#a2ZXSUvE)MA`w~~t1 ӭc rGf8C($#1]90W&< 宅ԀСVhiv_qoߦcD8w^G'SLGea ..i>h0Dk5Yn!D!a gП.GxcB!pӽW߱ xCM)3JD\NFSxC\) @.t/(˝I~_0,h2n FeReէ/4$wϺˌWzyl{n9eʂyz51;`nk*\CQߟf!]cj=GQ|nSc!]#Q՛H|ByV ӊY^c>m.ߞ,ܫBi%J(!Ȋ}ӓ?Qh3m~k 3PӤ?bM ^CMLlTY*B8$H8&AԶQPf;Mѓw JC'r{؅ ڇo 3GD/ã):~j?M!!΀1}-r[ե&e"7/. ,FH""0Ԗk\ī'WFWm  +|im eb)/%y|tу&.T޲@Eha+,ΨqQp{ͭi3}AC%+,56bşܧr B]˜_ۅ@'C0F#B1"qm{!->?v.H7$*1?4]Xvey4k*/yLQ327 V]Lxq:I\~3Lv|,慒Kk#hCWgN4BҎ.p.*pw}{,#0,)_ަ //uut5s])Ob栁H`MQ"GnP& aFѥv𰤉ݧ(_@:8оr'Q>OAϐ.Z;JQ4\J}Hu, ^נf`^<`B#FLTa# ~d2BGB!g2Lm0L\x1iI6gnN  sb=u2y / .ҹ)p.C`:LϥĴֹdU&Xr̘(k52ႵH[A[ MaS^媎8VXb!MJPx Obb"C{~85H{f 'L ~/8.%@J#vtM6PrR,YN}G^6h{gGeՃak` oRœ<-J4i 95 2cTVoПvʍbqbIi@Z9' axBlI4k:q{/# *$1)w $(Aa ) sH(<6Vk-Kp cA <\#RhnqKX9iȞX i3kǀ"x4'TS9ǿ-o&nZǖjj_ؕ (hbW> stream xYߓ۶~BB;yg֝L2sD )٭bAJԁgO$.x}s[cgB9Yτ|fa06}*w*Yg/Y.Ŏ<֖̄e8sǥ$ѱLDA7s,w\H$ V 7Q82iA"c)Ђ{ jX1+FQꇛ߯gb&]Μ)`lg+iƙv~9n~ff>g\ 1+DE*qdFH\ $iX>B=E43?p\ro7T4r(*3krI7|e T8֌faZK|pZ5k|ʌSحb!Ѣ-%(Tm/Tѳuٶ\U|l>(4ڒZunpvi1/{rYW}); njν̚dʖ )FCG\dBd%5۲C ڷ́AkznKpw$'B|0(3bwt0E>sI-r45"hd2q0wg{2+ɳ)"倀Tzd Rdft 5 s^-qIq&HlĿcrNJW^]K3(4<"cAC94ثgMJAIXKYs̱??`ì5҇ϝFa@!q^{j=MdAVߪC 'uюɝYƕ>r SwT 'D8eaf\Fڪ<JAQ^1<)|41kAqʍ sCa*| rU#M?zwFP@ +8q pO#GU>?#a_Dp.ʏ@{.j䊅B"W$2G{ Rc^$$G#'qwaOaT2u {#@Гh1Df,0CP3. m SL^1jj3wɜ 7_lg_6Ϧpdx}ℓ/m#7l,E|aTj Cbmh3<* ԟT;@P+ E aU၈I|ap'p/ "=s!y 6+(^0>`I1-_l>'":~PR-{&,,k/Koғ!&O7b<!p"82`!j endstream endobj 27 0 obj << /Length 1969 /Filter /FlateDecode >> stream xYK۸WUZ KI|SZ'9#adVQ;3~ Erln ht7׀߾m8gbs{"cˍъ e7MnؤR7om@MJR)X۔atw$2A1f&+j0'b[sri?X![QޓkၚQvctBZwZWGYgrRCC1 M1te}ي,][ݮkh6a7Lt)=>XظM }h]bXTUwtr8Y&U|! zpT+*v{wKWG$W-z[Py4m_65u6G(v0'hɾvkQ+vF&\ ;'mRF,'y\, _V1Q%VU]FA?2xSlV5})߄=nɞ4!鳜yXv))$f68g11'ק4J}ߔqVξ,I/ldFꀙs^.K NB&2@^\R2Pjf2smdrɔU\;G`2IɏWJ&b3\e"-/cډ,˚ĨUBnNhX*S|( %)|؉)؁yIu]_`. c?pځ?uwǭH_著VT% 1 #=K@Ӓ@+ NjpKK~~ =~@ae}3Chy@:%X^%s6^ C@;p+u, KSS/ﮏ[y88ٝ9"zsb$Iݡi˧PqXc%eS!G@Z]KDcA1xAiɍs8RM"lel= ' (Kpfp O1Wg8RG^ĴQ>cL'TFS|"_ӛ;R7#RK9R:M8)nW@oPNThY؍ɖܾF ޵#@|ٔ/p@vSGMס/%H4_L8eaMa|4:D.8bѱ0鈽=V ~Zi{Y`T .Eu RL?4V'ԊaTjY#IPs($l걜Vk%`: \̈́1)K=&TMp0AUy[&*>N.͕dXcW  _!`Jikg4330o<QF;2۹{gfɯp mN;Ѡ?h&A-e(vr p.x8v)ހޙ^UJ`}򄋍sc$q3|2-1m_fK%-ai "C]_O.'V;|cc P}]Eؕh1!Lw@4ːE XjLt/__zta6]G:Xӥ0Yjd1Jڬ/t6)]qxBA8=΍j¾Ƀ:"Vn*,<ě(-KR\izEx22KvIBnp$J#ޟߐvdoOStg$gk7~#bk.^bB2Ezs7q&+!;?TeqvBt{鏌u#GDm1E)Wtǹ endstream endobj 30 0 obj << /Length 2164 /Filter /FlateDecode >> stream xYKs6WHUYf+;fk'ueDLIq_(lӳsً@?n﮾{e3%]%ZIem\l۾)E4Vklc ,5M4͛26Ew-U4YsM~߿Rz)cD9\YQLH5#ǎ%6}^ydidznk牅 _VJyJ?w1Dj5QƤˈQ j1{T]M8IVkyzmvǙJ""Ylӈ=8{DdeZmĥ5x13,Dה0w#M8Z/D@ՇC*>}I(`'2k V,w1+ ĸ!WЯPocLl|G!3eDCؾ ǴSx IC`b^#qbt{Bt[ESTF'ܦw.[uI_zrXCƄLUNLC2rL'm ~ w00!HYږdJ-LEirU4#py{6;~ڌ@ncoNٱ* 1s̷dӯqZpɈ]<#(~;,sV@"*81RMUh$U& ۂp1.қǷ+V |@ۅ!`c)ʝWdX:@*:LM?\_}} CšN`SϪ۲)6_r[*v%ăU!uE#",nWc&Oe&]E0E"@NP IfSW{ό#"@"h?fᗪxF:S:_.zع[NAMGgG":"!@@g$D4/bW6W"??m9~J @}+{/:kEQ\@/FuPn"?ՐjI P& }#Dk갉Rkǻ\!Є%" =M#8Hh1A!?nh~b2R4s,nGN/yQa/ c~;wvV28s,>·hX|Y烯(&?8[8BEc?3KP`A =LF%/ קVwޕ8J]U) 6`!ƳM c?_g{^(ls,eP1n(pWQZ睟ʮ8~DŦrGPc^[ekJ)Ok?0:)(gk[4_Pdd,u> )[(\>_/};*PXgbO<qR]չsǡ jh7uW?s$ {vɴd7\#{,ѥ"--[fK[9Te ?=/ji7Ћ?g?3Ns@a׳N}8#< 8ٶ?w@r7MukS{醧shc1f%m`?3u1=Ok }sOI29xAh,*B-v<)FN ΄GsN ƴnrsiI+70;ͦo`/8g-2 C;:iGwBGa iOb< aba (k͆D endstream endobj 33 0 obj << /Length 1514 /Filter /FlateDecode >> stream xڭWKo7WTP@|A6FsXk)iծ I9ZwA/"9;:}3ΩSJn3aeδt2>-fr[f:0SB2>걤̉L=[jʒMT.(n&@̾I6L{dC 89qآى; \LJ{jv! w 7n{ "UۢQRwLJzt ax_/fwqÉ&gq]&u ;`I M0Rx$}z2nS  Ώ֎5/&Q^-`V p [&]7J+NS 4}v~jp!iGgd'kz::aN=]*Rӌؐ!eUSUF=ԤdžjΟFZutpjV]tEQSWu$T;N5;JBfNp9p rvH  8Vq֭a ga UIըc@ 'W@Rq޷>mɏ'Jv(]:x<@=VcXrG?kU|/}fsg7xC8z#T@Wh*lbwpp Ȍ$[?ta/oo,~A8盪$(|+j'صi}- e]az5E&-f3tCw Ga bt-s#ANQi̱~a\1,) Y?Jv _ iː ! 1e&1 @0&h}ej {%OM6pm4"ZP="rVۦ 7ޔ#02c~ +ā\ %@$x@+:㍅6YE|IÕ ^*\qlu]{ÑmYU~d͋0<"h!zh4|ݕ}P]1480K 0TX%n]~s&d}gc/<¨B4>*CQ0ʄt.gi!pnǴ֊QNd)q+V"0Hm}k/2Ɗw)&nz sq7`:VUSc,]OCw,̱ա+;p@*7PY`K\OCȺChh B{}q}(cBcqrO<6\,d: =z 4 ApϋÑk*dpt߱ 㓜rYF>jwRz#]_m}B| {\z0^NёOOAiaY/*s1*_.2ajC"L83حܮӋ^ƿ endstream endobj 48 0 obj << /Length1 1462 /Length2 6378 /Length3 0 /Length 7368 /Filter /FlateDecode >> stream xڍt4]׶ޢwI0^GFｌ1e1=х( A!J%C8 EG@ sb<  AHg`B!DzHܽ'YN/ 0xA>: wȟXFPC#n nP0u s  5_d/ۯ=fCzOoݟOs]ap_# o~csk" H ؙF x[$@> B'p{Ff_#~K[Y*s7w͌5Lt/PQ@ x%D@aa 蟁@?+ۃ;g?"3!ҁJҭD/Y]2Ug wƭtc SM!ͮ6ߨt; 0'$KqЃ")/Ys zp/ /v7׭,C*00נ @ȟͷ+ x;B[myAG8WO~{qDC~!='#@:@\DB$ FDm5_L0 KE4FvW˻1.u4IY q9Gq* ք*]"F;]y7<M\1лyzP}b :Q;SIƉVaӬ38H^z<.C?ӳn>&K*CY&,U z=<%;ɆRzH3([~:͔q&gyftc%Y*+f)2ƈޚդž~-ܽwZ{3SM> Q{;\r,X@>$N:Cٝk>ϱb4Uu]-80T=+3}(|!lB%rBʧ C3z~ROYd+7Ʌdj+? Gϟ|2TOJ~ʜ\;mOk*`] 44Bfw])gDTI˴p5RTSҦWfO8}V15&3~v5 p.yk<%SȜu²6RXX/i9jc_ڗZgLx~b9M8$J;^lL7d>yjt1#R_7 -פɮMFYb+UٓQQd<@`6[os%=x* {wDdo>OW8/*sѷkhxޯ\oN7qPgj-۶ IdkkSNJzB ceMֻ3!l~ 17GIR̃_hޓSbrr!T}ŗ?g\<`{/;3hFop4RyC;˚scVD7}a$#l@T1'IXoG7Fh)]܈A-;ĢE^-G5+NhǺ6zcYɷDGrBGnCދ|ErThp,i[|Lu5r7*Z U6?V(.f8wܸ98):-8ԥ,5E%pk>"{\-*u.y3yC7q!ҫ˭[κZ|?(+&̭c45q6'a3F0 |\bA7'F~x>]M]H.{|,pjUE|j{vaZ dԭi>?&`QZ/-&r|xU.{3x7Y-379OkD*~kR8U ~f7pX efv9̊#KCvTۦbE\5EҌ %DJF2g(A ] " YXQpvֺc[bEWbw/4Eg\z_R-I?ܟ -<}څ%MY[[kQzDE]wbW֩:N>Q'AiCJO%CUp(GV:*RZf-%.E{~LE\ONuUsnigNml4wa it U4KfIyu|K"جW`՚Wy/[Nf4`-_Zy>g$%3eCB=UDvJ|Q{Ȭ4S\Ocs׆.wc5}7S_s6+HSeFݻG\A^ K|uழS?ZddtZKƤw#buo#b O|nj>,4hTHWIvR/6n80+BsCN4nޒp",zåC+P!6u{JcjcWu.wt#(_BOM/EPo0QH۞3J+bP 0cHC:Ł|C k S9BdM2?}$Ho20I]"'g7/8 i)<i?~JpH_I=TAl"TK0x e;fPph>gxn m' 7PWtWR/ԓthZQ+C 5YܠM__,=AP|nBCAE(q ^dA>> KX$z2GaCSdz|ڬ9jaGw{$3(N"_}S{2@3Zn7c 40BSҡeM |nnG 3:n+T:~YisHc#Wm/tT*gx]_-ʌIN4X#:Cݠ/@_œ`8fAXZHh@'?"Ng(Gem%elۻ2wD_sn4Gw  0B(7 Ł2!ڡCX[+CvB<>T8r:DŽcjfofN08\YC}gJIn|?2x!1͡+ܷ's ԗb}^UCÇjٗ;Y_};Ȣ^:kLT"=(8(s[yXXvlU_U`w>7|扌9W^,"Bd>1pZy愾-v]u?#o%Pdն+?,) \6y~q&^0[$[Ϩ]C4kWNҳ4w^[Zuc(R1TE8#ZITER9P Vc,@[%Rr;v -z V'9ya#$X%hs" EC̒䂢 +l3v9Qƍw/' tU<9bw\Lϲ 6t9T~~j 5ZWH74Qˣ*0 ;&{δf/}U(` Jl4)m&o3acChږn1k21l~g=>s)zGf>#72摝EĊQОzj$DӀȮr15jnu%pMlҮIJiGx*d{)9 ï1OV&g> 4 ;S$H\ƍc3:F^782{iOp tz1NnLyU ߝֆ&-%%׼tʷ_hL3;Q5 xuaNtXd0?|lx~|kͮB=zW3`LCk. 4#*bQE ^x<%_mc\lx7'-a0*]r!]BRj%)VyP*-Q.ʄr!;>{H|y>&co$c2eg %/Z|Iw{ufv %fG\'>Øyv 9ۚzm3-zp(|ov`>Rڭn: %c*! 'Ϳ#%v YL?#X_tI;?.yt`fgYx?Dr.&VyЂOLsm֌{bJg8I/BTJ0]SF)=lNJ.}]꟞%N&lfS- I/U1PVi *`3QD.W7H^!;?o邞X.k ϶ڴRuSyvv@,U'W-3<5O\WYr4A0k1޴tDcE=g?/MܨuSk{Q.= ٙq;2C_+v ^?ɛdsp{=[em43'XB61njOT#0dp4jM%`J=I*Od:"V- -X^wآWȪX [" 6Xď,΂x^bĽ&ˉ(k髤̽;QԖ 2}[Y^ƍͅM|ߑigf6ğR3T1]_z۫\C?&i d༣N1C>÷l߇R_ &9(y׻7{r~?u_ =ԖtԻׯ34< yx*:lB>sO$dڸ.Os?9[4V_~l*UurМ'^ nt}p `ӬRJ3VZJ>_4]"ִu`JZ_8=60;, /`6*UwY' {cڶ1M Hmw;hf^0+9q;ƛw}4ւ7/ϋ'ڇL [c(*63UOw|1EHva򓗞w]etލN/:Gbń;fd”՚EBIͦ^>}u#8ot]κGMBdޏO=vF'yyt1" UR:!zZo''O MBt3IoShuN帢jrSt2YLq'|rėE_k!E.}y;SXq'T%z0$)M˃nd <1ޱhw2E-]g,oxMOvfW%a ģ$.DdOK3'﷬ dHDu֗>\`!CsH PV8_/g 3xPz']W[Ll% .:m&LLpQސkWUW*Nf0m$i hz:x\;4ykAǛƦPا +9IqiEc嚄l5zθ V<O!SM:3[8+y ˨*I1xXUo&w )~M$ p|/,T{Dh أZ-mdy iKYQ#p $B*OP^~@6ڻNɄWHaw[QkYˢc) R4zx)0E<,Pp)ǛK'iZgt*pSN_9MA/5jbrgSݏrJ'_ce睐꼥وzs/9].+b%8> Mt2=74x^~ׇZ۪!ng3K#t8#R 4LB8of>-7I+q( =a-;?f7/WwD~&刚a2Mf;?Ɵ(zhIif8n=l\\~Ү1ט/$|gFSb6{}g11b=CM Mԡ&v0ؾ|p[<˻6d1q߷QG7ِ,a a zlWg? endstream endobj 50 0 obj << /Length1 1771 /Length2 11783 /Length3 0 /Length 12928 /Filter /FlateDecode >> stream xڍP-` .ww'h$HKݝ\wwwdf{Ugmg})H V`zf&3 B6GHhk-P*YY̬ffN&&  lybz C@hH!jel 26@e@ ` lY&@׌ze+_!L`kFFGGG= ;+[cj:#lPm-,ƀHP1P2;sh xP|Zi,030/߁@8XYXY:,F s , Lг4mgng25t="@ÿ3Y@{d- E,,`;lp,-]@F0fTy!#3L\\ d`;5%okV6 #[`2 KFۂZLc0}ye?QEGYڿZ[)"bpgeг3X8|,^=S_$kCLꕺ@?Lfbg2xb.4H=՟/Wڃ_@u,T  A뽮+$@N@CO)Wp K?-30{}F^Ju 7.!ni`e{X9zzΈEW55:n#ڳ;98"E"n߈(0XJW? 7z]F=sk%ܯY Fgfb0 ML,, ،X'k֯2[ڛݿR6w;x\Y^I@ mm_'&N?t M[VV ;o$ުЏƒ{'E+K`5mM_pݬ!uf'5&֏~zC@:/BS`@ց hhܣL{6Ƒ]_|[Gea,u%p~%·uPdR;h վE!^[`tq~16ϋo3 1\%1EHpEcOpMSLbpP[wL<Xٻ|2~-I(y5 N`n#u5S{|V1M,7ФgPNcfq4`BidNsJ=OlQMw|Dli9Q;v]S07K@4V -l㎅^?pcԭ0AHOE ?q!8lmNnGv'|k :MjPd3lL8_ '`Gmʧ2NxO)p\w/FEaO'bte\rRo#1zm]c2efW'h1_Ĭ!2?~ 32#Moc3uă܈yU@*&ˈ3v;J2TYyr(cˑ] oX&5D I3@Ah ĠIy=?7Prcu'&˟g $<3Rl)NƩ$_.|i7 #49шF]r򖵻$6UKy.da;SӮ =[\eGGDDҾCμ~Oa^)51mM˗0A&F-ESw!hq@7:OTᦔg?NV̛Pz_nOŵյC%Sm (lc͇?c8j |Y66Nㆿcg z=VBn+9`P>9zh9@1>V^MR/~w[j|,*4p>0RM1fE~Cc\ 引aTP ?dCw*jNNdn=m@{fĜ6ʔ ^˅4ԮCy-!,q.FPۤ@oac~Yz 換5*1&)Ɩ/u٣MKf ?34f__!v/R+:ƑUlQYQM'ɋ쭺>|3hj'~z5ZF=qc@e-PCԕ(4KчK ڍ-^x7ظ s\5Sqd^ `A)l`t=75r٭ L v Us],VOG,y$A@M]Lh I_w9[~ކ!, `O I=&-dZt=T a-'Wx- OE};*=47qڷ`?%n LE|ɸVSck:oq;vfh=\H3#IE.oON}QCl@~oT$jéV9,|6?1z9Na6%lmX6*Fw_ ){;+p܈g8YW.Sʮ3"A%]=3F\t&ޯhWܻ<{]'#BS䶻'UÉŋ'}g*ް ǰ܆PQR;x;)ʤAi ϩ}E45F _:E#%(<1f2S "n.]P9\J%[4O33v G~C-/&4* [PH(YSǿp0ϙ$cǔ$&?b 5 u0FI.;oH7e(ـKYO8 ~)j_k0|lP_ ;ktv3s:a֮ԄYpޞk練K.v =v#Ù`Q_RN%ńBq^U-ZmwΈWF%<?,bqK0 ;u}.S)iI~C{HR/e7Kt^ZQm{^By,Wy)9ܠuh tRg/Fiks 3wKnd W]];lz*lQxiYhmظ3:Msœɒ1;ɢjFp2qԧ-&.Y"XIg_22cqT!\a˭hz?|Y2'5dT̟פ,20G+\ZOo_zAzt=C|/T75b7< ˭MvxK?gljyI*v:ޭ=+.\,[P5fmϟ _̧#kqX@Z*FLiuȶ6{}gz٫y6&˛jVE'CpU"9¬r4v&(o@Yp1߰+ ~W\..u:qÆm8kumD?c C+u<.>q4tn%Fs Vwvqw&)5z W;6"SE!SK֋op+J(t ʊ'NpgޓV%$h mܛk iZO#iaAF^zj%.}HcƗHٗǏxC\rKiʗg|To,nݥߔp\ aܰYHh.P ]2Ix-A"o - NRpBTf)X+#b2ÏrO>UNyɠr[ 2p'"lU)F0,)O|3Zw><}^-X\S6p+llδ! 2âO8"^*0rԷM߄4*0F1LlFW$*QH(!^ayk 3R="W~:s<}s&Lu̦LnmXkOMYڔc/\&.haj3a bg~'r t_Xf2gDvNuaEK8Oϗ=PF)]~\# 4ͽUݏe`gε(8/̻ DŽ &lhtn/ovI-F- ȧ!0 ˆ9$P6߈b#M*?}&>!gY#:J48`j7Va*aj痦lQ3ݕC&mg=W?IZ8W0F]A5@B֧z{"52 aE1~k= UOs/ׄɴ99q9;vվ~UK6'Yw!hq0קξ_!'H{KZWh'2VF=8FQTo$pm=νiEm-n']Çp_bApF_@c.3(WݔGcO>AFdD効E-vk_U݈TMA`GMRY>=2OfOς#djDs˦_MF&UoX &f" JD4T5׌̲"؃Mn86;x;xdԕ]1oKOSn8~#,uvv6O$?q-_5j2m&:yh-Kb=aMylxDYMhY܈e gg=@Zih+$1FƅX偱~W-(|i)F,]fpj:fQzڪBѣUPdvt?5yjgu35sdJcB7*ˠ9 z&g{V'esrS˳%]]UL\$ZTy{GTp|+p2q+*A!_ v&-dL^}s12 Bp.E߄L:62G9B*{+n Ӹی%mDoʧ#geyVH$()ǷD,CM FQ}"0d p= !oŠ`ĵR^tULADÑ-njix@ 7G70 ڬHS64ݢiʬ{?^dGh D3LCr}={S 'פ  z+CSgBK>>@I|I}Mm#;(D\ײl˫X2nk-#oRZv5t:}irg?PyeP bh`#&ʕʼn4I_7* Hs @#6 |&E(\5[ɰ[ٚsd|m׆!BOtl&Bdx~=#Y4#S8p9?eկx.j~iZȭNW}%'1RS$}#oH-W퐥7S%x ōİotPM9~mHZSH~FBy(Kfdu*VmzK ԦoWa7j ɕT&T̩'ah7LF} ъ"k 1nF|*#=_P)V2\Vׅ {nCCBؔ!7K㌆8((nOQKfڑ$v7S;)ab:dMdUQJ/7C}ЧؔbB\?BN,L: fm-}ߤ7wQ8Kh ׅ'nnQNle&-۝u151Q(3cIC}A9#99z9;x㊰C,_4ly]M4z'16q-ܧ~EÊn@묱AS۲?ª`̼ho%F Db8+=Pz3ZD柛hN]}`tM~~)őXmAidONHWnWrT˖m+@C*j:k@u-qv2K0* )#/FvN$w.|\v xlKXPU, ?->ѿ%]k>` QZC_Hy(*Cg0ȌRoŇDP/<2!e}Y[0!(UGT$Q%B[ fRI7eɳ5`wnK%`b9lYq K#`g铹ԛ\8Sf- $/q;Y.|ê EC$(۽_f+e9Ї+44G$ՖT%WV,mXEoȁB,rKcXX'_+{;`s`7 ƜAiāWEO7{(WjY=qt&ңJ Tw<d#FWhuJT"ƽ$PͪIL;ΰiLbf:jkJO֑H9 sn[!>ICiMG~M);T~۷zȝoY`+jw퉕3Y޿i֭PyJL(?붠~n5Fuf[F4N9fR N;7]!M!rVjpW=),d wN 3ǁ\ #NF_lpm75"x&ko%9I0辣q1,'lӆPBٸ㚌8C$⓪&t)F43d%ov|9`4{L?Jߴ5t˵ b؋1o~{>b+7aVܼ VL6'(AKSDěwS7J eܩ]3~{/mXjtIF,bFCihMyVm>TaY@){Ș[HF58yB. Mvb&6e(S SLc.'R/8ޤtP7K|+RMTzW9*#g``WNՇpwXN ;eb> stream xڍTm.( % 3tIt7 0 0CKwwH7H#%HwtJ7}_5k=s_׾i)Xa`i b $e@ 'ȁNKA؂jT? $& N9@Wp29 $M!E6 J!Vku01@,bv`G h=hfb PA d@ `Œ, LUƆN P,.&`b<`G5Y[{0/c Xbo߁ ?&ff0;{j ؂o -ol51}0 @ZL`P!8bDa,5ف8$!`5Y(7@-~adϮ88e%6y[f F||jf;=[P=`Pb~C8G'*@s` @A ?  >ps2x9 jo?eUאct0W+@@(@No_Y `'݇>+ev0;쁶`ÿY=|@\GQo,߄lm?j;uBk.-B?4Y)J^=Υ{w=Wo&#%K&ɅZgV^* b*1zDnB!OjTmPx=bԭ+O5'w?_r$UeТOkLp8r-Ɨ&twVe'^bj)flZiN\&3 e (Y5+$5P@ pZG!͘…i4+&sV{SZ$(G M*`-"tzDNj~Z(oأB),֫$G |Wd;xZBv/KE_arN}mudņR +flC|PNȑp~~CfI'LӖg~'dH L.*߄i'i_w{mﾖp&m0lG"gzk%"JxF/w~74WR$i,r\I-jg']X1QHoȟ|ܒ- `IsQoNՉ{%$lK˚:jZp!2t.ncYAۋcSԫyhLZ.)*t>t"dx,Vsk*lGDEv`1R ~Mx!Kz)'~BD~S]YX{̴T?\4]reWJ5Xtc)<ۡWA8|w62e OqQr2[y=r{nC>Cͅ;iuؓ9&F8O.ݤ:氺;mw.67ɢ U'qTXnثo){5ȃ2ZIo gx>E}4NW:#XX?։ps< W4 "7l y7sW?&}x9 /4AѮ-2`sY-ԩAcCw^ t87 /ب1a+}'3)CsBv[DMGEt1_nYwicF} IR7nPZh/;Fc.[,6vv1ӶuψƊpiT'4[ȖuD;<ɘi'4p'$ߗ͞}]l hU<4/%!~G_*L'P m+͓ňv׭O+߹DTkM|>W$&Y '׏?O=mq/R?cL8Mu:AU,Fh,qF~DًN=ZqVoWiza5ڳKGՙ3H^ 0Q=LyJ6Tb97`y50HKWhBUk`d4 >o9lɉnTl=ڻM[ȝRgW6! ?T8_c0J (=YH>J@v =ΌQ ;й68ZBw907{@7j6lRk aMzw[!557.9<==Uk`4_Hc" @U`I v.;dV@67gg跏+ճw7x" T+\w.W45 OON/; N-'/2RTkvVbبH \lt[>-"I).yk[໼G?Mb]:_@k@gwMK췣7UF 72쬇+TS" %pꈚ5?jݢ}.zD5"4>m5ѕmyQݷGἇX7ɥ{$cYIwVc`sb$L ,tU=tUʔnbk XO_=vYү$r>?ÌEm#0V}Uz\D ra㩑uMy-Є43-E=#";0(ψ4ܮᅼMjm.[N@yBstO)I`CO\~JE ư帲wդ> =gF*g& &Ij ,lM&?}YgQMaaTmvzW/ժ#uO1C}Bjf&MMo/v+.n{mub.ӻ֤2oex Y7`}-z}fM|Gfj\~Si4Ot$TqWE;ITr1?Wq87+'; ,_NbUuY& vq?jc!QR@CsA9*o84u_bzȸK:[\a)9Ec6/+tͤ5_5TdVR^ q)E3`cC&7{a T$(E{ v rZ]Ze(I=|s3ͯ󆌉GO3$Ww:HVx!QFm­55ye'ʙϯȌNVW>_'O#~jAgt ziNTJe`%7CЇOпHұU>ʞ+E5~,yW$Oe3yΪ~bod\ֳαƤE9 n$=b#s8%v= F5m3/{vy@V_"_f/ή~$.d+%X>DەiwRZ_!E9,rc4ܧ 5^7,F[TfG]]h+2% ιGVJ1&>oLyRwz4m3 jO.khFk9zoqD` BGD@+>mDcg7$޷S!2z4c I7SH!X<8o/.bBSEF1N3W f N"7/TJ]Qd TR.7/IlhvܮU JUyAQr//NL|)Fsv^a'U?ca5.A$wSd6R[c'Xl:2+E #DWA`TY%F* ֽc∳ ^Gn3zE#pH >0Y (f,|HT֍xZ (kieAyקI#=bo >|Dd0ኻ"KL05NH,ynmie:%FwtjrӆzdzDMܨ%\LPxLS=XRaE':$WVДD͚0QDZe)bISʀ jSE+qWőγ;M37ㅥ+r%L꫹ TVHg!ZFx_<F ndC=v'a<6A9fDk/zmMn(-JHް\ҷ^ر]<Va1V8P&C) c&;%3Ł' ,Am|kLc]"o5;Ay:IUtxW&4\bٍ/+%A^t}a‰ JMИ`~G57Ij% wqw[kF [~<X$ȎW!<ѿ$`'):%gn{&ڮD공_hg/- ↤ a,yR?sO4y-ۭ씊ѹUׇμ\Z}aʢdGzerw<ױ'->`0gP:0^XՅ[^qSln%P0eb :*yWc']=foDG>IF^ib /ΈI+ '?y8(SqZ,&-1Bc禈}96o?):F,$)OW#:1vo[e6>?ϺGS9zT0g|'S<,^>\Rx6Y$-ۓJdWp]޷m`x^-i4){;ksFgi\eX/'}ӴCe-PpY#|iN6 "Gr,%#ƛn(c+yO@cg{!dcox |0t/W: u$쬚 - &'7Ƈa|CzE"*S"OSs^9GAV`)1+Y11>2aDgl!\rTuzӱ- gB* s(`a }Toژ!WZ~H1pt[8l9sfxJ}?h'ZioR@NKGj(ϟ4ZvV7d߫~C+~zہvlS4Y>n|V($Ϋdjs0h8ghO9n2#Tj"p41[+Sө7N_>V>F69 }t/>O>h'%f}h+${4-GԺ59ÁdGR1\~sJz2fbh&|ԡ#q&4S ~sUiNLN\XnZmd{;TS#bXxsF"g2dP$i%&(hc4Q;` _ިƋkRuCg)ŖM)!whٶ8Wx݁Ci=O'IˆĮ.C#cxgڇ_@쯝d-H>"qo:@T%GsC Gc࢐Y{u>v;yEJ%s+ҿ[+ m9;bpI~Y^5=˷S8bG9zg3ޭ'S?SFM$;dڂho*KkꢃP@1gg/8O,PZ);ZB$0f,ک)ꃂU9CЎ`@a_#DuTC_6b2np =N'xiYuKCaJFJR+!QdZtHQ8'[߳хjp!ajy%ZRwlX6[>+X\z+6SLf*t3{] r?o5syIJu_6ErP^~k~WU(ldo093y[O1ena{yVxg:͵UKj`NRݴyKmIBc6;_ uQ 851vyD<*Q,}?`]kJF1bd[}Za-Na";ny}|H[oPf>vdu㠱dCU /h%SUΉBK> stream xڍTl6L#-ݲt#)ҍ ,,˲4(]HHtwH#tJ()><|svwfYtl`V %'W ರ聑_0.A%EG;Là5W_/"/*(6u re=`;{1 `>s!@(@9ݝh ta`RK#p ^^www  a'Ft@. a 3\= E [.wPpw8@W@!?Cxk6~+;hm s` 4 =@/"w@6x_X#p E_i99H_) 뻱{YG(a jΫ;TA`v $@OT\ra>/g,7oAJo7o tC<"iyu@j zU=A#E #k `(H wY֎w/˝"@wG*Ba66L@XD |wBx߭ 㷆|:ƞx!قO uL{ڝ<^ZSˌ.yVK)Y*~x5^ 9~NY!)k?_ksil[JZqiRV΃s8*:. ݻ:](+~e!ogKH5yȂzD.G^r4[N2"5☖Y|ԚW5l2]Ya#˹[Eɗ ""qf>e>`0Yq?Nia0o$to~AOB" ZJqdA7\3,N@nHOmPQ3lPd YU! m- {<]+e=t|#m7Z0 Dry}L]DV,'k|#jU ;ܞ(Q@b8zAbn5;W,.< ]‘jyH&_"g_ϔtkxX"گ› 3B"^65_G>Hgs!024Ȱ' 4nKgN,hzmƲЈ׏,24Dbʂv~7[l  C0&kգN/)SXhzNt#iQ`S%Pg71\( 7uÖg_'&7Qkߩ=5<1s 9\K;> UGKH`O*Ϯ"B"Wcઔe,6E}kQ!*Ε2KJ2KϕzR;!?bKIpґS,HDXgybw95FA L\B0>MɀKXS iaMI߆)a!EΆׁܳ"0l8ϩ$IQFPB9{0J]ԙapEG}Лxq*\ƭX#ZrZiki?c%&Di۪ `(!!Z^rl4oNџοh#>8ܮi?&&UڼD-k"֓M 8Q.a&P#1ʆMu˰:΃l,ulJ^RǙnx!%$!_{aPܒFGLfJ(1$!$ 76DCsj3y`QhѬkzAvޯ_x7e;&AYbVec.ka- -WRNIko)Cͣ9W6A(˰\9K-nh~\v#ތ b:8*J.#J!T%׳^uZp^LR?˧}5ިuNxMxP?Z޲sjr1Rc9^0~T<| RCPExt*Й87´bヅ,}S :)is%W"}$|&}GdStK&CMD0--X f_P MK'֭ts6!wFl'ϸD<'בy] ޽Z{;}ˠdN l%qǵEy5@1tw<={nҔ,vaS.'FI֫Q;nᔔ|#2Fj$qOEM)0m7Ud&lb쑪9YsX(Cu"ԡ)\9ňSyG挃ڗ-^ݪo e# \xc8Q$FΕI3I$>{\>X2L<`UTD򗩷OE8uN/?FT۲!FE2OM0KOGr#;fhw ({lt2lpVh5LpMr-Azj9nq6 z;&S/ǻzV><_ݭtњ]z`{ŮN2֥ O]_¶F04cZסCwisShJS K{ cze*|P5𣏕u<0:>%]jC, /jYGogܬX{ [//[-鬆S(X%+=uo q 6f= J(;ĆqpLLUg{U8#-O׼n{ibk#{@/+ೲ'dnٖGTVC6%YʙmEERe{"Gt 3.#blD@ծ؇ Ё\a%n2L;Ta\|17 wXs$}bUy]pTCF̫JV-LO%Az@]w(Wo۱:6?Я(]NPF4G~Be dLQ}"&}1rZhuWaļG+24C3D&`8wȄIim^>izõkkyA"ɱϙK&qsnĄ]%ʬ= ΦF 콮\+dMkW{*zz'mL{U&^:zrzVYU|2,+--=?|+5ItFl2DU>{%[jDT9ee>ǒbΨʎg4DpZ۝μpru+[' ! ׃ƘeE ·w4P~1뺵{ a}SUsְpO"5є%䑌F"T#ޗ.#m|.)a=Xgǔ_+] K=i;9%>Iyqt+80 M rچ QK&eLĶUKTVjolhC-f!"L拏~S?r( l-?rس37l +Pkj 9˙61E95?*{z7; cEDϵ6|FZԍ?b{^cSa&sxU0>0Nߛ;h,I8 +2y.M..Rsy-&3gi6 Dw#qunHڕ ">Yv/Ό%ϫ [I;7E ]SA\~/6s5F#WLeVh2pN2XgCIn+YKhC홬8J@Z+=q~=BDE챙OϘ+CݯR GPZEqǴ{ɨG[Q=2fkyLOֶT6sIH2P&w~:$KקZe*_8h4 J)Bɠ]ۿx{Waz@5ȀIhqkS-|&ev%/%'u!1;xcEf%s1%65|Qx2G]ů1PG<$v:{^j.eg9=$@v&ZR :o^c ?f:ْf%l{wMWNsBG눌7y]**Gr?Nv㯛5@)Jg3f֙aeØT%vi,B[&pk[#z1QȾ gѢSy?sןixܠ]x^a\BBЗZc-0)/InA [߸TvբürJ?CF=C5,ږS A4dJOux՚`}')lna7߰:_<%)2>׋'a^L ^2|%"隹U9?k?:i'4%&zGkZZ(&ϞT>Lzi!fJlFU ɻ~Z"fRKp GDD%`O.%yQjm<強 : nڙ&;0ũ+1es8li'i/vO Ʒ$)yAzI O}La[KAAp'W&EN{%;5723\eWg|sz7߫[z s櫰p^GZÃ%L{GϷ\]xoA&pc9C!2ymif~Ӑc}|jih RμOo=-Q|,ڣ "" 6 }]wQ*{NUx`Wޝ.!n<uIp)e ]K+}_ʚX)Ibr-t1MA0DGsFFGwe?}?J2l.KPN 9Y%h΋ ^:Qd28Espv&"m WFz,Ԍbg[zhڗq䂼ش҅nI-þk/`aGDgWu:V}mA,R;QBRnsL)GiU1)bK0\Pz>/?hCIJk}^@>jn伻.xBM@CvMN.. -\/= g/83Yu p4'Pw3Ox07H/D3Y|LBQ;A6$`AEPBWzocr|Ԛe ~՜ʠSޒn4XK "=AAvWL9@C~&-%h3D)z  U>XKna)y~=wN&I|u*xl-$(3*xmjY>^x~w0u]}uX$ iĀ׭S]CzasދV4G<쇮Л/FH@Cdȁ%Ç)^ʷk _ҋ_Ƨ9hjhw,j-݇(;k®\Uc@O\{yn/ٷUPYM}hWI!eof)-?&5L?yz+LDp/QX/]EOhk:9C>u+%ٺ$žػ`1ֳ>0fM OW^s<ɴ-kIӆF RYX9re5+anE>|}+aU9=?\Γ$9RȿO<ߞu3}d8R-G۴ uQ59 x%j91s6:|k^{{iQGE="5x_xi|" %H̀-GF$0\2/ Ts $?{눷W0qsgm_ifEK!Z> NX]XYocf endstream endobj 56 0 obj << /Length1 1391 /Length2 6189 /Length3 0 /Length 7143 /Filter /FlateDecode >> stream xڍtTk/]J H!݈ 10CH7HJ HH4"-%-) J7y{ZY?=Lzv0  H B|F`GKjraPeWtY#P:%kMhx@@!PT(&) #]d h4`PUvpD%$x~]@`[k(@rAU a`_)8:"^^^|.p> ' p wO׸kXF`!e- Gx@@Tm@ǁ|+;j C`Ň@"xP_8 oi X۠~7n PXk:;烃!&uP;E O Eݺ7:Ca^P?g{0vPH]/@n֑Wr#oWoo5_W+5lB­=A-;-`rC ɎRȨͻs_OOPزA!^.*6)(_^!Q( &CEWĪCa?͢n? {} w. ?E}0C,w?*o+/avC@a_b]Udpo:yKUHa*ƿCAz08׃  *[gԣG "ͿK*Cmav%(" vw&@%|(ځ j<=̝>E~Qa ?[FUGx~*m"oh dK0= zTR΋w}Hzu+N^i "Ίg')}HV9f}57&7]]Y%7|B=\MHn$M5CH/̫SYU2;6Q!yd78"h5&kˀEv$?>#{=|˨M+lI0|gHƌl`Waƽ)7T-./-u3ퟖlÒ41jI.ELI8YsHb 6p$.DȪaU \Tj#^jPVjm}? YQS#J1Z'8? .J(7V!RjD=~Zit?{c 6 tMSt8~zm)T:*MW;9 -I/9 VSx>9V]>qݓݔQla`Չmg9S!5HlcDh e)?ht.,pB$V$b2h{aNu-lx%9cS$AWPH|&}v^lm

jLܑ9崯uVPτ{nÑÙJՎgDJ%+ɳ3 T1 ֯;;&+I aM9?Ƅ>pYĊ-|HD\k|bf8DyE/~Prᕿvd^aߖj!v`Exh;B+a 1uEI)EKd'D0LZXvO"IЗq̲0Τ *b }Ύ{Nњ߰RLnB2m0Mzt^mDfEw j:?JFI_amj&SY,Sm5=W1w M624U6wvcl8$2M<7b/UC$Armť1>Zz(q#ID뇻+u|٪^͆'$2MN>4cۊҸt]8O/_e!L?iSL.ښF,1S=BqΣ%.jxp&53 "3@_fp-Ge}\AMkQxqR&θnx*ebI՝%KEq+$"'1Qjg߿qnfy B5oYg11~fv}YqnuۜoUBhyS: -q"e<7L1̾+쇶(}L!bQOÆpE+}dW' Ijķ,e9슧x[l+WuƲK gULoVM3]لO(hNt-Uo\=cB-S(:;qcg ,qC֐I4b+4@CQw mpҢ[AӴP…9Fv|A@F+R"ȍl ne3=i}e{V-fcix?RϬJ]/\;\}\qHOC{䩾nfr=KvXgPC5fQmW:0bq<=[SaG]H R3zηomofa˽9.[U>-d"w5]s۳54L.v l >  />M4uJ8).MsHTa1S)%y]=bj:hV?uII2T G~g}BUZ%0\ZRe  f+pvYn=iGٹ/=zpTjYx#x#'SNP~W`uDyԐE\̉oDu5rwJJ]bsM 'tA ٧_/N#PclEst´}Ch&{?}h4rfkɹ+2DxhyrLr ؆cD~Ѵ[{A|?`C16:$yLx^It 2ɺ,,ojT&~eN޻{앟xӍذ\-<]JD*Ҭ&i Ioy3UOHc20ܣk3P|c1Uܣ1#+2y6Z2Pi`ڥ2g.?F$su]a1 !WblŽ'MI.Z%8)SVtأ>lyZR){fqen<0?;L(|݀s5<,3 dKwߑX*G kmE( b &n=ؑmqMdhO;p⻎ɦe{N2j#q ?}2wd8*.63#pܒ}z( eӇC#{3~:)NSɨKŨT b_z:YV = 6[)"H\ny, Izm%;[d-(۹wL3 q\ N d]gv$r* մ﬑Mu:PO7w4QT:!5p=m{č' w?$nLYniHm*S/#SQ@tuhx_^yH5wEh=K'mKƈFm O6s"W6F7r%cյ&*(=ީޟۍ;5oDkďѡWy;ؔsV:%_z f L{>+l<9.`>wу䇆-l1wzfD}>挪mo[ N:i Lxh*,u9xS1 ckY=UM}t/ݚIdҌ-OSS"D7`]=I]QOQPCb6 wVV԰ZO".0 Vw$9 ؂r!XjpDSY3=}qܵ=V÷eqa {LRTENO2~H8[g*z! 3Pl.IGi^:;BG?hD5Uxe ;-~߇<.WE߂ U)B?̺eI]cg'~0ux?O7cJdMk(e6[SA%ܛ6ZTHL͙4P坃cط%ݳQ*]PN>AO|x!BjX-d/ 4!o(x.h'CHZ\u]$@v9Pȳ 0W}8BUU1+8ԋ's.FӀfQ8W]{f"t?ޗuGM!9h׻ ϻ[U"}:_3}Zs.dA+HY4aWfN:UnS0!F겏{72i"zNSI>4b-PT;HAhq⻁%USwƷ&!oTb/˙ct8EMKH|lc75 YcK/>2,+\[k|^&)ݷ@w֩t G4f})Iܭ( ( hX./iSyxx5 xԒ*|0@T _mdiWӻKȟ[;%.q}{c>O( W}w\w5޿\=PӴQaW~Sb}V\%YykcDO3-[d=RD3%Y%?l]wu;4|_ms_uq<~K᧠赝lP5lHEfZiW( Jn~D ^Xi%7mtae7:= "{m/919 婨\l/>dĖ*~IQwHi[VduTEnY`mdZM0,<d;*Ͷ'"9y xD)W+l8dvJSwجHUkj}Rq96k㎛ť&> stream xڍxT6Ҥn@zM@@zo{ J M)Qti MTi~k}Zɻyf̞gvah" E94PH0H(P3@(Fm `$0O4' bj` Bz! qHR$%Ā@鿉(O04 *#IKK v(<0Ƹܱ;B aOEP B8` C=;c$JCcpq/cgY 14yĝU$ CN.44xK^CD=WXLEo4mGq}eMlJ~-q\@]S3OM 67lДVL471]'y2IINŇJwÚ̏_S3I]au~.s_TN'šD.vq;rCj"t_jz!OY=M{yN7Y*E[#bwN?nݗzl7mWqPS3Qј(Ѣ.̦vDΩds*{{5nA{}55Ci*|h`5owc abHFUmGMTu'ݬhZjYECN4|6Y@2u[,jazVK" X^؋5ߨj.Ci|'hx;ۼ[Qdg'7ٌf6'Ny^. FAqh`LP\4G4 te޽YtPd,Ds~ 6b[J^Sn00}#ߌ~c&-d3;d{)*+a,' p7 F)//~% a&EBjY2ՖApsTݓyܝŮ7e}T[)Yqޘ0n{X5m?Hͅ|R^(~(ݍ> }fh[^3ES wボ~Ob143Ԯs )F3?$:lUݖ+&q&,{.AvVxd*܂!oCSB}\.f%zuۊKR3 tЊ&ER~ݾxZZHQqTxD=Y%Pj7CM‹c4GGNQcvTj.V 23U҆.^ŜxUk_LPIE2K grM'򶛁< i3@JG'C/n3ȥ| 9x521yf7'nЖ"-q'"hZOwX}h glFڥI a<|7r>t*3vi(ppP@x߀Rd#,82x90R?y*L, gυ}^ iY/[]4: .˲=P"=t#R3\(%D{wٗoN2ryIb9m 5hp+cu޷|<>jFx?Wpfb;Z}^]ܕR!ڜ8gv cR:PHUTkIOnMߢƬ܆JP][|7.߇Q;YnJ Վ{D+N&"=5v6Z ]UDS7$nϴ@RDp0. nsEx'5u"OW?Ӭs/OsVdJ>Jޛ}ݒuMziBhAKroF>)G(j]_b!3AGPnl5xi0uv+7fվHI Kz:(D%ت+p wxj^X{ppNbx ytlӑZR]o^"#dܴ;"Ie/^YW=^&Sp%D,X'_|a-0)>t **ź~ ( bA5_-ݼ*q\fa1xee!sA8F\VLMBp[R<<5*J.dxyLBGRTxN,;2:۲dtٜp麥Sx)lt(b)5:[:]捼sG>#ި2m{L՝4;H~w{pN ^zeS/{Iv,"0'yĶӸY}Рˉ@qY3],յT6Ag7bTaRߦHSҫ̲Rlj 4 19K-">0RfNrÐgiwïwPJ5?'K6;U͏pK'ʓvh g>f%3Vq`vS`\@t݇'N ܣ,2HSR>O,9޺F?9'U6Ξy0|],Gߋ pWo__{I䦬mϠwFhRU9, 3qT.?Cxj Pnqi8n ϭrF~;hLPiVy5g(vF[*WS ?{xIpъOsƣaR?3rG@QJYrmai;K6Yz `Q#9L*.:ufLΉj:}SSE5e*Ew'OS_ܳp6a7zuRsLTIOi+^ΜN5:-͜Y+ }q}ӣDzAL yfäj.Koǯ?!c3v"ᆞ^ IC]>oS5q}F]ktW@2=e0Ӫ|GOj5rDF VMXuh|i'Dp( Knj>+m8Ëo_eֿ(iԿxdJmXnh 7b""yƥQ>]KmМYoI3|kXWJIάKz&|AU}Sz 'ubqncAwyۮ>q9P~WB/T>ByݕLU轴y3o7 8_wh{.c$KK}3!eue*7ScJ,iE e8L "7^wNlW_ȏ[q"Q:63D'_)ꨊˢYm<-N= lKP/ VRz}&[gz1]緾6ؓJh*qlFC)+1IO`MbCg,уO嫳wrlWy-2`JWdȃl^#w fE'Tt0e\o}!%-tb=৐i>YXb:Qe]e4Jq9SN>@#oW"sRcȃxBzH\M;2{@;I$yǖ͆ cHcbmu.$3HM )P7 v!j_يs(J^EA]3Q X1iP:iAu}ULhܝ^8槢QL7(s[g芠Lp# O~Ayofrd>PD1RH/VqfqNU}7;g5XV(Ѡ,US@x]բv<{$73^/: KBrglM4\cqYų-v$lݪ?Nħv،F3QfTȭI)n&,2}gA79"覽&f!T @9vx,jْZYYRk4I^ ݤnKn5],JBʍnG-`B{8B#jnVj]֒cq܅]L-F29/]裿(:3X4\Qr,nj qڭ;! uR1vDNml;Pxd4-jK2\g%[b̡.q Mv; eqJeljFkޤ$kM CONdLq@nSO;|Y(tG*\$W)}ltA/n-~H@T7eRY4"ah>|=a/^_8ſ۞Mx?) `BҸ6h^c+lΙrDlsm=ob<٢(KL%4v廬"\(dZЄ4a9 EN)8ϗ.:'ŭfڜI+:aTDRDJDe%L?Q?>/"V7ZDn';n2J͎<>~j&t'ƻog+;8Wy[/ Ɍ |3n<. oB_w_o\N;5a8(4nskS}2݇s89W~ȜG_7޸ءg%(fЛmF|VNpkT6& endstream endobj 60 0 obj << /Length1 1395 /Length2 6123 /Length3 0 /Length 7080 /Filter /FlateDecode >> stream xڍuTo6-N et)tm ) J(! "% 4H H7gl8Y`(;]+( Ut,`( pr#.0 PH堂C8L颐@-(PXBFXR rDeO jp SF88bqe%~\hBpW\E(h"Xsbd@W vz!@C8ÀރLp?AÁ8#1$ 4uznpg?w ;_(A @{ wW !H/G xB.;!J@nah \~(+ Ր0+~@ákYg$ `@ p2A"=]p? KKHI@7QWzc7o/7A h~~'E{'0bvp8n[> ' G/ 2P653m(o(((-.JJJF?H{POkWǞ W溇±ɭ`(KCo En讇o3oa"\|:H @]D !<\۪tYPX #0wp> uC?/ p}݂ˆxuՐPD%4$۷0N0o&@HG* `p3#0θ-82@!WGESobpo805ʆ; o0![C]C:Zn\Cnjb>Uh4ejOtn0J͛66uLaDZǤyTeSOXW^떒|A[9(:AGxEkcϺvE(O>n$tlxĒ #)*)LZyU#8K/5 |5жIb|Ьo%js,Vu83/rC{fnh̀:cM 欃 %\!^)4ާU2ːBߡVbK!nkNKݕUTܓ1G3>fQ'wPcnM$oZΈs9kA<=?CkWV#c#[Ԁw>?}BtFȗ|Vt*.xb\C82ek*;n/3;,srn.ΰx0Y ] ̦6yeGYɄ+G֮!MK[`51VLi9qihgr!iH/0R!O*LnkT<%"Pڕ}g7!L@o5`YG_8dici>2 b6WW]6ߣ^ BovC s5ސ`;x~:Qqp ~q89\m)GdLE*הYHwe].ͲTb>xF(홚G ^mG3gb2N)$#ma<,ڛE:LRꛮG\OfxYAƆ"|%+͵rz)QC (8))K,k#U\ʏ$ܘ̶ycߓԮa/s5_sIYaԙ%<$O9ɺBшd>0$m>,ӡwWr $s+^4Eu{:a;E1O+"W˴{,Zyַ.LsaSQonA̡ mCҢ?, {q)dqѤ}=G8dutWig-"MmصgUC, V*gՄ#j=R? CG*879 Jy ^zVOYL?'5D-ĵjCdJϤ>#aR&| M) <8Vw1'MrA2[k ߵ͇n"6'b FS~Tf$׭djܠ'ڄ٤m+.ao^PhPE#rӛaHXw 9 Ó:ҟ+R2X? b %Y*6 |^pY+`n\نg`fgYr7~PFvw 6{?8t H2X D>ݛ&1Ok.a{7[Ьjd+\攗EAYO)ʾ<Ч>uV"O13pЬ]CE >XØgH^-$Jݜl݊fa5|#RP۔bӣd,nk|=s(?{a|Rx;`ix3ʧ?e<9In! Os`Nj` VvҶȗ\f/@>818b)s~R+AY㑏S7X? n9M^+B?djhWwXlN5K J$[(f \%9 Ju7LyA F4XerXL?aKԁ<Z7Lb*[`Ipm2C|ybL[6_z4ۺՐ~v#& Irk*o|Ŗ|=_7?vҥt#w} )X(q.1'͕6Vk;_gILei,S=ļP8jmgfaq|(Me{}OQF woU1mb@\pTh"Yo/Nt{Il" tmV=tQ rE_\]^}vo+_o=Og2YGgi J3RkITpnZuͭ5Nw6 d׮zxĤRcY*,̻ZKW (U8k_+K~,6UKs8\>ppuIk?g7 2 +O?Wj0f~Huیg, VEK_4F,}/#Ad'I,Ij΍/y!7*m}eQ>&^dW^\lEGZ4dR3ߧgG{Z(2߸|]&xq%]u bIheߟ,r^+:QMB0PO1 m.zB%՚4o.뚸u1 V"\ \ ^]H˜B~}. ܲȫIKKeo G8% BShBq|~R+տQUJZUc%}}?y)f1=-(fm?kNvD(/D U뛓Fε%P@vpsj `CkR~ <*ZleruU5Z^BB67R!wj'Lߵ|SNq|Z_aF8 Vls8u E3Xo~~~`1 3 3q#Q&S)^kc 6Q=b#:IbzX|@_M"@Ag[KaUry8"{N$_+bdҚ۾)'|c"%{3sfUՄ#>|{ߌP#ų:xH$5j\:8K/ ?(8w]ua4S'ePtuYcAm۪FwU"cR[Ab˅HRX; gLbxͩ2?Ic(ܩpg)KQ$(R6W}U _tl7ג&JC{jE)rTGefH{9$NZn)7I[ F'v pz_w޼$3!ކK$UAnzW 6keƜ3(/T5o6/f}f [fvr!'(}4tuJݽ/г h|Ҁn|ϷGK n:8Җ& G1]?ߋykʉCp<|_OdithHܗ743PȮxPILJIǽUcbl V~@JX*8}=.kjAƢʋ 砎yEhP4c-5fQ3xӹR{|vjG@![y_,sWNHC͖ց1֒R-Tʴ|7'1y #,ց gV i7wƁ^|A:+G4? 䍨vӕl4F&kۈs#/V*ۄl' 0uḀ<=^6uS<*˞C,zf7~`Y WHz5H͑]J+Opi;7ݙRFޘj1yST^4\zuL~ xH~Tu+U#3رK]CXb5Q8I0N3G8z g@FN*I~側D a`24Ωٝy93\-O0ĶhBP$*3oX{KWݏNI/Qt}/-t._YA# :s4)jlʂ3).H# %]i3m{WMSC}C-/& NѨ}4W`٭+vJE$x̛P~5ޟvOK:RXͫ1g&H8ipڋR4DuAZr?Nnvݞ7>gRLn+}aVq\j7K9TIف9Y{*:lc_!a+`p~)Ȳ1Y7͕?>v,taK P{p!1nvm軲2j=a/4Gz;c]_wv|6y_Cv4ORM{ިIԷZ2vYUek`goc.nM@dW2]e'uG1iL= U Z[MjyGTh;?ߒ[JLfUy\vc%sH!*y{ 'Km[=nBu !~/ԭZ^^zsuF9,*PO\卭O,g~@: dױ%}]=sD]*%S6ݲcyKP%3m:?z ~} [A-ꤺxS\AԋTWq[\%5DUKd"j# MߦWU|;H#yMTܚ rK>(?y6I{L؄ܞxp& Ba7JO t5M/݈C1|s#7ll<9>SǢ]ǛCR I 0\KH#/4vY<ۓ+JxPa ז&ē+̧q49-Z>1-,I wwϐY6L?9ƾnN<]ˏrK)Ɓ7ϊxs`M˙fLB$̞7pE$%Z3KgKP/Z? endstream endobj 62 0 obj << /Length1 727 /Length2 14708 /Length3 0 /Length 15301 /Filter /FlateDecode >> stream xmsp_-wƶmvv:mضfܺU_6֮::۹z:*šL̜FzX22' 4LfFF&X2 ҄A@&JOO p,mE-)y @ht2(Xd-Mv@*?_M 13'{[*@LAU`dg ř4_\g2,zX&& hni/ݤ :7!(ѐ ` 4jc#od P:r@';)@hg 4/R.F!dg Y:[zM-]~?sv6? i1;{SK;s?9/ﴢvTS8Yzt$:/JXÛ@`bgp1q?tM\v.Y{@ ڲ OUZKhXl$촡2Tϵ吅%Ν*N;\ BD:%c}-Pz5Yc)SaYG?$VƒjNxDmdA0dG|2u8R LG_`(8DJi*9{k4+av'! BCjb2"%}/H.lHbٽBr'1F!aaĜ~e_ oCKP1o7܈/_ ˹M=Wbp&GZie#0?FȍF64^r)l_״j5AhHkmOԏ#.K[QʋZTuYy!b߃ 1CQY)9MD*V6hl2s3}9%"RaEy\ ;>nx-KuVcILp)cUB1(oRFqSo/NQ>OfڅT_=N}?@/Pl]2Y-MN U/ 6A}`zvWx?/ =ơ |w`s$/z@Agnq1iLYP}\;+;}?HGO`W#~7|dmԒJ;F06M# *5JGa0'e&CPa=å//^h%&8GZ_U[8;3`ͤTםH5"JWN'*%6AxS9?'l; )em{/ψt-JTj*pbM CeiÜENEm).SR[1(4fk3 я\~SIjWa؎fjE0'O5"J'LH󇎒(: eRݐ8* q(Q:&ɳ# )oݸ6  Z >%nh;H/::'@-izೠDml7T/j+D@ߡhe՟oQ&AhlL"ty}XS1ӊsUSuS X. l*/*28q99g,1.}KPV5,~ۀڕJ[-}fodvSk'R_9z ^7(Bދ㔝;6t?d{lt g<4&|~^Dg1 "z+ޜ7T|>zSeGloveH6w퀣aD-^MGvH o ?-W¯ϼ5eRz :H#=r,9dXXxR$RhU93hmD?*f^OH*"[A[-q)]+\weVg4,~BzI`uNwmǞWhidLНSg5sҁXQkY)XxpL ܃hZ~?H}XRm1z(fۋx,\ctcꪈVK|i']6 ΡKh}CVyf <ҙw^l@ͺ$4 6ܶEsE`Qء[bօycsTEgK: Ur7 2Le(&ztQJN* ygǒA6Iۦ)ٚҪwKr.H2Y<>ˆfcoHwC$tGɕtI/,m)lSvU+Έ ݸd0HMKltΣN] (h_.ڕN)!W­Gk^4QO H\v kc!NZIz ;Us/|H0of+':-n=dS;[h#Q;$:ich!%%'Jv_|^JM& (LW12n8!4ۯB<ڗw۷f).;>!h8$o+QTׇ8;ݿ?ok^u%ш $j<&nG=%"n-pɹF]b?y_Uo>e2s rڻS:SѬ͊{&B!SZ/jibJ)Ծ͐Darm&%}Y F.~R[mQ<janb6,eLӗӣB^/]7$ S-LrAQrRqX㶐t/Y%?\يMEĄrz{tcxr?"t7v&,\%>Z ϦΊԦЯ-|IlKD~,ѻ={ll=Dma#弲~q%euP!cm=V<3Oj'PF5s$&M9@\mZ%/&n?3dIQ:GېG8{R0W[ޅ+t^qtehB!i#f%h\۳4o?c P8  @;A',O?9?\A.󔢊y~$֠ZЕ 2 EU0kTh_]|=zm".+_#[o!_[TE :Eyw+v kqͬTu]荱g`7ܭp#:a?f:WjEa/=sV覆s~p};lo* M]#30‘~sAyLh{+h9e#݋2疚xp9 0Op+H2˵PGtdxPpX!Q+8]xV>{uKz[_`|# ?rktƉ]NX**Kt YS/J1Ps>0ظb'RQ&) Uר)[mp#:i*d!'8+AzOͫE f#j;Ҡݷ/{^rZfFfXd'v/!qOIZZ:X7!XahjidL&t_r|S 暵n-{dƹ]K$~NjacO?Tda7J\bQa}yW#95*,8  c\0;x:!"Yi/RC&;0y6Ș:E4H|uZ 37dQFJ%L=1^iEBasCBLΦt K͕;QX3e;.mUMART ||EL@SqTƭ7{TY*/`bUd!60ѓt;=}믳i;*/3HIԱ>4ӠkIenRFR]z+v9[Cb.+FSux"o@BNLnMIV}/f;ؿ$x+O6Mq|e&`W.`#IjCq:QBڞb6vuw-kU1Zﴎx?N;s_9mp$>총dĩ{Z@Ԙ{%e_ުTXPvnia:;r>#:nT5mvSL ]Y;B Z?ئL]ϸؿ< Ts"{MZPFz.UBdf.]otxCLv M!߂96WN{'X'FЕpJԨNLnͮIMqtPLjf#Xkz(fG m13{C$f׺t*@JdQB~b[eLCI{Ȇ~$j8vS;']o).# VPYVs<|uzhBދ("6dj>g/4ge5}a`31Ϭ4tC;mץ*I#2^`4'#w{Sgr%ˎ8bĬ6/?;i{K3u޽$'9\%c''Q^ŎLጌv! "^d{JWO9,!ސm&Ḷ!_y3hW:"@7p .>ZӀLY1̍rsDVz4)7 T9js?Eu+fxN\֛'~D8L3IZ{}Л'1"]:KK¸t{V? uv>!JpJOCrTKTG7@ du]x2VQ{OpƱ5֛)R=P.b =І_J7"FkNHqŌiDHlՏwwVd}4d M ~KQggwKfi#{.c'N|bETî9'bo2.Zi)/Y!~y''cxQtBvstu-o߭኿sAJg!$`N!m1n(kv>hJ<7wdE_y]i X @X 27F8Dƨo]̨KS% +>0!s <9@abB:?"^Ad!t|"1 CdZ>V6أF7yQn;]ӴL"7m½)է!JGDP)J3]*ꘟeu&M|HoqVwhӍCoPea^5լ's KHd'L [)4pEqX⅀d@D{rm@IT!$=%!ui^_X$gCR}>TrpZG֥d H|`k>I j٣Ivǒ˫(Fk gRҞXُ.iY둑2 Z*$}toC{67ۨh[=!Mah&^)p6 Cު8nGˠ=c2WWd.uKr{<V[G/iIτ4C:4**pTKb0ue=,3Lf?'օ|˸$ DW70LV_67MVxP&eT\!r,&k>S?OY$!*X m,bdob\%"}Wb1W |&^p/y $X=A$Z&?&r"twZSEOݲsdÊbf&k/溑Ѳt0M&du_f )7g흮 $;d ~#TO.mLG̝VL;Y[(m"m"x03^L l.{ QZJ(aos_po-Zcg~^ 9-6r}&)lhwdv˲IPGv+)/3+B19i @G 5Rp{Ǣ3p%l+jѻ[`N4⍇TdYd[p>A9o"qvZJéZ2/5BdJ$_ 09 ttv[Mel\e| XtaE +!0/]`2JdƜcLݝA辻! zA D^ v '$q7YY*+HZ*` !1p7f9q2aژ~n.US[NZtJu睗i 仪Y;oO}hv]1~s>W QYDb/h,"FPP1$d/FΟuٽ>Qb ;1z Z**ˤ^*|D.'@l8il 11(k'2E 59x[SX(Z\Zup~-|g֛p-67YNg"S6$؜Mr+ߪ=#up~pT* B=2* |_{S6g Z$#;iybpfz1ɢ.clOD:KZGql5a͑hF,b8VBAYoA7u="L*ڛ2#i~ք[ښ=7oY2iW7f5&iT'/?VN=jM F6KU+>qZگn/(HR XpCɛv:BB#9(s<'q2mddWO)R4㛽ŘR|CVY~rMTQUai$͉v'N< ha|S)*p3xҀ5$◭3CYtRW|QosIb_%,O'ִF|F.tpQ]µATNO ,]=΃謬Wiþ'n U]EyDމIb{-m|]:v:"%8Vp~dnc׫& NuP|~a֖;U#E_縮ܹ#>uMĴ޴3x&!-KRykM_!L>ˆ+`85#Sx!Bn.G]az N66.r IQ^MXww@٭1ERKd\/ ԼR!`#zuvjˣ$Jl^!jFts? g@v. K䩕N|;rmJmsՇ#Ύ$ӆ9#|A</ԯᕾmoyݩSngIBŕzv84k;&(@Yֈw6YUѕ"1sMۊq'qNcBok]ٕ!+7( zP4g㷯YM{!xw].GwÎ"Vḥ[Kg(u2ͥz'eBG>/^m_DBFu3$"|]3sMaiN1eɑ¨-!2]1Tc"<ųu4͢]E.>ҕg;Ӟ7&¯o?3w/q8L*H+jGr.ՒPOa"y~`.@[=M,i)0ʖS3&ܵ/ kL<1 Bأ UR(M w~q[!dXfzCSv{`OL9 : 0e;)}S1Njx  S9dmY^2*Hppӂ>ږO>_zL3mM;> + vuo!r3y6حG#lgc?z9ped-fFX,i* + ڏпLOgG$h|*/W_17ކ{K&Z+QxZ6Qs./aF*"X.| o?e2:Sa?kT ˴ ^nGR=Jma`,5+9CC:̗uLȕ\6~RBF1+1(mFlO$xOK;LLW h.qV {7'ka_ ":QYI#faCbyT[[!/f]飗Y:)A\K+%I'K;Jn|U2gBKvRhnU{/`%F]~xrN]]wF8&azYIĂo7sxC=<?ý@c IH4D̸SR(u%A*)ng>.ٰd ?" WϢYTK* LM,a%Hx>Kx%VV1[zs$׬ ,w^yz?A09'6Jyk|땍kؕMհZG!`Ĉ=udkPTT< (|q~˹$/vINo0i(# '`'wBo)r;=YbP`s')WsWkbU =OR:IO{+SN.(*MjR.bi@t ][x6LP.6ːcVG>x C $.ϲ0ן>%aT>\+ ̰Rmfg%1[$3P< e^0J) Cm@>{9cnCyi,n=EߗmOQݐËCeqPf$*IeCH̎\~e?I_?ƾJ7 Fś?'/t ,O3ڙz ]gN L$-Ibq2W=^avۋ!7ѭ dόX"K#טS/0lgt=u#RשuIL3zBnwy/ҧPC Ġ)pk?5+aGN,rc~c/zE#0_+5.g90b GB1S$RJŬR%%_.є NJ:Ɲ ZzBGX9kΙ'Ѷ<3V4C g볖9K{3F^L@5Z*`]l@m1wE-|6-baRy!|R* JSQfd;sk]&P {% L6gJ xP2'B%VK6 =2|bc w %`B^0K6t$}k<~@ _A% (*jEʝG>h~'3&^~%GDxADV8e唌񫆩xVps˱/-$4m;@{(ސM4gQgCAt%Ɯ`ŝZrtB?ϤL˻S i\U[AhlK\jEAne3⻟$ NC+u8pA7_~x". '2*YPL"*"in&ǒ>HeZ2k+B]ɂGWi^0hk0|X"&قr,{fq @|QNZ1_ Ro" B_qbo ;!%yRoon <DNqZ˥NRۥ0(MnNFј*UQ(؛&aD29:(C7b%s KNC򫖬0݉3\XoO絇zبw^q8w s-bAJfQ+P(<s ˂j/ 5_#iZgn=YƁ>\ȩHuM88>pz&(UޗY!yϛΠ s5OWO emS:3Aogr Q|Q27FsP8ݜ gHm33/_8)4%d[EzhJ1NLjVsc˳BMA'.?ݟ%.sYaY=]e"PTR^LDg(wD;>G-}zґ0\9`byqVLIJ*31:j%!5Ԃo@R-]@Rbv?mـ-Q<~8< Jj/HPJ''hr$3N6 Fi\Eao)ub -A/p=%80NDK> Ek>ͤ=Еp*yS8zO 6 ފfPBzARܝ%ͪ"* wV[I+z mj^@4z*xyq]o\ Cga_ƕ%,(,+LS_E:&0n OXR ˬ㡀V r`woH^V- v`{M=Fi"'$; ~3)HA.4:w0:Oćz}5䧞 k R$FC ޼MӾŒ [([ɤ^vE@ &M0LlF}xN޲KzOS4S5}jė˛{w+ OЄ';?3y $JB| [ $ רYV$a;zA oa9ՀeDvy6&b/fqA0蕂][\La̿=Bd/ȍKS(P庯9E23?Cn7i'Į$:1Tb^5-}tkDFD꤬0.R#xC  endstream endobj 64 0 obj << /Length1 721 /Length2 21484 /Length3 0 /Length 22077 /Filter /FlateDecode >> stream xlpM-۶m۶mm۶mɉNNfܺUuSkWzWW?j^fzf&"U yf&&"&VrrQg+H`F p$bf! CN$leaJDeJ 3%?E%@$- ID%N$ 8)ZY]DDqLͬɅή3wv#WPTP#eT%27#Յ4_ϲ5e?YgX 0DfVD& +{&mo@񟰙Sr?RA*D\Dfg{";clq!j('L͍mqME`ffz?zsf^gZZ:ZM̬-T]3=%i"b'.ÿƃ_뿖E8x3sѳ01fc蚺9;]-? SUSP*jpڅ9#uUf[]dK35B8 =6L,q*[i·r{S0 l;Sۨ{׬͍`%z ~dIX!p'{Ij}Jlo8!m҂eX }[rlC GvN.;nve~*ݓX:kDbTgG|f:#'zޏMѷh wv^ngI+RtH*y.J5 p#+a(Cs׎jɚ$t#Yx1N&jw5|m`ɢ+Q9[FSns?fa}$.$ߟ'qD]#`&*2Gv-ɨ}xo l tg YJ:n)$`a[۱=qu_˩\zP - 8]]JGYcRioeCWKhYxcbŔP+2FT`;`*sC|`Q'\/$-?$/ am^sϣ>? 9^|#, d5l(CN;k!shS[CUhvrدtu iL>( [g|=W,sWe}'yְHlX^.Gej뮋 ?Oɠ rYY"2>%/igøtjKް6%O oͯpS?9~IAW5umCI!RMMv;9̼\ӸBA~W8tSQyIa ּcx22 ASsX "U3s1(ؙ6s9!x ܐ .N^&i{+Ri6jV KYC$e O,*.'it-R}WAqo6N\X)F=y2-D.-ISK\%jOޘ&X[ /b@<,g^0HH_`I^Njx`/`+'-./r4?y)N WT$oeu{/rU7( 3&C /jQݬ|o\%=4A z3{ )XH.~xnx.3In| WO*^ͅGnį),4\[S,PtS|D&D P*]+p&U?¶[z 45;eM*_z!ߕ[څ{H!x #٧, ,7y[DmOBҪ^lP =kr1 X%bGRbnY璻دH8O ·*񋠱Uef;VS=W Di}n/z/ZϷho6[IcT)#M>Dh"eJMN 4-Z€,!tpN+?)OJhK=='+g%3 kZ诩/{n+7q7۠HD@tϴ Ћmua U}ߟC \aJN x9;qe;?7uOԯ4 (F%EMuqVCkmxkElE,Xxk*8,< :ءeĤ4y1R܌~'}yHz)X&HMl[ {\J20L aj*˄J—ݥVFHgkJ9t""O rxh?<:cǣ<[H̕V7 mV4W'_VL,C _%(M&L8?Mq\zK\>! ArSUVlhɴ&<ַphH>>tcJ{(:dОU_d*zaN\!%%)9nM|nZ>ɉ8އGo[|Ne!Ѿm^OCZB)3y '$F snR*n.dG8-ZUk ]Z7ȋ9i5,VE1er32`ZAu0LiIKkUa"su۳-eWbTs T1i^L-AgS*/ժq8W^l“6ʙ ai2nLF.(2Zُ#[@wţcuv=KPu3v̅"X5Uا6]sE%[^2y( 3=5,W:6"έd$T$ Azə$5P\p =k=0x2ּd6N)4z !wu4;oaϙT6}ZyG_ت0 4C7KaT0Ӎ"GRaM]"YzyR_W E,o y/=z]Z'Z!G'4Ae0S"ڢ5}8'8$SAK/!0Ca >tv뺏CgE:А=lUwY`).sm3.¦AiRLn w>]K l 1Eq bes\I +a$y p^mX&I' v.:SmМpGaYmR3\xaco4ZP9&pӰTʻm5Lq;aM מdTؠD\cYEfnT.ߘCy+n]r\T>aY4h݉UUt-*R]ѵt+Ch ,:j>-AdehYUrra/󂵕_쐱E&xuGg^Uߐw0G^Db$`84PJOY=ӛZrLjP@.laMs[-1kZdC-HW\⻀ sG?lC-{" 1oS Ŏv[[xc5)ݢi %nV^_RΖ!S[ _eLa^]P`L/YL/hmN9Nq&1Lb>Ven9f9UЌjڄ&5yp]x*_9-O<;\ }S 1B0o c^Yݹ)b>oģs3> 7yeBWgxe d)QCz\/%U/1d3!qvcd(J-iQ``=wn;Eb-m+qx]f)0p4k>(rI[-ӰLyX*kyfsK6QRA`eUNDu+=^T'+т@ڙ^י+ &<`#D$SwbvC4~4tэ#Җظ\̭| A"n)zxڲyl4gpLഠx﫿cRL`"s,IMεO:┯=+A7pbA^ Kj=/#$Gx GBEdnN"isYཞ`"cl/]Uy !)+·Qzwwh睤Xo=`x8"cSz;KGLF$<9 0ϵAe/T{ypaw$C؋@g Hzh?)&kirlpDFv)ȍ3 >|@a,Y.(F/=-ڴ ;&VMIoCJWo"s4XXn H[a;beRac:OMݻơr%[<$ Z$؄`~y=ǗZ%"{)j|c`"H W>Bu3?`M7*gL'0Y$6H(er<0D+@XєbeV`ѡjL!A3gsWA 6%@t /u0@Rrjؕ1zQGv :R ?"3 k~ҡ١ ^<Տ,P$c@gzHn)6(\ =|7uR/F?I 7ԔJv6|rG86J}Ҥ)7BdBKq:׷dHP4qKZcFFǥ{| F/ mS3 ::m⇈aMLU<3D\QpgDS!JPܒY)_Ip|4Mh$\)U.yptˢ!-p)ʄΡRM9n`QvaТP}> (2Y v2Zj570gRиBIMn"x7MDsGjc1ңqԳ-F0vd~"ndcow[E>b)z3UlM"$ KˍW@Àpw|Dcr nsϽޞpkIcb})Ո[,3@r7X{exZ$݆hOY?G@qf՛4QOѻw!TY'a  L *%g/#IKsMm?Boh ԰Ǩs7d'IGZZ<6W5/w$DCYӆW-ϕmx+Fϼ9Ȉ@MuG֐Ϥ+Tè^TYto _7tߠ%U_PbˆrKT`lI[ _BM?e~j}`sK4r̖ϢpFscw.Oi9# o8 (KN\9̽4 Z~WbrW|5CLX?9,5[+ eY>˫n!Rb9Bv:xmQh_]eq2^4d {0+UF >jOˠF*fiow@ e&z@Qډ߆m[޵3Ш6 r<%I3l$]5y(pc՛v$'' i%,b.3ylk{/}cߤ'jzyWT5-Y񷸓,1,dBi$emv$"-/m-,\"]|^z^gh԰w%8bVyZ+;5ɠbep$,uֶ(z#>z#Hk062BfkQ3,? ov;sÌN%@q Jʉ -9H{93~sg[ О<\fPOg{Q z|t9Nȣ(ޔu_t"'Ne}€R;f\97bn)aѥ IBiCP'T[gJѓv*I e!8wgwE%EGdbSJ>?/6v螵oT8jEW[=8r'O*ێ#tMտ :$#2_-_ORߨ*lC: g<'e[L|Nl{&ט{Bռ,7z2Mȏѯ<*Sah pBi0!,GߋW-%?:ϿZw-Xԕpx !/]g/EyvpyMuu)}z'ҷF뿾@9໹?fKL1iRDFbX?&m9sUKh+i2f&T6]].%˞[~%^c5jΊ(ʇHxF 3[B$qL KG)@YV0 eJIj oș1p.xBK|iȃNb /E\P?yk[7>m?4*&`F#uGBE퐭kZvp-p^đ[I>Y,p7Z0NG5o]Z yHcLq}:s} ^Jja]\\<KO0c]f?,`1U\`LS5RbPtdxo|rq*Ek)Qjy6dB``jɉS7p؊I|1 MU6֫G֑cmԝ ,ԜKyp_V5JD߮d$V.2 F[1)=rܶ$@ h̙a6+/J4?=c2ʈz^ش7l ߃-v(nG%Uf 0cCZ)f_-z'9Ҕ^^J"k0ȗRE0](LA 6KB- U4G' S sqU:z5qw/d7)>V`+0I~! 5ߓ>Gq$A5hP~ at ro:ճ{8)JKFqv<á:s <;=Η7k*tezy7~#5ز yj Fۚ%VV8CRFDPUT߿r̛ _r[Xj?Ў_$ aK8<AbA5>dTIBpCFIT:uPo2M͇ ( d1~Gt2vSf~'0CUӢ.!kYm/_D* yT|+z8?TakT\}H&ԛ#Sg=^EQF;FA_U",ltc\VFa}]M)q!^QL.qvJG^eϐǑNOlG BGIC[1ѧL "k~ߡ}+[7PP/]oA0PAՆ*:;TJj)av%% 볏uVu`hF ǥ |=c= -"^%WlU@ )ڵ$-lHj/dRrkF.u6dZ|@vR((mE8[@2AL/Idb3N~alTί_$5鴧3Ϳ.Mm˞.$1p8;rUd耠Ҝew@eDiIhl`3!-I6{!?: ,e&KAVrʭ$1)*X1o2zFW;n$,riT:@hCpclnlp&Ww5͵Kv3x|oMOKTB*Cm]\L{aFܧG'U ԌwPai'ȣk/\zB!2,0Wl|UIjB1-:PgH(qIa*|)ErixB0kR~t-QʆX%o;¯PSm(ٔDn=-}CK='y5o-,Qbx|uST$[?i_/uzcU_WLj=/ْ,LWq #[;݄0|;;s |ju8SGhv t67@>^ EXtkt[W ʼmw[8;*X7oЮ(ʪa=j@$QG,D&+B~sϧ6'T=KnWr) wY#ǖ a` of8!7 X:"MѭmUs̎,/y?M^,6u2Ey/?t,Kу4*HOUt=߀R k{f݈#7SHY[ql+liw ۴:)ZYU 5̥鱖]ᰩΝ!taPtԙpU.U3`}0/[ >B[1\*1ҿt$'Νa܉?FI7k(t.} }665qFa NcL!g7϶vYew8OTjX!DVqe,$k.{)p8vU=)5ڃc,:%f&4;۟cq`H[p(^_y7:$_=}_ ńqjjhn:|z^l'mWMŽ:Nّ->heĹ'E4Gܿ괛*;nr`dx/t|M†4rÙ ;$X:.`1:M8Rnpo٘!}Uuy0 92#+g L c W bc_ɤY =xJ#&/u0Q/5.Zc2iGVO&ժnZdNF^NKWG~!\C0&%q0(8Tr!9"}M6R'u+FkC2[2􆖙6tg4]#HF~Vc:;_ը VʌUMN5y8A%*4ded*ɖc#'BmNdLj-BzԌt2=΢)>}r:I U|5N_KLȧn%#ٸ ipcb^ãMD9/fꬫb$rx9 f[9h@[@kGqJVr{Z@,Ԣ'gήZ฽p$ G|ׇː`}46&t6i5Y,[8,ь#pJW<7oVٯ$WVV7#qmeMPQ%}jC!IkKxfy(ϿQ7E u?ɿX, Bp+3s5R_WN>ޱ}0%\޽3V:T2 7/t!qT%_؅kfzm1 Z\ $:e0njp%S״藓 m_IfȬ]_eg$'șѻܛLh :"ihLMQ&n:t6 'a6ym2Ɩ3 _oWG -"QsmCAW \*2b$a.lGS\ ̂핆: h_`w ϐD L[@2_~;M{ef_>Ì]YpH"Y\ Хgi\,k%E63\=,K̖u a:(.6Yu\WzxUjwCOͽ*¼MWij?\ՌA&]{:wvqx}{kCza!.]YpS rSܶЧ"r5Z4b<=|ļn/^>IA1:+04㮇25ʓ &򺞖 8 ܔI0*gOȏ>\<%RO \g2A\hJF}N}$6nPq*ѳF ")V@6 W|J?䫄饑  )+nraгXfFE7rmS{ÒEbRB}׎3s+[걫ݳy`b63?Wr~x#K-r@I PQBU 3`L몟HpPzXYճt (o¤OW?5 Ѓ6%j~/#q6ʙD{GyZdLb,wc"XKfi@oВ 'ypo3FY{vlJ?ՏA:r6 =33e?ag6%2DEehܼiBr tRDՎ(⤵DpR#ς$<<.΢iKhrm,m_fzX+"?B/11g6[m64L>i~|/$9J&iԪu){] 3S7DdmNؾgvr5(~`-gy@QlXPԢlUX!_e>(FCe;Q mښ?z@z\^%%4=i.Yhly\@.vٟkW&YZĘ+|>jFu5bmewA$g]ʆZ'|wCl͝<,8U1;{ry1ߏ'OYǹ_WV%&pSeB: %0mBeGj*1rqi))ajR#* ;QA1p׺lO)ySմqEV֑A8v 8o"̃,h[Jڟh6%5=#t2FAD˜^EY!߾W 4 QɜIT/,¶7~R"S݁.$~0 Px!*TEV{H[mN%4Q$TܾIJj `.y#uy|2ʱh& R#eŸkkfD^:ұ >H,+ -20U!bv<)q w92.k.➉SP'h$,+^첰-eN<֪o.9ի ^)>Tq–I:x3>*,x<^F-_iI’/)vb<)r'M?aVWUO}JSs xY$F-7#P(XFrxڬ,61.=yT~{}}eRLCh G\PCysW')%ZI*9]K1_ಌ--uAF*ԥSKP]7m,puDτ@w+?`v*Ɇ^$Lc@-%~S x9ѐCOKstA mEX:#ۜzk$6WLUv t4W S* )&bZv2vY?D`ʰ*)Uمy#~.6 D!8zV  I@TSp3VG;rfF*LߗьVep#uKɷeR F {DмnY kTJ&#]NS @Ip!Ft) dj#_ US%SNԒlrSӳ*5 SwVGbCdz4)VElojÍځa3G]T=*Fաnd F)}Q';RvƺGQA "0z>XR} HkՅO2Ͻ:}DǝMj2K甏!\Η7#Rrhf295I/E*3&N="0U~OPht ryieh]B4U^*6)E?&.K& un :2RRخd17M H4Q*f6`6%6z+fGvǿwjUքl&<|`E䎕L]%i9e0k]2KDVD_3! =U[>F&䄰Ig#~y~ߎ^d_G3 $*v{|4mp j Lu?ڔIe6GLXj ]ᔦ_cۣQkolXաjxa`M ǭN4efdhXRP^ްi:q:z l㍆خ`"ݢ n[`fO2?}n?&V0R{FENwoѓe?nC3 6W쐀+?xA@&ҹfMޯCև7`JU8T~[LS+II2%)v>樺tN+bչY{=U+(_,Z O5-g1gҚfUQ%$A "} 0X/JJH&` 'EWE6R@ ֍H!ogƫyֵ:V³׈e v1.5u[~C]i@\ׂ,PGsC^3F7 _NJrzj?+IHbU}Y \<$mQq@_4')-|Dz^k胚ES$XVWفCaɢ8_QU`Yo. ?ng81xs֋!zT'hp*ɾAҢTsa}d4LKWX1";IɱFk?Z`WCS?S @k-"_^Ujrjl *9 D#Q4ut5/~'ow_3]IJaiR"Mb]W4,#K%.O89~ycN߻j=vmrhD_ cs +y2)IEwы3;1^J=˪fn'"?Y͏򮶠`b!5y?)fPT@%Ң8(8ZW=ng`ƛڭJcg/ݾ}I,A\< aU*%vx~tap)>XFRzFXR)MܪJg6ZlJA+%2SMq!4OHqpq 0F*f>;oܬ3?:{EѳZ8,c۾@q'7xm><\X;,5ݟ6;  < nW,T=I,RtϾ|P[)۞@<.*<4,5VmN r"մXD⹈mVYSL*M|/=A &1Hdr: 9MѷnCeyZZwGӸI9g'da.B9OaR%jw7xCި4%HA20fMJyph"/=֓ Am m?%+Xr |pU$#9[48Y oXy>>$yVw^MKmB L endstream endobj 66 0 obj << /Length1 721 /Length2 11903 /Length3 0 /Length 12493 /Filter /FlateDecode >> stream xmwePL-wwww8XЃww.e3nիeWꮦ uRw002$UXٙ̌lHb`VhLj { + fg4pPhZM-m,M;k;K 3#Yop,A1%eE)@ d ֖&yK#`fXٚZ#?l]@`v6 uI%Euhk [n 2;z-k-Z͂m1"L-M sK[$&ckfw?PՐ` 2vVڀbv6N 0@mXZqqArY:JZL-Jm+?q-пEdjlz_=l6dSQS53596o22& @'@_KQvn ,\6 35qAN 2AZY3 Jm)()2Ҡ[d\Ŵ05;'Q'uE!7>ےi"ƂP'H }7U .`4mLa.ïWWi'3OeJ0XJza16omh2~UaX_ =@n\RZ~+nNj =Or{l+Ŧ!J+ʘ M{򿬒bqVa=o&bRK!*zjBеw.8^^Gh5oH[ãUo> 9d3#yLfJ4}UWbrs&7"{5lo2ltM`v 69=AH)#x+'$.RJ:M5RrP=HuD_CG_`v[ETk3tnb:v |}z@ݲ=3X-T`?'V$+pFKzӏ´wKn[%JWiCN_(gSF޼D_a_ ;#G;7vǬ(Q|Jc{:^ᙦ,U i!Ϫ6uӜREhp  4WGJ#B.,U:^1&KlL]jiM a& FDn5“,]Vb7O*N>V料 {9Uq2҇U(]z_/ 8EVպ{ڪSR~f 0/b*k.͵OA0W۶ 8= bmG1f5W5~˧Z_{r{>BwS%~?Ax8>rPwiK'|"7Lҕ L𚒾 N94iW#តÐ 4)!Q3Ä-v,m6:2AHiU%fTKI(S@)g@*@-9Q܋+yl#W|!LT+rt.g 3 rG=&.Ȟjvgy*} [ y7x37d89+gT(K f+=@>uSơPygJZC!)ˉ&Acx!KѬ-Kc\q憏AUO [ ^!Vg X]k!KͮDo lW,Ӳͤf@̜+,.!_'%H<+ YROjcQ>ߨ^1*`zNL?\9nUyC-r3ݞ9P-)F6Oz)gGG!2iqc I9뺗{SGۘSه-') 8Ǵeecz5."#7%(n Ar|q J aDcSvޏ)o#φ`Pr.+^2gC]W$M(.0:DZT6*BN?!rj]#8/7P*fu߲Ko$`XT($^&߈t)񬜪)re\m IJ)q׳7Ėw[]óECϴu`ӼSi&{4Iv|y+I:O%q8%/ ~)6VN7A{Xq.d =.C.DVC@6\2E cF(D[m┝Pvz#$}%i K-XnA-ZD ;<(_#Da nVʈId=Z)2TZrxbcT1b8oE{Lڱ_`` /"+={f2/n{$xOMe5q8 ф}5b,qFK&oKI>  Ӭ 8%bOI$OKf\~qO:17f?ƢK #5%Ow`CgxҊ (!4 18|OSg.`_Jz @ v 8jCk\ `+"~rq{\m "㴐VW# õg-Xv ORVbgs^^7eAAϥ@)t1"6t~}lhx], 0s"`;-XזĴːs?v ƃ-%$BE.[x+]_"cio\'e ĵoݔ ntEx$z/pUίj(fKf9IlCFksOf6gqsXIRX/z.?'O)k]5q~cj f * ѝkl"bƟTh:,GR@]I( LGi`=ȥᩍ(T|~JOU2/:քL*FsNĿDqī]񍯣I d30[BQP=N,;0M:Oa<6mX t8`^g&ͤF@q;Y'u;!`}!vPwmx=D٫nBd!j)߻zMJ䏍%2Jy mjbdd6MaÐi'RUoA$F;.A{FeX#pLzFo~Tp V'UW\|y8LyK*?ۃĪʁXcrV Ӷ,T-4IjUԛsG燹%B#Xפ za{EtjtW,,~^뵦c]D74Esl)5.^ioQbmh໋@!CF.0!K| ʼnN\4b(cN~<3wR1 Z쐴@l#b,4b} $(6,Lx/?FuVh]d{#b%A[hY@+F^ ({!eEܞTP(CC"}l#g`1y`ʋ0Bpt=z*e$%!2&x 483{ 5QL },Cd7zޯzpڮ{hfJ>Wr-P"]wo}4j-0 Quv\m'+ [׸Zxg>Yqhx½iVuL PZsJeN~d3j&s\)ӂ`!=nbIKjlu@_8aQxƾYQvC}dN)̭,/L80 7 6k3t'PZ )su7~)j๮>7D:R~!Tm `:GZQ`<{d1̆.̻c[YyN:@7[(5NK]py"˷b* ťnɢA颱0/=#M5EkgYȜVꨔr3L%'eS3䮾N@ݗJyx! 13#j42כ>*9KP9"iDN\CO=0fma7%0Qjeq=.p"Xm)ggՠFFdX7? ^eagv튏J8F *"KYpO硖i!CsFM+#6}"ܟYHx 7Gȱ ^!Ԟ5`& #_'MV*X8B. ߆E-}22@Vh_TKC<PXuRxBp=?ho\Has0,:y 3~U m5s%תRI"lTm }R&~kG`H3B+}ښ8FEטcWx㋘-ݚ.~Q>deKB(OX< šèCIg9!T+$yno%p=aX 8`Cf(yҍLOYNpޭ7E 3Scl™a#Dqb&6=1kzq דKC%sTW͚t/Rwx"OFX/n\4˶8U*ӝpDZ> gAK܏cھ8_ɟ@U xo"S рw&фf١0z㮸CJ8[*R{h)%zZ>Tξfn6;GAR*?pHog rkvUb]mHk?aMsFp|0ZW;+=pq>D@s|ltup11=$pߑ\y2Π a7?Eekq'!]Z\G^ uѩI\ZdU[WN?|,jM jqbJxm%UA`)KnE{ ڐ]z7OjS' {!mC]Osڧ-!IQz-b|_Vud<ihoWvmKO%IT:fK-"MWJ'',׃~%p̔"j?/̱WtqvʉZn1u/Mcօd{.\?iT=z vO+i zڸ4ts>3a/bcvM["X"^$ޚ?KuT{\pQWX*T=8)aY:8~i:|Tbb"f^(3ՋR~TlW L@LcμݟL?i'AxǞ&"e9dnXmFVSۡFhޣ#+pL]D:;_T`$5)rWϽ۸j붷Νz*w+f(Mʚz بQs),$unՃa#+GsO?cNă4q[ߎ=˷d`YxlǢ$OT3yKKF~D~PF4ZLt$W&0 =XDzAMys(:_+:(qY 3J=]T ;:&3?ɓ˳V5 ׃NB$=CG(!7FG{5jPB-H~Sf7f ,;߹.|anCvWͥzWM#o>)lYuaú9/fӺdĮN̒s Ζ'H5~mQ<٫1 1gȇ)ՐEm:# }!~Nxhr*1d]~l3DH]TDE$Ͱ\7%eЁ=߲ϡxYo:jorO>% B9hSEctuٟ)Jw}Ns6#(vAX|N{EY$̂< Ep@ZxC&HQ,'ή3Ulta@wz}[9Vl"bp @aWvwT_Ȃ%pyYȚt"s 1O'sx vAROY ?'Ȓ{698~s)QH8޼w;"%\7Ru9C$"}g=<_kYlKgT Ȓ.cq~( d$҂ϙSFܑjs$cˆԈ3Lu hrC .uΜB^wR#~h6WL |v8v&o/JjVF䷵q浣3O,u<98Cu;Vs I(U.Mz3YJj3(M\'11M9#]>Yi69va*YXS:~ɧ]1Hdwz\vړbD?(B(S;)ʋs%\׍#rUHSprQv(>D{]Ù뚚?8z-U1H`ul= gŵi:4ߏ|v*oǓ'{V~vwrL8=A|T?(T ]U.>n|:Cij4?yO5tjp.y6Kh~EC) hV䘕x2n 1[vsl2J8 6mgH.Y̓xU{'2^ "2[-@@w*=j: :nz1|3vP#{;57T'~}KIױZ0@'Ao6.2H6vtf,gNk,R?1|5_D!3BRL'.FWbk@BKLٗ>[ͶMXLV]ỉq~yAO*b{-mywʏk^FbA"1V0!X\%,UGcX6sN!tZB߭TXa\&y^ :Ctqyhٛ5NiVa_5!;RBa Yu*&wEp\Β &klL[l[v~yTj66bI-Kʲ %tj;ruVC.n1HZ/' ~@mKe;7>4$! 늊6Kyf^,&hqܑyer]~&OrdˣT0PA#ܪ;pp" )1UX0Uw=h;Lb"g}UrKPEŅ7}ƪAbcfIT\ :~\Q lJ>M^'RM,(\idkJhZa?F:0~pRrGZC,;jz;w[0U"RQ5浸^<%b?]Osd$.X|?:2|H|!:#/\oVbgbM()7~Y CCۅ ?]<7:k^as:IՓ>E-Z_`km;P9*gMg42_yzQ9&.7+Yhr.I!DVd#],8̊]7}L,](N0 {7&|a@K +܃k.3b(S_Sst d^WN);%CI+#Y)K(H[>-p0q{"\n8b#ы٨=W?1%K%WgNtMcC, 5~#ro/"-Wģ`za,\KrIŮvֳ[APkߢ: I } Kށ~Rk j,&L%UV U[O6š_x$KEĘT9jyiV|0"rJGo0q-i lPpzsA& IOlXlD 8 V t:YR@Wvr|,>șC87y- HQSJyKV“paPbZ $n\,ug{ۚI]ҧN%k'}vAhqӡBknm7؛ND ICQw)PpޟRҍΝ?7־J.l̢$Kɍ; 1P+50^}s;u/|^b]f; /)cF~q)ӣ8Ͱ9 ސ^(UpU_:Wn_ w $bbm$ʍPBE7҃h:CyK[B=jOܴ xr(dqW6>gs!nf,xԹ~_/T\@Jx@$A `>SQPJ>o^]/!xs}>io).ږNrt DQ=~ V|, !SȘXxk]s}ZV\"I^N4wgY0Ȋ 퍣ln2 e-e\$"_zd܇_zUDxC;ZA+::l0.Q \UǙke/q:"sX Ώ*i2 \6nv~\^dZWdO̺u +'4/Ze^*ϱd (͆5>!%4I7pH5Gg/jx!?mj[@wA^0ohsaojØ|||쉺I%Ժ6`aaԸx4qI!c-  :sU19SίɈt/{Ki^A\|t;߮13ܠTG&}!Cn-l{I 9[-ک9a)n1=IKG\62tCv?k[*SDC YϜ8i8kIMH endstream endobj 68 0 obj << /Length1 721 /Length2 10975 /Length3 0 /Length 11572 /Filter /FlateDecode >> stream xmyeP]ݲ-5$wwn =X{έWj=1ϪIC!jx99X8XRj|vV.$qg $a h-@G' vrvЛ3M-llZ`{5&u j X*Jzi%M4t6ۘĺ   w0,lɅ w_a`@RMC` (me͝53#F:{;bEXؘ̀V6 $& x [9W_}2,nJ@8 P[A5)?,S{/}Yuߐ'BՖ-^6nZA^{19MCQWV[ OYdY]zil_Ϳ?bMM]m<Z} %&acpq889x8n@???z͑VCmKe5eɴ4si3`maAtAt:Lp|K4r8>CiHTLUa_\it E`su㚱8{Z#T*)cRqzޒ4A8_{F=HqP/ܣ6 SvL˕ ôrlJF-Z,ǢPY/']`Z6B_ r_oSB~iBtf{P08?lH}2>120t81I!g y}{-hX.ALY58uQOtmp7U!rj͒2њUG,Xf:C, Pn^Ԛ&v/td "ɜogXP]4U1u_yMM TdJV,-ղƤޅjot உj!x:H؟gp:-ɽk4jU\ZJ'Ra RamGpiӾzgxmjW`\Ei2`ibI Hb)͟*`H7.^3B3,hv\>)57.cTVj/':9XX.i6Xko*?mԷɍ'i՚@g2M5*nۜ'n_e,IdOn?fu*mN:6=^`꡽JTpU+<jTFiyZLN|m^k:F48̣Ŏ=rɜ [z/ɼ]x()Mcg[q=Qcuݢ0gkȲ P*jv<"ty#VrGS\>KZ iT)P F!~IU`-kϫui: "nPFf`n7ͻѯs$=]iFiRڤ;11RG"vЯpR5ߣ79^hS vcPơ@6X]YS-(wg1UN+VB{*x5w@z$-F<f2G5vCUbfhӻ,0$wخl H 8b̜[!G ?ӗY O2n gR5ikn5ǬٖoB]]K{,ڔ?A X eHQAS[qjRatB ?L*rls,kcOKe-U$lu> iaUEm/ wzɱMdrs%6Ckտ3Mp/J7>NIY3~~pܨ|kY͡ۋ~kD{DgruKʭVmN}`{4尝8Eey(Frd.Gr~kvP> =ߦnmz U7U~_POn`l M1ǥƏO(iAzab׹ԚNJou); r$8q'6a[Ἀl^bHW1(+;h+OdZ40^QGy&玉x,dY1rʡE& yg&o-TL龩O1mG9m$OiNf@O3Ng.-ecJ<;2Л 6]G}J Vx өP[ mx"+4I9/t>+ "'A3*KvD -Bf* yR U |h=곀MlNX)HS)/+leWſeak@Iv{% 0 Ea8BS_`+ bh`9_uSWOe?Fo !_ᩃcD|TGmvR<9ӧb 7l&1OM !E|c?>e~.RPO8:\ҤXjfB=|Ԙfۡ$u)n}Ze|SC~W Ӧ򪾰s87m^oso,9(qle1#_JO)%`3kEqfr:1XzL3_,ګP-i]ٴktvk ]? MnE/vիرf' ңr?q'/Qo=5?Wյ8C=))]-FѾ~,1M"IuM5 Y+K|NXm" FJ"ee|75Ey HO)˔^ӋMKĽu ɞLuQU+7OjI '5Z&|Q6sg?wɟxp?>a_;M@UR|M {UanO_aSMpp]T~+ Y<.Ï9c#1X XIJlZzΝyi9LazgAߢBhTrӔT܅ZiLDʖv[)1 / nɢqaQ }G~ ;btWP[e Qhl=ߎFY'׺m oߩ9~cF;_I]_p? ePI^e2K},kִ)gm~א IYu:'\}}̊f͝m1shF>C 8OnTQ 0,/ dZQU;h~I(C uEpRt7uYqNE2~FtoKYX `/{2.w х^wf%٠f h7D il0 k/EYydU>Α#e0ݞ?SH [#^ j rnI[OӒ0&>|FoEoseg)73NOҭ~iGpoRx1L7`8rLB)Om14Yyh+7? ^WܮZ`hL@WO9$^[G=e-B_lI~tq5Y9K)I0vD߸&1K5%yA#]<.3Jٽ ~*/1n2?4Y.шenyδEuQmN1M־7"!^]4&o\@C񳗪==q\Й"M nX 7y ׎_O/NDp[FEs34Eq$Rԝ^Rq$}r;0|i`Q(-u2k阅l5T'B,X \1;=d<|Hi͔X_DjM,2Cf@vAZPQĐ`HhBrM:(A5ߨ +]Ā kmq(+%;S8Yn"/?9 #(n񿺱AX.Tsƒ ̢ ~-ONrڽny}AlţBSM:.ku> ^%:i1P>Q!MQiEP$9~yR'))~{)~_Um]1SKPk5}ޟ u< 6VnI;=JLJ(J&ufխ[OW{XTlbB催̄qYOdAsbgDՓvo2Z2ۓ~<޼R|[=a͛4< OVŢHMZplѥ!YzbBkWp N\i4W!-oF@|LO˱;4O˕'B3L~@ expGSF~N 1 O&^ӹ4oFXQ@_fR9"s!ED`t)g@jejhrjBG%}+ptAKЄ4 ޛ6BIǰ"ZW]0ku.XwVEub䅘:B줨!AzĕKL.i1ߣm_rDɓdQ{fX[I3w1bԋN)BW葄zS 3D`ؗuA58^Ln='z!upԙ7P:{͵8>i9ƿK#"&-@z-5qcsq$v}90iګg bNX:m`74H;}QX)1.JdVGXd߈o<֒L#MWX:?kn,foLoX8QETS,E4?" @s3An2p|i_F;zر[:kjIK am;ЬaDB2۸ԟon2}r\%Q 67|>D&^ sVaˆ>Nbz0 JX #c5;m!Gd\&\#) i.?u9wŒLPBZϗ^T`c)'Rg,xٙ&!ytx5`9W"@j`˂rA.klϧڌQ~"WHƟҡ 2A-ؕHbnxTB$΁cZ":a֣՚%D{)$]&&3jtu[uTGdJBU|D흕V0dU=i ᘯ^Xnfvlnͽ4Mq22YAgS@jiňk>մGFj?2EJ WS S+N눊fv>A~L0lje) YܦBmiʖίH+q'1pH'v/hf )ّ㦧j,eJo]M~?R7V>ܻ<4GՍM?Q eͤ56j6^XQELSCw'dP }tH72b̞z1Ͼ3b[;hiaG>m4'Y0qp@Y}U *4ߍ,.u;줋E44#O# *fّB9k-f\>>ft!yho؍i:~/N<(ln >.׸&E [&g-fF"yoR H3(&PP 暴2Dt%_tyEM~)q趠f%p&C+d_%`-jU@Q5 /hȴ2*~x]>AN}/-;3o_&u6"SMCXB%]ZjGXb8XYC!K-#XuRa)mIG(ŧu޿HeOsM Lz%}7p[vb-1y h)0.ǥ 4~,9H] O0vzͫ` T(I[Awf sA15V*Vj!;%MzQoвZ$[L;R5'phV!6S9}FA[(-ɶ V&#5aRO.hDž?3WZ9y[azy{qRuXjqX˜d+EvC|Bbe>R#?zxRG%l:K!&TYhƺ,ӄS?< 1ثxto_[Xҡ 畳~yq(vԸ{L.>TxpI̎S t;uLG=ΈiFovƓԩY6LC" GiQ'2=Iiw_AԬk )+:#ccE8i#'x!WTYK^0CרmfP$qXy%4, > A~ds"0%Mf7}XY.wHncgv Rʥ.B Q)6#B+Mq~uâ0=an|vaRB6viVN%GcQyH)͝س>T5T0X[YB/waŔ͚g-Y<X-Fbh$dDqh. p`g}05`JԔ{1qe[3!S)>x3'Q@M0)JYQߔη2u]R`6VBĵ(50f_sPhLBpf=@TWx!Ӣ(:* !DqcYdJ;S,&Ih#' e+ْGjN C챌snmJ8Dq} ]˾ 5 IJGѱ8SVBR/<,X1j`)M %Es({)6h#"Hoav }s' 4OV4O ̬7V:\l{)[7V$lYU&׃a|^@/0'k/_Lu+Tv; endstream endobj 70 0 obj << /Length1 726 /Length2 29553 /Length3 0 /Length 30085 /Filter /FlateDecode >> stream xlyctͶutlmucޱNұm۶͎m{ϹqgaV\֏5 uV002T$TXX̌l #g ;[1#g@, ,Q;{G 3sg Ϳuk##@*""lZX ZRjIy5$hd Pt10Zl@4S;G-891+bv69qUa yU((r[g' g?dm1"&c-&ekjwb?9@4  @-jgc rA)g*߈Åmq ' wPM_q пoGp&T^v}?T&5Qauem&v@ [3?9WZ=`/ghaf&a,Eع{2pX,l?l?[GGTM ;au΄729xL94̔ dŠ9V? hϘmQ h|"$To wRK]%:Aj2MEUl=p njwޘ_Lʢ+c^34|VD )/ɜ,"n`ǫ3C+ =zQ0.<BCgdh͠( ޓDm?P JsZW*;IsFvai]Qz)oSw xw|8R}Qj`UwBbn/KOi3q9ЌUD0@Bpla7+ s}MVn5gey4vWZ3!rbn3>.p8)x2l/ccд g3K̅HI!T?!fI,}{|Xll^p 7(_̜[C=+OLD!ɤ? S8TMq;rE=sy&kAhiM\qv7W>{Gӛ+d=^meLVP?F|`(=+5Jtdtf7/!x8|YL +91\dy(pbb{'Ι5"vi[ɨ#>6{}7^džu޸܊'~Ϛ?I)d㵐MS5z웧fq6M8&w%/2RQߨH V:9GLi-n9ӕik;/<ҡ9N3׉uinpm1RS^h):,~:]Dcm}\0!~$.Ojqi߳2qLɳH^ФPzkt M+1QT沀k?H+I6Qdxb:b=~ +Qrms|Qf)"j\wS[q^=U"Nnc=ٵ\_1tx~ lt&kX^Up CB{w\'3Sr|O򹔽HV\xʯ9EbӘc"PK=^O߭t_>q;Bl{^>YH':;$,Bu}_+o(u/ fx̮qvy%/fWՒ6(耪9pY3T«? Immgv҅Yev_;qRL݈q[c!#Sӻ ՜PU枋奲F.f}X|zc8O=|J.y #DI;0H}"6 F/ՂF=oa(g*x)9;o'>C~4 ^]\YYDkͥŐZj;&ڔEX^#zi1|]Lތ<H5 ]Ϻy -,p !ČtQro ^j^o_" b;/{4:h}lcyvۘzQAD;1+1Dal ~N 2sބûC/i0}Y?;hނxC8WbD:l`3'=maG6" qF I=U;Y9c"YEꢁ|xi[UkgiFSBxSa"%-u*S%VqIɬ K*0);VkMOo!OȵJqU5eb "Ťgλ LQG)zJ? scL(0W}:I瘋 頔\6 ;=+R}5)k pD(Qer43T{جe^RlR?ydYs븦.PLjk6GeŠPo|ub %?ְX/6|ѦJNU{ϡ9CpbCr'4xtYayGlST9a4@h]z\݅> Bܪj9upf"ّp]zqV@^8 ,$70p I(3)p)B Gݧ5分&=T<į wOi?)Ҥz:VPQgV~p&` TQ˅78.L+GNP00Rt:wYAIuz^qld`m"niznj}2I}<$.%dg-#x,|_܌jG &\.kj!3 i-aR)ϰVԢ|{x0^ Vv|rӑ:ڷnm wq,LF-GZpӭK`NXisPX޲[FQ'SOFhA;lHzYؙN4!VPB"o:ґl##%oZHRW7Un(E sQ?@{wk.T+k'H,-h<)$>hRȓMb44_%y: _Y< *Tg8*ӱ,G逄v'  e;7={#@շ 6<[ ~QhaRSfyư%';Ts0Ƿ6p8_𐺿 /OQpvc}ZQZ"gd2LҒfF (4h]وq ^bUs!RL+M7vo#g2a*υ`$5iG$ڪ˅:oZɵČb?~g~eU48!ca=7 #G10v)b񱶦a Ӂ}\07dgK/CQ߉J[M(r;99Ew/Y y!R@=;?K S([_פk PYk;2\^Cl,,DEK~jKz̚BW[#O=!=!FжPfݧV^wE 3omVk@y~'O_7 jhQK[ł}б se7Xr@r|e}-6%ņm0Eѭ ͨK&)v:=Lf a&[>'mE*u7=k(Vev%6rr6̿0fh9%5i>Dm!.t( 7RG5|OZXσ,̆+[$:Qi#kje4F=]P@ZPP̠2,dktݧ+w|-A,`cЬߣ{C_{)mdWb_i21_'l*XP,5$j[4>q(4rqX+EKB,_NO&.U%#,Dx})i>1j0#dD9-"}T$$KuI%#EрeykH=IdZ`ʼDYgk=rr9ndO,W)_%OFi=I6yktttno}@_V*_-F$B\tq ]1zȗ2 6VǨkVȺo/`SQ\ Aq)x:F|ṳ~]MZyB+I^Rfxa=L'$Of 0J]+ -:TBKG X&= xBX0.>IO9)c`{Mrc$+Q "b7˘\pݦ*#G_{֚U)o+7wGJ6t n;Trx/ aac5~߲?5"5ogiddX6΂gH(iIlՉ05q^ MMJG ѦETVbCZgkbjs1ᷰAc"@p٬`%-D\syp+I wF蚏 Up(ldgIpt˫v@f'eMoXj?Ӭ76{r}%*jY<,vr\JG)G $%`? ~G'GWR~~-?ҖfހsTju- z[n~e\).6Pc5^bH~Ie:F>FEE{IA:i=瞙B~%-I ߤbIk\Ѥ97^gza7gۣI- Nj^E\\|񼊄9|W1*e. F=f Ѻa12٪9#̉+R!b Wq:WF/wOkX^mF⫦=+.ڇh[@KF4=EYhtD)6IxcBo),<"_fjq&ܳ9=K4äÓPw n_8q``OX,srߥUUqDjvGkp):qw҅|+6Z6Ll^s\q 2ۗ:㓪LV?3p)@Њ_~m?k;0@z"szG Ƣ&{/k GkbUZ,j? ޾{QE*M~}@F1JGla<љ 49ŠDKC\_jyʛh=g N-%CΓPhvvLMN_=߯x?_aEB㔐R|~KcB$o>&O׫=c/ʛKrZXm x%diAlRyA.XmwbbOkI1ȊΨ+"|c_?J- W ֙]^7Þ@ȝ`xfA;6~O)&eV}fn?p'.Јۢ,T֊ؒ~1Wy BeZB="oQS(Y=0!L0 :Q+o]q~+{UqK_ӷ1uI"Y_RՄx;Auwbbut7n{6cxؾg` ' v$ Oǘg͠zM]7;΅+E"(y*1JT]1Î[;{)g?I|ծS #j^xT6/&XYa B)&Nw[ࢹ\zLL;x1pKQ7 `N{X =ސ$*MHC \z1FWWe_Qyz%z+3/# ^rY!Z69]wt {k6,S?ʙ6[2/] IHfR)Wq'T ]bYMa2|wI4EGn)QM>9+2}+ wwuCw}Ow'C9[ ^c CzxM C@5WaZ j\z{,*do>oՊdaN8Qm1я #zV3?pxˌP8j>-rdچpm]#YFfl+Y%)~FXjjqnfgFP_l>ȞAܺ$uxQۛ8\.zANԑD-x3x6>PEBx<%P"?"/J{^}KDť lj ;.&"uE7`ҊIp2Bs\'ݾ "Et:$3 ycYEl7,& ŀ:3?#1#q^HaU?S`SI $=0N-}(8p\T4FI!f5/&ґGn|w!37ߢK|e&{YN/IzlBSF#4qƽ"*gַzt9x'}N|gu-B淼W849CgKLU5l8qԋ-~ ݱQr;^f2*5S}HuM ɰydsgxV8/y9VlCƙ  ?uq!PP=;v _j\>P}O^Z+ hG}GcέB?5^וC5 i#w!sB5G6#!7+Ȏ,q ( ٟ (W&Pbޏ(ySч ck ?sϟYu]/}KE-`!"¥ DY90$Ad*CiJdBTw_m6qp>/־ԩUBq!+ ][&QbgW${p)IFG疙q ru{ \SaճC4l'?x ܒp򕹐WoZ {__)fiT!USvfBˌMYrh. gc)?=pE\|MDXVoӶv"&~98`8qQܙ3^1?kFۋ}u_ we>srC{a2*ifֱ |  5%4]TР r}la:zͣGC1p|%~(wQD%{dҎP`+|,ʿ>x?Kg~iȬ=1L[nmǍy} 8jRUᄫmw3Rkjko@ N\.[`?s{:ɽΦD0)5i`=w[{Yq29קw1F8qm]01ZgYV#^R:{?D+= r Ԛ_" 1B:[(1۝٘DZOO9u5\ aoir 8fx~R%Ah֙ +NqXg¥$zpD5`a#(efhxZlU@T)}dc-2kf]eT Vij$5zXۅPtųVlpN0" BSPXGSP /.@VHDl8qzdF?GL[\BiVf* Y٥,=l꘢x]YyP2%KMx1CO0j;hONZ2t[su%uqW$#bA` k "W!4l{*%)["ևT1-b"6/2 {ܳEEB(dF;#TƽH"x_w`=?Lhґ9fܧ%ʩY9M ~yrBV'VO >,9+w#97 !ajvXR 0|IM{">9f%e=i0Y!ӤNU_@, s6ĺ$1rLz {W*y{1ϏsOov-'[8Ee3dZ%] *xKY"OK!%\t/Mτdr5[NjV;h}UN~gG2 5A0"kG{'"r2"m|?;(qxG=IC{KiZH8a1*>m>w,6}ʦeG#Ä*8@'iLi{UpǺ5}"d*h+8w\\SxE5>)Df Z6]s<Ji(wNq 2P8{sМyTrGĖ66^Ʋ C {LuѠU ̀* G%w+lȹBk{D`v_5,o s$yJ3} edFՐﷁ-6Yr6cxo;\׫̘aaSWsa)!]+RJ𜡽Ũ:Vj?f5ܿ-N6|绥ڻxRrіjAp*:s C .@nv=Cf ץwO eʯZKyYjCnCߊŞ>8nMz3!\KҚٟᤊ- 7䜗#T ?NAf㗹?K@$o7a$K[qlTBO)5[4>< ),ڇŪG +7TfȈ R-dmTPk?nPD& "fbS{=k-\)DBpՕ vgSn]){9~28O?c YLAtњ-:W8UeЈh&N/%8ڧ(f1xY;+wѧmᗇJ:x4#֫LexJ߻_Yiq2L&m7U孜\aiEn8P:|{=of|.ݍM4 ҵr\NOibH}=-GR- qH]Zgv⾤2a/F->sf-muo'VD2/q5lœL˗7*&x'Ki#mNuI0hQBT.?i) *Bt]>X]KN(z|ˋdCOK5b5eH M-hF"+P8-</şʭGƽ=Z6F%Mz8ؘ@t3Mi#`:S@b" X0XP_Xʽ\Rx`!!9^q[7m{ k- ]3O7Q/zi;79};⫣e?+"w ZqzД)w=uvYu gRT@وkXh_ڸib heJ6fv5ڢh$ޅ!?% _X:hewW"5D~Q]_DB -m vkD g=/i4G}̬Dz6q{1ݔߩ(.\4,%@l?>{DX۷yE!0k%qQkkC· l>{$M ."CIYIvBu0K'qp׎H0Zo$甽qjK'xb;P2g>G%3cE-bg9;]1נ( VT@B: ^fĸ`n1};JG!W{;mƾzApCs7R۵/}AȊ[z}^6A^iJiYel&tzedZ6 vwSkP~m]9C6|S+N;@&cg;͗~lPzxV^4dfM``vthMD=S[nκ2Bo)u뛣5Ya^YZ`JKnD]8f嵸d{H '7otBn9JtFU,chRII#A1GzF@Oj&]Df+(fy|MHnEK=1k8^gG$@pyﴯEWȹ6pǥ@ _$ŴCVϯoRwM0):Ŭ"nO_[@!-3t1dj ?ZqFݩZ5A^˯ Yw]pϹdCX7uCk06zGNm% ;hG W%Z'ΕMڠ_YtBػ~ G/ 1Ћ&;;yX˛5ޖ$!yR?3%b_Zvp0|\h}E`_EW):cP(/NxRX;)w㴫n!5V΂T+&-Z.F"Y0/Jc9U `' ,&6ѧnmT# pf;#V֦j[l6&!.3P@M5_?j+:ԜTᇀr[Ez)+KRMU@h@v#ų圿 ODSHGхH>k}ښhݪ}+^e.B6~l?eDN گfN*0o> {"W`?8f]R1],ҫ_,]n$ʋmK0{^Pw\89ٶٱeW8W+\ aWu,.ّ3!sJxzƖ|H>ãRK W&lhZ,^U!RScܲt>tѧ[Ә㰒 +#J:=u^8WyȂ {{*[}[~ECCbMDf ;.w:B~yVMsQlo0k#S0zd9LEx\BӃk@j#TE(j{FS\Q h~^﹮UHv~RC_DLs#XFCzmQ:oYJ2?DBLJj"_j?:tO%[+y?@ΑWU>kpISuja}>r7tˋ{0<{K8oz풹5;GU7#姷d'byGHϴºYcyrs#~r"Sqez(L#zPMC#Tw'JG7R7s/R7_}YaPM@d3E]B82[ԍ0C#QWT`TwS+ZAqb!fyk^Oަq)$K^ dw85 c=&s.]A򇑜;h<]Fg2Ĭ%;}%a.J˞CHç'Vh)ȳm:F`ev>*~Y`Hy_@bQwtd( )zof oi% ~s#k]q it{w |[2K'(|5J@h/pMq1[ {G ?>)lbw ӛ{'t$Dn<@ϽkjJLX\)k7-% 56KvJ]AՃ ?Ƹ-0 u?Y1( u] ?Q^xGG%̔WRx<1&FP(Wy@r?}HRD9XUJ)IJyl>8 oke(U~5dtEӛYXb`N[=K4ˏ,xc'4=<8{"Vtl5^3U$N^% N99v_Ƚw{#Q7scP@6/VOg536ȱ(CJ$hxdj+7nA3(? Zkg2sx7:" ^OaE %m3)cIghpLO":% @_p_!IeέQ9]\[~i`ͺ{e!SV̞uij*Yp?~4<B=1"Y;D¸l_&/Cbf_ icMV&i0a@e-}%d 1ȇ ~vf[IK>;JùXf4sKMY뼢|e4E.dcyˊ{)n aS7d1^4_'Z`瘂 bBXl\ ]n&ھ½CL-eFh !}Dv v/Hwκ&Zگ#8ԖUs?6At\"B{hBǍIHJt#YZkk'yr9(G$a,G^MM>0Z[f ,H`㛥b矿M_NQMy6ImCo*bti }Ud[ڶqZGjiT3n,rZq ԰|lR sIڄ|aa[.s&a_ߴ] (c۶mɎmVǶm۶mc;s}Ҫ4_/EXo=o.B1sWdG%B$-fc!/ "iԹb͑e,oK Eڔ~YϠqf0jOfo-x6n?!Kك5B60|jZ?kvőX9YxRX ܓI}:턮 Q52aSd) |r)Vލcŧwյ'pvQah^@4-yɷ#]`ۓ|ÝkY!4ASsuT$vUV9_Aꊚibx-jNO`.skXX0Rr0y3)/bic⹞`ޗbͿYjRN`TIe&iR+@?-M룂M?Sb[Zh!jhdSڍt5(0IiXe~ojָ<~;lvLh2JW_'}>~\ b!U ? ^z[ل#ŃvUA q~^έ Qj~h!!`V{j ;z< Ap/z;]ngq[lL=qC#le?ށ%G2c~y KKn_c{*S`NSZ5,6c?U+/W2.r!i^aK23/y.L<ڰٷ`խ/ W~04KM^0h?gG3:m7Dk82wawD\ H7vU 8Eh\kW䁃}@wMW1e`^XXUDե;L0rij'[dԵ8HUv|.38%\o=XAT3<33""cr[s3EZ(Q[5]34Ӡ?aR"^qgǒT9((1_D?J.?tlER#ˢU\9ռ:AfX8-7KJS )q֍a>d.fc}Hri2$Rd*'1h'ICi (x"#iN,";kF#g,5uI^A ԥVRXy4h( m_#r%0N= ~Tq;IWlq2#K$#WUbꄃkVSQ@7Pi*cdĆ6O./<1=?*4$!in$p< /C^glN^=;+@@o–Ԓ,fQVlZpnơ@zYEFBX(bXuhuqbb)a<>T (m0c;1( [dzc*w$ǟZx~e%2_dP`3gA^(1ݣ־`C퍒bTC@6iOfXm&tG#3)BjEm`K}9ovD) )X=jr0O=g=Y-w{mv,NQԘ~tB ts#{Lr ʨ(PЛ̙di_Xsfȅ,Q,bd dK)$htsjڅ)?~QZY z~]FngBP6~tIn tϾp`E P 'I6k8}ͼڄXrd>3,SA_C>0 'oTnsNP /P " MОNaJ%K(v Miy@K"pfF ֱMeV}>/̿AB/Q94Bux3lN!IT;fGA}/td$Rk3oV {+k^MAfS2l\`:d (_hlԳUT)B \RxAwyJ8vo??id0)e* IܰҽXQX}4hI)=?2ģ\"&0=Tkׂt#)qr-g[BjP5>XqΆhZ./l1.(ʳD">͟NZl& sx{eQ* LK&b^gxvnܪҙ[گVe `oQ@UZf O0=n;1a &5-4 6?lvxe2Sv}2ԛrkQ#T T#tN.9xc)1h 9ŠG'__gA<-e;# 7srŔQ,4e@k"k!:AzzGZӄ^׿ܠU_&s!9a8g/*cFe~l^SC4#f <- yǺ-v>J_3y0=j0/0hMw#TkY"EskxA 3w({Zפ$GT W9C=2̿q ǹlhà<%2y:1 6SMi= Rbٌ;BL Wڏv$) 1>2ƞI;'UXV<S$5XE)NN߳j%1;"`/cpF 9o+9 =M{'g]mN"KAjtRP9g=TT+W9w+ Z*h*jp+Wu7L̘ c2w]C!kG݅ϙJț'iBV{AfY'I mrY=j8[։7̙Rd3]JdԭIԜgN? C)gǽYR4A[J\{ӳ ҙO/qfk@=v.4nɯS^ux0ۘqWe!cd!jc7dʋ΍ȥ$ ڍZ9'H(&1!~oZ=O=|CM9]ږdHbTcc׹@j^DZ(+Y\xS^v[p5rIw,!MtF= _2Fv ^@b.Y"r>Y9AY˺pft))G;bg*S/ Sv"E|3H|BeE) iwxr=faKWθtqJ/B (7#hvsۜ-@lj.l$Kk]S{$ ?5HEK぀ 2i׹w9^͚1?01dU%^\/1gVÍ#ԐBr꼕vh  d!ބXJ6-?Z7ck?C.|l]p%WcrlB\K5?q=r#,D5-9Ұp@&8>ffX=ݮQ Z&J-dfXx>f5p8r{\[^luX|B xZ+z>hKD9D.WEEϏ H-p\1([u~Nub%Θr|K&,E ؛"QSˏZ;f~p2st,4&x\l GHyN*ScXXMPb8!z#qNQz7z•^\q, zߐ06M)A2S!E84Yt)c1:K3[662!*ˡLzX]s_'QFK7Q"!),=}\NثܦeF#w@"iîg4McE3Luۅ)I!mF"^ ?E%#Rj}@ed<) 08E.N n7Wg"hٯ v qh_6 '?4a,EeO04\X_ cf*޳uhHRI t#HWdՂ_mݳ;T-L~-ԡoG_``W!HҚm;FuǺbv)lqVVB1p..,:րLÙ }6~:;, Ǭ6x6Z°tS{ -s`d4"i0T1g=~>a!XXb nB5[, gY̹ۻ KfҪqԿ[vsDPn#"#RcBԭ%w#@av2N+p ls]TS{|30vo_0o'`+e*>,.ͩζpcyt8m|~z'UDq"v/ K:Y4QR֭ŽeQ*W.`ð \YWL_I&ZK9?(ThlI6*?%-Ask;6swgeJQEZ컥BGX9ЇuI9v2*"s;؋>E}ӆB<"3;H׸yeCS8]aqN=9M֛ްԞVo[0 am@'ߘ^aNJ8e:fyeizEH|Q] Ųz=Uh:Y-ޮn:ZMg%eQp m+v-Ik91 zN 2/GN0 kLRogo,;D0 +d`wE;Xu x j0z:2c_&l-9CC/x6i ,fԑ(QwCXkC{(Ȓcm/7rZaHn&RT vkժR`}E4m|@#tAa,#5pM f< |% 0]>--kO) ly$TBT;sܝ;{ 8!3ʤBFuNtŔ-O#=mWPGA_ԽܬӛG|ɨBOB"cEPfYt'^FA.8z3-ɂum7(kmVŋ[a0'_"%C_^Dv9 7g>k<"gTO3*]nzP4xZ]2L PMIi'NvyE@CF 6 'lbKəm:7-Ἆk ?Luem 捿A:M$]F1'yAf$y3.r i/M=3)2)k$`BO`oy+mmX%yOBhGWUoGU[+27Hãd7sE{̛FkW='(Uvit)XUKP?X߃0 ,x0DMަaɦշ]X㵢1 +U (̒b@b v[€aPwOvH9 [ٱS&`ز`~)EuM\|B}rN|AN+nVC6mⰤ=5\[MM%SI2M;爐4L/siC?BOr0'O>Ga7%$ 3ղaX3 ZpSvJrOC߳~њ\9;i 8C,aI9ࡥqإ^y]JCYӍ"q s"tF747WlVsJՓn:cN=d p^L}.ر]xy2]9Mq'P)m9.|~[<~zɡ})#'Ô"`h'z - ADArtە 6lwYN ɻΒ ]zqE;HOwW!z%~N=M yTg&{?dJӧڷHvGwYĻ5aq4FUS+X?O Zh6L>H4ǐUmK#R9`& 9`bTqףA!#lOz3JA:\ZhuzL!-ܟJ |ފ>yΌB17_->=)1m_;$ 2мtKhE&REvbAN4D\>)-įcdSVkTȢ0A"6 *{bޒ?_<`yvG U {nMJt*.f2اvqofG8@(R& *tPȺ dk/5V0^ZC$&9ncKSSUAߩ 5M~'Bb L 6)PaQrW!kk4w^QLZ@^{,W3?|; (G#`ݍg*6Mea]g\xB3a) v kҕAw2,i?kAUB(d aF$wJ = :4rmq@жԂY \?Iq' Ixf;j/dykB]ܟeB6p#$e}v;e^'O DSDcr9RR g2$3YQ=h _Y&aםjǎBBbx^FI :NseNS|Xlg{u$@HЬX5Զ^AE"+ 2EzS9Lcg"9\%%8톓 ;ݦڞ%E( a)P >VUמs>dPEy' hצo}}vf. ]ܢ쯕|7LWEmp4h\taa񇛚m<(cfSY4B+z|a96W. Tfւg}TVʖm`g=لoIe7qF+b;& <VCmMځ*F4JG*iVX, d~;\w[9H.$V'}.w.t7\]% }kg-pj o{zٚ-D'g)1, >rzU^4)9ؘFԆώ;{Y.% ChRV7aUF5:Cq/=,b+EȨ]W?.hF-Ho CNH@@KRu{$X+VRݑjEI92vxr3FPMw_;3H5u60Pt{._AU>2< cZX;9rIұ%޴ڋՎl_],6ʗõ(dDN}7Ŗ/ .%{DiȤR y;knL"c71(вMhbq^+9OeW%y =3tnl1P"mߚIEWCxuŘ,Q++ŷ|?NN{:ɅE2"1.6{da#9sPoLBhF^_ѹoaag Fh4n:ͤ~<1^r1fD/B"rgXp@=r}.*4o--է; ͘iׯPW'ݻ d+ 0!ޓ:2%w| E@[Jh2X^އ U-wgzTIaV؃l$p[alπnV|.=8p_OrUkNumc^ntMXR41n`qmQ&xW4ine k'ĉaoFA6[j҈H{4Hnyl~SlFDH)9]i >CgpxiO?o1`7QNmGI6ĖUp?(R)`SuXǒ%~̡}߹s{0-HnKȇ0;2ȴWL^3n0j}6ݽ 3ƣ=\;X R#bZK^tʍ1 . 4&MhIx} >SiaU'8C[5"}td.8Z|?"׍Dܨa VMV?[Z:VijLI8<A&79\9{RPQ8 0F<&ĪӤF'8r %Alh_?Z6\L|1;,9<_M =K%ܭ=er ⡊? ; w&B4^*7 T^/a3,yB:Jc*ܧwRdUj^o/d K5$Lp\JRuWi.o1]ģnFX +f؍( U.tKNA#$L6[ފ5w*D*?m b ] ~GRnvȕ0}2pKӋݓҜ;%f\͡ȯ#"V9yw5{s|DjòX:,JiuE$D;S9צC(+U8_x_71ve`k~)ЊLTe Y?sk܈T.V8^!YLd3'SL+y,>Ɇ0ǤɎR7O7qOnDxYEZgdq:BVmb7!i4u{K Gas]7~Exݛ [%_wwu\|k 6<_e=Mv&_=p\t!}$1P3^%t9e;4㣷z!iq@ssmfoǟ>1G,!bLk)Otـ;*90;Ț޹@=oa]C<\⧨ ߺ)AΡm9`.Z ehIr;;6:20XMv~1v&ur|J1r758S #B{ ""!S-s,ݥE^-Eeqk.^H{DLn)bFm+osl6}Z@5.NSG\݃dPqytxDgY`6kAv 7+V )ݫ h-1FHDӌ[-d~xI[~! YIҒ%("='L{ S+4(N9H:oc}"v.+"LW,`I4-CIQUtsr|tAU&3P3IQp'gw ĐA;|<{/Zﶗ |uq$B9%͉#\ăXD ^y͒fdti6NHh8hX=̂Z&XMtܽA&X0?',e "}|bjSH1V}9hE 2 i<]\.M5n٭8>+7I r [p!`MSMF&3t|iQBi)K' " E*ue5χ磢)o wtt rvX÷JJte Pk8.9"IWgDŮf9bPsd HTT;8[yxyI5d@tP9]ͼ@6/xda]!Q^x¨ Jh[E"ie@&϶VdSP5lv=Q pѤ(x ^ҷ;Vx$6@󇚛C-*ijTaO <4.\B%xL'[yٳw _ӭ1vLO3J=z're endstream endobj 72 0 obj << /Length1 725 /Length2 24519 /Length3 0 /Length 24948 /Filter /FlateDecode >> stream xlstf-'mcxb۶mwlFǶwι{ǹUk5k5ƪ]dDv*LtLeq&fFF#= 3VٔnjP6010D=Jc;jֆ&@#@hluuuturwt)`6+hJI(%T#k1ɔ `fO`lgk''u5ut @VLEH\^N & "05?hScg͎ZFko?=h 0251K7)[3;&.?hH015bm-ghc wq6uڙ:#@ mr6G ![c $t75Q:YYS?jbgkFg*A\FJCVa1[c;9@= Mﰂ!??\'L-kth3+EQv^ť:vF +8::[?'1ڲ1Oeڟr_ HiUe&Еkmࠅ% nϙ#RwĆqGD˸/$5[ozWj86rk ԓY9g5|(Le}?Wl%t)P3LhZ\ 쮁 \[i=WaĻ4hC&^6/T&iUro"+rxLBy\ALJ ^i_fxZoUw߰ /oL'IM܂b/z0/Z=kh=" ڼſa\dԓDD^%+'{)+x\oUL,Wdn}DK CݓNd}tky9sAʗU%htOPHRL-[oaDT |ZqȪ+=6h]UglM'*_/ؘK\md #`O޲:X|YtaN1I\g I0Z9 )laJHAVso.'f`)t J`|ʿ `-oc?P=W|qGL*?\]+9uq vHG㯤fJ#ґ O.r@vPYQAޖntƟ[^xAfǝCBgYaWĨYm(CkԀL;4}zȁմ@_*Q; )Ƨ c$陼u q_i|$N )%U7ZS=H7xk^XAگWg m9΋L:E6}G0iް6; g$}JCsau ~ts :ETw,$|rV/"\+63LKPϠ9?%eolo(g@LK݆gi 2={]-2| ;{ɕj@wocSjx{u)3JnJ0%B2ˈ7\=<^hv>gVObMI>/֍dc{ڎ=3pxq]* EiLҀ;fƒ׼N|HR<D Y 'OC9;YlQ(a@iBx1'G.yzTf&ݨaPG 1_ɀtK8<G_Ljh^!GuAqϧd\Qz X)ݮ[jj1&daF URac6SK)TorNx0FkN3cʥl]NM)n_a^΃NLtϟǵ\(wAxSnᛪJldˆUTJKG26^-u-LXLKeaЉAHrޢKʼR\W{埁IyX2<>ݥ3ؽ1p? Q5YJƌiuE,:AoǸu$RfFt|Ƭ wc?5xA1lCSa; :E!GD_-M,*%&Ꝛm5#dmYgG^)2$.y| ޸G)sRbwHזτ ._~@bpyv+.屺q.t;⑔ ^AUpgV^XN*n)t0`o@-=B3Q:ˢmj4|sV(Oc&i.C#853;SC"[<OW_D3; L )N&ڹI%0j6Qz\LuwqnZ, QozF[RﵷC}a: \fӫAַLL~$܇I- _ Čp~'2q~!ݥZf#.H5GRT.[bȪrj'];gcp)763#0j&1Hg+n<ƌyUvk3f!E_;0x}%KZl^ d 9^X}[oJ$bD*ӀD] n|MH7D߭Z륎";>y$l^3r;AL.Ni[G/q1-W9k9S8Qr5# 3:NCM햺UfЭ"yV,=~ AFt8ccw)e?Q/,D@AӬzX "%l|ƹX:@8KTq}\l"pGuxڪàtiuTdFy_D0<YxZ6n:+ %CGZA7Y]:#op浽6oƼz&;ci(ݵZ:O22pZpFE+]`c2qiiϜF7h~Ts36x(Z?YcOám =rPj{p"y$. xV$FaV9SU~ĪXt8X#kSa-<{n 'I|^G=,%U>T3rY"1=T6Z8Ď` &34 6a{gMf #iהEZP~y\L;ܧn"KD1=! u~GE|eoǤ@43Ѫ ZTs}V2mP w{`j(7(1nYk(->"'f8!.վZGr?y;87 bJq˸Wv;~"Yc}-pR|37 H<@#Oo1,KGȿxsxwqضa^% 7P6.ڴ\ >S%$+bBu nw|nD跄ꢩ&ɜ?Ә[o*{E(x$vq.eI:o(l`M;\cP{:kuN)b7o5^<֪tN ~7lLãe dʉ)יzՠ̠Ild%훾S7Í0t <rI}w<|CgJM_ /DDGoi=u;p4lpuU";AG4u*E[o<A X= A{mkRZ g)]r5NA亸,$G6Bḽ!3y!=\zrtVoOVAe=5\ۼ:/*TU32 (NT>%'=V刋&#u6z~P3]пI cĤÄq{~;mId\StF< MaQ>>v8*-{)z=@,NaڜV RHS|c_W1Tm~XΠ.FM#cVpLRPt&)L}HV?f]etT-gE* =mx6EbfqzxImu-ohs8#מG̐x1t6HWE~Res^%DZx,XTrTSq'-W-V֣0-l*uoy p"4$7i w{Yc3u:=S@~5ķ e,[:F?3 DPn1Z.f)B$+3b߈iULdjuV \Z&Gu%7~&Prn R{RWXMx?bw+yjf@F![7F/[jWt׆Ч2e×ԁ%EwdH)-/Nr%5'[nhk$Рm{ f Kkn4To 3}KyTƣm~~ğE,wyb2 T3Y96zDVYМ}?p+ɂ as-f(1/ڲHNµ;.FV۔ֻݿլq-ڭ\U w@z`*aw[f\B-Th#lp1AԜϑ` C +i@/+ډEr{tz]*R#%WXXW82tX=OLےA.LHlsjhӯaiDsB өL~`dgF0_G1FF~<][Fl\x,,|'QȄ.t%^թC38U{$]q ld%iQr>I͚]İe03 $L6\0BEybMANx4ݼQBt Q9lxt}kkt$p L~+h8]?~DBlOACQ}=݉сCg/3m" `ܫ^z7w.`#v=T $A T,mY:oWmzՂ)2/8 O(A-q$|宣WYs3#1:Js.l.l#i-JcWi2L+g㊤XB3âp$,6i1.m ZT2 WcE}ݍc)q Zpg@o*9}8+;O4UU/KdՈAbV](~&lXNL H% .p:n>4mӝ~M~6z{x cr5wKj-'Q5EɴeQYN <ѻ|\zY(qqK/[\Z ^b\z;)9z`r>V j9U81U0.CPqewmuz=v_wMW^%( wM8-nb֨ _>3"5yl6ڄtn|k7ĥ׹kIPK2I'xv^O.[:*2 cnӵ/G6eP&&Q"eg@Y!ʇ*E돿ea02jՅˬ~0%]$j7/:Fj9 ^ыBe}] _ޟ8ԷW@Kilg?!tHhO?@ٟYeՔ7]88\hMmـuIҽm6x5hv7XÀ#^jYtZNU9;cB ^7NqSTSݝ|[-WXU %p"z mWi,Hc:_P6P]ĕ0lf6xb'ˋ]O[?՟_JwA22sJm>x^l,:NJ16 0.qIp-1{ح[ЕEd׻? m^Im40]*σYZ b 0{5)JM/>(Ā?n7fjG*I<7 sc4 WKeZaTQ>OiCgH t׹b}{11KnL2?A3US dx_n9Z*Ɩ~˷hMg C(tc!Ȣ2|Q\ag+_E~-d/>J59Tj#}c^K0VRXe%ڣDHBSjbSpE;>cHb{л{9ttZ,N¸PCXUЫVǞg%,HW?eݵDO $FXGY4Y91 H?;߮_ݪ<A Bc^i{OM Xy @\Nz&9jfӧRz2b[uWW7w`,Tjt pSr` K2nS_2-kv@#yvjqªqma ',QA8N}І#2:>;̒>'qhm&OHyAf WC7ꙝ3 P+gg_d斮~y3/5 OBUUOb~@%N7xY.jEȕʈi}xeA&IMQ<u ̕'v )@۫PQpvGK3+&Y%d` ?$!Mf5#xڎ*ʊͳ ]JAc˗W=,iv@Qa; 7BebO;ڞ,ecBJwzd4x^d]tyV-iʏK<^dZ)gƛ3vʋ!m6t-:ʡFE+:і)c&Oev|Wٳ5Vv˺_,f;zB'0-4_MN[C#>u6Bg%(0hʺAV\#zIߍ{(Y鏇OvZplT5y&&WaB]U=w9n9E\E>f5I{rquqjW3,c"E ʼn$IGl"}b/1{ͫt% JaAjr &B V ސuoHm3\: Nы۪{. }f0\ d-HD/ 629!|!Pãb2HLB9"Lc~u`*3~Oا9>]!w ^E~d'25rlXrj$TW$$ooÏuTK",O;qZ3rCXx]Jۙ̊JL--a8UCyٸ 6-暃O1֮D~KUj6e z NċYx 8_Z3 +u l0Cij1)~.}dfC5`Ӂ$LTEo k.2-b5W|P@ӱ}nm| bU{t^ڦ \iR](s_z'4fDS.Iem)DE5.#{{ׇR&`-Wp. ~j~ptgF t ae2@ʷ5'fcz/.\k(V}f99oj룭5'0+U6|[qFDͶW]5@λ0h`#?k־hTAx'~@h<6 biPVT?T9& &mP.u.ka<)ɨ8_m]9KK>;$nW>/F.y-5}lR0̌| 5 nQgz[+`+&}IP&k>p&MC2D>`_w Md] tɍ2%q z&dDߊ:>iWU)IT1Ì9žT52>39ЂY] J{*)5&t9{[ᵉld3Z\!+-KhF/)_#'*G)?\WŃiʆKgl]2%Oy"QuYijBA{˨AMqfEm:гKM'vicӆ4n#\"gAS}(uwXkO` BR;9/wR9@Fy"뽲tƱ?3) AI+ (&\(58 UTJ oibzm?0T %R]#k;ߠ;~\v:";x|l~`. Nx[k%`g*K /T*y:*U=Réfa2&p( @8jI;DXhLX,R=TJ3 n+-Х2ID.N(}Uÿ4i6^Wf.Ig}@7AbOn!.ʻT3hyiש([N4::j!44>*as|A{,sR Cj6YC_a܆B-{B{ .;צy $U 5c*Qܳx&Hѫ *^b=Z>%5N\RhC7|0.>v=u]i/ Ϳ~A1s2-l#N|qx>;RtD} 9z5f04" Qк";./lZl!Zdٳ%!ޣ1.偭cnA~5?D=NLn-.wRX Kfyƨo4.>Z%z˷a9щiVѬBvkU68 8]<y ѼmvK7 'pلzznI`bRP&V~ ވXcSC&_{Eu)nPKf AF[9L$u`%G}IM%*D<9V K@2,m(1~ TOQqB(-l.PE+fCю5 j٪׏ v72)6crufS~pq4cl!$)$ D\^ Ȗ?(陃s 7AOTȇPy [:`.pxERYޅ|Q ͳ\VzJf}k u- ָX.ɽDpu0^0?+>g8'tHl`G7ྣZW*#@esc=)C΅>LXn*"L9߱&xKSx"(K2G9LnaNߨ=:>A!񂁭=pfBӺ,ᒱ6͖riEcI1;SZA >V㐛ևHǢ:ב~?I`nڒsHB<|., Z7!dQ1$JI6X}uJ[bTSIPP1L*"S{#R{Y&*$SR# nB_"*]u$V̼7.[v3߲X H@5iܼO6,E` I{ EQZpHaTҞ3ogCaP.yJ/r `~Y,LII \2$U1Ԩ˂c2j~).J.^:Ds{Pݷmf(T:[U*}4NpMw6 Ӎ0cDV ^VzyuY2+_yY5Pi^ZEdpN6掇Ǟ3"5:|fK3=Rª~"Iv ?} wE+tÞ3(;4.1,(7*$UnMP. \!<5m%aon ,{,lI}2ؼJN,:auJ!5dz*5a^; /q슒fF72A3o]`Sg?~fᨢq~ 1"dh|A1 I t:[gc@nlZzs+Xv+g39DQa;SQd͊_<2.(|J{6\ w>q,mVW¸pj|l]A4c:'u?co h<ߚI%!6W}ߒ\+Liu[BU5klzf@g7#sL4Ma#y] rpP22B(CxABiņG ֎<%,&qȘW.,6Qʺr-?]DU Y:H|M,^I*}\ UǺ]G0u[^D C(y'T,ֆ]mn+O3wlp;ah%D:ROiR1;o\t,%Md=F3&Tz\sT%5_Ӵ};yAY0*'jcʔ?O'^PI3֤ٞ)$H;!"viXSlP]~B̊O r A*8WO.To˂G-*Px^ `)-Nm1Rs؄㣛i%EfBr{: D[8W81Vk&U& +h?,N.x?$N= 7=9bȲނ@s}=2M:O>ک.8.5G $lS .YT:*ߎo=)YeL6':)BWC%ٴPWTŭlkCUy6c)t z+%4iUp(Ny& g" U/ȨRk "7]|  ':D|AZNۙDM5Q2U6P*!Xch0êkB!+jS llHZkشUWlRCC7AB .#Fwi/-Uvw4G1g9bCړ룊F;㑺bb`f_ ֹJrj[Jmc]g1r ېÙ).%޲NL6dUX_ i^*S|qzDC2X< .@@;6%NNYkBK͓,wBA9;MBX?Eقe닏Ne X~\>4MPTڟŴf-}1/@.T0pq^$ m4nc&$*OIvY^̭9-i'ͻ5J(h'*Al|eSfA1Z I+we;+u8yvz|K#9|jA`OܝVEMAe8U2zbX[8&֖ ETU?!î& j#{luۘVϴȑ!*:x%(iȗn;"x )ilP]Yr-O⌃ucث45_t[*>&)^BWIn"4=|o"PQԷݽQ<˅e7_j=9 ufrkde 2DH7GT]b&6H%-"DqN0yjv^cQJ+%ӂxT[;eKb͓#w˾ fpǬiΔ䢙?♿,4etڅMi,Ι?!?;\/p$o$vZ$*/P9=4^f}*hA`6*0%]p|3+%3|1y k)D?S!r)L kij]w=7Cyީh>FNz>Xbe a؝'uR C߽n üonglpdžؙ.Ju}܋K:|}h=:a"x@FhE^ J(ye,^butI\Rv*F`Y 5W ˋiط[iwG{Zޣgn8*9/65VU)j<ۚ5pnn#E!MYO5} nÕэd~;‡f^ߧLTYyL h[K|FCq+CYS絽P b?#4TݰJD& gi6E"8ly8 zaj1hc>ziOZS;R{h2p-e}E?msSgzP^y@C2./Jfsd1ߊ !ΒUJc|IoAI{ u+67ʄ$tR^DY>ӱT =f|:V r*GB:zIf@ߋUBd(m~՘YrI'1v~;4v25<'^Yb6a|"0$4fjG7VZO3T"s&ԯ޶mE.#i^FCOv| мFx/ӡ1r7&(, dDNZٳaem;<-CH ,1hТ_v(;bH!7bΕ*ٟPd.?ƦxLXHu#)\jԈatjIYc6VͱТ&۶m'm6dۚ<&&{{Wg={-!B@ژm Ryc8~H |h.t K+ܤ6@w9$u{"q H`݌a/[iN~`+9d'SL-?8R`ACA57[0 sΒC|DZytķ}̪vZڔτ ,2) \ -8= sFc|ӸBG)bCa7O.vGH.M3Jt&ץNo樟Qiƾ {<lT}΁K򣕤7JؙY穀;v: ɸ2(}ceGch.*NPRqkٶ$lp̀أ6wwpg,2p3 vog)v}+aړ/O75S;ƨ"9r4r1j4;D]rtZ@so|A~*1cT/Ujրw;;47&91o&]~&* $Y_Grl<(y?[sK<v:Sa1};{E"gRR+˟5J!"R媜T[`rה A="B5B֋oJE)wBfęI­Ϸܞ֫S%CAڽ{şqot u=cA;U%r_d9 H-q#U@ot PJ!ۙB|Ȓ'z{sQ>r>8?J4FHr"7-g"nk.!˒(/. Ax&(WD>%3$$}9I񊱩4+"Q)8 rh C3VL6Tڈ wBw#3[UfF43}RHʐ=BCՉ:9O8k COwў{B]<7%]]xd5֬C=egoH]k[>5,o9#bf9.dalKc-7`q3 >v#iM7<߆k⬑j1tgulK4|_b\DGk. NxXj?E_5Ԗe)vWt,gƹ'$_$AoڎWT}!W߱ZcB^-=J 0m7Ԭ[F2P.xp4 s ~JBZ>1o DL:.ٮ/1~wvn'4pR| rk3t,Xq:թ[a: ]X1r&!ޫz~\79 JL>`AG+ ce ш(@6# V%)H1Q 5|E41(<"i5}ץ@Ȱ9vi{0%fnJDvXNڇS$Vfq66tki7b1⢙7{{ގ-*alOO}ߣ^e#3ܴIodg?'z[ nPʐL*iseGhG"n 6Sx 1FvVvW2K/}ɀR.y'xL~Ұo0.;fϰoO ZBٜ#6޲΅kF$8)@BV/QI1k?Tq=!ڠN*HCϢsG*z@@P`jt$Q//@%k 9sa 2@=CHorYJePO$!AA/2 8@way-_+c$rĐA6+MC/|SL{GЃIx٤nVWG㮉*\3 ua|S9 30FҞ:YYP$ 9*rO8@mʰd=a3ƕ͵{|WRm~LV˚z:Bj1iVaȘN6w3[X4Kn)U:.-БB9/P ƀ3Zx _@~+M Uӂ8[@+fo NP\|'1:E L;\3+[uˇXNO@H@Qpt:P!Nڢ_5nf4o_Usք~K (}{Y#ChX v"%jEk,f%Ec(f#Gn[T5Ջj:tk?n!ōG`Z(Ӗ2O8>/}'S?}߆OIetͫ^asچQ΍=8]FMm9 ´ ~Evy/Y7r$y͓]'qPħzAhBWSY2bڗ$?&(k4锨 %vI?f'e.Ka] J7=8j!ij.fiCEOrX$dfI}#DχWi"5ymm'`G3[Rb L<~uuZjLg z 4#_T5 Q,L^=P Q eC4B@Sb7<\kLn9jgJ5&(znLcL\2Rp',0rI(PlDZ-4]|ڧVbdTPB0ogNmojseZ{PjDT͢gSю77 {%F!V;88m_E5C$nЊ(LHМVZvi ޣd79.cIh++XQ%Q#@kYb a Oq1a GSK\x5/ K+4R]U_=5 N{g*Vxlbqiq,€%{m[>04&j*SB =-],c&MR6\:Miry_g1kz2GBHOM?P7 hN^φGw&0Q:a1q@Į0նƠ@kL[&Q{igu|}Hy#T<¶~sO7^[.Q=ai$E}XU ^,/Fzc9zׇmXkvT.us@( lGJ~15cgֱ{|l̡0d6'5%Y|a+ sH꠪ wN9Pe2ZB EUF2aUKQUFNhppcVkB렋'vTce P6r[|@̫ϯ}Pܫ?zS@N6}=D$hdO*elT?吅~y4y$oZ'Y6ZۈM曪{>rn3 y{}V`tUYo~ԼLjh7-L@)j^?ՇjY7R҈Ou0Vj•fH% Œw2`J!DEs,=[7?^C=Ŕ1mTI0_3+ezJfLu*ҩyh#u>`l75'j-``&\o'gXڱ+w#P3C1j1Z/65&vo=yڙYocK_9۱?!Y{"aF3uv`y2tvRɵZHm,}u0joʱ!eX|UTL0{zh7kgƥ%%lmO|V+=^%48_^7(e'|a_ޞ+3("mYm|+n64`&Y$4Kΐ[x Zى,u `۔>-vKO^ 4$G:?f7 ~z^BU!:#'q3Ĥ$ lݐioa"IVSpy7r_XbٍҖ [rlX!`@>DPI\Mh2R>){}5T|VsLTR=0ҝ( 2U۰Pޙg)eg.; Fs!t OK(u+lLӽ3/MaYHNSopG,h_1so+_=nLEd,$>fgmy7"E}Qc ҫQ1>tu~02h*mUjy3Z#ǃ hdQi{AJD4)F&/^P'l)LpQ 3  IU/t}_m]Օ#M#ndZw'HuU@`xr Nkg^@yi._IAJBN\@H 1n))z/cl3l \aN/buܽ"_(e&F%cSnpP8,3J)3ZѮKBgO?{&I'7 tܨ9[7'Ѳ8'"nm =#-/ƈ,[ՀZ2mkKM~^5 !ۄejjs,deE`YO/3A'9UO[z(iϙLK@؏ A'&Q= SH6I[l='ҙF< Zz3J(`[*\䣳$31PqO[{dMrE"Gazi?sSXD"m~GRˆFC*,a-m:R}N Bt` k VJE:B<2o ^ѧlW\4%Rk/O57VC}QJ3ĕc;- ƬI,%""J1biځ=C"&cEb"d1VYkq ags /I:ʉxn'6}\ug]T;$kw/;3ɩ5I?9n-6+_2z͐ qAQ[J#F+e^ǐ 1 ӓӢNݷ췬Hsӑ3.ȖҷyXdIk4KV>ume5AHOSɿ9֞U=BʹLKnX#{򙛷M̜ɇ2sQԖΙf[W ?;^9Q9¨&achn-͍0e Q߆&g*7͐bLs+ dj՜G#,Kw=KZաG,|uRlKIrbGe3 GB}+Q%],dI ܢʛwۤa#LV vOP| -d]#jNRM^=9 ѵq?boEbg ,).2vq7 j[Oτ z kUd~I/_$+6S:PYWC;pF1v >h=&\ɋa"$hKX E!V4WƕW},9U籹3{[(5"me3y:7?a"{A>"F?TlwvA$F~s>~)aHWAH EZs.z Z?CSYLձw[S݈ $ ӂ@0<6Mv:2EՀ_6VԐWf;FMf+ lEeF=lTu e\}mv֨&w.IW=HхR!DZێB-HWm}xTT z^o| L6P30u\*Ȓv\ltgI,zZ+Av#ju)v<7DH4vE n}*J99'y ?0N%?X9{lIOQ/s>R\Dc:nc^T#ב;Dd܇ $~pR?IĨQTiqyHgnbVDFdč-F5+.L%F{*NX=7a\OxPZYCDX kn蕓1c^{nvx/=w<R>,xH2a|q%Ca7w.y} B.pň[i|х >l=z9s=ahLf D4O0 Mǫt{RZ&r' ;W@0~5q?2׆E2P"jpf.xO=ۖd.mc0v:\K(ů:+I,&t0^81ٹʷ_^%h8e(y#ҕoiF{m+"ۄw;/rӘ! gq )Vn,8_z}>U`!< Y\IMۀ=[`5@5Aٟ 7D) ɋ-%W 缮m!urL,[+!O-\eF+\Ĭ$v Fhծ0ͱ57Aǫm,ed(I9Q~5ޥ{ـH'r) d\`a0# mI0ej5.s12rNO?B%my9<" 5?z3zݷizwTMEHڽ|T~^MSR5[tRõuib9 tMSYht endstream endobj 74 0 obj << /Length 494 /Filter /FlateDecode >> stream xmMo0 !Rz|UAa۪V&$E 6~=HUAgɯ~uo$ƛLD- t @ZcNt=YNk`T=Ro æeCڕ(>Պ AiZsn[6uc^0Xah\je?0bprOY[AKS|dۙoF)MZ}4W@{YmG;<9`;K (EytbabisbgEjq(po$}Idon-p!J m-O[L endstream endobj 75 0 obj << /Length 696 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS 9_P{=s@dkx;`VY`s4JaQܡn.Uu9\Y6><ٴ.Z.4>Dӗ}~r:-d0VWk,8yLһʮӮђ[*mLr?q 5F8@=@)& 8Rx uD\j2HV0CzL] bctI g$`htы0\F0s jd< I6zg W qȐ+#k .bsrbmXK7ǵH7Gnb>&jؐu1VljOu$՟qWS/%1{\xB!K(hHTЖ枃Jρϯv=k2UKς_:~$/ ~E+7ˢ/ l(/} -+ZXukoԝE?ZK endstream endobj 76 0 obj << /Length 695 /Filter /FlateDecode >> stream xmTMo0Wx$ ! 8l[jWHL7IPV=M̼ su;Uٛ=w]yil;<[[j<=?׾+v`&ߴț<^*;~&Q>MS'K}v}tƾ`R\ws*pWl:*;m_Ű=EB.=]6E%‡hWvE;^N ƣՊU ٟweӟQ?OIz^UU|ڕߵ6ZrbˢXEIS:.trA&TH>4"PX H BM@5*08WfH AX v.2I## .zӘˈ0Qa8tcpN0A2 @݆s>^l>^wo_j4Rrtsľ x[%QLuQ.ݢT ܂PKߗp#}߂pMAM37CB2>*R{@8񩎤3 }c$f O#z  ) spW)9N{=g-_Z ~YK/t:/~e}Y%៍-t:UEk nmGkp\x{)ނ endstream endobj 77 0 obj << /Length 739 /Filter /FlateDecode >> stream xmUMo0WxvHUdCmU^!1H#x?gx]OTm$|͜s_Iss :L;<Sz==׾f`*_`ɫڟk3'iѴ}=M;7rfnj-eSӵOLg~8 )ok A8 $`I\3`Af<Z]! xNky"7 _㓧q H`nḱRONH=CpB:# =%888QA~!*zƜАT?!~> tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo0WxvHUdC۪TBb A!Gp?gxYOTm$|՜s_Iss :L;268{zb/}WUjWm?fd}Oi=7gRd{nCN8oͰof-%6'&9Pu`L/"tkں(a[ duS $xqa MN{}m}gىx` tw8y*sύ }nFE>7*QύR>7G];~<6OIyktg>O:yұϓN|I/|yIg>O:y҅ϓ.}2 L> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vw%g43>\ 6 EJ78 1{~`W(-;]%=xe_,b+-O;q\L}UI--=BKE1p[! Mߊyu>.N5K)Wb٬8i[_uʕMzQ)V(Txޢjy!Z2P="Zd0\ÃGR\).2*Шa!U,H`+j.5Nα@VK-x%3%AYӀzΚ>kP#5m0Woþj.ZT$X/)n)#Wo(oRZ $Kp4Z-b\1ܰJ P"GXQi/8k^Zq:Zs9dB )sL-7xJ`aɽ)f$1 dъcCZC<73JgznHȰYɚTa,_-O87}KԴܗLloK+gJ.GZyVc48Wt]:P~`rZq.n1] S/Pu7Ue:?&?!d&1yHn5)yғBx#1ޞ]Go׏M?X endstream endobj 80 0 obj << /Length 900 /Filter /FlateDecode >> stream xmUMo:W5?$R. d9M eCkmCp;;w~>|3E_?O]5߶w]Occ]=~?}Oyh9%?۹׬B|Ɯ>);vz|N8}No)e0&h?q:P_ X}ac1+a  jҢ~]ߏ{_r)4i_px`!dZ>i]<U_cr%ͪcךv[\٤ժX*be-@E-X@-꩖xkM PY@ ,#bEA 5rEqIb>,彐A$ G#e"&c D`%rE*s(Ǩ5ثCI*=ǔ^pk+ ܛbVLbX+@8:13Jp3<|6 ^ΜANVjRy9cpסAM}Ė)|֪,+pp70h8J+NK}Eլk)up >o U^g{_e{]*?`CBhgiیtV;۳ѝ)(ZK7bA;E^]|sQ endstream endobj 81 0 obj << /Length 868 /Filter /FlateDecode >> stream x}Un0CƆ"RVmkN7RI̤߯]U=ooƾ4qݰZGNc'>wÍzeu[U gҿl Qķ&M'G3Hy_ S)E~e!jءC4qjz( z#neDvBwfs5} FzqۿitXoBjߙo{b?WWZ/ԼiL)͙ \݄Wb MLS!"q #u!`Nȩ(( LFUjp49cIMh ,hPE4pbvŢ !\΀Ѹ 8!\=#2:x 1v9/8vӺuSqk4 "nXCI8'ľ&p 2<Wcǘ,9Ϳ1bxb Ài',ymƌ&Q/kC^،1ۜ1q, Vu 3/d Ͷb l͘S&Ş c,Xu ֟_~CO` ?'>ψ:sh.Xgo\΄rYgBЏ>;gX|&}ggg݉gt3zw3|s3߉YX/gKzJrg^od ,gz)R؇O5_qTԼV j M2GFN(:pTy 8kn":qo{~Y=[|btD&U endstream endobj 82 0 obj << /Length 866 /Filter /FlateDecode >> stream x}UMo0+J! ᫊"Rj.RI73W3njNelܬ;WW\?pu4{SlY]jwOusR^u5sx0ֳ0;]nL#;z,gS t;en>r8S0qj>w};B U5gѻ9x};a`TG?y:o&ߏE]&AjZu/?v_t|z;:ذfhkܸ_\zu \7g"NyOܵڿB`ilB =@ )U 9yI(J5<T` M55֜RhR 1ڟS(yq( buX& &q,1+N978Nsk`q8 ^8% FMq.5Sh@kO ׏p$q1/]}/ĩ»p^`D3F?x[a 1ec!/1g)cd?4dK^| МQV1Կ'1t?ƺ9Y?ГrYs֟'g)437YgD3\ib-z3zs ,>G|ZV|ƾ3ֵ33qgng3tZ[Yog,g[3 =L3z/gd ,gz)R؇O5_TTV *M2GZN(:pTy 8kn":qw{Y-7]%# endstream endobj 83 0 obj << /Length 867 /Filter /FlateDecode >> stream x}UMo0+J! ᫊"Rj.RI73W3njNelܬ;WW\?pu4{SlY]jwOusR^u5sx05rtlf)OS`)?>RTO)suߖSIQg Lڮ9ˈ;~?˥?y|#7~l/3bV+պ};85wѩƆ56CN]]₥+U9q~=W(_KdR$| 4hd52HHNsL FU*q8cMMh QEk%RWp gn~FȋCam `42W0A/c9^'-pʹ)pq[[i])9^W5js7 Gb_#xb~ ' ˏ1}cLu'No ޅ0&1Ie76Z cx-~`& y%Q?K'!/h],KV0d 1էM=Ռ3g1Y ~i?'?!>L9g)q:#eNC?lыѣc`83ֲ3#>w+>Cӊ݊͊T_|~+>Cg!>cB|/g)g{!>_|&~'a9K!B>,TGbPq> stream x}UMo0+J! ᫊"Rj.RI73W3njNelܬ;WW\?pu4{SlY]jwOusR^u5sxu5rtlf)OS`)?>RTO)suߖSIQg Lڮ9ˈ;~?˥?y|#7~l/3bV+պ};85wѩƆ56CN]]₥+U9q~=W(_KdR$| 4hd52HHNsL FU*q8cMMh QEk%RWp gn~FȋCam `42W0A/c9^'-pʹ)pq[[i])9^W5js7 Gb_#xb~ ' ˏ1}cLu'No ޅ0&1Ie76Z cx-~`& y%Q?K'!/h],KV0d 1էM=Ռ3g1Y ~i?'?!>L9g)q:#eNC?lыѣc`83ֲ3#>w+>Cӊ݊͊T_|~+>Cg!>cB|/g)g{!>_|&~'a9K!B>,TGbPq> stream x}UMo0+J! ᫊"Rj.R!W3njNylܬ;WWМ~8׺2{SlݤMƓ7}zn݅9p/]A:fL9Ngiob쉬f 9돱ncsO{(g1?\֟g Yg 9LsQ.(ug^/u ?L[ V|FV|oV|3[: 3 ~!>CO!>S 33>Y^ ?a!SMW,:?8ÇqG湪N$ոd<}]/pD=t].Z/ endstream endobj 86 0 obj << /Length 866 /Filter /FlateDecode >> stream x}UMo0+J! ᫊"Rjn"B73W3njehܬ;WWU\8׺v=ߩonTtƓ7]ziTCA:fM9Ηfi<WOlJQn8N[hEOrDz=4CH޾Gwt>X.Ouá{Qן tzutZ}]ˏѩ]3NN46[w>7,^e]׵͙SwPG*X$D F @F@k} 89@FJuFF#`R0JRq eF)kjBS` F5(Z#.9Bkx>w{7E^ kCXq pD zAet 8alSM3?rN%NbQDa 8>#h0\?I`\~KWc?qc.\X7ьO*ezl,d mY50ymȋ,aYʘ8 xAf_14g%cxU>ob쉬f 9돱ncsO{(g1?\֟g Yg 9LsQ.(ug^/u ?L[ V|FV|oV|3[: 3 ~!>CO!>S 33>Y^ ?a!SMW,:?8ÇqG湪N$ոd2 }ν_V,z薛.ZP endstream endobj 88 0 obj << /Producer (pdfTeX-1.40.26) /Creator (TeX) /CreationDate (D:20250312221506+01'00') /ModDate (D:20250312221506+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.141592653-2.6-1.40.26 (TeX Live 2024) kpathsea version 6.4.0) >> endobj 11 0 obj << /Type /ObjStm /N 54 /First 431 /Length 3779 /Filter /FlateDecode >> stream x[SS篘{kK*@QV񺀊Z>D8B0 9ɜۭΜ_D#"qh*#+a :V*mX#AX-qIXB Sea $I)`1N8 ]Sl8X:X% ^x!aQEȰ"z"ƨ")^$9YH VdӋ@~"gX$d(0 Q-46zhdV ;A[G:T1 4 4% R`5db&& B,O0!аn<|!]7B5rj4mFӉǃ yLn'Jp}UW@"L<\~$4𡐻$#?Dx&6m!䰙]!S]wEL~&[# OFr;iQ{kܢȕT׆kyYWxyԪ]^vm\?Y\ʑ5$+|: M|L؄1M85޴6{7DZ7c zLzYW(݁J/4nȞQaB@G#ҥ=hBfϐjv_A-y,I%z=K1ָv7'7y n4pgnXa]J?9ʯa%E3[Z>$>Xl9M 1-c|ƻjE`!D R`ex\8B9UN]K3 .lLl+gِ( oJكXm͟P cު݈sz(f̸xuKmVeRN;%RƉ-*#" 2t!G[MbҐ cAt^*0F}F8j^C$6jH~rV5mr78 r̡ 9NX:#TaߺŚR1a*DY\as$L8ZAGL@rMPʡYV"˂b|d$[υ#JO6t6Fv0~J!i>RiB}gNiQov19<] %dt{sxFO8C-ncZ䴢ZIgio:l.<6ỲK8{k48<;1xp:<\P{rsy9񛚯CXť?:xs0~O[ NՀWsCv!|k~%|"|#| OX+ʋӁэnëSy=/r"'3`\ &r:f:jxIIĴ-| ̰7:yz#0`<-rJN}5ӁDo7_n`H^18ޭcϞ=AWֆ6)ǰz}ձ)cӻO߁MoW&,P.7U`E,&v}p޺/-Rqsڱuuvpl]@z0u 0h8 ymm k%8[.[&M?jto5)l6>gϳv {[V}w( ym~TbA8wG`6KRptj ?}}{otI^D^pynβ'Rٕ%qx*R#m]_PE,Jyv.\'eΡbgtH7"e:CvȱKXPYfڒ? \yqJ ~L]> ?5ow8LBCu|>Ny3 <793B8940C3A555E873D33B46D2117BD4>] /Length 261 /Filter /FlateDecode >> stream x.CQQGqz;JVU]Vg003OfpJH _;_69 C1Tm.DGlb]Wᅽ-%1/ŪX)1@:vA|k3-͌&Zg6GDSDbT"+r"/ (1&JbhWD/*G$q"CiB˪JV V5rg5C^Vuaj.jY=݃yzޛg>{R''{el2(& endstream endobj startxref 205979 %%EOF semTools/README.md0000644000176200001440000000311514006342740013336 0ustar liggesusers# `semTools` Useful tools for structural equation modeling. This is an R package whose primary purpose is to extend the functionality of the R package `lavaan`. There are several *suites* of tools in the package, which correspond to the same theme. To browse these suites, open the help page at the Console: ``` ?semTools::`semTools-package` ``` Additional tools are available to do not require users to rely on any R packages for SEM (e.g., `lavaan`, `OpenMx`, or `sem`), as long as their other software provides the information they need. Examples: - `monteCarloMed()` to calculate Monte Carlo confidence intervals for functions of parameters, such as indirect effects in mediation models - `calculate.D2()` to pool *z* or chi-squared statistics across multiple imputations of missing data - `indProd()` for creating product indicators of latent interactions - `SSpower()` provides analytically derived power estimates for SEMs - `tukeySEM()` for Tukey's WSD post-hoc test of mean-differences under unequal variance and sample size - `bsBootMiss()` to transform incomplete data to be consistent with the null-hypothesized model, appropriate for model-based (a.k.a. "Bollen--Stine") boostrapping All users of R (or SEM) are invited to submit functions or ideas for functions by contacting the maintainer, Terrence Jorgensen (TJorgensen314 at gmail dot com). Contributors are encouraged to use **Roxygen** comments to document their contributed code, which is consistent with the rest of `semTools`. Read the vignette from the `roxygen2` package for details: ``` vignette("rd", package = "roxygen2") ``` semTools/build/0000755000176200001440000000000014764374533013176 5ustar liggesuserssemTools/build/vignette.rds0000644000176200001440000000032214764374533015532 0ustar liggesusersO 0tR"')DnDvdJ]Omι\[p!cĕ(FDALh)+ d䄯yߴΥ-v+AjZuL*J~X|0;^f& N9Jdjÿ+Gqi6ZpFt$7v*semTools/build/partial.rdb0000644000176200001440000000007514764374476015333 0ustar liggesusersb```b`aaf`b1 H020piּb C"N27semTools/man/0000755000176200001440000000000014752741066012646 5ustar liggesuserssemTools/man/compareFit.Rd0000644000176200001440000000727514764324031015231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compareFit.R \name{compareFit} \alias{compareFit} \title{Build an object summarizing fit indices across multiple models} \usage{ compareFit(..., nested = TRUE, argsLRT = list(), indices = TRUE, moreIndices = FALSE, baseline.model = NULL, nPrior = 1) } \arguments{ \item{...}{fitted \code{lavaan} models or list(s) of \code{lavaan} objects. \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} objects are also accepted, but all models must belong to the same class.} \item{nested}{\code{logical} indicating whether the models in \code{...} are nested. See \code{\link[=net]{net()}} for an empirical test of nesting.} \item{argsLRT}{\code{list} of arguments to pass to \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}, as well as to \code{\link[lavaan.mi:lavTestLRT.mi]{lavaan.mi::lavTestLRT.mi()}} and \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} when comparing \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} models.} \item{indices}{\code{logical} indicating whether to return fit indices from the \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} function. Selecting particular indices is controlled in the \code{summary} method; see \linkS4class{FitDiff}.} \item{moreIndices}{\code{logical} indicating whether to return fit indices from the \code{\link[=moreFitIndices]{moreFitIndices()}} function. Selecting particular indices is controlled in the \code{summary} method; see \linkS4class{FitDiff}.} \item{baseline.model}{optional fitted \link[lavaan:lavaan-class]{lavaan::lavaan} model passed to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} to calculate incremental fit indices.} \item{nPrior}{passed to \code{\link[=moreFitIndices]{moreFitIndices()}}, if relevant} } \value{ A \linkS4class{FitDiff} object that saves model fit comparisons across multiple models. If the models are not nested, only fit indices for each model are returned. If the models are nested, the differences in fit indices are additionally returned, as well as test statistics comparing each sequential pair of models (ordered by their degrees of freedom). } \description{ This function will create the template to compare fit indices across multiple fitted lavaan objects. The results can be exported to a clipboard or a file later. } \examples{ HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' ## non-nested models fit1 <- cfa(HS.model, data = HolzingerSwineford1939) m2 <- ' f1 =~ x1 + x2 + x3 + x4 f2 =~ x5 + x6 + x7 + x8 + x9 ' fit2 <- cfa(m2, data = HolzingerSwineford1939) (out1 <- compareFit(fit1, fit2, nested = FALSE)) summary(out1) ## nested model comparisons: measurement equivalence/invariance fit.config <- cfa(HS.model, data = HolzingerSwineford1939, group = "school") fit.metric <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = "loadings") fit.scalar <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = c("loadings","intercepts")) fit.strict <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = c("loadings","intercepts","residuals")) measEqOut <- compareFit(fit.config, fit.metric, fit.scalar, fit.strict, moreIndices = TRUE) # include moreFitIndices() summary(measEqOut) summary(measEqOut, fit.measures = "all") summary(measEqOut, fit.measures = c("aic", "bic", "sic", "ibic")) } \seealso{ \linkS4class{FitDiff}, \code{\link[=clipboard]{clipboard()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/tukeySEM.Rd0000644000176200001440000000423214631670014014632 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tukeySEM.R \name{tukeySEM} \alias{tukeySEM} \title{Tukey's WSD post-hoc test of means for unequal variance and sample size} \usage{ tukeySEM(m1, m2, var1, var2, n1, n2, ng) } \arguments{ \item{m1}{Mean of group 1.} \item{m2}{Mean of group 2.} \item{var1}{Variance of group 1.} \item{var2}{Variance of group 2.} \item{n1}{Sample size of group 1.} \item{n2}{Sample size of group 2.} \item{ng}{Total number of groups to be compared (i.e., the number of groups compared in the omnibus test).} } \value{ A vector with three elements: \enumerate{ \item \code{q}: The \emph{q} statistic \item \code{df}: The degrees of freedom for the \emph{q} statistic \item \code{p}: A \emph{p} value based on the \emph{q} statistic, \emph{df}, and the total number of groups to be compared } } \description{ This function computes Tukey's WSD post hoc test of means when variances and sample sizes are not equal across groups. It can be used as a post hoc test when comparing latent means in multiple group SEM. } \details{ After conducting an omnibus test of means across three of more groups, researchers often wish to know which sets of means differ at a particular Type I error rate. Tukey's WSD test holds the error rate stable across multiple comparisons of means. This function implements an adaptation of Tukey's WSD test from Maxwell & Delaney (2004), that allows variances and sample sizes to differ across groups. } \examples{ ## For a case where three groups have been compared: ## Group 1: mean = 3.91, var = 0.46, n = 246 ## Group 2: mean = 3.96, var = 0.62, n = 465 ## Group 3: mean = 2.94, var = 1.07, n = 64 ## compare group 1 and group 2 tukeySEM(3.91, 3.96, 0.46, 0.62, 246, 425, 3) ## compare group 1 and group 3 tukeySEM(3.91, 2.94, 0.46, 1.07, 246, 64, 3) ## compare group 2 and group 3 tukeySEM(3.96, 2.94, 0.62, 1.07, 465, 64, 3) } \references{ Maxwell, S. E., & Delaney, H. D. (2004). \emph{Designing experiments and analyzing data: A model comparison perspective} (2nd ed.). Mahwah, NJ: Lawrence Erlbaum Associates. } \author{ Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) } semTools/man/plausibleValues.Rd0000644000176200001440000002031114764330772016273 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plausibleValues.R \name{plausibleValues} \alias{plausibleValues} \title{Plausible-Values Imputation of Factor Scores Estimated from a lavaan Model} \usage{ plausibleValues(object, nDraws = 20L, seed = 12345, omit.imps = c("no.conv", "no.se"), ...) } \arguments{ \item{object}{A fitted model of class \link[lavaan:lavaan-class]{lavaan::lavaan}, \link[blavaan:blavaan-class]{blavaan::blavaan}, or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}} \item{nDraws}{\code{integer} specifying the number of draws, analogous to the number of imputed data sets. If \code{object} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}, this will be the number of draws taken \emph{per imputation}. If \code{object} is of class \link[blavaan:blavaan-class]{blavaan::blavaan}, \code{nDraws} cannot exceed \code{blavInspect(object, "niter") * blavInspect(bfitc, "n.chains")} (number of MCMC samples from the posterior). The drawn samples will be evenly spaced (after permutation for \code{target="stan"}), using \code{\link[=ceiling]{ceiling()}} to resolve decimals.} \item{seed}{\code{integer} passed to \code{\link[=set.seed]{set.seed()}}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations when \code{object} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}. Can include any of \code{c("no.conv", "no.se", "no.npd")}.} \item{...}{Optional arguments to pass to \code{\link[lavaan:lavPredict]{lavaan::lavPredict()}}. \code{assemble} will be ignored because multiple groups are always assembled into a single \code{data.frame} per draw. \code{type} will be ignored because it is set internally to \code{type="lv"}.} } \value{ A \code{list} of length \code{nDraws}, each of which is a \code{data.frame} containing plausible values, which can be treated as a \code{list} of imputed data sets to be passed to \code{\link[=runMI]{runMI()}} (see \strong{Examples}). If \code{object} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}, the \code{list} will be of length \code{nDraws*m}, where \code{m} is the number of imputations. } \description{ Draw plausible values of factor scores estimated from a fitted \code{\link[lavaan:lavaan]{lavaan::lavaan()}} model, then treat them as multiple imputations of missing data using \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}}. } \details{ Because latent variables are unobserved, they can be considered as missing data, which can be imputed using Monte Carlo methods. This may be of interest to researchers with sample sizes too small to fit their complex structural models. Fitting a factor model as a first step, \code{\link[lavaan:lavPredict]{lavaan::lavPredict()}} provides factor-score estimates, which can be treated as observed values in a path analysis (Step 2). However, the resulting standard errors and test statistics could not be trusted because the Step-2 analysis would not take into account the uncertainty about the estimated factor scores. Using the asymptotic sampling covariance matrix of the factor scores provided by \code{\link[lavaan:lavPredict]{lavaan::lavPredict()}}, \code{plausibleValues} draws a set of \code{nDraws} imputations from the sampling distribution of each factor score, returning a list of data sets that can be treated like multiple imputations of incomplete data. If the data were already imputed to handle missing data, \code{plausibleValues} also accepts an object of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}, and will draw \code{nDraws} plausible values from each imputation. Step 2 would then take into account uncertainty about both missing values and factor scores. Bayesian methods can also be used to generate factor scores, as available with the \pkg{blavaan} package, in which case plausible values are simply saved parameters from the posterior distribution. See Asparouhov and Muthen (2010) for further technical details and references. Each returned \code{data.frame} includes a \code{case.idx} column that indicates the corresponding rows in the data set to which the model was originally fitted (unless the user requests only Level-2 variables). This can be used to merge the plausible values with the original observed data, but users should note that including any new variables in a Step-2 model might not accurately account for their relationship(s) with factor scores because they were not accounted for in the Step-1 model from which factor scores were estimated. If \code{object} is a multilevel \code{lavaan} model, users can request plausible values for latent variables at particular levels of analysis by setting the \code{\link[lavaan:lavPredict]{lavaan::lavPredict()}} argument \code{level=1} or \code{level=2}. If the \code{level} argument is not passed via \dots, then both levels are returned in a single merged data set per draw. For multilevel models, each returned \code{data.frame} also includes a column indicating to which cluster each row belongs (unless the user requests only Level-2 variables). } \examples{ ## example from ?cfa and ?lavPredict help pages HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit1 <- cfa(HS.model, data = HolzingerSwineford1939) fs1 <- plausibleValues(fit1, nDraws = 3, ## lavPredict() can add only the modeled data append.data = TRUE) lapply(fs1, head) \donttest{ ## To merge factor scores to original data.frame (not just modeled data) fs1 <- plausibleValues(fit1, nDraws = 3) idx <- lavInspect(fit1, "case.idx") # row index for each case if (is.list(idx)) idx <- do.call(c, idx) # for multigroup models data(HolzingerSwineford1939) # copy data to workspace HolzingerSwineford1939$case.idx <- idx # add row index as variable ## loop over draws to merge original data with factor scores for (i in seq_along(fs1)) { fs1[[i]] <- merge(fs1[[i]], HolzingerSwineford1939, by = "case.idx") } lapply(fs1, head) ## multiple-group analysis, in 2 steps step1 <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = c("loadings","intercepts")) PV.list <- plausibleValues(step1) ## subsequent path analysis path.model <- ' visual ~ c(t1, t2)*textual + c(s1, s2)*speed ' if(requireNamespace("lavaan.mi")){ library(lavaan.mi) step2 <- sem.mi(path.model, data = PV.list, group = "school") ## test equivalence of both slopes across groups lavTestWald.mi(step2, constraints = 't1 == t2 ; s1 == s2') } ## multilevel example from ?Demo.twolevel help page model <- ' level: 1 fw =~ y1 + y2 + y3 fw ~ x1 + x2 + x3 level: 2 fb =~ y1 + y2 + y3 fb ~ w1 + w2 ' msem <- sem(model, data = Demo.twolevel, cluster = "cluster") mlPVs <- plausibleValues(msem, nDraws = 3) # both levels by default lapply(mlPVs, head, n = 10) ## only Level 1 mlPV1 <- plausibleValues(msem, nDraws = 3, level = 1) lapply(mlPV1, head) ## only Level 2 mlPV2 <- plausibleValues(msem, nDraws = 3, level = 2) lapply(mlPV2, head) ## example with 20 multiple imputations of missing data: nPVs <- 5 nImps <- 20 if(requireNamespace("lavaan.mi")){ data(HS20imps, package = "lavaan.mi") ## specify CFA model from lavaan's ?cfa help page HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' out2 <- cfa.mi(HS.model, data = HS20imps) PVs <- plausibleValues(out2, nDraws = nPVs) idx <- out2@Data@case.idx # can't use lavInspect() on lavaan.mi ## empty list to hold expanded imputations impPVs <- list() for (m in 1:nImps) { HS20imps[[m]]["case.idx"] <- idx for (i in 1:nPVs) { impPVs[[ nPVs*(m - 1) + i ]] <- merge(HS20imps[[m]], PVs[[ nPVs*(m - 1) + i ]], by = "case.idx") } } lapply(impPVs, head) } } } \references{ Asparouhov, T. & Muthen, B. O. (2010). \emph{Plausible values for latent variables using M}plus. Technical Report. Retrieved from www.statmodel.com/download/Plausible.pdf } \seealso{ \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}}, \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/permuteMeasEq-class.Rd0000644000176200001440000001551414632143415017012 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/permuteMeasEq.R \docType{class} \name{permuteMeasEq-class} \alias{permuteMeasEq-class} \alias{show,permuteMeasEq-method} \alias{summary,permuteMeasEq-method} \alias{hist,permuteMeasEq-method} \title{Class for the Results of Permutation Randomization Tests of Measurement Equivalence and DIF} \usage{ \S4method{show}{permuteMeasEq}(object) \S4method{summary}{permuteMeasEq}(object, alpha = 0.05, nd = 3, extra = FALSE) \S4method{hist}{permuteMeasEq}(x, ..., AFI, alpha = 0.05, nd = 3, printLegend = TRUE, legendArgs = list(x = "topleft")) } \arguments{ \item{object, x}{object of class \code{permuteMeasEq}} \item{alpha}{alpha level used to draw confidence limits in \code{hist} and flag significant statistics in \code{summary} output} \item{nd}{number of digits to display} \item{extra}{\code{logical} indicating whether the \code{summary} output should return permutation-based \emph{p} values for each statistic returned by the \code{extra} function. If \code{FALSE} (default), \code{summary} will return permutation-based \emph{p} values for each modification index.} \item{...}{Additional arguments to pass to \code{\link[graphics:hist]{graphics::hist()}}} \item{AFI}{\code{character} indicating the fit measure whose permutation distribution should be plotted} \item{printLegend}{\code{logical}. If \code{TRUE} (default), a legend will be printed with the histogram} \item{legendArgs}{\code{list} of arguments passed to the \code{\link[graphics:legend]{graphics::legend()}} function. The default argument is a list placing the legend at the top-left of the figure.} } \value{ \itemize{ \item The \code{show} method prints a summary of the multiparameter omnibus test results, using the user-specified AFIs. The parametric (\eqn{\Delta})\eqn{\chi^2} test is also displayed. \item The \code{summary} method prints the same information from the \code{show} method, but when \code{extra = FALSE} (the default) it also provides a table summarizing any requested follow-up tests of DIF using modification indices in slot \code{MI.obs}. The user can also specify an \code{alpha} level for flagging modification indices as significant, as well as \code{nd} (the number of digits displayed). For each modification index, the \emph{p} value is displayed using a central \eqn{\chi^2} distribution with the \emph{df} shown in that column. Additionally, a \emph{p} value is displayed using the permutation distribution of the maximum index, which controls the familywise Type I error rate in a manner similar to Tukey's studentized range test. If any indices are flagged as significant using the \code{tukey.p.value}, then a message is displayed for each flagged index. The invisibly returned \code{data.frame} is the displayed table of modification indices, unless \code{\link[=permuteMeasEq]{permuteMeasEq()}} was called with \code{param = NULL}, in which case the invisibly returned object is \code{object}. If \code{extra = TRUE}, the permutation-based \emph{p} values for each statistic returned by the \code{extra} function are displayed and returned in a \code{data.frame} instead of the modification indices requested in the \code{param} argument. \item The \code{hist} method returns a list of \code{length == 2}, containing the arguments for the call to \code{hist} and the arguments to the call for \code{legend}, respectively. This list may facilitate creating a customized histogram of \code{AFI.dist}, \code{MI.dist}, or \code{extra.dist} } } \description{ This class contains the results of tests of Measurement Equivalence and Differential Item Functioning (DIF). } \section{Slots}{ \describe{ \item{\code{PT}}{A \code{data.frame} returned by a call to \code{\link[lavaan:parTable]{lavaan::parTable()}} on the constrained model} \item{\code{modelType}}{A character indicating the specified \code{modelType} in the call to \code{permuteMeasEq}} \item{\code{ANOVA}}{A \code{numeric} vector indicating the results of the observed (\eqn{\Delta})\eqn{\chi^2} test, based on the central \eqn{\chi^2} distribution} \item{\code{AFI.obs}}{A vector of observed (changes in) user-selected fit measures} \item{\code{AFI.dist}}{The permutation distribution(s) of user-selected fit measures. A \code{data.frame} with \code{n.Permutations} rows and one column for each \code{AFI.obs}.} \item{\code{AFI.pval}}{A vector of \emph{p} values (one for each element in slot \code{AFI.obs}) calculated using slot \code{AFI.dist}, indicating the probability of observing a change at least as extreme as \code{AFI.obs} if the null hypothesis were true} \item{\code{MI.obs}}{A \code{data.frame} of observed Lagrange Multipliers (modification indices) associated with the equality constraints or fixed parameters specified in the \code{param} argument. This is a subset of the output returned by a call to \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}} on the constrained model.} \item{\code{MI.dist}}{The permutation distribution of the maximum modification index (among those seen in slot \code{MI.obs$X2}) at each permutation of group assignment or of \code{covariates}} \item{\code{extra.obs}}{If \code{permuteMeasEq} was called with an \code{extra} function, the output when applied to the original data is concatenated into this vector} \item{\code{extra.dist}}{A \code{data.frame}, each column of which contains the permutation distribution of the corresponding statistic in slot \code{extra.obs}} \item{\code{n.Permutations}}{An \code{integer} indicating the number of permutations requested by the user} \item{\code{n.Converged}}{An \code{integer} indicating the number of permuation iterations which yielded a converged solution} \item{\code{n.nonConverged}}{An \code{integer} vector of length \code{n.Permutations} indicating how many times group assignment was randomly permuted (at each iteration) before converging on a solution} \item{\code{n.Sparse}}{Only relevant with \code{ordered} indicators when \code{modelType == "mgcfa"}. An \code{integer} vector of length \code{n.Permutations} indicating how many times group assignment was randomly permuted (at each iteration) before obtaining a sample with all categories observed in all groups.} \item{\code{oldSeed}}{An \code{integer} vector storing the value of \code{.Random.seed} before running \code{permuteMeasEq}. Only relevant when using a parallel/multicore option and the original \code{RNGkind() != "L'Ecuyer-CMRG"}. This enables users to restore their previous \code{.Random.seed} state, if desired, by running: \code{.Random.seed[-1] <- permutedResults@oldSeed[-1]}} }} \section{Objects from the Class}{ Objects can be created via the \code{\link[=permuteMeasEq]{permuteMeasEq()}} function. } \examples{ # See the example from the permuteMeasEq function } \seealso{ \code{\link[=permuteMeasEq]{permuteMeasEq()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/efaUnrotate-deprecated.Rd0000644000176200001440000000537714764270501017516 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/efa.R \name{efaUnrotate-deprecated} \alias{efaUnrotate-deprecated} \title{Analyze Unrotated Exploratory Factor Analysis Model} \usage{ efaUnrotate(data = NULL, nf, varList = NULL, start = TRUE, aux = NULL, ...) } \arguments{ \item{data}{A target \code{data.frame}} \item{nf}{The desired number of factors} \item{varList}{Target observed variables. If not specified, all variables in \code{data} will be used (or \code{sample.cov} if \code{is.null(data)}; see \code{\link[lavaan]{cfa}} for argument descriptions).} \item{start}{Use starting values in the analysis from the \code{\link{factanal}} \code{function}. If \code{FALSE}, the starting values from the \code{lavaan} package will be used. \code{TRUE} is ignored with a warning if the \code{aux} argument is used.} \item{aux}{The list of auxiliary variables. These variables will be included in the model by the saturated-correlates approach to account for missing information.} \item{\dots}{Other arguments in the \code{\link[lavaan]{cfa}} function in the \code{lavaan} package, such as \code{ordered}, \code{se}, \code{estimator}, or \code{sample.cov} and \code{sample.nobs}.} } \value{ A \code{lavaan} output of unrotated exploratory factor analysis solution. } \description{ This function will analyze unrotated exploratory factor analysis model. The unrotated solution can be rotated by the \code{\link{orthRotate}} and \code{\link{oblqRotate}} functions. } \details{ This function will generate a lavaan script for unrotated exploratory factor analysis model such that (1) all factor loadings are estimated, (2) factor variances are fixed to 1, (3) factor covariances are fixed to 0, and (4) the dot products of any pairs of columns in the factor loading matrix are fixed to zero (Johnson & Wichern, 2002). The reason for creating this function to supplement the \code{\link{factanal}} function is that users can enjoy some advanced features from the \code{lavaan} package, such as scaled \eqn{\chi^2}, diagonally weighted least squares estimation for ordinal indicators, or full-information maximum likelihood (FIML) to handle incomplete data. } \examples{ \donttest{ unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, varList = paste0("x", 1:9), estimator = "mlr") summary(unrotated, std = TRUE) inspect(unrotated, "std") dat <- data.frame(HolzingerSwineford1939, z = rnorm(nrow(HolzingerSwineford1939), 0, 1)) unrotated2 <- efaUnrotate(dat, nf = 2, varList = paste0("x", 1:9), aux = "z") } } \seealso{ \code{\link{semTools-deprecated}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/htmt.Rd0000644000176200001440000000777514632150341014114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/htmt.R \name{htmt} \alias{htmt} \title{Assessing Discriminant Validity using Heterotrait--Monotrait Ratio} \usage{ htmt(model, data = NULL, sample.cov = NULL, missing = "listwise", ordered = NULL, absolute = TRUE, htmt2 = TRUE) } \arguments{ \item{model}{lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} of a confirmatory factor analysis model where at least two factors are required for indicators measuring the same construct.} \item{data}{A \code{data.frame} or data \code{matrix}} \item{sample.cov}{A covariance or correlation matrix can be used, instead of \verb{data=}, to estimate the HTMT values.} \item{missing}{If \code{"listwise"}, cases with missing values are removed listwise from the data frame. If \code{"direct"} or \code{"ml"} or \code{"fiml"} and the estimator is maximum likelihood, an EM algorithm is used to estimate the unrestricted covariance matrix (and mean vector). If \code{"pairwise"}, pairwise deletion is used. If \code{"default"}, the value is set depending on the estimator and the mimic option (see details in \code{\link[lavaan:lavCor]{lavaan::lavCor()}}).} \item{ordered}{Character vector. Only used if object is a \code{data.frame}. Treat these variables as ordered (ordinal) variables. Importantly, all other variables will be treated as numeric (unless \code{is.ordered} in \verb{data=}). See also \code{\link[lavaan:lavCor]{lavaan::lavCor()}}.} \item{absolute}{\code{logical} indicating whether HTMT values should be estimated based on absolute correlations (default is \code{TRUE}). This is recommended for HTMT but required for HTMT2 (so silently ignored).} \item{htmt2}{\code{logical} indicating whether to use the geometric mean (default, appropriate for congeneric indicators) or arithmetic mean (which assumes tau-equivalence).} } \value{ A matrix showing HTMT(2) values (i.e., discriminant validity) between each pair of factors. } \description{ This function assesses discriminant validity through the heterotrait-monotrait ratio (HTMT) of the correlations (Henseler, Ringlet & Sarstedt, 2015). Specifically, it assesses the arithmetic (Henseler et al., ) or geometric (Roemer et al., 2021) mean correlation among indicators across constructs (i.e. heterotrait--heteromethod correlations) relative to the geometric-mean correlation among indicators within the same construct (i.e. monotrait--heteromethod correlations). The resulting HTMT(2) values are interpreted as estimates of inter-construct correlations. Absolute values of the correlations are recommended to calculate the HTMT matrix, and are required to calculate HTMT2. Correlations are estimated using the \code{\link[lavaan:lavCor]{lavaan::lavCor()}} function. } \examples{ HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' dat <- HolzingerSwineford1939[, paste0("x", 1:9)] htmt(HS.model, dat) ## save covariance matrix HS.cov <- cov(HolzingerSwineford1939[, paste0("x", 1:9)]) ## HTMT using arithmetic mean htmt(HS.model, sample.cov = HS.cov, htmt2 = FALSE) } \references{ Henseler, J., Ringle, C. M., & Sarstedt, M. (2015). A new criterion for assessing discriminant validity in variance-based structural equation modeling. \emph{Journal of the Academy of Marketing Science, 43}(1), 115--135. \doi{10.1007/s11747-014-0403-8} Roemer, E., Schuberth, F., & Henseler, J. (2021). HTMT2---An improved criterion for assessing discriminant validity in structural equation modeling. \emph{Industrial Management & Data Systems, 121}(21), 2637--2650. \doi{10.1108/IMDS-02-2021-0082} Voorhees, C. M., Brady, M. K., Calantone, R., & Ramirez, E. (2016). Discriminant validity testing in marketing: An analysis, causes for concern, and proposed remedies. \emph{Journal of the Academy of Marketing Science, 44}(1), 119--134. \doi{10.1007/s11747-015-0455-4} } \author{ Ylenio Longo (University of Nottingham; \email{yleniolongo@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/lavTestWald.mi-deprecated.Rd0000644000176200001440000001250014764333003020056 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI-Wald.R \name{lavTestWald.mi-deprecated} \alias{lavTestWald.mi-deprecated} \title{Wald Test for Multiple Imputations} \usage{ lavTestWald.mi(object, constraints = NULL, test = c("D1","D2"), asymptotic = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), verbose = FALSE, warn = TRUE) } \arguments{ \item{object}{An object of class \linkS4class{OLDlavaan.mi}.} \item{constraints}{A \code{character} string (typically between single quotes) containing one or more equality constraints. See examples for more details} \item{test}{\code{character} indicating which pooling method to use. \code{"D1"} or \code{"Rubin"} (default) indicates Rubin's (1987) rules will be applied to the point estimates and the asymptotic covariance matrix of model parameters, and those pooled values will be used to calculate the Wald test in the usual manner. \code{"D2"}, \code{"LMRR"}, or \code{"Li.et.al"} indicate that the complete-data Wald test statistic should be calculated using each imputed data set, which will then be pooled across imputations, as described in Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010, chapter 8).} \item{asymptotic}{\code{logical}. If \code{FALSE} (default), the pooled test will be returned as an \emph{F}-distributed statistic with numerator (\code{df1}) and denominator (\code{df2}) degrees of freedom. If \code{TRUE}, the pooled \emph{F} statistic will be multiplied by its \code{df1} on the assumption that its \code{df2} is sufficiently large enough that the statistic will be asymptotically \eqn{\chi^2} distributed with \code{df1}.} \item{scale.W}{\code{logical}. If \code{FALSE}, the pooled asymptotic covariance matrix of model parameters is calculated as the weighted sum of the within-imputation and between-imputation components. Otherwise, the pooled asymptotic covariance matrix of model parameters is calculated by scaling the within-imputation component by the average relative increase in variance (ARIV; see Enders, 2010, p. 235), which is \emph{only} consistent when requesting the \emph{F} test (i.e., \code{asymptotic = FALSE}. Ignored (irrelevant) if \code{test = "D2"}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. Specific imputation numbers can also be included in this argument, in case users want to apply their own custom omission criteria (or simulations can use different numbers of imputations without redundantly refitting the model).} \item{verbose}{\code{logical}. If \code{TRUE}, print the restriction matrix and the estimated restricted values.} \item{warn}{\code{logical}. If \code{TRUE}, print warnings if they occur.} } \value{ A vector containing the Wald test statistic (either an \code{F} or \eqn{\chi^2} statistic, depending on the \code{asymptotic} argument), the degrees of freedom (numerator and denominator, if \code{asymptotic = FALSE}), and a \emph{p} value. If \code{asymptotic = FALSE}, the relative invrease in variance (RIV, or average for multiparameter tests: ARIV) used to calculate the denominator \emph{df} is also returned as a missing-data diagnostic, along with the fraction missing information (FMI = ARIV / (1 + ARIV)). } \description{ Wald test for testing a linear hypothesis about the parameters of lavaan models fitted to multiple imputed data sets. Statistics for constraining one or more free parameters in a model can be calculated from the pooled point estimates and asymptotic covariance matrix of model parameters using Rubin's (1987) rules, or by pooling the Wald test statistics across imputed data sets (Li, Meng, Raghunathan, & Rubin, 1991). } \details{ The constraints are specified using the \code{"=="} operator. Both the left-hand side and the right-hand side of the equality can contain a linear combination of model parameters, or a constant (like zero). The model parameters must be specified by their user-specified labels from the \code{link[lavaan]{model.syntax}}. Names of defined parameters (using the ":=" operator) can be included too. } \examples{ ## See the new lavaan.mi package } \references{ Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data. \emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. New York, NY: Wiley. } \seealso{ \code{\link[lavaan:lavTestWald]{lavaan::lavTestWald()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Adapted from \pkg{lavaan} source code, written by Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) } \keyword{internal} semTools/man/PAVranking.Rd0000644000176200001440000002457414764275037015154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PAVranking.R \name{PAVranking} \alias{PAVranking} \title{Parcel-Allocation Variability in Model Ranking} \usage{ PAVranking(model0, model1, data, parcel.names, item.syntax, nAlloc = 100, fun = "sem", alpha = 0.05, bic.crit = 10, fit.measures = c("chisq", "df", "cfi", "tli", "rmsea", "srmr", "logl", "aic", "bic", "bic2"), ..., show.progress = FALSE, iseed = 12345, warn = FALSE) } \arguments{ \item{model0, model1}{\code{\link[lavaan:lavaan]{lavaan::lavaan()}} model syntax specifying nested models (\code{model0} within \code{model1}) to be fitted to the same parceled data. Note that there can be a mixture of items and parcels (even within the same factor), in case certain items should never be parceled. Can be a character string or parameter table. Also see \code{\link[lavaan:model.syntax]{lavaan::lavaanify()}} for more details.} \item{data}{A \code{data.frame} containing all observed variables appearing in \verb{model0=} and \verb{model1=}, as well as those in the \verb{item.syntax=} used to create parcels. If the data have missing values, multiple imputation before parceling is recommended: submit a stacked data set (with a variable for the imputation number, so they can be separated later) and set \code{do.fit=FALSE} to return the list of \code{data.frame}s (one per allocation), each of which is a stacked, multiply imputed data set with parcels created using the same allocation scheme.} \item{parcel.names}{\code{character} vector containing names of all parcels appearing as indicators in \verb{model0=} or \verb{model1=}.} \item{item.syntax}{\code{\link[lavaan:lavaan]{lavaan::lavaan()}} model syntax specifying the model that would be fit to all of the unparceled items, including items that should be randomly allocated to parcels appearing in \verb{model0=} and \verb{model1=}.} \item{nAlloc}{The number of random items-to-parcels allocations to generate.} \item{fun}{\code{character} string indicating the name of the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function used to fit \verb{model0=} and \verb{model1=} to \verb{data=}. Can only take the values \code{"lavaan"}, \code{"sem"}, \code{"cfa"}, or \code{"growth"}.} \item{alpha}{Alpha level used as criterion for significance.} \item{bic.crit}{Criterion for assessing evidence in favor of one model over another. See Rafferty (1995) for guidelines (default is "very strong evidence" in favor of the model with lower BIC).} \item{fit.measures}{\code{character} vector containing names of fit measures to request from each fitted \link[lavaan:lavaan-class]{lavaan::lavaan} model. See the output of \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} for a list of available measures.} \item{\dots}{Additional arguments to be passed to \code{\link[lavaan:lavaanList]{lavaan::lavaanList()}}. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}} \item{show.progress}{If \code{TRUE}, show a \code{\link[utils:txtProgressBar]{utils::txtProgressBar()}} indicating how fast each model-fitting iterates over allocations.} \item{iseed}{(Optional) Random seed used for parceling items. When the same random seed is specified and the program is re-run, the same allocations will be generated. The seed argument can be used to assess parcel-allocation variability in model ranking when considering more than two models. For each pair of models under comparison, the program should be rerun using the same random seed. Doing so ensures that multiple model comparisons will employ the same set of parcel datasets. \emph{Note}: When using \pkg{parallel} options, you must first type \code{RNGkind("L'Ecuyer-CMRG")} into the R Console, so that the seed will be controlled across cores.} \item{warn}{Whether to print warnings when fitting models to each allocation} } \value{ A \code{list} with 3 elements. The first two (\code{model0.results} and \code{model1.results}) are results returned by \code{\link[=parcelAllocation]{parcelAllocation()}} for \code{model0} and \code{model1}, respectively. The third element (\code{model0.v.model1}) is a \code{list} of model-comparison results, including the following: \item{\verb{LRT_Summary:}}{ The average likelihood ratio test across allocations, as well as the \emph{SD}, minimum, maximum, range, and the proportion of allocations for which the test was significant.} \item{\verb{Fit_Index_Differences:}}{ Differences in fit indices, organized by what proportion favored each model and among those, what the average difference was.} \item{\verb{Favored_by_BIC:}}{ The proportion of allocations in which each model met the criterion (\code{bic.crit}) for a substantial difference in fit.} \item{\verb{Convergence_Summary:}}{ The proportion of allocations in which each model (and both models) converged on a solution.} Histograms are also printed to the current plot-output device. } \description{ This function quantifies and assesses the consequences of parcel-allocation variability for model ranking of structural equation models (SEMs) that differ in their structural specification but share the same parcel-level measurement specification (see Sterba & Rights, 2016). This function calls \code{\link[=parcelAllocation]{parcelAllocation()}}---which can be used with only one SEM in isolation---to fit two (assumed) nested models to each of a specified number of random item-to-parcel allocations. Output includes summary information about the distribution of model selection results (including plots) and the distribution of results for each model individually, across allocations within-sample. Note that this function can be used when selecting among more than two competing structural models as well (see instructions below involving the \verb{seed=} argument). } \details{ This is based on a SAS macro \code{ParcelAlloc} (Sterba & MacCallum, 2010). The \code{PAVranking()} function produces results discussed in Sterba and Rights (2016) relevant to the assessment of parcel-allocation variability in model selection and model ranking. Specifically, the \code{PAVranking()} function first calls \code{\link[=parcelAllocation]{parcelAllocation()}} to generate a given number (\verb{nAlloc=}) of item-to-parcel allocations, fitting both specified models to each allocation, and providing summaryies of PAV for each model. Additionally, \code{PAVranking()} provides the following new summaries: \itemize{ \item{PAV in model selection index values and model ranking between Models \verb{model0=} and \verb{model1=}.} \item{The proportion of allocations that converged and the proportion of proper solutions (results are summarized for allocations with both converged and proper allocations only).} } For further details on the benefits of the random allocation of items to parcels, see Sterba (2011) and Sterba and MacCallum (2010). To test whether nested models have equivalent fit, results can be pooled across allocations using the same methods available for pooling results across multiple imputations of missing data (see \strong{Examples}). \emph{Note}: This function requires the \code{lavaan} package. Missing data must be coded as \code{NA}. If the function returns \code{"Error in plot.new() : figure margins too large"}, the user may need to increase size of the plot window (e.g., in RStudio) and rerun the function. } \examples{ ## Specify the item-level model (if NO parcels were created) ## This must apply to BOTH competing models item.syntax <- c(paste0("f1 =~ f1item", 1:9), paste0("f2 =~ f2item", 1:9)) cat(item.syntax, sep = "\n") ## Below, we reduce the size of this same model by ## applying different parceling schemes ## Specify a 2-factor CFA with correlated factors, using 3-indicator parcels mod1 <- ' f1 =~ par1 + par2 + par3 f2 =~ par4 + par5 + par6 ' ## Specify a more restricted model with orthogonal factors mod0 <- ' f1 =~ par1 + par2 + par3 f2 =~ par4 + par5 + par6 f1 ~~ 0*f2 ' ## names of parcels (must apply to BOTH models) (parcel.names <- paste0("par", 1:6)) \donttest{ ## override default random-number generator to use parallel options RNGkind("L'Ecuyer-CMRG") PAVranking(model0 = mod0, model1 = mod1, data = simParcel, nAlloc = 100, parcel.names = parcel.names, item.syntax = item.syntax, # parallel = "multicore", # parallel available on Mac/Linux std.lv = TRUE) # any addition lavaan arguments ## POOL RESULTS by treating parcel allocations as multiple imputations. ## Details provided in Sterba & Rights (2016); see ?poolMAlloc. ## save list of data sets instead of fitting model yet dataList <- parcelAllocation(mod0, # or mod1 (either uses same allocations) data = simParcel, nAlloc = 100, parcel.names = parcel.names, item.syntax = item.syntax, do.fit = FALSE) ## now fit each model to each data set if(requireNamespace("lavaan.mi")){ library(lavaan.mi) fit0 <- cfa.mi(mod0, data = dataList, std.lv = TRUE) fit1 <- cfa.mi(mod1, data = dataList, std.lv = TRUE) anova(fit0, fit1) # Pooled test statistic comparing models. help(package = "lavaan.mi") # Find more methods for pooling results. } } } \references{ Raftery, A. E. (1995). Bayesian model selection in social research. \emph{Sociological Methodology, 25}, 111--163. \doi{10.2307/271063} Sterba, S. K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling, 18}(4), 554--577.\doi{10.1080/10705511.2011.607073} Sterba, S. K., & MacCallum, R. C. (2010). Variability in parameter estimates and model fit across repeated allocations of items to parcels. \emph{Multivariate Behavioral Research, 45}(2), 322--358. \doi{10.1080/00273171003680302} Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation variability in practice: Combining sources of uncertainty and choosing the number of allocations. \emph{Multivariate Behavioral Research, 51}(2--3), 296--313. \doi{10.1080/00273171.2016.1144502} Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model selection: Parcel-allocation variability in model ranking. \emph{Psychological Methods, 22}(1), 47--68. \doi{10.1037/met0000067} } \seealso{ \code{\link[=parcelAllocation]{parcelAllocation()}} for fitting a single model, \code{\link[=poolMAlloc]{poolMAlloc()}} for choosing the number of allocations } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/efa.ekc.Rd0000644000176200001440000000700614632144146014425 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/EmpKaiser.R \name{efa.ekc} \alias{efa.ekc} \title{Empirical Kaiser criterion} \usage{ efa.ekc(data = NULL, sample.cov = NULL, sample.nobs = NULL, missing = "default", ordered = NULL, plot = TRUE) } \arguments{ \item{data}{A \code{data.frame} or data \code{matrix} containing columns of variables to be factor-analyzed.} \item{sample.cov}{A covariance or correlation matrix can be used, instead of \code{data}, to estimate the eigenvalues.} \item{sample.nobs}{Number of observations (i.e. sample size) if \code{is.null(data)} and \verb{sample.cov=} is used.} \item{missing}{If \code{"listwise"}, incomplete cases are removed listwise from the \code{data.frame}. If \code{"direct"} or \code{"ml"} or \code{"fiml"} and the \verb{estimator=} is maximum likelihood, an EM algorithm is used to estimate an unrestricted covariance matrix (and mean vector). If \code{"pairwise"}, pairwise deletion is used. If `"default"``, the value is set depending on the estimator and the mimic option (see \code{\link[lavaan:lavCor]{lavaan::lavCor()}} for details).} \item{ordered}{\code{character} vector. Only used if object is a \code{data.frame}. Treat these variables as \verb{ordered=} (ordinal) variables. Importantly, all other variables will be treated as numeric (unless \code{is.ordered == TRUE} in \code{data}). (see also \link[lavaan:lavCor]{lavCor})} \item{plot}{logical. Whether to print a scree plot comparing the sample eigenvalues with the reference eigenvalues.} } \value{ A \code{data.frame} showing the sample and reference eigenvalues. The number of factors suggested by the Empirical Kaiser Criterion (i.e. the sample eigenvalues greater than the reference eigenvalues) is returned as an attribute (see \strong{Examples}). The number of factors suggested by the original Kaiser Criterion (i.e. sample eigenvalues > 1) is also printed as a header to the \code{data.frame} } \description{ Identify the number of factors to extract based on the Empirical Kaiser Criterion (EKC). The analysis can be run on a \code{data.frame} or data \code{matrix} (\code{data}), or on a correlation or covariance matrix (\code{sample.cov}) and the sample size (\code{sample.nobs}). A \code{data.frame} is returned with two columns: the eigenvalues from your data or covariance matrix and the reference eigenvalues. The number of factors suggested by the Empirical Kaiser Criterion (i.e. the sample eigenvalues greater than the reference eigenvalues), and the number of factors suggested by the original Kaiser Criterion (i.e. sample eigenvalues > 1) is printed above the output. } \examples{ ## Simulate data with 3 factors model <- ' f1 =~ .3*x1 + .5*x2 + .4*x3 f2 =~ .3*x4 + .5*x5 + .4*x6 f3 =~ .3*x7 + .5*x8 + .4*x9 ' dat <- simulateData(model, seed = 123) ## save summary statistics myCovMat <- cov(dat) myCorMat <- cor(dat) N <- nrow(dat) ## Run the EKC function (out <- efa.ekc(dat)) ## To extract the recommended number of factors using the EKC: attr(out, "nfactors") ## If you do not have raw data, you can use summary statistics (x1 <- efa.ekc(sample.cov = myCovMat, sample.nobs = N, plot = FALSE)) (x2 <- efa.ekc(sample.cov = myCorMat, sample.nobs = N, plot = FALSE)) } \references{ Braeken, J., & van Assen, M. A. L. M. (2017). An empirical Kaiser criterion. \emph{Psychological Methods, 22}(3), 450--466. \doi{10.1037/met0000074} } \author{ Ylenio Longo (University of Nottingham; \email{yleniolongo@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/probe2WayMC.Rd0000644000176200001440000002041714753073632015231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/probeInteraction.R \name{probe2WayMC} \alias{probe2WayMC} \title{Probing two-way interaction on the no-centered or mean-centered latent interaction} \usage{ probe2WayMC(fit, nameX, nameY, modVar, valProbe, group = 1L, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{fit}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object with a latent 2-way interaction.} \item{nameX}{\code{character} vector of all 3 factor names used as the predictors. The lower-order factors must be listed first, and the final name must be the latent interaction factor.} \item{nameY}{The name of factor that is used as the dependent variable.} \item{modVar}{The name of factor that is used as a moderator. The effect of the other independent factor will be probed at each value of the moderator variable listed in \code{valProbe}.} \item{valProbe}{The values of the moderator that will be used to probe the effect of the focal predictor.} \item{group}{In multigroup models, the label of the group for which the results will be returned. Must correspond to one of \code{lavInspect(fit, "group.label")}, or an integer corresponding to which of those group labels.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Ignored unless \code{fit} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ A list with two elements: \enumerate{ \item \code{SimpleIntercept}: The simple intercepts given each value of the moderator. \item \code{SimpleSlope}: The simple slopes given each value of the moderator. } In each element, the first column represents the values of the moderator specified in the \code{valProbe} argument. The second column is the simple intercept or simple slope. The third column is the \emph{SE} of the simple intercept or simple slope. The fourth column is the Wald (\emph{z}) statistic, and the fifth column is the associated \emph{p} value testing the null hypothesis that each simple intercept or slope is 0. } \description{ Probing interaction for simple intercept and simple slope for the no-centered or mean-centered latent two-way interaction } \details{ Before using this function, researchers need to make the products of the indicators between the first-order factors using mean centering (Marsh, Wen, & Hau, 2004). Note that the double-mean centering may not be appropriate for probing interaction if researchers are interested in simple intercepts. The mean or double-mean centering can be done by the \code{\link[=indProd]{indProd()}} function. The indicator products can be made for all possible combination or matched-pair approach (Marsh et al., 2004). Next, the hypothesized model with the regression with latent interaction will be used to fit all original indicators and the product terms. See the example for how to fit the product term below. Once the lavaan result is obtained, this function will be used to probe the interaction. Let that the latent interaction model regressing the dependent variable (\eqn{Y}) on the independent variable (\eqn{X}) and the moderator (\eqn{Z}) be \deqn{ Y = b_0 + b_1X + b_2Z + b_3XZ + r, } where \eqn{b_0} is the estimated intercept or the expected value of \eqn{Y} when both \eqn{X} and \eqn{Z} are 0, \eqn{b_1} is the effect of \eqn{X} when \eqn{Z} is 0, \eqn{b_2} is the effect of \eqn{Z} when \eqn{X} is 0, \eqn{b_3} is the interaction effect between \eqn{X} and \eqn{Z}, and \eqn{r} is the residual term. To probe a two-way interaction, the simple intercept of the independent variable at each value of the moderator (Aiken & West, 1991; Cohen, Cohen, West, & Aiken, 2003; Preacher, Curran, & Bauer, 2006) can be obtained by \deqn{ b_{0|X = 0, Z} = b_0 + b_2 Z. } The simple slope of the independent varaible at each value of the moderator can be obtained by \deqn{ b_{X|Z} = b_1 + b_3 Z. } The variance of the simple intercept formula is \deqn{ Var\left(b_{0|X = 0, Z}\right) = Var\left(b_0\right) + 2Z \times Cov\left(b_0, b_2\right) + Z^2 \times Var\left(b_2\right) }, where \eqn{Var} denotes the variance of a parameter estimate and \eqn{Cov} denotes the covariance of two parameter estimates. The variance of the simple slope formula is \deqn{ Var\left(b_{X|Z}\right) = Var\left(b_1\right) + 2Z \times Cov\left(b_1, b_3\right) + Z^2 \times Var\left(b_3\right) } Wald \emph{z} statistic is used for test statistic (even for objects of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}). } \examples{ dat2wayMC <- indProd(dat2way, 1:3, 4:6) # double mean centered by default model1 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f12 =~ x1.x4 + x2.x5 + x3.x6 f3 =~ x7 + x8 + x9 f3 ~ f1 + f2 + f12 f12 ~~ 0*f1 + 0*f2 # not necessary, but implied by double mean centering " fitMC2way <- sem(model1, data = dat2wayMC, meanstructure = TRUE) summary(fitMC2way) probe2WayMC(fitMC2way, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) ## can probe multigroup models, one group at a time dat2wayMC$g <- 1:2 model2 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f12 =~ x1.x4 + x2.x5 + x3.x6 f3 =~ x7 + x8 + x9 f3 ~ c(b1.g1, b1.g2)*f1 + c(b2.g1, b2.g2)*f2 + c(b12.g1, b12.g2)*f12 f12 ~~ 0*f1 + 0*f2 " fit2 <- sem(model2, data = dat2wayMC, group = "g") probe2WayMC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) # group = 1 by default probe2WayMC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1), group = 2) } \references{ Tutorial: Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting latent variable interactions using the \code{semTools} package. \emph{Psych, 3}(3), 322--335. \doi{10.3390/psych3030024} Background literature: Aiken, L. S., & West, S. G. (1991). \emph{Multiple regression: Testing and interpreting interactions}. Newbury Park, CA: Sage. Cohen, J., Cohen, P., West, S. G., & Aiken, L. S. (2003). \emph{Applied multiple regression/correlation analysis for the behavioral sciences} (3rd ed.). New York, NY: Routledge. Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of latent interactions: Evaluation of alternative estimation strategies and indicator construction. \emph{Psychological Methods, 9}(3), 275--300. \doi{10.1037/1082-989X.9.3.275} Preacher, K. J., Curran, P. J., & Bauer, D. J. (2006). Computational tools for probing interactions in multiple linear regression, multilevel modeling, and latent curve analysis. \emph{Journal of Educational and Behavioral Statistics, 31}(4), 437--448. \doi{10.3102/10769986031004437} } \seealso{ \itemize{ \item \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. \item \code{\link[=probe3WayMC]{probe3WayMC()}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe2WayRC]{probe2WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=probe3WayRC]{probe3WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=plotProbe]{plotProbe()}} Plot the simple intercepts and slopes of the latent interaction. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/lrv2ord.Rd0000644000176200001440000001217014751367446014535 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ordMoments.R \name{lrv2ord} \alias{lrv2ord} \title{Calculate Population Moments for Ordinal Data Treated as Numeric} \usage{ lrv2ord(Sigma, Mu, thresholds, cWts) } \arguments{ \item{Sigma}{Population covariance \code{\link[=matrix]{matrix()}}, with variable names saved in the \code{\link[=dimnames]{dimnames()}} attribute.} \item{Mu}{Optional \code{numeric} vector of population means. If missing, all means will be set to zero.} \item{thresholds}{Either a single \code{numeric} vector of population thresholds used to discretize each normally distributed variable, or a named \code{list} of each discretized variable's vector of thresholds. The discretized variables may be a subset of all variables in \code{Sigma} if the remaining variables are intended to be observed rather than latent normally distributed variables.} \item{cWts}{Optional (default when missing is to use 0 for the lowest category, followed by successive integers for each higher category). Either a single \code{numeric} vector of category weights (if they are identical across all variables) or a named \code{list} of each discretized variable's vector of category weights.} } \value{ A \code{list} including the LRV-scale population moments (means, covariance matrix, correlation matrix, and thresholds), the category weights, a \code{data.frame} of implied univariate moments (means, \emph{SD}s, skewness, and excess kurtosis (i.e., in excess of 3, which is the kurtosis of the normal distribution) for discretized data treated as \code{numeric}, and the implied covariance and correlation matrix of discretized data treated as \code{numeric}. } \description{ This function calculates ordinal-scale moments implied by LRV-scale moments } \details{ Binary and ordinal data are frequently accommodated in SEM by incorporating a threshold model that links each observed categorical response variable to a corresponding latent response variable that is typically assumed to be normally distributed (Kamata & Bauer, 2008; Wirth & Edwards, 2007). This function can be useful for real-data analysis or for designing Monte Carlo simulations, as described by Jorgensen and Johnson (2022). } \examples{ ## SCENARIO 1: DIRECTLY SPECIFY POPULATION PARAMETERS ## specify population model in LISREL matrices Nu <- rep(0, 4) Alpha <- c(1, -0.5) Lambda <- matrix(c(1, 1, 0, 0, 0, 0, 1, 1), nrow = 4, ncol = 2, dimnames = list(paste0("y", 1:4), paste0("eta", 1:2))) Psi <- diag(c(1, .75)) Theta <- diag(4) Beta <- matrix(c(0, .5, 0, 0), nrow = 2, ncol = 2) ## calculate model-implied population means and covariance matrix ## of latent response variables (LRVs) IB <- solve(diag(2) - Beta) # to save time and space Mu_LRV <- Nu + Lambda \%*\% IB \%*\% Alpha Sigma_LRV <- Lambda \%*\% IB \%*\% Psi \%*\% t(IB) \%*\% t(Lambda) + Theta ## Specify (unstandardized) thresholds to discretize normally distributed data ## generated from Mu_LRV and Sigma_LRV, based on marginal probabilities PiList <- list(y1 = c(.25, .5, .25), y2 = c(.17, .33, .33, .17), y3 = c(.1, .2, .4, .2, .1), ## make final variable highly asymmetric y4 = c(.33, .25, .17, .12, .08, .05)) sapply(PiList, sum) # all sum to 100\% CumProbs <- sapply(PiList, cumsum) ## unstandardized thresholds TauList <- mapply(qnorm, p = lapply(CumProbs, function(x) x[-length(x)]), m = Mu_LRV, sd = sqrt(diag(Sigma_LRV))) for (i in 1:4) names(TauList[[i]]) <- paste0(names(TauList)[i], "|t", 1:length(TauList[[i]])) ## assign numeric weights to each category (optional, see default) NumCodes <- list(y1 = c(-0.5, 0, 0.5), y2 = 0:3, y3 = 1:5, y4 = 1:6) ## Calculate Population Moments for Numerically Coded Ordinal Variables lrv2ord(Sigma = Sigma_LRV, Mu = Mu_LRV, thresholds = TauList, cWts = NumCodes) ## SCENARIO 2: USE ESTIMATED PARAMETERS AS POPULATION data(datCat) # already stored as c("ordered","factor") fit <- cfa(' f =~ 1*u1 + 1*u2 + 1*u3 + 1*u4 ', data = datCat) lrv2ord(Sigma = fit, thresholds = fit) # use same fit for both ## or use estimated thresholds with specified parameters, but note that ## lrv2ord() will only extract standardized thresholds dimnames(Sigma_LRV) <- list(paste0("u", 1:4), paste0("u", 1:4)) lrv2ord(Sigma = cov2cor(Sigma_LRV), thresholds = fit) } \references{ Jorgensen, T. D., & Johnson, A. R. (2022). How to derive expected values of structural equation model parameters when treating discrete data as continuous. \emph{Structural Equation Modeling, 29}(4), 639--650. \doi{10.1080/10705511.2021.1988609} Kamata, A., & Bauer, D. J. (2008). A note on the relation between factor analytic and item response theory models. \emph{Structural Equation Modeling, 15}(1), 136--153. \doi{10.1080/10705510701758406} Wirth, R. J., & Edwards, M. C. (2007). Item factor analysis: Current approaches and future directions. \emph{Psychological Methods, 12}(1), 58--79. \doi{10.1037/1082-989X.12.1.58} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Andrew R. Johnson (Curtin University; \email{andrew.johnson@curtin.edu.au}) } semTools/man/mardiaKurtosis.Rd0000644000176200001440000000356214632147325016137 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDiagnosis.R \name{mardiaKurtosis} \alias{mardiaKurtosis} \title{Finding Mardia's multivariate kurtosis} \usage{ mardiaKurtosis(dat, use = "everything") } \arguments{ \item{dat}{The target matrix or data frame with multiple variables} \item{use}{Missing data handling method from the \code{\link[stats:cor]{stats::cov()}} function.} } \value{ A value of a Mardia's multivariate kurtosis with a test statistic } \description{ Finding Mardia's multivariate kurtosis of multiple variables } \details{ The Mardia's multivariate kurtosis formula (Mardia, 1970) is \deqn{ b_{2, d} = \frac{1}{n}\sum^n_{i=1}\left[ \left(\bold{X}_i - \bold{\bar{X}} \right)^{'} \bold{S}^{-1} \left(\bold{X}_i - \bold{\bar{X}} \right) \right]^2, } where \eqn{d} is the number of variables, \eqn{X} is the target dataset with multiple variables, \eqn{n} is the sample size, \eqn{\bold{S}} is the sample covariance matrix of the target dataset, and \eqn{\bold{\bar{X}}} is the mean vectors of the target dataset binded in \eqn{n} rows. When the population multivariate kurtosis is normal, the \eqn{b_{2,d}} is asymptotically distributed as normal distribution with the mean of \eqn{d(d + 2)} and variance of \eqn{8d(d + 2)/n}. } \examples{ library(lavaan) mardiaKurtosis(HolzingerSwineford1939[ , paste0("x", 1:9)]) } \references{ Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications. \emph{Biometrika, 57}(3), 519--530. \doi{10.2307/2334770} } \seealso{ \itemize{ \item \code{\link[=skew]{skew()}} Find the univariate skewness of a variable \item \code{\link[=kurtosis]{kurtosis()}} Find the univariate excessive kurtosis of a variable \item \code{\link[=mardiaSkew]{mardiaSkew()}} Find the Mardia's multivariate skewness of a set of variables } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/nullRMSEA.Rd0000644000176200001440000000455014632143413014670 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fitIndices.R \name{nullRMSEA} \alias{nullRMSEA} \title{Calculate the RMSEA of the null model} \usage{ nullRMSEA(object, scaled = FALSE, silent = FALSE) } \arguments{ \item{object}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions.} \item{scaled}{If \code{TRUE}, the scaled (or robust, if available) RMSEA is returned. Ignored if a robust test statistic was not requested.} \item{silent}{If \code{TRUE}, do not print anything on the screen.} } \value{ A value of RMSEA of the null model (a \code{numeric} vector) returned invisibly. } \description{ Calculate the RMSEA of the null (baseline) model } \details{ RMSEA of the null model is calculated similar to the formula provided in the \code{lavaan} package. The standard formula of RMSEA is \deqn{ RMSEA =\sqrt{\frac{\chi^2}{N \times df} - \frac{1}{N}} \times \sqrt{G} } where \eqn{\chi^2} is the chi-square test statistic value of the target model, \eqn{N} is the total sample size, \eqn{df} is the degree of freedom of the hypothesized model, \eqn{G} is the number of groups. Kenny proposed in his website that "A reasonable rule of thumb is to examine the RMSEA for the null model and make sure that is no smaller than 0.158. An RMSEA for the model of 0.05 and a TLI of .90, implies that the RMSEA of the null model is 0.158. If the RMSEA for the null model is less than 0.158, an incremental measure of fit may not be that informative." See also \url{http://davidakenny.net/cm/fit.htm} } \examples{ HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit <- cfa(HS.model, data = HolzingerSwineford1939) nullRMSEA(fit) } \references{ Kenny, D. A., Kaniskan, B., & McCoach, D. B. (2015). The performance of RMSEA in models with small degrees of freedom. \emph{Sociological Methods Research, 44}(3), 486--507. \doi{10.1177/0049124114543236} } \seealso{ \itemize{ \item \code{\link[=miPowerFit]{miPowerFit()}} For the modification indices and their power approach for model fit evaluation \item \code{\link[=moreFitIndices]{moreFitIndices()}} For other fit indices } } \author{ Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/imposeStart.Rd0000644000176200001440000000645414006342740015444 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/imposeStart.R \name{imposeStart} \alias{imposeStart} \title{Specify starting values from a lavaan output} \usage{ imposeStart(out, expr, silent = TRUE) } \arguments{ \item{out}{The \code{lavaan} output that users wish to use the parameter estimates as staring values for an analysis model} \item{expr}{The original code that users use to run a lavaan model} \item{silent}{Logical to print the parameter table with new starting values} } \value{ A fitted lavaan model } \description{ This function will save the parameter estimates of a lavaan output and impose those parameter estimates as starting values for another analysis model. The free parameters with the same names or the same labels across two models will be imposed the new starting values. This function may help to increase the chance of convergence in a complex model (e.g., multitrait-multimethod model or complex longitudinal invariance model). } \examples{ ## The following example show that the longitudinal weak invariance model ## using effect coding was not convergent with three time points but convergent ## with two time points. Thus, the parameter estimates from the model with ## two time points are used as starting values of the three time points. ## The model with new starting values is convergent properly. weak2time <- ' # Loadings f1t1 =~ LOAD1*y1t1 + LOAD2*y2t1 + LOAD3*y3t1 f1t2 =~ LOAD1*y1t2 + LOAD2*y2t2 + LOAD3*y3t2 # Factor Variances f1t1 ~~ f1t1 f1t2 ~~ f1t2 # Factor Covariances f1t1 ~~ f1t2 # Error Variances y1t1 ~~ y1t1 y2t1 ~~ y2t1 y3t1 ~~ y3t1 y1t2 ~~ y1t2 y2t2 ~~ y2t2 y3t2 ~~ y3t2 # Error Covariances y1t1 ~~ y1t2 y2t1 ~~ y2t2 y3t1 ~~ y3t2 # Factor Means f1t1 ~ NA*1 f1t2 ~ NA*1 # Measurement Intercepts y1t1 ~ INT1*1 y2t1 ~ INT2*1 y3t1 ~ INT3*1 y1t2 ~ INT4*1 y2t2 ~ INT5*1 y3t2 ~ INT6*1 # Constraints for Effect-coding Identification LOAD1 == 3 - LOAD2 - LOAD3 INT1 == 0 - INT2 - INT3 INT4 == 0 - INT5 - INT6 ' model2time <- lavaan(weak2time, data = exLong) weak3time <- ' # Loadings f1t1 =~ LOAD1*y1t1 + LOAD2*y2t1 + LOAD3*y3t1 f1t2 =~ LOAD1*y1t2 + LOAD2*y2t2 + LOAD3*y3t2 f1t3 =~ LOAD1*y1t3 + LOAD2*y2t3 + LOAD3*y3t3 # Factor Variances f1t1 ~~ f1t1 f1t2 ~~ f1t2 f1t3 ~~ f1t3 # Factor Covariances f1t1 ~~ f1t2 + f1t3 f1t2 ~~ f1t3 # Error Variances y1t1 ~~ y1t1 y2t1 ~~ y2t1 y3t1 ~~ y3t1 y1t2 ~~ y1t2 y2t2 ~~ y2t2 y3t2 ~~ y3t2 y1t3 ~~ y1t3 y2t3 ~~ y2t3 y3t3 ~~ y3t3 # Error Covariances y1t1 ~~ y1t2 y2t1 ~~ y2t2 y3t1 ~~ y3t2 y1t1 ~~ y1t3 y2t1 ~~ y2t3 y3t1 ~~ y3t3 y1t2 ~~ y1t3 y2t2 ~~ y2t3 y3t2 ~~ y3t3 # Factor Means f1t1 ~ NA*1 f1t2 ~ NA*1 f1t3 ~ NA*1 # Measurement Intercepts y1t1 ~ INT1*1 y2t1 ~ INT2*1 y3t1 ~ INT3*1 y1t2 ~ INT4*1 y2t2 ~ INT5*1 y3t2 ~ INT6*1 y1t3 ~ INT7*1 y2t3 ~ INT8*1 y3t3 ~ INT9*1 # Constraints for Effect-coding Identification LOAD1 == 3 - LOAD2 - LOAD3 INT1 == 0 - INT2 - INT3 INT4 == 0 - INT5 - INT6 INT7 == 0 - INT8 - INT9 ' ### The following command does not provide convergent result # model3time <- lavaan(weak3time, data = exLong) ### Use starting values from the model with two time points model3time <- imposeStart(model2time, lavaan(weak3time, data = exLong)) summary(model3time) } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/reliabilityL2-deprecated.Rd0000644000176200001440000001333514753073632017745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reliability.R \name{reliabilityL2-deprecated} \alias{reliabilityL2-deprecated} \title{Calculate the reliability values of a second-order factor} \usage{ reliabilityL2(object, secondFactor, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object, expected to contain a least one exogenous higher-order common factor.} \item{secondFactor}{The name of a single second-order factor in the model fitted in \code{object}. The function must be called multiple times to estimate reliability for each higher-order factor.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ Reliability values at Levels 1 and 2 of the second-order factor, as well as the partial reliability value at Level 1 } \description{ Calculate the reliability values (coefficient omega) of a second-order factor } \details{ The first formula of the coefficient omega (in the \code{\link[=reliability]{reliability()}}) will be mainly used in the calculation. The model-implied covariance matrix of a second-order factor model can be separated into three sources: the second-order common-factor variance, the residual variance of the first-order common factors (i.e., not accounted for by the second-order factor), and the measurement error of observed indicators: \deqn{ \hat{\Sigma} = \Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime} + \Lambda \Psi_{u} \Lambda^{\prime} + \Theta, } where \eqn{\hat{\Sigma}} is the model-implied covariance matrix, \eqn{\Lambda} contains first-order factor loadings, \eqn{\bold{B}} contains second-order factor loadings, \eqn{\Phi_2} is the covariance matrix of the second-order factor(s), \eqn{\Psi_{u}} is the covariance matrix of residuals from first-order factors, and \eqn{\Theta} is the covariance matrix of the measurement errors from observed indicators. Thus, we can calculate the proportion of variance of a composite score calculated from the observed indicators (e.g., a total score or scale mean) that is attributable to the second-order factor, i.e. coefficient omega at Level 1: \deqn{ \omega_{L1} = \frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime} \bold{1}}{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 \bold{B} ^{\prime} \Lambda^{\prime} \bold{1} + \bold{1}^{\prime} \Lambda \Psi_{u} \Lambda^{\prime} \bold{1} + \bold{1}^{\prime} \Theta \bold{1}}, } where \eqn{\bold{1}} is the \emph{k}-dimensional vector of 1 and \emph{k} is the number of observed variables. The model-implied covariance matrix among first-order factors (\eqn{\Phi_1}) can be calculated as: \deqn{ \Phi_1 = \bold{B} \Phi_2 \bold{B}^{\prime} + \Psi_{u}, } Thus, the proportion of variance among first-order common factors that is attributable to the second-order factor (i.e., coefficient omega at Level 2) can be calculated as: \deqn{ \omega_{L2} = \frac{\bold{1}_F^{\prime} \bold{B} \Phi_2 \bold{B}^{\prime} \bold{1}_F}{\bold{1}_F^{\prime} \bold{B} \Phi_2 \bold{B}^{\prime} \bold{1}_F + \bold{1}_F^{\prime} \Psi_{u} \bold{1}_F}, } where \eqn{\bold{1}_F} is the \emph{F}-dimensional vector of 1 and \emph{F} is the number of first-order factors. This Level-2 omega can be interpreted as an estimate of the reliability of a hypothetical composite calculated from error-free observable variables representing the first-order common factors. This might only be meaningful as a thought experiment. An additional thought experiment is possible: If the observed indicators contained only the second-order common-factor variance and unsystematic measurement error, then there would be no first-order common factors because their unique variances would be excluded from the observed measures. An estimate of this hypothetical composite reliability can be calculated as the partial coefficient omega at Level 1, or the proportion of observed variance explained by the second-order factor after partialling out the uniqueness from the first-order factors: \deqn{ \omega_{L1} = \frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime} \bold{1}}{\bold{1}^{\prime} \Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime} \bold{1} + \bold{1}^{\prime} \Theta \bold{1}}, } Note that if the second-order factor has a direct factor loading on some observed variables, the observed variables will be counted as first-order factors, which might not be desirable. } \examples{ HS.model3 <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 higher =~ visual + textual + speed' fit6 <- cfa(HS.model3, data = HolzingerSwineford1939) reliability(fit6) # Should provide a warning for the endogenous variables reliabilityL2(fit6, "higher") } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } \keyword{internal} semTools/man/poolMAlloc.Rd0000644000176200001440000003320314764270501015171 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/poolMAlloc.R \name{poolMAlloc} \alias{poolMAlloc} \title{Combine sampling variability with parcel-allocation variability by pooling results across M parcel-allocations} \usage{ poolMAlloc(nPerPar, facPlc, nAllocStart, nAllocAdd = 0, parceloutput = NULL, syntax, dataset, stopProp, stopValue, selectParam = NULL, indices = "default", double = FALSE, checkConv = FALSE, names = "default", leaveout = 0, useTotalAlloc = FALSE, ...) } \arguments{ \item{nPerPar}{A list in which each element is a vector, corresponding to each factor, indicating sizes of parcels. If variables are left out of parceling, they should not be accounted for here (i.e., there should not be parcels of size "1").} \item{facPlc}{A list of vectors, each corresponding to a factor, specifying the item indicators of that factor (whether included in parceling or not). Either variable names or column numbers. Variables not listed will not be modeled or included in output datasets.} \item{nAllocStart}{The number of random allocations of items to parcels to generate in the first iteration of the algorithm.} \item{nAllocAdd}{The number of allocations to add with each iteration of the algorithm. Note that if only one iteration is desired, \code{nAllocAdd} can be set to \eqn{0} and results will be output for \code{nAllocStart} allocations only.} \item{parceloutput}{Optional \code{character}. Path (folder/directory) where \emph{M} (the final selected number of allocations) parceled data sets will be outputted from the iteration where the algorithm met stopping criteria. Note for Windows users: file path must be specified using forward slashes (\code{/}), not backslashes (\verb{\\\\}). See \code{\link[base:path.expand]{base::path.expand()}} for details. If \code{NULL} (default), nothing is saved to disk.} \item{syntax}{lavaan syntax that defines the model.} \item{dataset}{Item-level dataset} \item{stopProp}{Value used in defining stopping criteria of the algorithm (\eqn{\delta_a} in Sterba & Rights, 2016). This is the minimum proportion of change (in any pooled parameter or pooled standard error estimate listed in \code{selectParam}) that is allowable from one iteration of the algorithm to the next. That is, change in pooled estimates and pooled standard errors from one iteration to the next must all be less than (\code{stopProp}) \eqn{\times} (value from former iteration). Note that \code{stopValue} can override this criterion (see below). Also note that values less than .01 are unlikely to lead to more substantively meaningful precision. Also note that if only \code{stopValue} is a desired criterion, \code{stopProp} can be set to 0.} \item{stopValue}{Value used in defining stopping criteria of the algorithm (\eqn{\delta_b} in Sterba & Rights, 2016). \code{stopValue} is a minimum allowable amount of absolute change (in any pooled parameter or pooled standard error estimate listed in \code{selectParam}) from one iteration of the algorithm to the next. For a given pooled estimate or pooled standard error, \code{stopValue} is only invoked as a stopping criteria when the minimum change required by \code{stopProp} is less than \code{stopValue}. Note that values less than .01 are unlikely to lead to more substantively meaningful precision. Also note that if only \code{stopProp} is a desired criterion, \code{stopValue} can be set to 0.} \item{selectParam}{(Optional) A list of the pooled parameters to be used in defining stopping criteria (i.e., \code{stopProp} and \code{stopValue}). These parameters should appear in the order they are listed in the lavaan syntax. By default, all pooled parameters are used. Note that \code{selectParam} should only contain freely-estimated parameters. In one example from Sterba & Rights (2016) \code{selectParam} included all free parameters except item intercepts and in another example \code{selectParam} included only structural parameters.} \item{indices}{Optional \code{character} vector indicating the names of available \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} to be included in the output. The first and second elements should be a chi-squared test statistic and its associated degrees of freedom, both of which will be added if missing. If \code{"default"}, the indices will be \code{c("chisq", "df", "cfi", "tli", "rmsea","srmr")}. If a robust test statistic is requested (see \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}), \code{c("chisq","df")} will be replaced by \code{c("chisq.scaled","df.scaled")}. For the output to include both the naive and robust test statistics, \code{indices} should include both, but put the scaled test statistics first, as in \code{indices = c("chisq.scaled", "df.scaled", "chisq", "df")}} \item{double}{(Optional) If set to \code{TRUE}, requires stopping criteria (\code{stopProp} and \code{stopValue}) to be met for all parameters (in \code{selectParam}) for two consecutive iterations of the algorithm. By default, this is set to \code{FALSE}, meaning stopping criteria need only be met at one iteration of the algorithm.} \item{checkConv}{(Optional) If set to TRUE, function will output pooled estimates and standard errors from 10 iterations post-convergence.} \item{names}{(Optional) A character vector containing the names of parceled variables.} \item{leaveout}{(Optional) A vector of variables to be left out of randomized parceling. Either variable names or column numbers are allowed.} \item{useTotalAlloc}{(Optional) If set to \code{TRUE}, function will output a separate set of results that uses all allocations created by the algorithm, rather than \emph{M} allocations (see "Allocations needed for stability" below). This distinction is further discussed in Sterba and Rights (2016).} \item{\dots}{Additional arguments to be passed to \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}} } \value{ \item{Estimates}{A table containing pooled results across \emph{M} allocations at the iteration where stopping criteria were met. Columns correspond to individual parameter name, pooled estimate, pooled standard error, \emph{p} value for a \emph{z} test of the parameter, normal-theory \eqn{95\%} CI, \emph{p} value for a \emph{t} test of the parameter (using \eqn{df} described in Sterba & Rights, 2016), and \emph{t}-based \eqn{95\%} CI for the parameter.} \item{Fit}{A table containing results related to model fit from the \emph{M} allocations at the iteration where stopping criteria were met. Columns correspond to fit index names, the mean of each index across allocations, the \emph{SD} of each fit index across allocations, the minimum, maximum and range of each fit index across allocations, and the percent of the \emph{M} allocations where the chi-square test of absolute fit was significant.} \item{Proportions}{A table containing the proportion of the final \emph{M} allocations that (a) met the optimizer convergence criteria) and (b) converged to proper solutions. Note that pooled estimates, pooled standard errors, and other results are computed using only the converged, proper allocations.} \item{Stability}{The number of allocations (\emph{M}) needed for stability, at which point the algorithm's stopping criteria (defined above) were met.} \item{Uncertainty}{Indices used to quantify uncertainty in estimates due to sample vs. allocation variability. A table containing individual parameter names, an estimate of the proportion of total variance of a pooled parameter estimate that is attributable to parcel-allocation variability (PPAV), and an estimate of the ratio of the between-allocation variance of a pooled parameter estimate to the within-allocation variance (RPAV). See Sterba & Rights (2016) for more detail.} \item{Time}{The total runtime of the function, in minutes. Note that the total runtime will be greater when the specified model encounters convergence problems for some allocations, as is the case with the \code{\link[=simParcel]{simParcel()}} dataset used below.} } \description{ This function employs an iterative algorithm to pick the number of random item-to-parcel allocations needed to meet user-defined stability criteria for a fitted structural equation model (SEM) (see \strong{Details} below for more information). Pooled point and standard-error estimates from this SEM can be outputted at this final selected number of allocations (however, it is more efficient to save the allocations and treat them as multiple imputations using \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}}; see \strong{See Also} for links with examples). Additionally, new indices (see Sterba & Rights, 2016) are outputted for assessing the relative contributions of parcel-allocation variability vs. sampling variability in each estimate. At each iteration, this function generates a given number of random item-to-parcel allocations, fits a SEM to each allocation, pools estimates across allocations from that iteration, and then assesses whether stopping criteria are met. If stopping criteria are not met, the algorithm increments the number of allocations used (generating all new allocations). } \details{ This function implements an algorithm for choosing the number of allocations (\emph{M}; described in Sterba & Rights, 2016), pools point and standard-error estimates across these \emph{M} allocations, and produces indices for assessing the relative contributions of parcel-allocation variability vs. sampling variability in each estimate. To obtain pooled test statistics for model fit or model comparison, the \code{list} or parcel allocations can be passed to \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}} (find \strong{Examples} on the help pages for \code{\link[=parcelAllocation]{parcelAllocation()}} and \code{\link[=PAVranking]{PAVranking()}}). This function randomly generates a given number (\code{nAllocStart}) of item-to-parcel allocations, fits a SEM to each allocation, and then increments the number of allocations used (by \code{nAllocAdd}) until the pooled point and standard-error estimates fulfill stopping criteria (\code{stopProp} and \code{stopValue}, defined above). A summary of results from the model that was fit to the \emph{M} allocations are returned. Additionally, this function outputs the proportion of allocations with solutions that converged (using a maximum likelihood estimator) as well as the proportion of allocations with solutions that were converged and proper. The converged and proper solutions among the final \emph{M} allocations are used in computing pooled results. Additionally, after each iteration of the algorithm, information useful in monitoring the algorithm is outputted. The number of allocations used at that iteration, the proportion of pooled parameter estimates meeting stopping criteria at the previous iteration, the proportion of pooled standard errors meeting stopping criteria at the previous iteration, and the runtime of that iteration are outputted. When stopping criteria are satisfied, the full set of results are outputted. For further details on the benefits of the random allocation of items to parcels, see Sterba (2011) and Sterba & MacCallum (2010). } \examples{ \donttest{ ## lavaan syntax: A 2 Correlated ## factor CFA model to be fit to parceled data parmodel <- ' f1 =~ NA*p1f1 + p2f1 + p3f1 f2 =~ NA*p1f2 + p2f2 + p3f2 p1f1 ~ 1 p2f1 ~ 1 p3f1 ~ 1 p1f2 ~ 1 p2f2 ~ 1 p3f2 ~ 1 p1f1 ~~ p1f1 p2f1 ~~ p2f1 p3f1 ~~ p3f1 p1f2 ~~ p1f2 p2f2 ~~ p2f2 p3f2 ~~ p3f2 f1 ~~ 1*f1 f2 ~~ 1*f2 f1 ~~ f2 ' ## specify items for each factor f1name <- colnames(simParcel)[1:9] f2name <- colnames(simParcel)[10:18] ## run function poolMAlloc(nPerPar = list(c(3,3,3), c(3,3,3)), facPlc = list(f1name, f2name), nAllocStart = 10, nAllocAdd = 10, syntax = parmodel, dataset = simParcel, stopProp = .03, stopValue = .03, selectParam = c(1:6, 13:18, 21), names = list("p1f1","p2f1","p3f1","p1f2","p2f2","p3f2"), double = FALSE, useTotalAlloc = FALSE) } ## See examples on ?parcelAllocation and ?PAVranking for how to obtain ## pooled test statistics and other pooled lavaan output. ## Details provided in Sterba & Rights (2016). } \references{ Sterba, S. K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling, 18}(4), 554--577. \doi{10.1080/10705511.2011.607073} Sterba, S. K., & MacCallum, R. C. (2010). Variability in parameter estimates and model fit across random allocations of items to parcels. \emph{Multivariate Behavioral Research, 45}(2), 322--358. \doi{10.1080/00273171003680302} Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation variability in practice: Combining sources of uncertainty and choosing the number of allocations. \emph{Multivariate Behavioral Research, 51}(2--3), 296--313. \doi{10.1080/00273171.2016.1144502} Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model selection: Parcel-allocation variability in model ranking. \emph{Psychological Methods, 22}(1), 47--68. \doi{10.1037/met0000067} } \seealso{ \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}} for treating allocations as multiple imputations to pool results across allocations. See \strong{Examples} on help pages for \code{\link[=parcelAllocation]{parcelAllocation()}} (when fitting a single model) and \code{\link[=PAVranking]{PAVranking()}} (when comparing 2 models). } \author{ Jason D. Rights (Vanderbilt University; \email{jason.d.rights@vanderbilt.edu}) The author would also like to credit Corbin Quick and Alexander Schoemann for providing the original \code{\link[=parcelAllocation]{parcelAllocation()}} function (prior to its revision by Terrence D. Jorgensen) on which this function is based. } semTools/man/modindices.mi-deprecated.Rd0000644000176200001440000001701414764333003017747 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI-modification.R \name{modindices.mi-deprecated} \alias{modindices.mi-deprecated} \title{Modification Indices for Multiple Imputations} \usage{ modindices.mi(object, test = c("D2","D1"), omit.imps = c("no.conv","no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) modificationIndices.mi(object, test = c("D2","D1"), omit.imps = c("no.conv","no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) modificationindices.mi(object, test = c("D2","D1"), omit.imps = c("no.conv","no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) } \arguments{ \item{object}{An object of class \linkS4class{OLDlavaan.mi}} \item{test}{\code{character} indicating which pooling method to use. \code{"D1"} requests Mansolf, Jorgensen, & Enders' (2020) proposed Wald-like test for pooling the gradient and information, which are then used to calculate score-test statistics in the usual manner. \code{"D2"} (default because it is less computationall intensive) requests to pool the complete-data score-test statistics from each imputed data set, then pool them across imputations, described by Li et al. (1991) and Enders (2010).} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. Specific imputation numbers can also be included in this argument, in case users want to apply their own custom omission criteria (or simulations can use different numbers of imputations without redundantly refitting the model).} \item{standardized}{\code{logical}. If \code{TRUE}, two extra columns (\verb{$sepc.lv} and \verb{$sepc.all}) will contain standardized values for the EPCs. In the first column (\verb{$sepc.lv}), standardizization is based on the variances of the (continuous) latent variables. In the second column (\verb{$sepc.all}), standardization is based on both the variances of both (continuous) observed and latent variables. (Residual) covariances are standardized using (residual) variances.} \item{cov.std}{\code{logical}. \code{TRUE} if \code{test == "D2"}. If \code{TRUE} (default), the (residual) observed covariances are scaled by the square-root of the diagonal elements of the \eqn{\Theta} matrix, and the (residual) latent covariances are scaled by the square-root of the diagonal elements of the \eqn{\Psi} matrix. If \code{FALSE}, the (residual) observed covariances are scaled by the square-root of the diagonal elements of the model-implied covariance matrix of observed variables (\eqn{\Sigma}), and the (residual) latent covariances are scaled by the square-root of the diagonal elements of the model-implied covariance matrix of the latent variables.} \item{information}{\code{character} indicating the type of information matrix to use (check \code{\link[lavaan:lavInspect]{lavaan::lavInspect()}} for available options). \code{"expected"} information is the default, which provides better control of Type I errors.} \item{power}{\code{logical}. If \code{TRUE}, the (post-hoc) power is computed for each modification index, using the values of \code{delta} and \code{alpha}.} \item{delta}{The value of the effect size, as used in the post-hoc power computation, currently using the unstandardized metric of the \verb{$epc} column.} \item{alpha}{The significance level used for deciding if the modification index is statistically significant or not.} \item{high.power}{If the computed power is higher than this cutoff value, the power is considered 'high'. If not, the power is considered 'low'. This affects the values in the \verb{$decision} column in the output.} \item{sort.}{\code{logical}. If \code{TRUE}, sort the output using the values of the modification index values. Higher values appear first.} \item{minimum.value}{\code{numeric}. Filter output and only show rows with a modification index value equal or higher than this minimum value.} \item{maximum.number}{\code{integer}. Filter output and only show the first maximum number rows. Most useful when combined with the \code{sort.} option.} \item{na.remove}{\code{logical}. If \code{TRUE} (default), filter output by removing all rows with \code{NA} values for the modification indices.} \item{op}{\code{character} string. Filter the output by selecting only those rows with operator \code{op}.} } \value{ A \code{data.frame} containing modification indices and (S)EPCs. } \description{ Modification indices (1-\emph{df} Lagrange multiplier tests) from a latent variable model fitted to multiple imputed data sets. Statistics for releasing one or more fixed or constrained parameters in model can be calculated by pooling the gradient and information matrices across imputed data sets in a method proposed by Mansolf, Jorgensen, & Enders (2020)---analogous to the "D1" Wald test proposed by Li, Meng, Raghunathan, & Rubin (1991)---or by pooling the complete-data score-test statistics across imputed data sets (i.e., "D2"; Li et al., 1991). } \note{ When \code{test = "D2"}, each (S)EPC will be pooled by taking its average across imputations. When \code{test = "D1"}, EPCs will be calculated in the standard way using the pooled gradient and information, and SEPCs will be calculated by standardizing the EPCs using model-implied (residual) variances. } \examples{ ## See the new lavaan.mi package } \references{ Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data.\emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} Mansolf, M., Jorgensen, T. D., & Enders, C. K. (2020). A multiple imputation score test for model modification in structural equation models. \emph{Psychological Methods, 25}(4), 393--411. \doi{10.1037/met0000243} } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Adapted from \pkg{lavaan} source code, written by Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) \code{test = "D1"} method proposed by Maxwell Mansolf (University of California, Los Angeles; \email{mamansolf@gmail.com}) } \keyword{internal} semTools/man/plotProbe.Rd0000644000176200001440000001126614632143416015101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/probeInteraction.R \name{plotProbe} \alias{plotProbe} \title{Plot a latent interaction} \usage{ plotProbe(object, xlim, xlab = "Indepedent Variable", ylab = "Dependent Variable", legend = TRUE, legendArgs = list(), ...) } \arguments{ \item{object}{A \code{list}, typically the result of probing a latent 2-way or 3-way interaction obtained from the \code{\link[=probe2WayMC]{probe2WayMC()}}, \code{\link[=probe2WayRC]{probe2WayRC()}}, \code{\link[=probe3WayMC]{probe3WayMC()}}, or \code{\link[=probe3WayRC]{probe3WayRC()}} functions.} \item{xlim}{The vector of two numbers: the minimum and maximum values of the independent variable} \item{xlab}{The label of the x-axis} \item{ylab}{The label of the y-axis} \item{legend}{\code{logical}. If \code{TRUE} (default), a legend is printed.} \item{legendArgs}{\code{list} of arguments passed to \code{\link[=legend]{legend()}} function if \code{legend=TRUE}.} \item{\dots}{Any additional argument for the \code{\link[=plot]{plot()}} function} } \value{ None. This function will plot the simple main effect only. } \description{ This function will plot the line graphs representing the simple effect of the independent variable given the values of the moderator. For multigroup models, it will only generate a plot for 1 group, as specified in the function used to obtain the first argument. } \note{ If the \code{object} does not contain simple intercepts (i.e., if the \code{object$SimpleIntcept} element is \code{NULL}), then all simple intercepts are arbitrarily set to zero in order to plot the simple slopes. This may not be consistent with the fitted model, but was (up until version 0.5-7) the default behavior when the y-intercept was fixed to 0. In this case, although the relative steepness of simple slopes can still meaningfully be compared, the relative vertical positions of lines at any point along the \emph{x}-axis should not be interpreted. } \examples{ library(lavaan) dat2wayMC <- indProd(dat2way, 1:3, 4:6) model1 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f12 =~ x1.x4 + x2.x5 + x3.x6 f3 =~ x7 + x8 + x9 f3 ~ f1 + f2 + f12 f12 ~~ 0*f1 f12 ~~ 0*f2 x1 ~ 0*1 x4 ~ 0*1 x1.x4 ~ 0*1 x7 ~ 0*1 f1 ~ NA*1 f2 ~ NA*1 f12 ~ NA*1 f3 ~ NA*1 " fitMC2way <- sem(model1, data = dat2wayMC, meanstructure = TRUE) result2wayMC <- probe2WayMC(fitMC2way, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) plotProbe(result2wayMC, xlim = c(-2, 2)) dat3wayMC <- indProd(dat3way, 1:3, 4:6, 7:9) model3 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f3 =~ x7 + x8 + x9 f12 =~ x1.x4 + x2.x5 + x3.x6 f13 =~ x1.x7 + x2.x8 + x3.x9 f23 =~ x4.x7 + x5.x8 + x6.x9 f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 f4 =~ x10 + x11 + x12 f4 ~ f1 + f2 + f3 + f12 + f13 + f23 + f123 f1 ~~ 0*f12 f1 ~~ 0*f13 f1 ~~ 0*f123 f2 ~~ 0*f12 f2 ~~ 0*f23 f2 ~~ 0*f123 f3 ~~ 0*f13 f3 ~~ 0*f23 f3 ~~ 0*f123 f12 ~~ 0*f123 f13 ~~ 0*f123 f23 ~~ 0*f123 x1 ~ 0*1 x4 ~ 0*1 x7 ~ 0*1 x10 ~ 0*1 x1.x4 ~ 0*1 x1.x7 ~ 0*1 x4.x7 ~ 0*1 x1.x4.x7 ~ 0*1 f1 ~ NA*1 f2 ~ NA*1 f3 ~ NA*1 f12 ~ NA*1 f13 ~ NA*1 f23 ~ NA*1 f123 ~ NA*1 f4 ~ NA*1 " fitMC3way <- sem(model3, data = dat3wayMC, std.lv = FALSE, meanstructure = TRUE) result3wayMC <- probe3WayMC(fitMC3way, nameX = c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), nameY = "f4", modVar = c("f1", "f2"), valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) plotProbe(result3wayMC, xlim = c(-2, 2)) } \references{ Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting latent variable interactions using the \code{semTools} package. \emph{Psych, 3}(3), 322--335. \doi{10.3390/psych3030024} } \seealso{ \itemize{ \item \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. \item \code{\link[=probe2WayMC]{probe2WayMC()}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe3WayMC]{probe3WayMC()}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe2WayRC]{probe2WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=probe3WayRC]{probe3WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/rotate-deprecated.Rd0000644000176200001440000000531314764270501016525 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/efa.R \name{rotate-deprecated} \alias{rotate-deprecated} \title{Implement orthogonal or oblique rotation} \usage{ orthRotate(object, method = "varimax", ...) oblqRotate(object, method = "quartimin", ...) funRotate(object, fun, ...) } \arguments{ \item{object}{A lavaan output} \item{method}{The method of rotations, such as \code{"varimax"}, \code{"quartimax"}, \code{"geomin"}, \code{"oblimin"}, or any gradient projection algorithms listed in the \code{\link[GPArotation]{GPA}} function in the \code{GPArotation} package.} \item{fun}{The name of the function that users wish to rotate the standardized solution. The functions must take the first argument as the standardized loading matrix and return the \code{GPArotation} object. Check this page for available functions: \code{\link[GPArotation]{rotations}}.} \item{\dots}{Additional arguments for the \code{\link[GPArotation]{GPForth}} function (for \code{orthRotate}), the \code{\link[GPArotation]{GPFoblq}} function (for \code{oblqRotate}), or the function that users provide in the \code{fun} argument.} } \value{ An \code{linkS4class{EFA}} object that saves the rotated EFA solution } \description{ These functions will implement orthogonal or oblique rotation on standardized factor loadings from a lavaan output. } \details{ These functions will rotate the unrotated standardized factor loadings by orthogonal rotation using the \code{\link[GPArotation]{GPForth}} function or oblique rotation using the \code{\link[GPArotation]{GPFoblq}} function the \code{GPArotation} package. The resulting rotation matrix will be used to calculate standard errors of the rotated standardized factor loading by delta method by numerically computing the Jacobian matrix by the \code{\link[lavaan]{lav_func_jacobian_simple}} function. } \examples{ \donttest{ unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, varList = paste0("x", 1:9), estimator = "mlr") # Orthogonal varimax out.varimax <- orthRotate(unrotated, method = "varimax") summary(out.varimax, sort = FALSE, suppress = 0.3) # Orthogonal Quartimin orthRotate(unrotated, method = "quartimin") # Oblique Quartimin oblqRotate(unrotated, method = "quartimin") # Geomin oblqRotate(unrotated, method = "geomin") # Target rotation library(GPArotation) target <- matrix(0, 9, 3) target[1:3, 1] <- NA target[4:6, 2] <- NA target[7:9, 3] <- NA colnames(target) <- c("factor1", "factor2", "factor3") ## This function works with GPArotation version 2012.3-1 funRotate(unrotated, fun = "targetQ", Target = target) } } \seealso{ \code{\link{semTools-deprecated}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } \keyword{internal} semTools/man/quark.Rd0000644000176200001440000001173114764270501014255 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quark.R \name{quark} \alias{quark} \title{Quark} \usage{ quark(data, id, order = 1, silent = FALSE, ...) } \arguments{ \item{data}{The data frame is a required component for \code{quark}. In order for \code{quark} to process a data frame, it must not contain any factors or text-based variables. All variables must be in numeric format. Identifiers and dates can be left in the data; however, they will need to be identified under the \code{id} argument.} \item{id}{Identifiers and dates within the dataset will need to be acknowledged as \code{quark} cannot process these. By acknowledging the identifiers and dates as a vector of column numbers or variable names, \code{quark} will remove them from the data temporarily to complete its main processes. Among many potential issues of not acknowledging identifiers and dates are issues involved with imputation, product and polynomial effects, and principal component analysis.} \item{order}{Order is an optional argument provided by quark that can be used when the imputation procedures in mice fail. Under some circumstances, mice cannot calculate missing values due to issues with extreme missingness. Should an error present itself stating a failure due to not having any columns selected, set the argument \code{order = 2} in order to reorder the imputation method procedure. Otherwise, use the default \code{order = 1}.} \item{silent}{If \code{FALSE}, the details of the \code{quark} process are printed.} \item{\dots}{additional arguments to pass to \code{\link[mice:mice]{mice::mice()}}.} } \value{ The output value from using the quark function is a list. It will return a list with 7 components. \item{ID Columns}{Is a vector of the identifier columns entered when running quark.} \item{ID Variables}{Is a subset of the dataset that contains the identifiers as acknowledged when running quark.} \item{Used Data}{Is a matrix / dataframe of the data provided by user as the basis for quark to process.} \item{Imputed Data}{Is a matrix / dataframe of the data after the multiple method imputation process.} \item{Big Matrix}{Is the expanded product and polynomial matrix.} \item{Principal Components}{Is the entire dataframe of principal components for the dataset. This dataset will have the same number of rows of the big matrix, but will have 1 less column (as is the case with principal component analyses).} \item{Percent Variance Explained}{Is a vector of the percent variance explained with each column of principal components.} } \description{ The \code{quark} function provides researchers with the ability to calculate and include component scores calculated by taking into account the variance in the original dataset and all of the interaction and polynomial effects of the data in the dataset. } \details{ The \code{quark} function calculates these component scores by first filling in the data via means of multiple imputation methods and then expanding the dataset by aggregating the non-overlapping interaction effects between variables by calculating the mean of the interactions and polynomial effects. The multiple imputation methods include one of iterative sampling and group mean substitution and multiple imputation using a polytomous regression algorithm (mice). During the expansion process, the dataset is expanded to three times its normal size (in width). The first third of the dataset contains all of the original data post imputation, the second third contains the means of the polynomial effects (squares and cubes), and the final third contains the means of the non-overlapping interaction effects. A full principal componenent analysis is conducted and the individual components are retained. The subsequent \code{\link[=combinequark]{combinequark()}} function provides researchers the control in determining how many components to extract and retain. The function returns the dataset as submitted (with missing values) and the component scores as requested for a more accurate multiple imputation in subsequent steps. } \examples{ set.seed(123321) dat <- HolzingerSwineford1939[,7:15] misspat <- matrix(runif(nrow(dat) * 9) < 0.3, nrow(dat)) dat[misspat] <- NA dat <- cbind(HolzingerSwineford1939[,1:3], dat) \donttest{ quark.list <- quark(data = dat, id = c(1, 2)) final.data <- combinequark(quark = quark.list, percent = 80) ## Example to rerun quark after imputation failure: quark.list <- quark(data = dat, id = c(1, 2), order = 2) } } \references{ Howard, W. J., Rhemtulla, M., & Little, T. D. (2015). Using Principal Components as Auxiliary Variables in Missing Data Estimation. \emph{Multivariate Behavioral Research, 50}(3), 285--299. \doi{10.1080/00273171.2014.999267} } \seealso{ \code{\link[=combinequark]{combinequark()}} } \author{ Steven R. Chesnut (University of Southern Mississippi; \email{Steven.Chesnut@usm.edu}) Danny Squire (Texas Tech University) Terrence D. Jorgensen (University of Amsterdam) The PCA code is copied and modified from the \code{FactoMineR} package. } semTools/man/auxiliary.Rd0000644000176200001440000001160714753073632015147 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/auxiliary.R \name{auxiliary} \alias{auxiliary} \alias{lavaan.auxiliary} \alias{cfa.auxiliary} \alias{sem.auxiliary} \alias{growth.auxiliary} \title{Implement Saturated Correlates with FIML} \usage{ auxiliary(model, data, aux, fun, ..., envir = getNamespace("lavaan"), return.syntax = FALSE) lavaan.auxiliary(model, data, aux, ..., envir = getNamespace("lavaan")) cfa.auxiliary(model, data, aux, ..., envir = getNamespace("lavaan")) sem.auxiliary(model, data, aux, ..., envir = getNamespace("lavaan")) growth.auxiliary(model, data, aux, ..., envir = getNamespace("lavaan")) } \arguments{ \item{model}{The analysis model can be specified with 1 of 2 objects: \enumerate{ \item lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} specifying a hypothesized model \emph{without} mention of auxiliary variables in \code{aux} \item a parameter table, as returned by \code{\link[lavaan:parTable]{lavaan::parTable()}}, specifying the target model \emph{without} auxiliary variables. This option requires these columns (and silently ignores all others): \code{c("lhs","op","rhs","user","group","free","label","plabel","start")} }} \item{data}{\code{data.frame} that includes auxiliary variables as well as any observed variables in the \code{model}} \item{aux}{\code{character}. Names of auxiliary variables to add to \code{model}} \item{fun}{\code{character}. Name of a specific lavaan function used to fit \code{model} to \code{data} (i.e., \code{"lavaan"}, \code{"cfa"}, \code{"sem"}, or \code{"growth"}). Only required for \code{auxiliary}.} \item{...}{Additional arguments to pass to \verb{fun=}.} \item{envir}{Passed to \code{\link[=do.call]{do.call()}}.} \item{return.syntax}{\code{logical} indicating whether to return a \code{character} string of \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} that can be added to a target \verb{model=} that is also a \code{character} string. This can be advantageous, for example, to use add saturated correlates to a \pkg{blavaan} model.} } \value{ a fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object. Additional information is stored as a \code{list} in the \verb{@external} slot: \itemize{ \item \code{baseline.model}. a fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object. Results of fitting an appropriate independence model for the calculation of incremental fit indices (e.g., CFI, TLI) in which the auxiliary variables remain saturated, so only the target variables are constrained to be orthogonal. See Examples for how to send this baseline model to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}. \item \code{aux}. The character vector of auxiliary variable names. \item \code{baseline.syntax}. A character vector generated within the \code{auxiliary} function, specifying the \code{baseline.model} syntax. } } \description{ Automatically add auxiliary variables to a lavaan model when using full information maximum likelihood (FIML) to handle missing data } \details{ These functions are wrappers around the corresponding lavaan functions. You can use them the same way you use \code{\link[lavaan:lavaan]{lavaan::lavaan()}}, but you \emph{must} pass your full \code{data.frame} to the \code{data} argument. Because the saturated-correlates approaches (Enders, 2008) treats exogenous variables as random, \code{fixed.x} must be set to \code{FALSE}. Because FIML requires continuous data (although nonnormality corrections can still be requested), no variables in the model nor auxiliary variables specified in \code{aux} can be declared as \code{ordered}. } \examples{ dat1 <- lavaan::HolzingerSwineford1939 set.seed(12345) dat1$z <- rnorm(nrow(dat1)) dat1$x5 <- ifelse(dat1$z < quantile(dat1$z, .3), NA, dat1$x5) dat1$x9 <- ifelse(dat1$z > quantile(dat1$z, .8), NA, dat1$x9) targetModel <- " visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 " ## works just like cfa(), but with an extra "aux" argument fitaux1 <- cfa.auxiliary(targetModel, data = dat1, aux = "z", missing = "fiml", estimator = "mlr") ## with multiple auxiliary variables and multiple groups fitaux2 <- cfa.auxiliary(targetModel, data = dat1, aux = c("z","ageyr","grade"), group = "school", group.equal = "loadings") ## calculate correct incremental fit indices (e.g., CFI, TLI) fitMeasures(fitaux2, fit.measures = c("cfi","tli")) ## NOTE: lavaan will use the internally stored baseline model, which ## is the independence model plus saturated auxiliary parameters lavInspect(fitaux2@external$baseline.model, "free") } \references{ Enders, C. K. (2008). A note on the use of missing auxiliary variables in full information maximum likelihood-based structural equation models. \emph{Structural Equation Modeling, 15}(3), 434--448. \doi{10.1080/10705510802154307} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/discriminantValidity.Rd0000644000176200001440000001122514753073632017326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/discriminantValidity.R \name{discriminantValidity} \alias{discriminantValidity} \title{Calculate discriminant validity statistics} \usage{ discriminantValidity(object, cutoff = 0.9, merge = FALSE, level = 0.95, boot.ci.type = "perc") } \arguments{ \item{object}{The \link[lavaan:lavaan-class]{lavaan::lavaan} model object returned by the \code{\link[lavaan:cfa]{lavaan::cfa()}} function.} \item{cutoff}{A cutoff to be used in the constrained models in likelihood ratio tests.} \item{merge}{Whether the constrained models should be constructed by merging two factors as one. Implies \code{cutoff} = 1.} \item{level}{The confidence level required.} \item{boot.ci.type}{If bootstrapping was used, the type of interval required. The value should be one of \code{"norm"}, \code{"basic"}, \code{"perc"}, or \code{"bca.simple"}. For the first three options, see the help page of the \code{boot.ci} function in the boot package. The \code{"bca.simple"} option produces intervals using the adjusted bootstrap percentile (BCa) method, but with no correction for acceleration (only for bias). Note that the p-value is still computed assuming that the z-statistic follows a standard normal distribution.} } \value{ A \code{data.frame} of latent variable correlation estimates, their confidence intervals, and a likelihood ratio tests against constrained models. with the following attributes: \describe{ \item{baseline}{The baseline model after possible rescaling.} \item{constrained}{A \code{list} of the fitted constrained models used in the likelihood ratio test.} } } \description{ Calculate discriminant validity statistics based on a fitted lavaan object } \details{ Evaluated on the measurement scale level, discriminant validity is commonly evaluated by checking if each pair of latent correlations is sufficiently below one (in absolute value) that the latent variables can be thought of representing two distinct constructs. \code{discriminantValidity} function calculates two sets of statistics that are commonly used in discriminant validity evaluation. The first set are factor correlation estimates and their confidence intervals. The second set is a series of nested model tests, where the baseline model is compared against a set of constrained models that are constructed by constraining each factor correlation to the specified cutoff one at a time. The function assume that the \code{object} is set of confirmatory factor analysis results where the latent variables are scaled by fixing their variances to 1s. If the model is not a CFA model, the function will calculate the statistics for the correlations among exogenous latent variables, but for the \emph{residual} variances with endogenous variables. If the latent variables are scaled in some other way (e.g. fixing the first loadings), the function issues a warning and re-estimates the model by fixing latent variances to 1 (and estimating all loadings) so that factor covariances are already estimated as correlations. The likelihood ratio tests are done by comparing the original baseline model against more constrained alternatives. By default, these alternatives are constructed by fixing each correlation at a time to a cutoff value. The typical purpose of this test is to demonstrate that the estimated factor correlation is well below the cutoff and a significant \eqn{chi^2} statistic thus indicates support for discriminant validity. In some cases, the original correlation estimate may already be greater than the cutoff, making it redundant to fit a "restricted" model. When this happens, the likelihood ratio test will be replaced by comparing the baseline model against itself. For correlations that are estimated to be negative, a negation of the cutoff is used in the constrained model. Another alternative is to do a nested model comparison against a model where two factors are merged as one by setting the \code{merge} argument to \code{TRUE}. In this comparison, the constrained model is constructed by removing one of the correlated factors from the model and assigning its indicators to the factor that remains in the model. } \examples{ library(lavaan) HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit <- cfa(HS.model, data = HolzingerSwineford1939) discriminantValidity(fit) discriminantValidity(fit, merge = TRUE) } \references{ Rönkkö, M., & Cho, E. (2022). An updated guideline for assessing discriminant validity. \emph{Organizational Research Methods}, 25(1), 6–14. \doi{10.1177/1094428120968614} } \author{ Mikko Rönkkö (University of Jyväskylä; \email{mikko.ronkko@jyu.fi}): } semTools/man/bsBootMiss.Rd0000644000176200001440000001422714764317714015231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/missingBootstrap.R \name{bsBootMiss} \alias{bsBootMiss} \title{Bollen-Stine Bootstrap with the Existence of Missing Data} \usage{ bsBootMiss(x, transformation = 2, nBoot = 500, model, rawData, Sigma, Mu, group, ChiSquared, EMcov, writeTransData = FALSE, transDataOnly = FALSE, writeBootData = FALSE, bootSamplesOnly = FALSE, writeArgs, seed = NULL, suppressWarn = TRUE, showProgress = TRUE, ...) } \arguments{ \item{x}{A target \code{lavaan} object used in the Bollen-Stine bootstrap} \item{transformation}{The transformation methods in Savalei and Yuan (2009). There are three methods in the article, but only the first two are currently implemented here. Use \code{transformation = 1} when there are few missing data patterns, each of which has a large size, such as in a planned-missing-data design. Use \code{transformation = 2} when there are more missing data patterns. The currently unavailable \code{transformation = 3} would be used when several missing data patterns have n = 1.} \item{nBoot}{The number of bootstrap samples.} \item{model}{Optional. The target model if \code{x} is not provided.} \item{rawData}{Optional. The target raw data set if \code{x} is not provided.} \item{Sigma}{Optional. The model-implied covariance matrix if \code{x} is not provided.} \item{Mu}{Optional. The model-implied mean vector if \code{x} is not provided.} \item{group}{Optional character string specifying the name of the grouping variable in \code{rawData} if \code{x} is not provided.} \item{ChiSquared}{Optional. The model's \eqn{\chi^2} test statistic if \code{x} is not provided.} \item{EMcov}{Optional, if \code{x} is not provided. The EM (or Two-Stage ML) estimated covariance matrix used to speed up Transformation 2 algorithm.} \item{writeTransData}{Logical. If \code{TRUE}, the transformed data set is written to a text file, \code{transDataOnly} is set to \code{TRUE}, and the transformed data is returned invisibly.} \item{transDataOnly}{Logical. If \code{TRUE}, the result will provide the transformed data only.} \item{writeBootData}{Logical. If \code{TRUE}, the stacked bootstrap data sets are written to a text file, \code{bootSamplesOnly} is set to \code{TRUE}, and the list of bootstrap data sets are returned invisibly.} \item{bootSamplesOnly}{Logical. If \code{TRUE}, the result will provide bootstrap data sets only.} \item{writeArgs}{Optional \code{list}. If \code{writeBootData = TRUE} or \code{writeBootData = TRUE}, user can pass arguments to the \code{\link[utils:write.table]{utils::write.table()}} function as a list. Some default values are provided: \code{file} = "bootstrappedSamples.dat", \code{row.names} = \code{FALSE}, and \code{na} = "-999", but the user can override all of these by providing other values for those arguments in the \code{writeArgs} list.} \item{seed}{The seed number used in randomly drawing bootstrap samples.} \item{suppressWarn}{Logical. If \code{TRUE}, warnings from \code{lavaan} function will be suppressed when fitting the model to each bootstrap sample.} \item{showProgress}{Logical. Indicating whether to display a progress bar while fitting models to bootstrap samples.} \item{\dots}{The additional arguments in the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}} } \value{ As a default, this function returns a \linkS4class{BootMiss} object containing the results of the bootstrap samples. Use \code{show}, \code{summary}, or \code{hist} to examine the results. Optionally, the transformed data set is returned if \code{transDataOnly = TRUE}. Optionally, the bootstrap data sets are returned if \code{bootSamplesOnly = TRUE}. } \description{ Implement the Bollen and Stine's (1992) Bootstrap when missing observations exist. The implemented method is proposed by Savalei and Yuan (2009). This can be used in two ways. The first and easiest option is to fit the model to incomplete data in \code{lavaan} using the FIML estimator, then pass that \code{lavaan} object to \code{bsBootMiss}. } \details{ The second is designed for users of other software packages (e.g., LISREL, EQS, Amos, or Mplus). Users can import their data, \eqn{\chi^2} value, and model-implied moments from another package, and they have the option of saving (or writing to a file) either the transformed data or bootstrapped samples of that data, which can be analyzed in other programs. In order to analyze the bootstrapped samples and return a \emph{p} value, users of other programs must still specify their model using lavaan syntax. } \examples{ dat1 <- HolzingerSwineford1939 dat1$x5 <- ifelse(dat1$x1 <= quantile(dat1$x1, .3), NA, dat1$x5) dat1$x9 <- ifelse(is.na(dat1$x5), NA, dat1$x9) targetModel <- " visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 " targetFit <- sem(targetModel, dat1, meanstructure = TRUE, std.lv = TRUE, missing = "fiml", group = "school") summary(targetFit, fit = TRUE, standardized = TRUE) \donttest{ ## The number of bootstrap samples should be much higher than this example temp <- bsBootMiss(targetFit, transformation = 1, nBoot = 10, seed = 31415) temp summary(temp) hist(temp) hist(temp, printLegend = FALSE) # suppress the legend ## user can specify alpha level (default: alpha = 0.05), and the number of ## digits to display (default: nd = 2). Pass other arguments to hist(...), ## or a list of arguments to legend() via "legendArgs" hist(temp, alpha = .01, nd = 3, xlab = "something else", breaks = 25, legendArgs = list("bottomleft", box.lty = 2)) } } \references{ Bollen, K. A., & Stine, R. A. (1992). Bootstrapping goodness-of-fit measures in structural equation models. \emph{Sociological Methods & Research, 21}(2), 205--229. \doi{10.1177/0049124192021002004} Savalei, V., & Yuan, K.-H. (2009). On the model-based bootstrap with missing data: Obtaining a p-value for a test of exact fit. \emph{Multivariate Behavioral Research, 44}(6), 741--763. \doi{10.1080/00273170903333590} } \seealso{ \linkS4class{BootMiss} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Syntax for transformations borrowed from http://www2.psych.ubc.ca/~vsavalei/ } semTools/man/FitDiff-class.Rd0000644000176200001440000000561614764270501015555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/compareFit.R \docType{class} \name{FitDiff-class} \alias{FitDiff-class} \alias{show,FitDiff-method} \alias{summary,FitDiff-method} \title{Class For Representing A Template of Model Fit Comparisons} \usage{ \S4method{show}{FitDiff}(object) \S4method{summary}{FitDiff}(object, fit.measures = "default", nd = 3, tag = "†") } \arguments{ \item{object}{object of class \code{FitDiff}} \item{fit.measures}{\code{character} vector naming fit indices the user can request from \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}. If \code{"default"}, the fit measures will be \code{c("chisq", "df", "pvalue", "cfi", "tli", "rmsea", "srmr", "aic", "bic")}. If \code{"all"}, all available fit measures will be returned.} \item{nd}{number of digits printed} \item{tag}{single \code{character} used to flag the model preferred by each fit index. To omit tags, set to \code{NULL} or \code{NA}.} } \description{ This class contains model fit measures and model fit comparisons among multiple models } \section{Slots}{ \describe{ \item{\code{name}}{\code{character}. The name of each model} \item{\code{model.class}}{\code{character}. One class to which each model belongs} \item{\code{nested}}{\code{data.frame}. Model fit comparisons between adjacently nested models that are ordered by their degrees of freedom (\emph{df})} \item{\code{fit}}{\code{data.frame}. Fit measures of all models specified in the \code{name} slot, ordered by their \emph{df}} \item{\code{fit.diff}}{\code{data.frame}. Sequential differences in fit measures in the \code{fit} slot} }} \section{Objects from the Class}{ Objects can be created via the \code{\link[=compareFit]{compareFit()}} function. } \examples{ HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit.config <- cfa(HS.model, data = HolzingerSwineford1939, group = "school") ## invariance constraints fit.metric <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = "loadings") fit.scalar <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = c("loadings","intercepts")) fit.strict <- cfa(HS.model, data = HolzingerSwineford1939, group = "school", group.equal = c("loadings","intercepts","residuals")) measEqOut <- compareFit(fit.config, fit.metric, fit.scalar, fit.strict) summary(measEqOut) summary(measEqOut, fit.measures = "all") summary(measEqOut, fit.measures = c("aic", "bic")) if(interactive()){ ## Save results to a file saveFile(measEqOut, file = "measEq.txt") ## Copy to a clipboard clipboard(measEqOut) } } \seealso{ \code{\link[=compareFit]{compareFit()}}; \code{\link[=clipboard]{clipboard()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/findRMSEAsamplesizenested.Rd0000644000176200001440000000370014632143415020134 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisNested.R \name{findRMSEAsamplesizenested} \alias{findRMSEAsamplesizenested} \title{Find sample size given a power in nested model comparison} \usage{ findRMSEAsamplesizenested(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, power = 0.8, alpha = 0.05, group = 1) } \arguments{ \item{rmsea0A}{The \eqn{H_0} baseline RMSEA} \item{rmsea0B}{The \eqn{H_0} alternative RMSEA (trivial misfit)} \item{rmsea1A}{The \eqn{H_1} baseline RMSEA} \item{rmsea1B}{The \eqn{H_1} alternative RMSEA (target misfit to be rejected)} \item{dfA}{degree of freedom of the more-restricted model.} \item{dfB}{degree of freedom of the less-restricted model.} \item{power}{The desired statistical power.} \item{alpha}{The alpha level.} \item{group}{The number of group in calculating RMSEA.} } \description{ Find the sample size that the power in rejection the samples from the alternative pair of RMSEA is just over the specified power. } \examples{ findRMSEAsamplesizenested(rmsea0A = 0, rmsea0B = 0, rmsea1A = 0.06, rmsea1B = 0.05, dfA = 22, dfB = 20, power = 0.80, alpha = .05, group = 1) } \references{ MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing differences between nested covariance structure models: Power analysis and null hypotheses. \emph{Psychological Methods, 11}(1), 19--35. \doi{10.1037/1082-989X.11.1.19} } \seealso{ \itemize{ \item \code{\link[=plotRMSEApowernested]{plotRMSEApowernested()}} to plot the statistical power for nested model comparison based on population RMSEA given the sample size \item \code{\link[=findRMSEApowernested]{findRMSEApowernested()}} to find the power for a given sample size in nested model comparison based on population RMSEA } } \author{ Bell Clinton Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/probe3WayRC.Rd0000644000176200001440000002037414753073632015241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/probeInteraction.R \name{probe3WayRC} \alias{probe3WayRC} \title{Probing three-way interaction on the residual-centered latent interaction} \usage{ probe3WayRC(fit, nameX, nameY, modVar, valProbe1, valProbe2, group = 1L, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{fit}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object with a latent 2-way interaction.} \item{nameX}{\code{character} vector of all 7 factor names used as the predictors. The 3 lower-order factors must be listed first, followed by the 3 second-order factors (specifically, the 4th element must be the interaction between the factors listed first and second, the 5th element must be the interaction between the factors listed first and third, and the 6th element must be the interaction between the factors listed second and third). The final name will be the factor representing the 3-way interaction.} \item{nameY}{The name of factor that is used as the dependent variable.} \item{modVar}{The name of two factors that are used as the moderators. The effect of the independent factor on each combination of the moderator variable values will be probed.} \item{valProbe1}{The values of the first moderator that will be used to probe the effect of the independent factor.} \item{valProbe2}{The values of the second moderator that will be used to probe the effect of the independent factor.} \item{group}{In multigroup models, the label of the group for which the results will be returned. Must correspond to one of \code{lavInspect(fit, "group.label")}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Ignored unless \code{fit} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ A list with two elements: \enumerate{ \item \code{SimpleIntercept}: The model-implied intercepts given each combination of moderator values. \item \code{SimpleSlope}: The model-implied slopes given each combination of moderator values. } In each element, the first column represents values of the first moderator specified in the \code{valProbe1} argument. The second column represents values of the second moderator specified in the \code{valProbe2} argument. The third column is the simple intercept or simple slope. The fourth column is the \emph{SE} of the simple intercept or simple slope. The fifth column is the Wald (\emph{z}) statistic, and the sixth column is its associated \emph{p} value to test the null hypothesis that each simple intercept or simple slope equals 0. } \description{ Probing interaction for simple intercept and simple slope for the residual-centered latent three-way interaction (Geldhof et al., 2013) } \details{ Before using this function, researchers need to make the products of the indicators between the first-order factors and residualize the products by the original indicators (Lance, 1988; Little, Bovaird, & Widaman, 2006). The process can be automated by the \code{\link[=indProd]{indProd()}} function. Note that the indicator products can be made for all possible combination or matched-pair approach (Marsh et al., 2004). Next, the hypothesized model with the regression with latent interaction will be used to fit all original indicators and the product terms (Geldhof et al., 2013). To use this function the model must be fit with a mean structure. See the example for how to fit the product term below. Once the lavaan result is obtained, this function will be used to probe the interaction. The probing process on residual-centered latent interaction is based on transforming the residual-centered result into the no-centered result. See Geldhof et al. (2013) for further details. Note that this approach based on a strong assumption that the first-order latent variables are normally distributed. The probing process is applied after the no-centered result (parameter estimates and their covariance matrix among parameter estimates) has been computed. See the \code{\link[=probe3WayMC]{probe3WayMC()}} for further details. } \examples{ dat3wayRC <- orthogonalize(dat3way, 1:3, 4:6, 7:9) model3 <- " ## define latent variables f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f3 =~ x7 + x8 + x9 ## 2-way interactions f12 =~ x1.x4 + x2.x5 + x3.x6 f13 =~ x1.x7 + x2.x8 + x3.x9 f23 =~ x4.x7 + x5.x8 + x6.x9 ## 3-way interaction f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 ## outcome variable f4 =~ x10 + x11 + x12 ## latent regression model f4 ~ b1*f1 + b2*f2 + b3*f3 + b12*f12 + b13*f13 + b23*f23 + b123*f123 ## orthogonal terms among predictors f1 ~~ 0*f12 + 0*f13 + 0*f123 f2 ~~ 0*f12 + 0*f23 + 0*f123 f3 ~~ 0*f13 + 0*f23 + 0*f123 f12 + f13 + f23 ~~ 0*f123 ## identify latent means x1 + x4 + x7 + x1.x4 + x1.x7 + x4.x7 + x1.x4.x7 + x10 ~ 0*1 f1 + f2 + f3 + f12 + f13 + f23 + f123 + f4 ~ NA*1 " fitRC3way <- sem(model3, data = dat3wayRC, meanstructure = TRUE) summary(fitRC3way) probe3WayMC(fitRC3way, nameX = c("f1" ,"f2" ,"f3", "f12","f13","f23", # this order matters! "f123"), # 3-way interaction nameY = "f4", modVar = c("f1", "f2"), valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) } \references{ Tutorial: Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting latent variable interactions using the \code{semTools} package. \emph{Psych, 3}(3), 322--335. \doi{10.3390/psych3030024} Background literature: Geldhof, G. J., Pornprasertmanit, S., Schoemann, A., & Little, T. D. (2013). Orthogonalizing through residual centering: Extended applications and caveats. \emph{Educational and Psychological Measurement, 73}(1), 27--46. \doi{10.1177/0013164412445473} Lance, C. E. (1988). Residual centering, exploratory and confirmatory moderator analysis, and decomposition of effects in path models containing interactions. \emph{Applied Psychological Measurement, 12}(2), 163--175. \doi{10.1177/014662168801200205} Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of orthogonalizing powered and product terms: Implications for modeling interactions. \emph{Structural Equation Modeling, 13}(4), 497--519. \doi{10.1207/s15328007sem1304_1} Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of latent interactions: Evaluation of alternative estimation strategies and indicator construction. \emph{Psychological Methods, 9}(3), 275--300. \doi{10.1037/1082-989X.9.3.275} Pornprasertmanit, S., Schoemann, A. M., Geldhof, G. J., & Little, T. D. (submitted). \emph{Probing latent interaction estimated with a residual centering approach.} } \seealso{ \itemize{ \item \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. \item \code{\link[=probe2WayMC]{probe2WayMC()}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe3WayMC]{probe3WayMC()}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe2WayRC]{probe2WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=plotProbe]{plotProbe()}} Plot the simple intercepts and slopes of the latent interaction. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/plotRMSEAdist.Rd0000644000176200001440000000615314632143415015563 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisRMSEA.R \name{plotRMSEAdist} \alias{plotRMSEAdist} \title{Plot the sampling distributions of RMSEA} \usage{ plotRMSEAdist(rmsea, n, df, ptile = NULL, caption = NULL, rmseaScale = TRUE, group = 1) } \arguments{ \item{rmsea}{The vector of RMSEA values to be plotted} \item{n}{Sample size of a dataset} \item{df}{Model degrees of freedom} \item{ptile}{The percentile rank of the distribution of the first RMSEA that users wish to plot a vertical line in the resulting graph} \item{caption}{The name vector of each element of \code{rmsea}} \item{rmseaScale}{If \code{TRUE}, the RMSEA scale is used in the x-axis. If \code{FALSE}, the chi-square scale is used in the x-axis.} \item{group}{The number of group that is used to calculate RMSEA.} } \description{ Plots the sampling distributions of RMSEA based on the noncentral chi-square distributions } \details{ This function creates overlappling plots of the sampling distribution of RMSEA based on noncentral \eqn{\chi^2} distribution (MacCallum, Browne, & Suguwara, 1996). First, the noncentrality parameter (\eqn{\lambda}) is calculated from RMSEA (Steiger, 1998; Dudgeon, 2004) by \deqn{\lambda = (N - 1)d\varepsilon^2 / K,} where \eqn{N} is sample size, \eqn{d} is the model degree of freedom, \eqn{K} is the number of group, and \eqn{\varepsilon} is the population RMSEA. Next, the noncentral \eqn{\chi^2} distribution with a specified \emph{df} and noncentrality parameter is plotted. Thus, the x-axis represents the sample \eqn{\chi^2} value. The sample \eqn{\chi^2} value can be transformed to the sample RMSEA scale (\eqn{\hat{\varepsilon}}) by \deqn{\hat{\varepsilon} = \sqrt{K}\sqrt{\frac{\chi^2 - d}{(N - 1)d}},} where \eqn{\chi^2} is the \eqn{\chi^2} value obtained from the noncentral \eqn{\chi^2} distribution. } \examples{ plotRMSEAdist(c(.05, .08), n = 200, df = 20, ptile = .95, rmseaScale = TRUE) plotRMSEAdist(c(.05, .01), n = 200, df = 20, ptile = .05, rmseaScale = FALSE) } \references{ Dudgeon, P. (2004). A note on extending Steiger's (1998) multiple sample RMSEA adjustment to other noncentrality parameter-based statistic. \emph{Structural Equation Modeling, 11}(3), 305--319. \doi{10.1207/s15328007sem1103_1} MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis and determination of sample size for covariance structure modeling. \emph{Psychological Methods, 1}(2), 130--149. \doi{10.1037/1082-989X.1.2.130} Steiger, J. H. (1998). A note on multiple sample extensions of the RMSEA fit index. \emph{Structural Equation Modeling, 5}(4), 411--419. \doi{10.1080/10705519809540115} } \seealso{ \itemize{ \item \code{\link[=plotRMSEApower]{plotRMSEApower()}} to plot the statistical power based on population RMSEA given the sample size \item \code{\link[=findRMSEApower]{findRMSEApower()}} to find the statistical power based on population RMSEA given a sample size \item \code{\link[=findRMSEAsamplesize]{findRMSEAsamplesize()}} to find the minium sample size for a given statistical power based on population RMSEA } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/kd.Rd0000644000176200001440000000463514006342740013527 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/kd.R \name{kd} \alias{kd} \title{Generate data via the Kaiser-Dickman (1962) algorithm.} \usage{ kd(covmat, n, type = c("exact", "sample")) } \arguments{ \item{covmat}{a symmetric, positive definite covariance matrix} \item{n}{the sample size for the data that will be generated} \item{type}{type of data generation. \code{exact} generates data that exactly correspond to \code{covmat}. \code{sample} treats \code{covmat} as a poulation covariance matrix, generating a sample of size \code{n}.} } \value{ \code{kd} returns a data matrix of dimension \code{n} by \code{nrow(covmat)}. } \description{ Given a covariance matrix and sample size, generate raw data that correspond to the covariance matrix. Data can be generated to match the covariance matrix exactly, or to be a sample from the population covariance matrix. } \details{ By default, R's \code{cov()} function divides by \code{n}-1. The data generated by this algorithm result in a covariance matrix that matches \code{covmat}, but you must divide by \code{n} instead of \code{n}-1. } \examples{ #### First Example ## Get data dat <- HolzingerSwineford1939[ , 7:15] hs.n <- nrow(dat) ## Covariance matrix divided by n hscov <- ((hs.n-1)/hs.n) * cov(dat) ## Generate new, raw data corresponding to hscov newdat <- kd(hscov, hs.n) ## Difference between new covariance matrix and hscov is minimal newcov <- (hs.n-1)/hs.n * cov(newdat) summary(as.numeric(hscov - newcov)) ## Generate sample data, treating hscov as population matrix newdat2 <- kd(hscov, hs.n, type = "sample") #### Another example ## Define a covariance matrix covmat <- matrix(0, 3, 3) diag(covmat) <- 1.5 covmat[2:3,1] <- c(1.3, 1.7) covmat[3,2] <- 2.1 covmat <- covmat + t(covmat) ## Generate data of size 300 that have this covariance matrix rawdat <- kd(covmat, 300) ## Covariances are exact if we compute sample covariance matrix by ## dividing by n (vs by n - 1) summary(as.numeric((299/300)*cov(rawdat) - covmat)) ## Generate data of size 300 where covmat is the population covariance matrix rawdat2 <- kd(covmat, 300) } \references{ Kaiser, H. F. and Dickman, K. (1962). Sample and population score matrices and sample correlation matrices from an arbitrary population correlation matrix. \emph{Psychometrika, 27}(2), 179--182. \doi{10.1007/BF02289635} } \author{ Ed Merkle (University of Missouri; \email{merklee@missouri.edu}) } semTools/man/permuteMeasEq.Rd0000644000176200001440000006412614764270501015715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/permuteMeasEq.R \name{permuteMeasEq} \alias{permuteMeasEq} \title{Permutation Randomization Tests of Measurement Equivalence and Differential Item Functioning (DIF)} \usage{ permuteMeasEq(nPermute, modelType = c("mgcfa", "mimic"), con, uncon = NULL, null = NULL, param = NULL, freeParam = NULL, covariates = NULL, AFIs = NULL, moreAFIs = NULL, maxSparse = 10, maxNonconv = 10, showProgress = TRUE, warn = -1, datafun, extra, parallelType = c("none", "multicore", "snow"), ncpus = NULL, cl = NULL, iseed = 12345) } \arguments{ \item{nPermute}{An integer indicating the number of random permutations used to form empirical distributions under the null hypothesis.} \item{modelType}{A character string indicating type of model employed: multiple-group CFA (\code{"mgcfa"}) or MIMIC (\code{"mimic"}).} \item{con}{The constrained \code{lavaan} object, in which the parameters specified in \code{param} are constrained to equality across all groups when \code{modelType = "mgcfa"}, or which regression paths are fixed to zero when \code{modelType = "mimic"}. In the case of testing \emph{configural} invariance when \code{modelType = "mgcfa"}, \code{con} is the configural model (implicitly, the unconstrained model is the saturated model, so use the defaults \code{uncon = NULL} and \code{param = NULL}). When \code{modelType = "mimic"}, \code{con} is the MIMIC model in which the covariate predicts the latent construct(s) but no indicators (unless they have already been identified as DIF items).} \item{uncon}{Optional. The unconstrained \code{lavaan} object, in which the parameters specified in \code{param} are freely estimated in all groups. When \code{modelType = "mgcfa"}, only in the case of testing \emph{configural} invariance should \code{uncon = NULL}. When \code{modelType = "mimic"}, any non-\verb{NULL uncon} is silently set to \code{NULL}.} \item{null}{Optional. A \code{lavaan} object, in which an alternative null model is fit (besides the default independence model specified by \code{lavaan}) for the calculation of incremental fit indices. See Widamin & Thompson (2003) for details. If \code{NULL}, \code{lavaan}'s default independence model is used.} \item{param}{An optional character vector or list of character vectors indicating which parameters the user would test for DIF following a rejection of the omnibus null hypothesis tested using (\code{more})\code{AFIs}. Note that \code{param} does not guarantee certain parameters \emph{are} constrained in \code{con}; that is for the user to specify when fitting the model. If users have any "anchor items" that they would never intend to free across groups (or levels of a covariate), these should be excluded from \code{param}; exceptions to a type of parameter can be specified in \code{freeParam}. When \code{modelType = "mgcfa"}, \code{param} indicates which parameters of interest are constrained across groups in \code{con} and are unconstrained in \code{uncon}. Parameter names must match those returned by \code{names(coef(con))}, but omitting any group-specific suffixes (e.g., \code{"f1~1"} rather than \code{"f1~1.g2"}) or user-specified labels (that is, the parameter names must follow the rules of lavaan's \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}}). Alternatively (or additionally), to test all constraints of a certain type (or multiple types) of parameter in \code{con}, \code{param} may take any combination of the following values: \code{"loadings"}, \code{"intercepts"}, \code{"thresholds"}, \code{"residuals"}, \code{"residual.covariances"}, \code{"means"}, \code{"lv.variances"}, and/or \code{"lv.covariances"}. When \code{modelType = "mimic"}, \code{param} must be a vector of individual parameters or a list of character strings to be passed one-at-a-time to \code{lavaan::lavTestScore(object = con, add = param[i])}, indicating which (sets of) regression paths fixed to zero in \code{con} that the user would consider freeing (i.e., exclude anchor items). If \code{modelType = "mimic"} and \code{param} is a list of character strings, the multivariate test statistic will be saved for each list element instead of 1-\emph{df} modification indices for each individual parameter, and \code{names(param)} will name the rows of the \code{MI.obs} slot (see \linkS4class{permuteMeasEq}). Set \code{param = NULL} (default) to avoid collecting modification indices for any follow-up tests.} \item{freeParam}{An optional character vector, silently ignored when \code{modelType = "mimic"}. If \code{param} includes a type of parameter (e.g., \code{"loadings"}), \code{freeParam} indicates exceptions (i.e., anchor items) that the user would \emph{not} intend to free across groups and should therefore be ignored when calculating \emph{p} values adjusted for the number of follow-up tests. Parameter types that are already unconstrained across groups in the fitted \code{con} model (i.e., a \emph{partial} invariance model) will automatically be ignored, so they do not need to be specified in \code{freeParam}. Parameter names must match those returned by \code{names(coef(con))}, but omitting any group-specific suffixes (e.g., \code{"f1~1"} rather than \code{"f1~1.g2"}) or user-specified labels (that is, the parameter names must follow the rules of lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}}).} \item{covariates}{An optional character vector, only applicable when \code{modelType = "mimic"}. The observed data are partitioned into columns indicated by \code{covariates}, and the rows are permuted simultaneously for the entire set before being merged with the remaining data. Thus, the covariance structure is preserved among the covariates, which is necessary when (e.g.) multiple dummy codes are used to represent a discrete covariate or when covariates interact. If \code{covariates = NULL} when \code{modelType = "mimic"}, the value of \code{covariates} is inferred by searching \code{param} for predictors (i.e., variables appearing after the "\code{~}" operator).} \item{AFIs}{A character vector indicating which alternative fit indices (or chi-squared itself) are to be used to test the multiparameter omnibus null hypothesis that the constraints specified in \code{con} hold in the population. Any fit measures returned by \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} may be specified (including constants like \code{"df"}, which would be nonsensical). If both \code{AFIs} and \code{moreAFIs} are \code{NULL}, only \code{"chisq"} will be returned.} \item{moreAFIs}{Optional. A character vector indicating which (if any) alternative fit indices returned by \code{\link[=moreFitIndices]{moreFitIndices()}} are to be used to test the multiparameter omnibus null hypothesis that the constraints specified in \code{con} hold in the population.} \item{maxSparse}{Only applicable when \code{modelType = "mgcfa"} and at least one indicator is \code{ordered}. An integer indicating the maximum number of consecutive times that randomly permuted group assignment can yield a sample in which at least one category (of an \code{ordered} indicator) is unobserved in at least one group, such that the same set of parameters cannot be estimated in each group. If such a sample occurs, group assignment is randomly permuted again, repeatedly until a sample is obtained with all categories observed in all groups. If \code{maxSparse} is exceeded, \code{NA} will be returned for that iteration of the permutation distribution.} \item{maxNonconv}{An integer indicating the maximum number of consecutive times that a random permutation can yield a sample for which the model does not converge on a solution. If such a sample occurs, permutation is attempted repeatedly until a sample is obtained for which the model does converge. If \code{maxNonconv} is exceeded, \code{NA} will be returned for that iteration of the permutation distribution, and a warning will be printed when using \code{show} or \code{summary}.} \item{showProgress}{Logical. Indicating whether to display a progress bar while permuting. Silently set to \code{FALSE} when using parallel options.} \item{warn}{Sets the handling of warning messages when fitting model(s) to permuted data sets. See \code{\link[base:options]{base::options()}}.} \item{datafun}{An optional function that can be applied to the data (extracted from \code{con}) after each permutation, but before fitting the model(s) to each permutation. The \code{datafun} function must have an argument named \code{data} that accepts a \code{data.frame}, and it must return a \code{data.frame} containing the same column names. The column order may differ, the values of those columns may differ (so be careful!), and any additional columns will be ignored when fitting the model, but an error will result if any column names required by the model syntax do not appear in the transformed data set. Although available for any \code{modelType}, \code{datafun} may be useful when using the MIMIC method to test for nonuniform DIF (metric/weak invariance) by using product indicators for a latent factor representing the interaction between a factor and one of the \code{covariates}, in which case the product indicators would need to be recalculated after each permutation of the \code{covariates}. To access other R objects used within \code{permuteMeasEq}, the arguments to \code{datafun} may also contain any subset of the following: \code{"con"}, \code{"uncon"}, \code{"null"}, \code{"param"}, \code{"freeParam"}, \code{"covariates"}, \code{"AFIs"}, \code{"moreAFIs"}, \code{"maxSparse"}, \code{"maxNonconv"}, and/or \code{"iseed"}. The values for those arguments will be the same as the values supplied to \code{permuteMeasEq}.} \item{extra}{An optional function that can be applied to any (or all) of the fitted lavaan objects (\code{con}, \code{uncon}, and/or \code{null}). This function will also be applied after fitting the model(s) to each permuted data set. To access the R objects used within \code{permuteMeasEq}, the arguments to \code{extra} must be any subset of the following: \code{"con"}, \code{"uncon"}, \code{"null"}, \code{"param"}, \code{"freeParam"}, \code{"covariates"}, \code{"AFIs"}, \code{"moreAFIs"}, \code{"maxSparse"}, \code{"maxNonconv"}, and/or \code{"iseed"}. The values for those arguments will be the same as the values supplied to \code{permuteMeasEq}. The \code{extra} function must return a named \code{numeric} vector or a named \code{list} of scalars (i.e., a \code{list} of \code{numeric} vectors of \code{length == 1}). Any unnamed elements (e.g., \code{""} or \code{NULL}) of the returned object will result in an error.} \item{parallelType}{The type of parallel operation to be used (if any). The default is \code{"none"}. Forking is not possible on Windows, so if \code{"multicore"} is requested on a Windows machine, the request will be changed to \code{"snow"} with a message.} \item{ncpus}{Integer: number of processes to be used in parallel operation. If \code{NULL} (the default) and \code{parallelType \%in\% c("multicore","snow")}, the default is one less than the maximum number of processors detected by \code{\link[parallel:detectCores]{parallel::detectCores()}}. This default is also silently set if the user specifies more than the number of processors detected.} \item{cl}{An optional \pkg{parallel} or \pkg{snow} cluster for use when \code{parallelType = "snow"}. If \code{NULL}, a \code{"PSOCK"} cluster on the local machine is created for the duration of the \code{permuteMeasEq} call. If a valid \code{\link[parallel:makeCluster]{parallel::makeCluster()}} object is supplied, \code{parallelType} is silently set to \code{"snow"}, and \code{ncpus} is silently set to \code{length(cl)}.} \item{iseed}{Integer: Only used to set the states of the RNG when using parallel options, in which case \code{\link[base:Random]{base::RNGkind()}} is set to \code{"L'Ecuyer-CMRG"} with a message. See \code{\link[parallel:RngStream]{parallel::clusterSetRNGStream()}} and Section 6 of \code{vignette("parallel", "parallel")} for more details. If user supplies an invalid value, \code{iseed} is silently set to the default (12345). To set the state of the RNG when not using parallel options, call \code{\link[base:Random]{base::set.seed()}} before calling \code{permuteMeasEq}.} } \value{ The \linkS4class{permuteMeasEq} object representing the results of testing measurement equivalence (the multiparameter omnibus test) and DIF (modification indices), as well as diagnostics and any \code{extra} output. } \description{ The function \code{permuteMeasEq} provides tests of hypotheses involving measurement equivalence, in one of two frameworks: multigroup CFA or MIMIC models. } \details{ The function \code{permuteMeasEq} provides tests of hypotheses involving measurement equivalence, in one of two frameworks: \enumerate{ \item{1} For multiple-group CFA models, provide a pair of nested lavaan objects, the less constrained of which (\code{uncon}) freely estimates a set of measurement parameters (e.g., factor loadings, intercepts, or thresholds; specified in \code{param}) in all groups, and the more constrained of which (\code{con}) constrains those measurement parameters to equality across groups. Group assignment is repeatedly permuted and the models are fit to each permutation, in order to produce an empirical distribution under the null hypothesis of no group differences, both for (a) changes in user-specified fit measures (see \code{AFIs} and \code{moreAFIs}) and for (b) the maximum modification index among the user-specified equality constraints. Configural invariance can also be tested by providing that fitted lavaan object to \code{con} and leaving \code{uncon = NULL}, in which case \code{param} must be \code{NULL} as well. \item{2} In MIMIC models, one or a set of continuous and/or discrete \code{covariates} can be permuted, and a constrained model is fit to each permutation in order to provide a distribution of any fit measures (namely, the maximum modification index among fixed parameters in \code{param}) under the null hypothesis of measurement equivalence across levels of those covariates. } In either framework, modification indices for equality constraints or fixed parameters specified in \code{param} are calculated from the constrained model (\code{con}) using the function \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}}. For multiple-group CFA models, the multiparameter omnibus null hypothesis of measurement equivalence/invariance is that there are no group differences in any measurement parameters (of a particular type). This can be tested using the \code{anova} method on nested \code{lavaan} objects, as seen in the output of \code{\link[=measurementInvariance]{measurementInvariance()}}, or by inspecting the change in alternative fit indices (AFIs) such as the CFI. The permutation randomization method employed by \code{permuteMeasEq} generates an empirical distribution of any \code{AFIs} under the null hypothesis, so the user is not restricted to using fixed cutoffs proposed by Cheung & Rensvold (2002), Chen (2007), or Meade, Johnson, & Braddy (2008). If the multiparameter omnibus null hypothesis is rejected, partial invariance can still be established by freeing invalid equality constraints, as long as equality constraints are valid for at least two indicators per factor. Modification indices can be calculated from the constrained model (\code{con}), but multiple testing leads to inflation of Type I error rates. The permutation randomization method employed by \code{permuteMeasEq} creates a distribution of the maximum modification index if the null hypothesis is true, which allows the user to control the familywise Type I error rate in a manner similar to Tukey's \emph{q} (studentized range) distribution for the Honestly Significant Difference (HSD) post hoc test. For MIMIC models, DIF can be tested by comparing modification indices of regression paths to the permutation distribution of the maximum modification index, which controls the familywise Type I error rate. The MIMIC approach could also be applied with multiple-group models, but the grouping variable would not be permuted; rather, the covariates would be permuted separately within each group to preserve between-group differences. So whether parameters are constrained or unconstrained across groups, the MIMIC approach is only for testing null hypotheses about the effects of \code{covariates} on indicators, controlling for common factors. In either framework, \code{\link[lavaan:lavaan]{lavaan::lavaan()}}'s \code{group.label} argument is used to preserve the order of groups seen in \code{con} when permuting the data. } \examples{ \donttest{ ######################## ## Multiple-Group CFA ## ######################## ## create 3-group data in lavaan example(cfa) data HS <- lavaan::HolzingerSwineford1939 HS$ageGroup <- ifelse(HS$ageyr < 13, "preteen", ifelse(HS$ageyr > 13, "teen", "thirteen")) ## specify and fit an appropriate null model for incremental fit indices mod.null <- c(paste0("x", 1:9, " ~ c(T", 1:9, ", T", 1:9, ", T", 1:9, ")*1"), paste0("x", 1:9, " ~~ c(L", 1:9, ", L", 1:9, ", L", 1:9, ")*x", 1:9)) fit.null <- cfa(mod.null, data = HS, group = "ageGroup") ## fit target model with varying levels of measurement equivalence mod.config <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit.config <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup") fit.metric <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup", group.equal = "loadings") fit.scalar <- cfa(mod.config, data = HS, std.lv = TRUE, group = "ageGroup", group.equal = c("loadings","intercepts")) ####################### Permutation Method ## fit indices of interest for multiparameter omnibus test myAFIs <- c("chisq","cfi","rmsea","mfi","aic") moreAFIs <- c("gammaHat","adjGammaHat") ## Use only 20 permutations for a demo. In practice, ## use > 1000 to reduce sampling variability of estimated p values ## test configural invariance set.seed(12345) out.config <- permuteMeasEq(nPermute = 20, con = fit.config) out.config ## test metric equivalence set.seed(12345) # same permutations out.metric <- permuteMeasEq(nPermute = 20, uncon = fit.config, con = fit.metric, param = "loadings", AFIs = myAFIs, moreAFIs = moreAFIs, null = fit.null) summary(out.metric, nd = 4) ## test scalar equivalence set.seed(12345) # same permutations out.scalar <- permuteMeasEq(nPermute = 20, uncon = fit.metric, con = fit.scalar, param = "intercepts", AFIs = myAFIs, moreAFIs = moreAFIs, null = fit.null) summary(out.scalar) ## Not much to see without significant DIF. ## Try using an absurdly high alpha level for illustration. outsum <- summary(out.scalar, alpha = .50) ## notice that the returned object is the table of DIF tests outsum ## visualize permutation distribution hist(out.config, AFI = "chisq") hist(out.metric, AFI = "chisq", nd = 2, alpha = .01, legendArgs = list(x = "topright")) hist(out.scalar, AFI = "cfi", printLegend = FALSE) ####################### Extra Output ## function to calculate expected change of Group-2 and -3 latent means if ## each intercept constraint were released extra <- function(con) { output <- list() output["x1.vis2"] <- lavTestScore(con, release = 19:20, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[70] output["x1.vis3"] <- lavTestScore(con, release = 19:20, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[106] output["x2.vis2"] <- lavTestScore(con, release = 21:22, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[70] output["x2.vis3"] <- lavTestScore(con, release = 21:22, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[106] output["x3.vis2"] <- lavTestScore(con, release = 23:24, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[70] output["x3.vis3"] <- lavTestScore(con, release = 23:24, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[106] output["x4.txt2"] <- lavTestScore(con, release = 25:26, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[71] output["x4.txt3"] <- lavTestScore(con, release = 25:26, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[107] output["x5.txt2"] <- lavTestScore(con, release = 27:28, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[71] output["x5.txt3"] <- lavTestScore(con, release = 27:28, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[107] output["x6.txt2"] <- lavTestScore(con, release = 29:30, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[71] output["x6.txt3"] <- lavTestScore(con, release = 29:30, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[107] output["x7.spd2"] <- lavTestScore(con, release = 31:32, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[72] output["x7.spd3"] <- lavTestScore(con, release = 31:32, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[108] output["x8.spd2"] <- lavTestScore(con, release = 33:34, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[72] output["x8.spd3"] <- lavTestScore(con, release = 33:34, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[108] output["x9.spd2"] <- lavTestScore(con, release = 35:36, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[72] output["x9.spd3"] <- lavTestScore(con, release = 35:36, univariate = FALSE, epc = TRUE, warn = FALSE)$epc$epc[108] output } ## observed EPC extra(fit.scalar) ## permutation results, including extra output set.seed(12345) # same permutations out.scalar <- permuteMeasEq(nPermute = 20, uncon = fit.metric, con = fit.scalar, param = "intercepts", AFIs = myAFIs, moreAFIs = moreAFIs, null = fit.null, extra = extra) ## summarize extra output summary(out.scalar, extra = TRUE) ########### ## MIMIC ## ########### ## Specify Restricted Factor Analysis (RFA) model, equivalent to MIMIC, but ## the factor covaries with the covariate instead of being regressed on it. ## The covariate defines a single-indicator construct, and the ## double-mean-centered products of the indicators define a latent ## interaction between the factor and the covariate. mod.mimic <- ' visual =~ x1 + x2 + x3 age =~ ageyr age.by.vis =~ x1.ageyr + x2.ageyr + x3.ageyr x1 ~~ x1.ageyr x2 ~~ x2.ageyr x3 ~~ x3.ageyr ' HS.orth <- indProd(var1 = paste0("x", 1:3), var2 = "ageyr", match = FALSE, data = HS[ , c("ageyr", paste0("x", 1:3))] ) fit.mimic <- cfa(mod.mimic, data = HS.orth, meanstructure = TRUE) summary(fit.mimic, stand = TRUE) ## Whereas MIMIC models specify direct effects of the covariate on an indicator, ## DIF can be tested in RFA models by specifying free loadings of an indicator ## on the covariate's construct (uniform DIF, scalar invariance) and the ## interaction construct (nonuniform DIF, metric invariance). param <- as.list(paste0("age + age.by.vis =~ x", 1:3)) names(param) <- paste0("x", 1:3) # param <- as.list(paste0("x", 1:3, " ~ age + age.by.vis")) # equivalent ## test both parameters simultaneously for each indicator do.call(rbind, lapply(param, function(x) lavTestScore(fit.mimic, add = x)$test)) ## or test each parameter individually lavTestScore(fit.mimic, add = as.character(param)) ####################### Permutation Method ## function to recalculate interaction terms after permuting the covariate datafun <- function(data) { d <- data[, c(paste0("x", 1:3), "ageyr")] indProd(var1 = paste0("x", 1:3), var2 = "ageyr", match = FALSE, data = d) } set.seed(12345) perm.mimic <- permuteMeasEq(nPermute = 20, modelType = "mimic", con = fit.mimic, param = param, covariates = "ageyr", datafun = datafun) summary(perm.mimic) } } \references{ \strong{Papers about permutation tests of measurement equivalence:} Jorgensen, T. D., Kite, B. A., Chen, P.-Y., & Short, S. D. (2018). Permutation randomization methods for testing measurement equivalence and detecting differential item functioning in multiple-group confirmatory factor analysis. \emph{Psychological Methods, 23}(4), 708--728. \doi{10.1037/met0000152} Kite, B. A., Jorgensen, T. D., & Chen, P.-Y. (2018). Random permutation testing applied to measurement invariance testing with ordered-categorical indicators. \emph{Structural Equation Modeling 25}(4), 573--587. \doi{10.1080/10705511.2017.1421467} Jorgensen, T. D. (2017). Applying permutation tests and multivariate modification indices to configurally invariant models that need respecification. \emph{Frontiers in Psychology, 8}(1455). \doi{10.3389/fpsyg.2017.01455} \strong{Additional reading:} Chen, F. F. (2007). Sensitivity of goodness of fit indexes to lack of measurement invariance. \emph{Structural Equation Modeling, 14}(3), 464--504. \doi{10.1080/10705510701301834} Cheung, G. W., & Rensvold, R. B. (2002). Evaluating goodness-of-fit indexes for testing measurement invariance. \emph{Structural Equation Modeling, 9}(2), 233--255. \doi{10.1207/S15328007SEM0902_5} Meade, A. W., Johnson, E. C., & Braddy, P. W. (2008). Power and sensitivity of alternative fit indices in tests of measurement invariance. \emph{Journal of Applied Psychology, 93}(3), 568--592. \doi{10.1037/0021-9010.93.3.568} Widamin, K. F., & Thompson, J. S. (2003). On specifying the null model for incremental fit indices in structural equation modeling. \emph{Psychological Methods, 8}(1), 16--37. \doi{10.1037/1082-989X.8.1.16} } \seealso{ \code{\link[stats:TukeyHSD]{stats::TukeyHSD()}}, \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}}, \code{\link[=measurementInvariance]{measurementInvariance()}}, \code{\link[=measurementInvarianceCat]{measurementInvarianceCat()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/skew.Rd0000644000176200001440000000325614632143413014101 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDiagnosis.R \name{skew} \alias{skew} \title{Finding skewness} \usage{ skew(object, population = FALSE) } \arguments{ \item{object}{A vector used to find a skewness} \item{population}{\code{TRUE} to compute the parameter formula. \code{FALSE} to compute the sample statistic formula.} } \value{ A value of a skewness with a test statistic if the population is specified as \code{FALSE} } \description{ Finding skewness (\eqn{g_{1}}) of an object } \details{ The skewness computed by default is \eqn{g_{1}}, the third standardized moment of the empirical distribution of \code{object}. The population parameter skewness \eqn{\gamma_{1}} formula is \deqn{\gamma_{1} = \frac{\mu_{3}}{\mu^{3/2}_{2}},} where \eqn{\mu_{i}} denotes the \eqn{i} order central moment. The skewness formula for sample statistic \eqn{g_{1}} is \deqn{g_{1} = \frac{k_{3}}{k^{2}_{2}},} where \eqn{k_{i}} are the \eqn{i} order \emph{k}-statistic. The standard error of the skewness is \deqn{Var(\hat{g}_1) = \frac{6}{N}} where \eqn{N} is the sample size. } \examples{ skew(1:5) } \references{ Weisstein, Eric W. (n.d.). \emph{Skewness}. Retrived from \emph{MathWorld}--A Wolfram Web Resource: \url{http://mathworld.wolfram.com/Skewness.html} } \seealso{ \itemize{ \item \code{\link[=kurtosis]{kurtosis()}} Find the univariate excessive kurtosis of a variable \item \code{\link[=mardiaSkew]{mardiaSkew()}} Find Mardia's multivariate skewness of a set of variables \item \code{\link[=mardiaKurtosis]{mardiaKurtosis()}} Find the Mardia's multivariate kurtosis of a set of variables } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/parcelAllocation.Rd0000644000176200001440000002241114764334714016412 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parcelAllocation.R \name{parcelAllocation} \alias{parcelAllocation} \title{Random Allocation of Items to Parcels in a Structural Equation Model} \usage{ parcelAllocation(model, data, parcel.names, item.syntax, nAlloc = 100, fun = "sem", alpha = 0.05, fit.measures = c("chisq", "df", "cfi", "tli", "rmsea", "srmr"), ..., show.progress = FALSE, iseed = 12345, do.fit = TRUE, return.fit = FALSE, warn = FALSE) } \arguments{ \item{model}{\code{\link[lavaan:lavaan]{lavaan::lavaan()}} model syntax specifying the model fit to (at least some) parceled data. Note that there can be a mixture of items and parcels (even within the same factor), in case certain items should never be parceled. Can be a character string or parameter table. Also see \code{\link[lavaan:model.syntax]{lavaan::lavaanify()}} for more details.} \item{data}{A \code{data.frame} containing all observed variables appearing in the \code{model}, as well as those in the \code{item.syntax} used to create parcels. If the data have missing values, multiple imputation before parceling is recommended: submit a stacked data set (with a variable for the imputation number, so they can be separateed later) and set \code{do.fit = FALSE} to return the list of \code{data.frame}s (one per allocation), each of which is a stacked, imputed data set with parcels.} \item{parcel.names}{\code{character} vector containing names of all parcels appearing as indicators in \code{model}.} \item{item.syntax}{\code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} specifying the model that would be fit to all of the unparceled items, including items that should be randomly allocated to parcels appearing in \code{model}.} \item{nAlloc}{The number of random items-to-parcels allocations to generate.} \item{fun}{\code{character} string indicating the name of the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function used to fit \code{model} to \code{data}. Can only take the values \code{"lavaan"}, \code{"sem"}, \code{"cfa"}, or \code{"growth"}.} \item{alpha}{Alpha level used as criterion for significance.} \item{fit.measures}{\code{character} vector containing names of fit measures to request from each fitted \code{\link[lavaan:lavaan]{lavaan::lavaan()}} model. See the output of \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} for a list of available measures.} \item{\dots}{Additional arguments to be passed to \code{\link[lavaan:lavaanList]{lavaan::lavaanList()}}. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}} \item{show.progress}{If \code{TRUE}, show a \code{\link[utils:txtProgressBar]{utils::txtProgressBar()}} indicating how fast the model-fitting iterates over allocations.} \item{iseed}{(Optional) Random seed used for parceling items. When the same random seed is specified and the program is re-run, the same allocations will be generated. Using the same \code{iseed} argument will ensure the any model is fit to the same parcel allocations. \emph{Note}: When using \pkg{parallel} options, you must first type \code{RNGkind("L'Ecuyer-CMRG")} into the R Console, so that the seed will be controlled across cores.} \item{do.fit}{If \code{TRUE} (default), the \code{model} is fitted to each parceled data set, and the summary of results is returned (see the Value section below). If \code{FALSE}, the items are randomly parceled, but the model is not fit; instead, the \code{list} of \code{data.frame}s is returned (so assign it to an object).} \item{return.fit}{If \code{TRUE}, a \link[lavaan:lavaanList-class]{lavaan::lavaanList} object is returned with the \code{list} of results across allocations} \item{warn}{Whether to print warnings when fitting \code{model} to each allocation} } \value{ \item{Estimates}{A \code{data.frame} containing results related to parameter estimates with columns corresponding to their names; average and standard deviation across allocations; minimum, maximum, and range across allocations; and the proportion of allocations in which each parameter estimate was significant.} \item{SE}{A \code{data.frame} containing results similar to \code{Estimates}, but related to the standard errors of parameter estimates.} \item{Fit}{A \code{data.frame} containing results related to model fit, with columns corresponding to fit index names; their average and standard deviation across allocations; the minimum, maximum, and range across allocations; and (if the test statistic or RMSEA is included in \code{fit.measures}) the proportion of allocations in which each test of (exact or close) fit was significant.} \item{Model}{A \link[lavaan:lavaanList-class]{lavaan::lavaanList} object containing results of the \code{model} fitted to each parcel allocation. Only returned if \code{return.fit = TRUE}.} } \description{ This function generates a given number of randomly generated item-to-parcel allocations, fits a model to each allocation, and provides averaged results over all allocations. } \details{ This function implements the random item-to-parcel allocation procedure described in Sterba (2011) and Sterba and MacCallum (2010). The function takes a single data set with item-level data, randomly assigns items to parcels, fits a structural equation model to the parceled data using \code{\link[lavaan:lavaanList]{lavaan::lavaanList()}}, and repeats this process for a user-specified number of random allocations. Results from all fitted models are summarized in the output. For further details on the benefits of randomly allocating items to parcels, see Sterba (2011) and Sterba and MacCallum (2010). } \examples{ ## Fit 2-factor CFA to simulated data. Each factor has 9 indicators. ## Specify the item-level model (if NO parcels were created) item.syntax <- c(paste0("f1 =~ f1item", 1:9), paste0("f2 =~ f2item", 1:9)) cat(item.syntax, sep = "\n") ## Below, we reduce the size of this same model by ## applying different parceling schemes ## 3-indicator parcels mod.parcels <- ' f1 =~ par1 + par2 + par3 f2 =~ par4 + par5 + par6 ' ## names of parcels (parcel.names <- paste0("par", 1:6)) \donttest{ ## override default random-number generator to use parallel options RNGkind("L'Ecuyer-CMRG") parcelAllocation(mod.parcels, data = simParcel, nAlloc = 100, parcel.names = parcel.names, item.syntax = item.syntax, # parallel = "multicore", # parallel available in Mac/Linux std.lv = TRUE) # any addition lavaan arguments ## POOL RESULTS by treating parcel allocations as multiple imputations ## Details provided in Sterba & Rights (2016); see ?poolMAlloc. ## save list of data sets instead of fitting model yet dataList <- parcelAllocation(mod.parcels, data = simParcel, nAlloc = 100, parcel.names = parcel.names, item.syntax = item.syntax, do.fit = FALSE) ## now fit the model to each data set library(lavaan.mi) fit.parcels <- cfa.mi(mod.parcels, data = dataList, std.lv = TRUE) summary(fit.parcels) # pooled using Rubin's rules anova(fit.parcels) # pooled test statistic help(package = "lavaan.mi") # find more methods for pooling results } ## multigroup example simParcel$group <- 0:1 # arbitrary groups for example mod.mg <- ' f1 =~ par1 + c(L2, L2)*par2 + par3 f2 =~ par4 + par5 + par6 ' ## names of parcels (parcel.names <- paste0("par", 1:6)) parcelAllocation(mod.mg, data = simParcel, parcel.names, item.syntax, std.lv = TRUE, group = "group", group.equal = "loadings", nAlloc = 20, show.progress = TRUE) ## parcels for first factor, items for second factor mod.items <- ' f1 =~ par1 + par2 + par3 f2 =~ f2item2 + f2item7 + f2item8 ' ## names of parcels (parcel.names <- paste0("par", 1:3)) parcelAllocation(mod.items, data = simParcel, parcel.names, item.syntax, nAlloc = 20, std.lv = TRUE) ## mixture of 1- and 3-indicator parcels for second factor mod.mix <- ' f1 =~ par1 + par2 + par3 f2 =~ f2item2 + f2item7 + f2item8 + par4 + par5 + par6 ' ## names of parcels (parcel.names <- paste0("par", 1:6)) parcelAllocation(mod.mix, data = simParcel, parcel.names, item.syntax, nAlloc = 20, std.lv = TRUE) } \references{ Sterba, S. K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling, 18}(4), 554--577. \doi{10.1080/10705511.2011.607073} Sterba, S. K. & MacCallum, R. C. (2010). Variability in parameter estimates and model fit across random allocations of items to parcels. \emph{Multivariate Behavioral Research, 45}(2), 322--358. \doi{10.1080/00273171003680302} Sterba, S. K., & Rights, J. D. (2016). Accounting for parcel-allocation variability in practice: Combining sources of uncertainty and choosing the number of allocations. \emph{Multivariate Behavioral Research, 51}(2--3), 296--313. \doi{10.1080/00273171.2016.1144502} Sterba, S. K., & Rights, J. D. (2017). Effects of parceling on model selection: Parcel-allocation variability in model ranking. \emph{Psychological Methods, 22}(1), 47--68. \doi{10.1037/met0000067} } \seealso{ \code{\link[=PAVranking]{PAVranking()}} for comparing 2 models, \code{\link[=poolMAlloc]{poolMAlloc()}} for choosing the number of allocations } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/lavTestScore.mi-deprecated.Rd0000644000176200001440000001735714764333003020261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI-score.R \name{lavTestScore.mi-deprecated} \alias{lavTestScore.mi-deprecated} \title{Score Test for Multiple Imputations} \usage{ lavTestScore.mi(object, add = NULL, release = NULL, test = c("D2","D1"), scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), asymptotic = is.null(add), univariate = TRUE, cumulative = FALSE, epc = FALSE, standardized = epc, cov.std = epc, verbose = FALSE, warn = TRUE, information = "expected") } \arguments{ \item{object}{An object of class \linkS4class{OLDlavaan.mi}.} \item{add}{Either a \code{character} string (typically between single quotes) or a parameter table containing additional (currently fixed-to-zero) parameters for which the score test must be computed.} \item{release}{Vector of \code{integer}s. The indices of the \emph{equality} constraints that should be released. The indices correspond to the order of the equality constraints as they appear in the parameter table.} \item{test}{\code{character} indicating which pooling method to use. \code{"D1"} requests Mansolf, Jorgensen, & Enders' (2020) proposed Wald-like test for pooling the gradient and information, which are then used to calculate score-test statistics in the usual manner. \code{"D2"} (default because it is less computationall intensive) requests to pool the complete-data score-test statistics from each imputed data set, then pool them across imputations, described by Li et al. (1991) and Enders (2010).} \item{scale.W}{\code{logical}. If \code{FALSE}, the pooled information matrix is calculated as the weighted sum of the within-imputation and between-imputation components. Otherwise, the pooled information is calculated by scaling the within-imputation component by the average relative increase in variance (ARIV; Enders, 2010, p. 235), which is \emph{only} consistent when requesting the \emph{F} test (i.e., \code{asymptotic = FALSE}. Ignored (irrelevant) if \code{test = "D2"}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. Specific imputation numbers can also be included in this argument, in case users want to apply their own custom omission criteria (or simulations can use different numbers of imputations without redundantly refitting the model).} \item{asymptotic}{\code{logical}. If \code{FALSE} (default when using \code{add} to test adding fixed parameters to the model), the pooled test will be returned as an \emph{F}-distributed variable with numerator (\code{df1}) and denominator (\code{df2}) degrees of freedom. If \code{TRUE}, the pooled \emph{F} statistic will be multiplied by its \code{df1} on the assumption that its \code{df2} is sufficiently large enough that the statistic will be asymptotically \eqn{\chi^2} distributed with \code{df1}. When using the \code{release} argument, \code{asymptotic} will be set to \code{TRUE} because (A)RIV can only be calculated for \code{add}ed parameters.} \item{univariate}{\code{logical}. If \code{TRUE}, compute the univariate score statistics, one for each constraint.} \item{cumulative}{\code{logical}. If \code{TRUE}, order the univariate score statistics from large to small, and compute a series of multivariate score statistics, each time including an additional constraint in the test.} \item{epc}{\code{logical}. If \code{TRUE}, and we are releasing existing constraints, compute the expected parameter changes for the existing (free) parameters (and any specified with \code{add}), if all constraints were released. For EPCs associated with a particular (1-\emph{df}) constraint, only specify one parameter in \code{add} or one constraint in \code{release}.} \item{standardized}{If \code{TRUE}, two extra columns (\code{sepc.lv} and \code{sepc.all}) in the \verb{$epc} table will contain standardized values for the EPCs. See \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}}.} \item{cov.std}{\code{logical}. See \code{\link[lavaan:standardizedSolution]{lavaan::standardizedSolution()}}.} \item{verbose}{\code{logical}. Not used for now.} \item{warn}{\code{logical}. If \code{TRUE}, print warnings if they occur.} \item{information}{\code{character} indicating the type of information matrix to use (check \code{\link[lavaan:lavInspect]{lavaan::lavInspect()}} for available options). \code{"expected"} information is the default, which provides better control of Type I errors.} } \value{ A list containing at least one \code{data.frame}: \itemize{ \item{\verb{$test}: The total score test, with columns for the score test statistic (\code{X2}), its degrees of freedom (\code{df}), its \emph{p} value under the \eqn{\chi^2} distribution (\code{p.value}), and if \code{asymptotic=FALSE}, the average relative invrease in variance (ARIV) used to calculate the denominator \emph{df} is also returned as a missing-data diagnostic, along with the fraction missing information (FMI = ARIV / (1 + ARIV)).} \item{\verb{$uni}: Optional (if \code{univariate=TRUE}). Each 1-\emph{df} score test, equivalent to modification indices. Also includes EPCs if \code{epc=TRUE}, and RIV and FMI if \code{asymptotic=FALSE}.} \item{\verb{$cumulative}: Optional (if \code{cumulative=TRUE}). Cumulative score tests, with ARIV and FMI if \code{asymptotic=FALSE}.} \item{\verb{$epc}: Optional (if \code{epc=TRUE}). Parameter estimates, expected parameter changes, and expected parameter values if ALL the tested constraints were freed.} } See \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}} for details. } \description{ Score test (or "Lagrange multiplier" test) for lavaan models fitted to multiple imputed data sets. Statistics for releasing one or more fixed or constrained parameters in model can be calculated by pooling the gradient and information matrices pooled across imputed data sets in a method proposed by Mansolf, Jorgensen, & Enders (2020)---analogous to the "D1" Wald test proposed by Li, Meng, Raghunathan, & Rubin's (1991)---or by pooling the complete-data score-test statistics across imputed data sets (i.e., "D2"; Li et al., 1991). } \examples{ ## See the new lavaan.mi package } \references{ Bentler, P. M., & Chou, C.-P. (1992). Some new covariance structure model improvement statistics. \emph{Sociological Methods & Research, 21}(2), 259--282. \doi{10.1177/0049124192021002006} Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data. \emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} Mansolf, M., Jorgensen, T. D., & Enders, C. K. (2020). A multiple imputation score test for model modification in structural equation models. \emph{Psychological Methods, 25}(4), 393--411. \doi{10.1037/met0000243} } \seealso{ \code{\link[lavaan:lavTestScore]{lavaan::lavTestScore()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Adapted from \pkg{lavaan} source code, written by Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) \code{test = "D1"} method proposed by Maxwell Mansolf (University of California, Los Angeles; \email{mamansolf@gmail.com}) } \keyword{internal} semTools/man/semTools-deprecated.Rd0000644000176200001440000001746714634306041017044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/aa_semTools-deprecated.R, R/efa.R, % R/longInvariance.R, R/measurementInvariance.R, R/measurementInvarianceCat.R, % R/reliability.R, R/runMI-LRT.R, R/runMI-Wald.R, R/runMI-modification.R, % R/runMI-score.R, R/runMI.R \name{semTools-deprecated} \alias{semTools-deprecated} \alias{efaUnrotate} \alias{orthRotate} \alias{oblqRotate} \alias{funRotate} \alias{longInvariance} \alias{measurementInvariance} \alias{measurementInvarianceCat} \alias{reliability} \alias{reliabilityL2} \alias{lavTestLRT.mi} \alias{lavTestWald.mi} \alias{modindices.mi} \alias{modificationIndices.mi} \alias{modificationindices.mi} \alias{lavTestScore.mi} \alias{runMI} \alias{lavaan.mi} \alias{cfa.mi} \alias{sem.mi} \alias{growth.mi} \alias{calculate.D2} \title{Deprecated functions in package \pkg{semTools}.} \usage{ efaUnrotate(data = NULL, nf, varList = NULL, start = TRUE, aux = NULL, ...) orthRotate(object, method = "varimax", ...) oblqRotate(object, method = "quartimin", ...) funRotate(object, fun, ...) longInvariance(model, varList, auto = "all", constrainAuto = FALSE, fixed.x = TRUE, std.lv = FALSE, group = NULL, group.equal = "", group.partial = "", strict = FALSE, warn = TRUE, debug = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001", ...) measurementInvariance(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001") measurementInvarianceCat(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "default") reliability(object, what = c("alpha", "omega", "omega2", "omega3", "ave"), return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), omit.indicators = character(0), omit.imps = c("no.conv", "no.se")) reliabilityL2(object, secondFactor, omit.imps = c("no.conv", "no.se")) lavTestLRT.mi(object, h1 = NULL, test = c("D3", "D2"), omit.imps = c("no.conv", "no.se"), asymptotic = FALSE, pool.robust = FALSE, ...) lavTestWald.mi(object, constraints = NULL, test = c("D1", "D2"), asymptotic = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv", "no.se"), verbose = FALSE, warn = TRUE) modindices.mi(object, test = c("D2", "D1"), omit.imps = c("no.conv", "no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) modificationIndices.mi(object, test = c("D2", "D1"), omit.imps = c("no.conv", "no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) modificationindices.mi(object, test = c("D2", "D1"), omit.imps = c("no.conv", "no.se"), standardized = TRUE, cov.std = TRUE, information = "expected", power = FALSE, delta = 0.1, alpha = 0.05, high.power = 0.75, sort. = FALSE, minimum.value = 0, maximum.number = nrow(LIST), na.remove = TRUE, op = NULL) lavTestScore.mi(object, add = NULL, release = NULL, test = c("D2", "D1"), scale.W = !asymptotic, omit.imps = c("no.conv", "no.se"), asymptotic = is.null(add), univariate = TRUE, cumulative = FALSE, epc = FALSE, standardized = epc, cov.std = epc, verbose = FALSE, warn = TRUE, information = "expected") runMI(model, data, fun = "lavaan", ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) lavaan.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) cfa.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) sem.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) growth.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) calculate.D2(w, DF = 0L, asymptotic = FALSE) } \description{ The functions listed below are deprecated and will be defunct in the near future. When possible, alternative functions with similar functionality are also mentioned. Help pages for deprecated functions are available at \code{help("semTools-deprecated")}. } \section{Support functions for exploratory factor analysis in \code{lavaan}}{ The \code{efaUnrotate}, \code{orthRotate}, \code{oblqRotate}, and \code{funRotate} functions will no longer be supported. These functions allowed users to estimate EFA parameters with \code{lavaan}. Instead, users can now directly use \code{lavaan}'s \code{\link[lavaan]{efa}()} function. Exploratory SEM (ESEM) is also supported by lavaan using special operators in \code{lavaan}'s \code{\link[lavaan]{model.syntax}}; see \url{https://github.com/yrosseel/lavaan/issues/112} for details. } \section{Previous measurement-invariance functions}{ The \code{measurementInvariance}, \code{measurementInvarianceCat}, and \code{longInvariance} functions will no longer be supported. Instead, use the \code{\link[=measEq.syntax]{measEq.syntax()}} function, which is much more flexible and supports a wider range of data (e.g., any mixture of \code{numeric} and \code{ordered} indicators, any combination of multiple groups and repeated measures, models fit to multiple imputations with \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}}). } \section{Reliability}{ The original \code{reliability} function was suboptimally designed. For example, AVE was returned, which is not a reliability index. Also, alpha and several omega-type coefficients were returned, including the original formula that was in appropriate for models with complex structure. Some features could be controlled by the user for one but not both types of index For example, alpha for categorical indicators was returned on both the observed and latent-response scales, but this was not an option for any omega-type indices. The omegas differed in terms of whether the observed or model-implied covariance matrix was used in the denominator, but alpha was only computed using the observed matrix. These inconsistencies have been resolved in the new \code{\link[=compRelSEM]{compRelSEM()}} function, which returns only one reliability index (per factor, optionally total score) according to the user's requested features, for which there is much more flexibility. Average variance extracted is now available in a dedicated \code{\link[=AVE]{AVE()}} function. } \section{Higher-Order Reliability}{ Originally, composite reliability of a single higher-order factor was estimated in a separate function: \code{reliabilityL2}. It is now available for multiple higher-order factors in the same model, and from the same \code{\link[=compRelSEM]{compRelSEM()}} function that estimates reliability for first-order factors, using the \verb{higher=} argument to name higher-order factors in the fitted model. } \section{\code{runMI()} and the \code{lavaan.mi} class functionality}{ The \code{runMI()} function and support for \code{lavaan.mi-class} objects became such a large part of semTools that it made sense to move that functionality to its own package. The \pkg{lavaan.mi} package is now available for users to fit \code{lavaan} models to their multiply imputed data. The new package already fixes many bugs and provides many new features that make the semTools \code{OLDlavaan.mi-class} obsolete. Please immediately discontinue your dependence on \code{semTools::runMI()} amd transition to the new \pkg{lavaan.mi} package, which also provides a more similar user interface as the \pkg{lavaan} package provides for a single \verb{data=} set. The README on \url{https://github.com/TDJorgensen/lavaan.mi} provides a list of analogous functionality in \pkg{lavaan} and \pkg{lavaan.mi}, and the NEWS file documents new features and other differences from the deprecated \code{semTools::runMI()} functionality. } \keyword{internal} semTools/man/measurementInvarianceCat-deprecated.Rd0000644000176200001440000000717714764270501022216 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/measurementInvarianceCat.R \name{measurementInvarianceCat-deprecated} \alias{measurementInvarianceCat-deprecated} \title{Measurement Invariance Tests for Categorical Items} \usage{ measurementInvarianceCat(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "default") } \arguments{ \item{...}{The same arguments as for any lavaan model. See \code{\link[lavaan:cfa]{lavaan::cfa()}} for more information.} \item{std.lv}{If \code{TRUE}, the fixed-factor method of scale identification is used. If \code{FALSE}, the first variable for each factor is used as marker variable.} \item{strict}{If \code{TRUE}, the sequence requires `strict' invariance. See details for more information.} \item{quiet}{If \code{FALSE} (default), a summary is printed out containing an overview of the different models that are fitted, together with some model comparison tests. If \code{TRUE}, no summary is printed.} \item{fit.measures}{Fit measures used to calculate the differences between nested models.} \item{baseline.model}{custom baseline model passed to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}} \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} for available options} } \value{ Invisibly, all model fits in the sequence are returned as a list. } \description{ Testing measurement invariance across groups using a typical sequence of model comparison tests. } \details{ Theta parameterization is used to represent SEM for categorical items. That is, residual variances are modeled instead of the total variance of underlying normal variate for each item. Five models can be tested based on different constraints across groups. \enumerate{ \item Model 1: configural invariance. The same factor structure is imposed on all groups. \item Model 2: weak invariance. The factor loadings are constrained to be equal across groups. \item Model 3: strong invariance. The factor loadings and thresholds are constrained to be equal across groups. \item Model 4: strict invariance. The factor loadings, thresholds and residual variances are constrained to be equal across groups. For categorical variables, all residual variances are fixed as 1. \item Model 5: The factor loadings, threshoulds, residual variances and means are constrained to be equal across groups. } However, if all items have two items (dichotomous), scalar invariance and weak invariance cannot be separated because thresholds need to be equal across groups for scale identification. Users can specify \code{strict} option to include the strict invariance model for the invariance testing. See the further details of scale identification and different parameterization in Millsap and Yun-Tein (2004). } \examples{ \donttest{ syntax <- ' f1 =~ u1 + u2 + u3 + u4' measurementInvarianceCat(model = syntax, data = datCat, group = "g", parameterization = "theta", estimator = "wlsmv", ordered = c("u1", "u2", "u3", "u4")) } } \references{ Millsap, R. E., & Yun-Tein, J. (2004). Assessing factorial invariance in ordered-categorical measures. \emph{Multivariate Behavioral Research, 39}(3), 479--515. \doi{10.1207/S15327906MBR3903_4} } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/Net-class.Rd0000644000176200001440000000233314632143412014753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/NET.R \docType{class} \name{Net-class} \alias{Net-class} \alias{show,Net-method} \alias{summary,Net-method} \title{Class For the Result of Nesting and Equivalence Testing} \usage{ \S4method{show}{Net}(object) \S4method{summary}{Net}(object) } \arguments{ \item{object}{An object of class \code{Net}.} } \value{ \item{show}{\code{signature(object = "Net")}: prints the logical matrix of test results. \code{NA} indicates a model did not converge.} \item{summary}{\code{signature(object = "Net")}: prints a narrative description of results. The original \code{object} is invisibly returned.} } \description{ This class contains the results of nesting and equivalence testing among multiple models } \section{Slots}{ \describe{ \item{\code{test}}{Logical \code{matrix} indicating nesting/equivalence among models} \item{\code{df}}{The degrees of freedom of tested models} }} \section{Objects from the Class}{ Objects can be created via the \code{\link[=net]{net()}} function. } \examples{ # See the example in the net function. } \seealso{ \code{\link[=net]{net()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/plotRMSEApower.Rd0000644000176200001440000000747414632143415015763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisRMSEA.R \name{plotRMSEApower} \alias{plotRMSEApower} \title{Plot power curves for RMSEA} \usage{ plotRMSEApower(rmsea0, rmseaA, df, nlow, nhigh, steps = 1, alpha = 0.05, group = 1, ...) } \arguments{ \item{rmsea0}{Null RMSEA} \item{rmseaA}{Alternative RMSEA} \item{df}{Model degrees of freedom} \item{nlow}{Lower sample size} \item{nhigh}{Upper sample size} \item{steps}{Increase in sample size for each iteration. Smaller values of steps will lead to more precise plots. However, smaller step sizes means a longer run time.} \item{alpha}{Alpha level used in power calculations} \item{group}{The number of group that is used to calculate RMSEA.} \item{\dots}{The additional arguments for the plot function.} } \value{ Plot of power for RMSEA against a range of sample sizes } \description{ Plots power of RMSEA over a range of sample sizes } \details{ This function creates plot of power for RMSEA against a range of sample sizes. The plot places sample size on the horizontal axis and power on the vertical axis. The user should indicate the lower and upper values for sample size and the sample size between each estimate ("step size") We strongly urge the user to read the sources below (see References) before proceeding. A web version of this function is available at: \url{http://quantpsy.org/rmsea/rmseaplot.htm}. This function is also implemented in the web application "power4SEM": \url{https://sjak.shinyapps.io/power4SEM/} } \examples{ plotRMSEApower(rmsea0 = .025, rmseaA = .075, df = 23, nlow = 100, nhigh = 500, steps = 10) } \references{ MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing differences between nested covariance structure models: Power analysis and null hypotheses. \emph{Psychological Methods, 11}(1), 19--35. \doi{10.1037/1082-989X.11.1.19} MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis and determination of sample size for covariance structure modeling. \emph{Psychological Methods, 1}(2), 130--149. \doi{10.1037/1082-989X.1.2.130} MacCallum, R. C., Lee, T., & Browne, M. W. (2010). The issue of isopower in power analysis for tests of structural equation models. \emph{Structural Equation Modeling, 17}(1), 23--41. \doi{10.1080/10705510903438906} Preacher, K. J., Cai, L., & MacCallum, R. C. (2007). Alternatives to traditional model comparison strategies for covariance structure models. In T. D. Little, J. A. Bovaird, & N. A. Card (Eds.), \emph{Modeling contextual effects in longitudinal studies} (pp. 33--62). Mahwah, NJ: Lawrence Erlbaum Associates. Steiger, J. H. (1998). A note on multiple sample extensions of the RMSEA fit index. \emph{Structural Equation Modeling, 5}(4), 411--419. \doi{10.1080/10705519809540115} Steiger, J. H., & Lind, J. C. (1980, June). \emph{Statistically based tests for the number of factors.} Paper presented at the annual meeting of the Psychometric Society, Iowa City, IA. Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. (2021). Analytical power calculations for structural equation modeling: A tutorial and Shiny app. \emph{Behavior Research Methods, 53}, 1385--1406. \doi{10.3758/s13428-020-01479-0} } \seealso{ \itemize{ \item \code{\link[=plotRMSEAdist]{plotRMSEAdist()}} to visualize the RMSEA distributions \item \code{\link[=findRMSEApower]{findRMSEApower()}} to find the statistical power based on population RMSEA given a sample size \item \code{\link[=findRMSEAsamplesize]{findRMSEAsamplesize()}} to find the minium sample size for a given statistical power based on population RMSEA } } \author{ Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) Kristopher J. Preacher (Vanderbilt University; \email{kris.preacher@vanderbilt.edu}) Donna L. Coffman (Pennsylvania State University; \email{dlc30@psu.edu}) } semTools/man/mardiaSkew.Rd0000644000176200001440000000356714632147325015232 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDiagnosis.R \name{mardiaSkew} \alias{mardiaSkew} \title{Finding Mardia's multivariate skewness} \usage{ mardiaSkew(dat, use = "everything") } \arguments{ \item{dat}{The target matrix or data frame with multiple variables} \item{use}{Missing data handling method from the \code{\link[stats:cor]{stats::cov()}} function.} } \value{ A value of a Mardia's multivariate skewness with a test statistic } \description{ Finding Mardia's multivariate skewness of multiple variables } \details{ The Mardia's multivariate skewness formula (Mardia, 1970) is \deqn{ b_{1, d} = \frac{1}{n^2}\sum^n_{i=1}\sum^n_{j=1}\left[ \left(\bold{X}_i - \bold{\bar{X}} \right)^{'} \bold{S}^{-1} \left(\bold{X}_j - \bold{\bar{X}} \right) \right]^3, } where \eqn{d} is the number of variables, \eqn{X} is the target dataset with multiple variables, \eqn{n} is the sample size, \eqn{\bold{S}} is the sample covariance matrix of the target dataset, and \eqn{\bold{\bar{X}}} is the mean vectors of the target dataset binded in \eqn{n} rows. When the population multivariate skewness is normal, the \eqn{\frac{n}{6}b_{1,d}} is asymptotically distributed as \eqn{\chi^2} distribution with \eqn{d(d + 1)(d + 2)/6} degrees of freedom. } \examples{ library(lavaan) mardiaSkew(HolzingerSwineford1939[ , paste0("x", 1:9)]) } \references{ Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications. \emph{Biometrika, 57}(3), 519--530. \doi{10.2307/2334770} } \seealso{ \itemize{ \item \code{\link[=skew]{skew()}} Find the univariate skewness of a variable \item \code{\link[=kurtosis]{kurtosis()}} Find the univariate excessive kurtosis of a variable \item \code{\link[=mardiaKurtosis]{mardiaKurtosis()}} Find the Mardia's multivariate kurtosis of a set of variables } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/OLDlavaan.mi-class.Rd0000644000176200001440000003174114764333003016442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI-methods.R \docType{class} \name{OLDlavaan.mi-class} \alias{OLDlavaan.mi-class} \alias{show,OLDlavaan.mi-method} \alias{summary,OLDlavaan.mi-method} \alias{fitMeasures,OLDlavaan.mi-method} \alias{fitmeasures,OLDlavaan.mi-method} \alias{anova,OLDlavaan.mi-method} \alias{nobs,OLDlavaan.mi-method} \alias{coef,OLDlavaan.mi-method} \alias{vcov,OLDlavaan.mi-method} \alias{fitted,OLDlavaan.mi-method} \alias{fitted.values,OLDlavaan.mi-method} \alias{residuals,OLDlavaan.mi-method} \alias{resid,OLDlavaan.mi-method} \title{Class for a lavaan Model Fitted to Multiple Imputations} \usage{ \S4method{show}{OLDlavaan.mi}(object) \S4method{summary}{OLDlavaan.mi}(object, se = TRUE, ci = FALSE, level = 0.95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv", "no.se"), asymptotic = FALSE, header = TRUE, output = "text", fit.measures = FALSE, ...) \S4method{nobs}{OLDlavaan.mi}(object, total = TRUE) \S4method{coef}{OLDlavaan.mi}(object, type = "free", labels = TRUE, omit.imps = c("no.conv", "no.se")) \S4method{vcov}{OLDlavaan.mi}(object, type = c("pooled", "between", "within", "ariv"), scale.W = TRUE, omit.imps = c("no.conv", "no.se")) \S4method{anova}{OLDlavaan.mi}(object, ...) \S4method{fitMeasures}{OLDlavaan.mi}(object, fit.measures = "all", baseline.model = NULL, output = "vector", omit.imps = c("no.conv", "no.se"), ...) \S4method{fitmeasures}{OLDlavaan.mi}(object, fit.measures = "all", baseline.model = NULL, output = "vector", omit.imps = c("no.conv", "no.se"), ...) \S4method{fitted}{OLDlavaan.mi}(object, omit.imps = c("no.conv", "no.se")) \S4method{fitted.values}{OLDlavaan.mi}(object, omit.imps = c("no.conv", "no.se")) \S4method{residuals}{OLDlavaan.mi}(object, type = c("raw", "cor"), omit.imps = c("no.conv", "no.se")) \S4method{resid}{OLDlavaan.mi}(object, type = c("raw", "cor"), omit.imps = c("no.conv", "no.se")) } \arguments{ \item{object}{An object of class \code{OLDlavaan.mi}} \item{se, ci, level, standardized, rsquare, header, output}{See \code{\link[lavaan:parameterEstimates]{lavaan::parameterEstimates()}}. The \verb{output=} argument can also be passed to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}.} \item{fmi}{\code{logical} indicating whether to include the Fraction Missing Information (FMI) for parameter estimates in the \code{summary} output (see \strong{Value} section).} \item{scale.W}{\code{logical}. If \code{TRUE} (default), the \code{vcov} method will calculate the pooled covariance matrix by scaling the within-imputation component by the ARIV (see Enders, 2010, p. 235, for definition and formula). Otherwise, the pooled matrix is calculated as the weighted sum of the within-imputation and between-imputation components (see Enders, 2010, ch. 8, for details). This in turn affects how the \code{summary()} method calculates its pooled standard errors, as well as \code{\link[=lavTestWald.mi]{lavTestWald.mi()}}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation. Specific imputation numbers can also be included in this argument, in case users want to apply their own custom omission criteria (or simulations can use different numbers of imputations without redundantly refitting the model).} \item{asymptotic}{\code{logical}. If \code{FALSE} (typically a default, but see \strong{Value} section for details using various methods), pooled tests (of fit or pooled estimates) will be \emph{F} or \emph{t} statistics with associated degrees of freedom (\emph{df}). If \code{TRUE}, the (denominator) \emph{df} are assumed to be sufficiently large for a \emph{t} statistic to follow a normal distribution, so it is printed as a \emph{z} statisic; likewise, \emph{F} times its numerator \emph{df} is printed, assumed to follow a \eqn{\chi^2} distribution.} \item{fit.measures, baseline.model}{See \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}. \code{summary(object, fit.measures = TRUE)} will print (but not return) a table of fit measures to the console.} \item{...}{Additional arguments passed to \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}}, or subsequently to \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}.} \item{total}{\code{logical} (default: \code{TRUE}) indicating whether the \code{nobs} method should return the total sample size or (if \code{FALSE}) a vector of group sample sizes.} \item{type}{The meaning of this argument varies depending on which method it it used for. Find detailed descriptions in the \strong{Value} section under \code{coef}, \code{vcov}, and \code{residuals}.} \item{labels}{\code{logical} indicating whether the \code{coef} output should include parameter labels. Default is \code{TRUE}.} } \value{ \item{coef}{\code{signature(object = "OLDlavaan.mi", type = "free", labels = TRUE, omit.imps = c("no.conv","no.se"))}: See \link[lavaan:lavaan-class]{lavaan::lavaan}. Returns the pooled point estimates (i.e., averaged across imputed data sets; see Rubin, 1987).} \item{vcov}{\code{signature(object = "OLDlavaan.mi", scale.W = TRUE, omit.imps = c("no.conv","no.se"), type = c("pooled","between","within","ariv"))}: By default, returns the pooled covariance matrix of parameter estimates (\code{type = "pooled"}), the within-imputations covariance matrix (\code{type = "within"}), the between-imputations covariance matrix (\code{type = "between"}), or the average relative increase in variance (\code{type = "ariv"}) due to missing data.} \item{fitted.values}{\code{signature(object = "OLDlavaan.mi", omit.imps = c("no.conv","no.se"))}: See \link[lavaan:lavaan-class]{lavaan::lavaan}. Returns model-implied moments, evaluated at the pooled point estimates.} \item{fitted}{alias for \code{fitted.values}} \item{residuals}{\code{signature(object = "OLDlavaan.mi", type = c("raw","cor"), omit.imps = c("no.conv","no.se"))}: See \link[lavaan:lavaan-class]{lavaan::lavaan}. By default (\code{type = "raw"}), returns the difference between the model-implied moments from \code{fitted.values} and the pooled observed moments (i.e., averaged across imputed data sets). Standardized residuals are also available, using Bollen's (\code{type = "cor"} or \code{"cor.bollen"}) or Bentler's (\code{type = "cor.bentler"}) formulas.} \item{resid}{alias for \code{residuals}} \item{nobs}{\code{signature(object = "OLDlavaan.mi", total = TRUE)}: either the total (default) sample size or a vector of group sample sizes (\code{total = FALSE}).} \item{anova}{\code{signature(object = "OLDlavaan.mi", ...)}: Returns a test of model fit for a single model (\code{object}) or test(s) of the difference(s) in fit between nested models passed via \code{...}. See \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}} and \code{\link[=compareFit]{compareFit()}} for details.} \item{fitMeasures}{\code{signature(object = "OLDlavaan.mi", fit.measures = "all", baseline.model = NULL, output = "vector", omit.imps = c("no.conv","no.se"), ...)}: See lavaan's \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} for details. Pass additional arguments to \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}} via \code{...}.} \item{fitmeasures}{alias for \code{fitMeasures}.} \item{show}{\code{signature(object = "OLDlavaan.mi")}: returns a message about convergence rates and estimation problems (if applicable) across imputed data sets.} \item{summary}{\code{signature(object = "OLDlavaan.mi", se = TRUE, ci = FALSE, level = .95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, scale.W = !asymptotic, omit.imps = c("no.conv","no.se"), asymptotic = FALSE, header = TRUE, output = "text", fit.measures = FALSE, ...)}: See \code{\link[lavaan:parameterEstimates]{lavaan::parameterEstimates()}} for details. By default, \code{summary()} returns pooled point and \emph{SE} estimates, along with \emph{t} test statistics and their associated \emph{df} and \emph{p} values. If \code{ci = TRUE}, confidence intervals are returned with the specified confidence \code{level} (default 95\\% CI). If \code{asymptotic = TRUE}, \emph{z} instead of \emph{t} tests are returned. \code{standardized} solution(s) can also be requested by name (\code{"std.lv"} or \code{"std.all"}) or both are returned with \code{TRUE}. \emph{R}-squared for endogenous variables can be requested, as well as the Fraction Missing Information (FMI) for parameter estimates. By default, the output will appear like \code{lavaan}'s \code{summary()} output, but if \code{output == "data.frame"}, the returned \code{data.frame} will resemble the \code{parameterEstimates()} output. The \code{scale.W} argument is passed to \code{vcov} (see description above). Setting \code{fit.measures=TRUE} will additionally print fit measures to the console, but they will not be returned; additional arguments may be passed via \code{...} to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} and subsequently to \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}}.} } \description{ This class extends the \link[lavaan:lavaanList-class]{lavaan::lavaanList} class, created by fitting a lavaan model to a list of data sets. In this case, the list of data sets are multiple imputations of missing data. } \section{Slots}{ \describe{ \item{\code{coefList}}{\code{list} of estimated coefficients in matrix format (one per imputation) as output by \code{lavInspect(fit, "est")}} \item{\code{phiList}}{\code{list} of model-implied latent-variable covariance matrices (one per imputation) as output by \code{lavInspect(fit, "cov.lv")}} \item{\code{miList}}{\code{list} of modification indices output by \code{\link[lavaan:modificationIndices]{lavaan::modindices()}}} \item{\code{seed}}{\code{integer} seed set before running imputations} \item{\code{lavListCall}}{call to \code{\link[lavaan:lavaanList]{lavaan::lavaanList()}} used to fit the model to the list of imputed data sets in \verb{@DataList}, stored as a \code{list} of arguments} \item{\code{imputeCall}}{call to imputation function (if used), stored as a \code{list} of arguments} \item{\code{convergence}}{\code{list} of \code{logical} vectors indicating whether, for each imputed data set, (1) the model converged on a solution, (2) \emph{SE}s could be calculated, (3) the (residual) covariance matrix of latent variables (\eqn{\Psi}) is non-positive-definite, and (4) the residual covariance matrix of observed variables (\eqn{\Theta}) is non-positive-definite.} \item{\code{lavaanList_slots}}{All remaining slots are from \link[lavaan:lavaanList-class]{lavaan::lavaanList}, but \code{\link[=runMI]{runMI()}} only populates a subset of the \code{list} slots, two of them with custom information:} \item{\code{DataList}}{The \code{list} of imputed data sets} \item{\code{SampleStatsList}}{List of output from \code{lavInspect(fit, "sampstat")} applied to each fitted model} \item{\code{ParTableList}}{See \link[lavaan:lavaanList-class]{lavaan::lavaanList}} \item{\code{vcovList}}{See \link[lavaan:lavaanList-class]{lavaan::lavaanList}} \item{\code{testList}}{See \link[lavaan:lavaanList-class]{lavaan::lavaanList}} \item{\code{h1List}}{See \link[lavaan:lavaanList-class]{lavaan::lavaanList}. An additional element is added to the \code{list}: \verb{$PT} is the "saturated" model's parameter table, returned by \code{\link[lavaan:lav_partable]{lavaan::lav_partable_unrestricted()}}.} \item{\code{baselineList}}{See \link[lavaan:lavaanList-class]{lavaan::lavaanList}} }} \section{Objects from the Class}{ See the \code{\link[=runMI]{runMI()}} function for details. } \examples{ ## See the new lavaan.mi package } \references{ Asparouhov, T., & Muthen, B. (2010). \emph{Chi-square statistics with multiple imputation}. Technical Report. Retrieved from \url{http://www.statmodel.com/} Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data. \emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} Meng, X.-L., & Rubin, D. B. (1992). Performing likelihood ratio tests with multiply-imputed data sets. \emph{Biometrika, 79}(1), 103--111. \doi{10.2307/2337151} Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. New York, NY: Wiley. } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/residualCovariate.Rd0000644000176200001440000000274414632143416016602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/residualCovariate.R \name{residualCovariate} \alias{residualCovariate} \title{Residual-center all target indicators by covariates} \usage{ residualCovariate(data, targetVar, covVar) } \arguments{ \item{data}{The desired data to be transformed.} \item{targetVar}{Varible names or the position of indicators that users wish to be residual centered (as dependent variables)} \item{covVar}{Covariate names or the position of the covariates using for residual centering (as independent variables) onto target variables} } \value{ The data that the target variables replaced by the residuals } \description{ This function will regress target variables on the covariate and replace the target variables by the residual of the regression analysis. This procedure is useful to control the covariate from the analysis model (Geldhof, Pornprasertmanit, Schoemann, & Little, 2013). } \examples{ dat <- residualCovariate(attitude, 2:7, 1) } \references{ Geldhof, G. J., Pornprasertmanit, S., Schoemann, A. M., & Little, T. D. (2013). Orthogonalizing through residual centering: Extended applications and caveats. \emph{Educational and Psychological Measurement, 73}(1), 27--46. \doi{10.1177/0013164412445473} } \seealso{ \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/exLong.Rd0000644000176200001440000000152414006342740014357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{exLong} \alias{exLong} \title{Simulated Data set to Demonstrate Longitudinal Measurement Invariance} \format{ A \code{data.frame} with 200 observations of 10 variables. \describe{ \item{sex}{Sex of respondents} \item{y1t1}{Indicator 1 in Time 1} \item{y2t1}{Indicator 2 in Time 1} \item{y3t1}{Indicator 3 in Time 1} \item{y1t2}{Indicator 1 in Time 2} \item{y2t2}{Indicator 2 in Time 2} \item{y3t2}{Indicator 3 in Time 2} \item{y1t3}{Indicator 1 in Time 3} \item{y2t3}{Indicator 2 in Time 3} \item{y3t3}{Indicator 3 in Time 3} } } \source{ Data were generated using the \code{simsem} package. } \usage{ exLong } \description{ A simulated data set with 1 factors with 3 indicators in three timepoints } \examples{ head(exLong) } \keyword{datasets} semTools/man/twostage-class.Rd0000644000176200001440000001473614753073632016106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/TSML.R \docType{class} \name{twostage-class} \alias{twostage-class} \alias{show,twostage-method} \alias{summary,twostage-method} \alias{anova,twostage-method} \alias{vcov,twostage-method} \alias{coef,twostage-method} \alias{fitted.values,twostage-method} \alias{fitted,twostage-method} \alias{residuals,twostage-method} \alias{resid,twostage-method} \alias{nobs,twostage-method} \title{Class for the Results of 2-Stage Maximum Likelihood (TSML) Estimation for Missing Data} \usage{ \S4method{show}{twostage}(object) \S4method{summary}{twostage}(object, ...) \S4method{anova}{twostage}(object, h1 = NULL, baseline = FALSE) \S4method{nobs}{twostage}(object, type = c("ntotal", "ngroups", "n.per.group", "norig", "patterns", "coverage")) \S4method{coef}{twostage}(object, type = c("free", "user")) \S4method{vcov}{twostage}(object, baseline = FALSE) \S4method{fitted.values}{twostage}(object, model = c("target", "saturated", "baseline"), type = "moments", labels = TRUE) \S4method{fitted}{twostage}(object, model = c("target", "saturated", "baseline"), type = "moments", labels = TRUE) \S4method{residuals}{twostage}(object, type = c("raw", "cor", "normalized", "standardized")) \S4method{resid}{twostage}(object, type = c("raw", "cor", "normalized", "standardized")) } \arguments{ \item{object}{An object of class \code{twostage}.} \item{...}{arguments passed to \code{\link[lavaan:parameterEstimates]{lavaan::parameterEstimates()}}.} \item{h1}{An object of class \code{twostage} in which \code{object} is nested, so that their difference in fit can be tested using \code{anova} (see \strong{Value} section for details).} \item{baseline}{\code{logical} indicating whether to return results for the baseline model, rather than the default target (hypothesized) model.} \item{type}{The meaning of this argument varies depending on which method it it used for. Find detailed descriptions in the \strong{Value} section under \code{coef}, \code{nobs}, and \code{residuals}.} \item{model}{\code{character} naming the slot for which to return the model-implied sample moments (see \code{fitted.values} description.)} \item{labels}{\code{logical} indicating whether the model-implied sample moments should have (row/column) labels.} } \value{ \item{show}{\verb{signature(object = "twostage"):} The \code{show} function is used to display the results of the \code{anova} method, as well as the header of the (uncorrected) target model results.} \item{summary}{\verb{signature(object = "twostage", ...):} The summary function prints the same information from the \code{show} method, but also provides (and returns) the output of \code{parameterEstimates(object@target, ...)} with corrected \emph{SE}s, test statistics, and confidence intervals. Additional arguments can be passed to \code{\link[lavaan:parameterEstimates]{lavaan::parameterEstimates()}}, including \code{fmi = TRUE} to provide an estimate of the fraction of missing information.} \item{anova}{\verb{signature(object = "twostage", h1 = NULL, baseline = FALSE):} The \code{anova} function returns the residual-based \eqn{\chi^2} test statistic result, as well as the scaled \eqn{\chi^2} test statistic result, for the model in the \code{target} slot, or for the model in the \code{baseline} slot if \code{baseline = TRUE}. The user can also provide a single additional \code{twostage} object to the \code{h1} argument, in which case \code{anova} returns residual-based and scaled (\eqn{\Delta})\eqn{\chi^2} test results, under the assumption that the models are nested. The models will be automatically sorted according their degrees of freedom.} \item{nobs}{\verb{signature(object = "twostage", type = c("ntotal", "ngroups", "n.per.group", "norig", "patterns", "coverage")):} The \code{nobs} function will return the total sample sized used in the analysis by default. Also available are the number of groups or the sample size per group, the original sample size (if any rows were deleted because all variables were missing), the missing data patterns, and the matrix of coverage (diagonal is the proportion of sample observed on each variable, and off-diagonal is the proportion observed for both of each pair of variables).} \item{coef}{\verb{signature(object = "twostage", type = c("free", "user")):} This is simply a wrapper around the corresponding \link[lavaan:lavaan-class]{lavaan::lavaan} method, providing point estimates from the \code{target} slot.} \item{vcov}{\verb{signature(object = "twostage", baseline = FALSE):} Returns the asymptotic covariance matrix of the estimated parameters (corrected for additional uncertainty due to missing data) for the model in the \code{target} slot, or for the model in the \code{baseline} slot if \code{baseline = TRUE}.} \item{fitted.values, fitted}{\verb{signature(object = "twostage", model = c("target", "saturated", "baseline")):} This is simply a wrapper around the corresponding \link[lavaan:lavaan-class]{lavaan::lavaan} method, providing model-implied sample moments from the slot specified in the \code{model} argument.} \item{residuals, resid}{\verb{signature(object = "twostage", type = c("raw", "cor", "normalized", "standardized")):} This is simply a wrapper around the corresponding \link[lavaan:lavaan-class]{lavaan::lavaan} method, providing residuals of the specified \code{type} from the \code{target} slot.} } \description{ This class contains the results of 2-Stage Maximum Likelihood (TSML) estimation for missing data. The \code{summary}, \code{anova}, \code{vcov} methods return corrected \emph{SE}s and test statistics. Other methods are simply wrappers around the corresponding \link[lavaan:lavaan-class]{lavaan::lavaan} methods. } \section{Slots}{ \describe{ \item{\code{saturated}}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object containing the saturated model results} \item{\code{target}}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object containing the target/hypothesized model results} \item{\code{baseline}}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object containing the baseline/null model results} \item{\code{auxNames}}{A character string (potentially of \code{length == 0}) of any auxiliary variable names, if used} }} \section{Objects from the Class}{ Objects can be created via the \code{\link[=twostage]{twostage()}} function. } \examples{ # See the example from the twostage function } \seealso{ \code{\link[=twostage]{twostage()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/mvrnonnorm.Rd0000644000176200001440000000377214632143414015347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mvrnonnorm.R \name{mvrnonnorm} \alias{mvrnonnorm} \title{Generate Non-normal Data using Vale and Maurelli (1983) method} \usage{ mvrnonnorm(n, mu, Sigma, skewness = NULL, kurtosis = NULL, empirical = FALSE) } \arguments{ \item{n}{Sample size} \item{mu}{A mean vector. If elements are named, those will be used as variable names in the returned data matrix.} \item{Sigma}{A positive-definite symmetric matrix specifying the covariance matrix of the variables. If rows or columns are named (and \code{mu} is unnamed), those will be used as variable names in the returned data matrix.} \item{skewness}{A vector of skewness of the variables} \item{kurtosis}{A vector of excessive kurtosis of the variables} \item{empirical}{deprecated, ignored.} } \value{ A data matrix } \description{ Generate Non-normal Data using Vale and Maurelli (1983) method. The function is designed to be as similar as the popular \code{mvrnorm} function in the \code{MASS} package. The codes are copied from \code{mvrnorm} function in the \code{MASS} package for argument checking and \code{lavaan} package for data generation using Vale and Maurelli (1983) method. } \examples{ set.seed(123) mvrnonnorm(20, c(1, 2), matrix(c(10, 2, 2, 5), 2, 2), skewness = c(5, 2), kurtosis = c(3, 3)) ## again, with variable names specified in mu set.seed(123) mvrnonnorm(20, c(a = 1, b = 2), matrix(c(10, 2, 2, 5), 2, 2), skewness = c(5, 2), kurtosis = c(3, 3)) } \references{ Vale, C. D. & Maurelli, V. A. (1983). Simulating multivariate nonormal distributions. \emph{Psychometrika, 48}(3), 465--471. \doi{10.1007/BF02293687} } \author{ The original function is the \code{\link[lavaan:simulateData]{lavaan::simulateData()}} function written by Yves Rosseel in the \code{lavaan} package. The function is adjusted for a convenient usage by Sunthud Pornprasertmanit (\email{psunthud@gmail.com}). Terrence D. Jorgensen added the feature to retain variable names from \code{mu} or \code{Sigma}. } semTools/man/partialInvariance.Rd0000644000176200001440000003141014764270501016562 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/partialInvariance.R \name{partialInvariance} \alias{partialInvariance} \alias{partialInvarianceCat} \title{Partial Measurement Invariance Testing Across Groups} \usage{ partialInvariance(fit, type, free = NULL, fix = NULL, refgroup = 1, poolvar = TRUE, p.adjust = "none", fbound = 2, return.fit = FALSE, method = "satorra.bentler.2001") partialInvarianceCat(fit, type, free = NULL, fix = NULL, refgroup = 1, poolvar = TRUE, p.adjust = "none", return.fit = FALSE, method = "satorra.bentler.2001") } \arguments{ \item{fit}{A list of models for invariance testing. Each model should be assigned by appropriate names (see details). The result from \code{\link[=measurementInvariance]{measurementInvariance()}} or \code{\link[=measurementInvarianceCat]{measurementInvarianceCat()}} could be used in this argument directly.} \item{type}{The types of invariance testing: "metric", "scalar", "strict", or "means"} \item{free}{A vector of variable names that are free across groups in advance. If partial mean invariance is tested, this argument represents a vector of factor names that are free across groups.} \item{fix}{A vector of variable names that are constrained to be equal across groups in advance. If partial mean invariance is tested, this argument represents a vector of factor names that are fixed across groups.} \item{refgroup}{The reference group used to make the effect size comparison with the other groups.} \item{poolvar}{If \code{TRUE}, the variances are pooled across group for standardization. Otherwise, the variances of the reference group are used for standardization.} \item{p.adjust}{The method used to adjust p values. See \code{\link[stats:p.adjust]{stats::p.adjust()}} for the options for adjusting p values. The default is to not use any corrections.} \item{fbound}{The z-scores of factor that is used to calculate the effect size of the loading difference proposed by Millsap and Olivera-Aguilar (2012).} \item{return.fit}{Return the submodels fitted by this function} \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} for available options} } \value{ A list of results are provided. The list will consists of at least two elements: \enumerate{ \item \code{estimates}: The results of parameter estimates including pooled estimates (\code{poolest}), the estimates for each group, standardized estimates for each group (\code{std}), the difference in standardized values, and the effect size statistic (\emph{q} for factor loading difference and \emph{h} for error variance difference). See the details of this effect size statistic by running \code{vignette("partialInvariance")}. In the \code{partialInvariance} function, the additional effect statistics proposed by Millsap and Olivera-Aguilar (2012) are provided. For factor loading, the additional outputs are the observed mean difference (\code{diff_mean}), the mean difference if factor scores are low (\code{low_fscore}), and the mean difference if factor scores are high (\code{high_fscore}). The low factor score is calculated by (a) finding the factor scores that its \emph{z} score equals -\code{bound} (the default is \eqn{-2}) from all groups and (b) picking the minimum value among the factor scores. The high factor score is calculated by (a) finding the factor scores that its \emph{z} score equals \code{bound} (default = 2) from all groups and (b) picking the maximum value among the factor scores. For measurement intercepts, the additional outputs are the observed means difference (\code{diff_mean}) and the proportion of the differences in the intercepts over the observed means differences (\code{propdiff}). For error variances, the additional outputs are the proportion of the difference in error variances over the difference in observed variances (\code{propdiff}). \item \code{results}: Statistical tests as well as the change in CFI are provided. \eqn{\chi^2} and \emph{p} value are provided for all methods. \item \code{models}: The submodels used in the \code{free} and \code{fix} methods, as well as the nested and parent models. The nested and parent models will be changed from the original models if \code{free} or \code{fit} arguments are specified. } } \description{ This test will provide partial invariance testing by (a) freeing a parameter one-by-one from nested model and compare with the original nested model or (b) fixing (or constraining) a parameter one-by-one from the parent model and compare with the original parent model. This function only works with congeneric models. The \code{partialInvariance} is used for continuous variable. The \code{partialInvarianceCat} is used for categorical variables. } \details{ There are four types of partial invariance testing: \itemize{ \item Partial weak invariance. The model named 'fit.configural' from the list of models is compared with the model named 'fit.loadings'. Each loading will be freed or fixed from the metric and configural invariance models respectively. The modified models are compared with the original model. Note that the objects in the list of models must have the names of "fit.configural" and "fit.loadings". Users may use "metric", "weak", "loading", or "loadings" in the \code{type} argument. Note that, for testing invariance on marker variables, other variables will be assigned as marker variables automatically. \item Partial strong invariance. The model named 'fit.loadings' from the list of models is compared with the model named either 'fit.intercepts' or 'fit.thresholds'. Each intercept will be freed or fixed from the scalar and metric invariance models respectively. The modified models are compared with the original model. Note that the objects in the list of models must have the names of "fit.loadings" and either "fit.intercepts" or "fit.thresholds". Users may use "scalar", "strong", "intercept", "intercepts", "threshold", or "thresholds" in the \code{type} argument. Note that, for testing invariance on marker variables, other variables will be assigned as marker variables automatically. Note that if all variables are dichotomous, scalar invariance testing is not available. \item Partial strict invariance. The model named either 'fit.intercepts' or 'fit.thresholds' (or 'fit.loadings') from the list of models is compared with the model named 'fit.residuals'. Each residual variance will be freed or fixed from the strict and scalar (or metric) invariance models respectively. The modified models are compared with the original model. Note that the objects in the list of models must have the names of "fit.residuals" and either "fit.intercepts", "fit.thresholds", or "fit.loadings". Users may use "strict", "residual", "residuals", "error", or "errors" in the \code{type} argument. \item Partial mean invariance. The model named either 'fit.intercepts' or 'fit.thresholds' (or 'fit.residuals' or 'fit.loadings') from the list of models is compared with the model named 'fit.means'. Each factor mean will be freed or fixed from the means and scalar (or strict or metric) invariance models respectively. The modified models are compared with the original model. Note that the objects in the list of models must have the names of "fit.means" and either "fit.residuals", "fit.intercepts", "fit.thresholds", or "fit.loadings". Users may use "means" or "mean" in the \code{type} argument. } Two types of comparisons are used in this function: \enumerate{ \item \code{free}: The nested model is used as a template. Then, one parameter indicating the differences between two models is free. The new model is compared with the nested model. This process is repeated for all differences between two models. The likelihood-ratio test and the difference in CFI are provided. \item \code{fix}: The parent model is used as a template. Then, one parameter indicating the differences between two models is fixed or constrained to be equal to other parameters. The new model is then compared with the parent model. This process is repeated for all differences between two models. The likelihood-ratio test and the difference in CFI are provided. \item \code{wald}: This method is similar to the \code{fix} method. However, instead of building a new model and compare them with likelihood-ratio test, multivariate wald test is used to compare equality between parameter estimates. See \code{\link[lavaan:lavTestWald]{lavaan::lavTestWald()}} for further details. Note that if any rows of the contrast cannot be summed to 0, the Wald test is not provided, such as comparing two means where one of the means is fixed as 0. This test statistic is not as accurate as likelihood-ratio test provided in \code{fix}. I provide it here in case that likelihood-ratio test fails to converge. } Note that this function does not adjust for the inflated Type I error rate from multiple tests. The degree of freedom of all tests would be the number of groups minus 1. The details of standardized estimates and the effect size used for each parameters are provided in the vignettes by running \code{vignette("partialInvariance")}. } \examples{ ## Conduct weak invariance testing manually by using fixed-factor ## method of scale identification library(lavaan) conf <- " f1 =~ NA*x1 + x2 + x3 f2 =~ NA*x4 + x5 + x6 f1 ~~ c(1, 1)*f1 f2 ~~ c(1, 1)*f2 " weak <- " f1 =~ NA*x1 + x2 + x3 f2 =~ NA*x4 + x5 + x6 f1 ~~ c(1, NA)*f1 f2 ~~ c(1, NA)*f2 " configural <- cfa(conf, data = HolzingerSwineford1939, std.lv = TRUE, group="school") weak <- cfa(weak, data = HolzingerSwineford1939, group="school", group.equal="loadings") models <- list(fit.configural = configural, fit.loadings = weak) partialInvariance(models, "metric") \donttest{ partialInvariance(models, "metric", free = "x5") # "x5" is free across groups in advance partialInvariance(models, "metric", fix = "x4") # "x4" is fixed across groups in advance ## Use the result from the measurementInvariance function HW.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' models2 <- measurementInvariance(model = HW.model, data=HolzingerSwineford1939, group="school") partialInvariance(models2, "scalar") ## Conduct weak invariance testing manually by using fixed-factor ## method of scale identification for dichotomous variables f <- rnorm(1000, 0, 1) u1 <- 0.9*f + rnorm(1000, 1, sqrt(0.19)) u2 <- 0.8*f + rnorm(1000, 1, sqrt(0.36)) u3 <- 0.6*f + rnorm(1000, 1, sqrt(0.64)) u4 <- 0.7*f + rnorm(1000, 1, sqrt(0.51)) u1 <- as.numeric(cut(u1, breaks = c(-Inf, 0, Inf))) u2 <- as.numeric(cut(u2, breaks = c(-Inf, 0.5, Inf))) u3 <- as.numeric(cut(u3, breaks = c(-Inf, 0, Inf))) u4 <- as.numeric(cut(u4, breaks = c(-Inf, -0.5, Inf))) g <- rep(c(1, 2), 500) dat2 <- data.frame(u1, u2, u3, u4, g) configural2 <- " f1 =~ NA*u1 + u2 + u3 + u4 u1 | c(t11, t11)*t1 u2 | c(t21, t21)*t1 u3 | c(t31, t31)*t1 u4 | c(t41, t41)*t1 f1 ~~ c(1, 1)*f1 f1 ~ c(0, NA)*1 u1 ~~ c(1, 1)*u1 u2 ~~ c(1, NA)*u2 u3 ~~ c(1, NA)*u3 u4 ~~ c(1, NA)*u4 " outConfigural2 <- cfa(configural2, data = dat2, group = "g", parameterization = "theta", estimator = "wlsmv", ordered = c("u1", "u2", "u3", "u4")) weak2 <- " f1 =~ NA*u1 + c(f11, f11)*u1 + c(f21, f21)*u2 + c(f31, f31)*u3 + c(f41, f41)*u4 u1 | c(t11, t11)*t1 u2 | c(t21, t21)*t1 u3 | c(t31, t31)*t1 u4 | c(t41, t41)*t1 f1 ~~ c(1, NA)*f1 f1 ~ c(0, NA)*1 u1 ~~ c(1, 1)*u1 u2 ~~ c(1, NA)*u2 u3 ~~ c(1, NA)*u3 u4 ~~ c(1, NA)*u4 " outWeak2 <- cfa(weak2, data = dat2, group = "g", parameterization = "theta", estimator = "wlsmv", ordered = c("u1", "u2", "u3", "u4")) modelsCat <- list(fit.configural = outConfigural2, fit.loadings = outWeak2) partialInvarianceCat(modelsCat, type = "metric") partialInvarianceCat(modelsCat, type = "metric", free = "u2") partialInvarianceCat(modelsCat, type = "metric", fix = "u3") ## Use the result from the measurementInvarianceCat function model <- ' f1 =~ u1 + u2 + u3 + u4 f2 =~ u5 + u6 + u7 + u8' modelsCat2 <- measurementInvarianceCat(model = model, data = datCat, group = "g", parameterization = "theta", estimator = "wlsmv", strict = TRUE) partialInvarianceCat(modelsCat2, type = "scalar") } } \references{ Millsap, R. E., & Olivera-Aguilar, M. (2012). Investigating measurement invariance using confirmatory factor analysis. In R. H. Hoyle (Ed.), \emph{Handbook of structural equation modeling} (pp. 380--392). New York, NY: Guilford. } \seealso{ \code{\link[=measurementInvariance]{measurementInvariance()}} for measurement invariance for continuous variables; \code{\link[=measurementInvarianceCat]{measurementInvarianceCat()}} for measurement invariance for categorical variables; \code{\link[lavaan:lavTestWald]{lavaan::lavTestWald()}} for multivariate Wald test } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/clipboard.Rd0000644000176200001440000000664414764270501015100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clipboard.R \name{clipboard} \alias{clipboard} \alias{saveFile} \title{Copy or save the result of \code{lavaan} or \code{FitDiff} objects into a clipboard or a file} \usage{ clipboard(object, what = "summary", ...) saveFile(object, file, what = "summary", tableFormat = FALSE, fit.measures = "default", writeArgs = list(), ...) } \arguments{ \item{object}{An object of class \link[lavaan:lavaan-class]{lavaan::lavaan} or \linkS4class{FitDiff}.} \item{what}{The attributes of the \code{lavaan} object to be copied in the clipboard. \code{"summary"} is to copy the screen provided from the \code{summary} function. \code{"mifit"} is to copy the result from the \code{\link[=miPowerFit]{miPowerFit()}} function. Other attributes listed in the \code{inspect} method in the \link[lavaan:lavaan-class]{lavaan::lavaan} could also be used, such as \code{"coef"}, \code{"se"}, \code{"fit"}, \code{"samp"}, and so on. Ignored for \linkS4class{FitDiff}-class objects.} \item{\dots}{Additional arguments when passing a \code{lavaan} object to the \code{summary} or \code{\link[=miPowerFit]{miPowerFit()}} function.} \item{file}{A file name used for saving the result.} \item{tableFormat}{If \code{TRUE}, save the result in the table format using tabs for separation. Otherwise, save the result as the output screen printed in the R console.} \item{fit.measures}{\code{character} vector specifying names of fit measures returned by \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}} to be copied/saved. Only relevant if \code{object} is class \linkS4class{FitDiff}.} \item{writeArgs}{\code{list} of additional arguments to be passed to \code{\link[utils:write.table]{utils::write.table()}}} } \value{ The resulting output will be saved into a clipboard or a file. If using the \code{clipboard} function, users may paste it in the other applications. } \description{ Copy or save the result of \code{lavaan} or \linkS4class{FitDiff} object into a clipboard or a file. From the clipboard, users may paste the result into the Microsoft Excel or spreadsheet application to create a table of the output. } \examples{ library(lavaan) HW.model <- ' visual =~ x1 + c1*x2 + x3 textual =~ x4 + c1*x5 + x6 speed =~ x7 + x8 + x9 ' fit <- cfa(HW.model, data = HolzingerSwineford1939, group = "school") if(interactive()){ # Copy the summary of the lavaan object clipboard(fit) # pass additional arguments to summary() method for class?lavaan clipboard(fit, rsquare = TRUE, standardized = TRUE, fit.measures = TRUE) # Copy modification indices and fit stats from the miPowerFit() function clipboard(fit, "mifit") # Copy the parameter estimates clipboard(fit, "coef") # Copy the standard errors clipboard(fit, "se") # Copy the sample statistics clipboard(fit, "samp") # Copy the fit measures clipboard(fit, "fit") # Save the summary of the lavaan object saveFile(fit, "out.txt") # Save modification indices and fit stats from the miPowerFit() function saveFile(fit, "out.txt", "mifit") # Save the parameter estimates saveFile(fit, "out.txt", "coef") # Save the standard errors saveFile(fit, "out.txt", "se") # Save the sample statistics saveFile(fit, "out.txt", "samp") # Save the fit measures saveFile(fit, "out.txt", "fit") } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/kurtosis.Rd0000644000176200001440000000341414632143413015007 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dataDiagnosis.R \name{kurtosis} \alias{kurtosis} \title{Finding excessive kurtosis} \usage{ kurtosis(object, population = FALSE) } \arguments{ \item{object}{A vector used to find a excessive kurtosis} \item{population}{\code{TRUE} to compute the parameter formula. \code{FALSE} to compute the sample statistic formula.} } \value{ A value of an excessive kurtosis with a test statistic if the population is specified as \code{FALSE} } \description{ Finding excessive kurtosis (\eqn{g_{2}}) of an object } \details{ The excessive kurtosis computed by default is \eqn{g_{2}}, the fourth standardized moment of the empirical distribution of \code{object}. The population parameter excessive kurtosis \eqn{\gamma_{2}} formula is \deqn{\gamma_{2} = \frac{\mu_{4}}{\mu^{2}_{2}} - 3,} where \eqn{\mu_{i}} denotes the \eqn{i} order central moment. The excessive kurtosis formula for sample statistic \eqn{g_{2}} is \deqn{g_{2} = \frac{k_{4}}{k^{2}_{2}} - 3,} where \eqn{k_{i}} are the \eqn{i} order \emph{k}-statistic. The standard error of the excessive kurtosis is \deqn{Var(\hat{g}_{2}) = \frac{24}{N}} where \eqn{N} is the sample size. } \examples{ kurtosis(1:5) } \references{ Weisstein, Eric W. (n.d.). \emph{Kurtosis.} Retrieved from \emph{MathWorld}--A Wolfram Web Resource: \url{http://mathworld.wolfram.com/Kurtosis.html} } \seealso{ \itemize{ \item \code{\link[=skew]{skew()}} Find the univariate skewness of a variable \item \code{\link[=mardiaSkew]{mardiaSkew()}} Find the Mardia's multivariate skewness of a set of variables \item \code{\link[=mardiaKurtosis]{mardiaKurtosis()}} Find the Mardia's multivariate kurtosis of a set of variables } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/findRMSEAsamplesize.Rd0000644000176200001440000000437114632143415016736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisRMSEA.R \name{findRMSEAsamplesize} \alias{findRMSEAsamplesize} \title{Find the minimum sample size for a given statistical power based on population RMSEA} \usage{ findRMSEAsamplesize(rmsea0, rmseaA, df, power = 0.8, alpha = 0.05, group = 1) } \arguments{ \item{rmsea0}{Null RMSEA} \item{rmseaA}{Alternative RMSEA} \item{df}{Model degrees of freedom} \item{power}{Desired statistical power to reject misspecified model (test of close fit) or retain good model (test of not-close fit)} \item{alpha}{Alpha level used in power calculations} \item{group}{The number of group that is used to calculate RMSEA.} } \description{ Find the minimum sample size for a specified statistical power based on population RMSEA. This function can be applied for both test of close fit and test of not-close fit (MacCallum, Browne, & Suguwara, 1996) } \details{ This function find the minimum sample size for a specified power based on an iterative routine. The sample size keep increasing until the calculated power from \code{\link[=findRMSEApower]{findRMSEApower()}} function is just over the specified power. If \code{group} is greater than 1, the resulting sample size is the sample size per group. } \examples{ findRMSEAsamplesize(rmsea0 = .05, rmseaA = .08, df = 20, power = 0.80) } \references{ MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis and determination of sample size for covariance structure modeling. \emph{Psychological Methods, 1}(2), 130--149. \doi{10.1037/1082-989X.1.2.130} Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. (2021). Analytical power calculations for structural equation modeling: A tutorial and Shiny app. \emph{Behavior Research Methods, 53}, 1385--1406. \doi{10.3758/s13428-020-01479-0} } \seealso{ \itemize{ \item \code{\link[=plotRMSEApower]{plotRMSEApower()}} to plot the statistical power based on population RMSEA given the sample size \item \code{\link[=plotRMSEAdist]{plotRMSEAdist()}} to visualize the RMSEA distributions \item \code{\link[=findRMSEApower]{findRMSEApower()}} to find the statistical power based on population RMSEA given a sample size } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/calculate.D2-deprecated.Rd0000644000176200001440000000630114633640443017427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI.R \name{calculate.D2-deprecated} \alias{calculate.D2-deprecated} \title{Calculate the "D2" statistic} \usage{ calculate.D2(w, DF = 0L, asymptotic = FALSE) } \arguments{ \item{w}{\code{numeric} vector of Wald \eqn{\chi^2} statistics. Can also be Wald \emph{z} statistics, which will be internally squared to make \eqn{\chi^2} statistics with one \emph{df} (must set \code{DF = 0L}).} \item{DF}{degrees of freedom (\emph{df}) of the \eqn{\chi^2} statistics. If \code{DF = 0L} (default), \code{w} is assumed to contain \emph{z} statistics, which will be internally squared.} \item{asymptotic}{\code{logical}. If \code{FALSE} (default), the pooled test will be returned as an \emph{F}-distributed statistic with numerator (\code{df1}) and denominator (\code{df2}) degrees of freedom. If \code{TRUE}, the pooled \emph{F} statistic will be multiplied by its \code{df1} on the assumption that its \code{df2} is sufficiently large enough that the statistic will be asymptotically \eqn{\chi^2} distributed with \code{df1}.} } \value{ A \code{numeric} vector containing the test statistic, \emph{df}, its \emph{p} value, and 2 missing-data diagnostics: the relative invrease in variance (RIV, or average for multiparameter tests: ARIV) and the fraction missing information (FMI = ARIV / (1 + ARIV)). } \description{ This is a utility function used to calculate the "D2" statistic for pooling test statistics across multiple imputations. This function is called by several functions used for \linkS4class{OLDlavaan.mi} objects, such as \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}}, \code{\link[=lavTestWald.mi]{lavTestWald.mi()}}, and \code{\link[=lavTestScore.mi]{lavTestScore.mi()}}. But this function can be used for any general scenario because it only requires a vector of \eqn{\chi^2} statistics (one from each imputation) and the degrees of freedom for the test statistic. See Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010, chapter 8) for details about how it is calculated. } \examples{ ## generate a vector of chi-squared values, just for example DF <- 3 # degrees of freedom M <- 20 # number of imputations CHI <- rchisq(M, DF) ## pool the "results" calculate.D2(CHI, DF) # by default, an F statistic is returned calculate.D2(CHI, DF, asymptotic = TRUE) # asymptotically chi-squared ## generate standard-normal values, for an example of Wald z tests Z <- rnorm(M) calculate.D2(Z) # default DF = 0 will square Z to make chisq(DF = 1) ## F test is equivalent to a t test with the denominator DF } \references{ Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data. \emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} } \seealso{ \code{\link[=lavTestLRT.mi]{lavTestLRT.mi()}}, \code{\link[=lavTestWald.mi]{lavTestWald.mi()}}, \code{\link[=lavTestScore.mi]{lavTestScore.mi()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/maximalRelia.Rd0000644000176200001440000001144214753073632015542 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reliability.R \name{maximalRelia} \alias{maximalRelia} \title{Calculate maximal reliability} \usage{ maximalRelia(object, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object, expected to contain only exogenous common factors (i.e., a CFA model).} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ Maximal reliability values of each group. The maximal-reliability weights are also provided. Users may extracted the weighted by the \code{attr} function (see example below). } \description{ Calculate maximal reliability of a scale } \details{ Given that a composite score (\eqn{W}) is a weighted sum of item scores: \deqn{ W = \bold{w}^\prime \bold{x} ,} where \eqn{\bold{x}} is a \eqn{k \times 1} vector of the scores of each item, \eqn{\bold{w}} is a \eqn{k \times 1} weight vector of each item, and \eqn{k} represents the number of items. Then, maximal reliability is obtained by finding \eqn{\bold{w}} such that reliability attains its maximum (Li, 1997; Raykov, 2012). Note that the reliability can be obtained by \deqn{ \rho = \frac{\bold{w}^\prime \bold{S}_T \bold{w}}{\bold{w}^\prime \bold{S}_X \bold{w}}} where \eqn{\bold{S}_T} is the covariance matrix explained by true scores and \eqn{\bold{S}_X} is the observed covariance matrix. Numerical method is used to find \eqn{\bold{w}} in this function. For continuous items, \eqn{\bold{S}_T} can be calculated by \deqn{ \bold{S}_T = \Lambda \Psi \Lambda^\prime,} where \eqn{\Lambda} is the factor loading matrix and \eqn{\Psi} is the covariance matrix among factors. \eqn{\bold{S}_X} is directly obtained by covariance among items. For categorical items, Green and Yang's (2009) method is used for calculating \eqn{\bold{S}_T} and \eqn{\bold{S}_X}. The element \eqn{i} and \eqn{j} of \eqn{\bold{S}_T} can be calculated by \deqn{ \left[\bold{S}_T\right]_{ij} = \sum^{C_i - 1}_{c_i = 1} \sum^{C_j - 1}_{c_j - 1} \Phi_2\left( \tau_{x_{c_i}}, \tau_{x_{c_j}}, \left[ \Lambda \Psi \Lambda^\prime \right]_{ij} \right) - \sum^{C_i - 1}_{c_i = 1} \Phi_1(\tau_{x_{c_i}}) \sum^{C_j - 1}_{c_j - 1} \Phi_1(\tau_{x_{c_j}}),} where \eqn{C_i} and \eqn{C_j} represents the number of thresholds in Items \eqn{i} and \eqn{j}, \eqn{\tau_{x_{c_i}}} represents the threshold \eqn{c_i} of Item \eqn{i}, \eqn{\tau_{x_{c_j}}} represents the threshold \eqn{c_i} of Item \eqn{j}, \eqn{ \Phi_1(\tau_{x_{c_i}})} is the cumulative probability of \eqn{\tau_{x_{c_i}}} given a univariate standard normal cumulative distribution and \eqn{\Phi_2\left( \tau_{x_{c_i}}, \tau_{x_{c_j}}, \rho \right)} is the joint cumulative probability of \eqn{\tau_{x_{c_i}}} and \eqn{\tau_{x_{c_j}}} given a bivariate standard normal cumulative distribution with a correlation of \eqn{\rho} Each element of \eqn{\bold{S}_X} can be calculated by \deqn{ \left[\bold{S}_T\right]_{ij} = \sum^{C_i - 1}_{c_i = 1} \sum^{C_j - 1}_{c_j - 1} \Phi_2\left( \tau_{V_{c_i}}, \tau_{V_{c_j}}, \rho^*_{ij} \right) - \sum^{C_i - 1}_{c_i = 1} \Phi_1(\tau_{V_{c_i}}) \sum^{C_j - 1}_{c_j - 1} \Phi_1(\tau_{V_{c_j}}),} where \eqn{\rho^*_{ij}} is a polychoric correlation between Items \eqn{i} and \eqn{j}. } \examples{ total <- 'f =~ x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 ' fit <- cfa(total, data = HolzingerSwineford1939) maximalRelia(fit) # Extract the weight mr <- maximalRelia(fit) attr(mr, "weight") } \references{ Li, H. (1997). A unifying expression for the maximal reliability of a linear composite. \emph{Psychometrika, 62}(2), 245--249. \doi{10.1007/BF02295278} Raykov, T. (2012). Scale construction and development using structural equation modeling. In R. H. Hoyle (Ed.), \emph{Handbook of structural equation modeling} (pp. 472--494). New York, NY: Guilford. } \seealso{ \code{\link[=reliability]{reliability()}} for reliability of an unweighted composite score } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/indProd.Rd0000644000176200001440000001200214764270501014521 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/indProd.R \name{indProd} \alias{indProd} \alias{orthogonalize} \title{Make products of indicators using no centering, mean centering, double-mean centering, or residual centering} \usage{ indProd(data, var1, var2, var3 = NULL, match = TRUE, meanC = TRUE, residualC = FALSE, doubleMC = TRUE, namesProd = NULL) orthogonalize(data, var1, var2, var3 = NULL, match = TRUE, namesProd = NULL) } \arguments{ \item{data}{The desired data to be transformed.} \item{var1}{Names or indices of the variables loaded on the first factor} \item{var2}{Names or indices of the variables loaded on the second factor} \item{var3}{Names or indices of the variables loaded on the third factor (for three-way interaction)} \item{match}{Specify \code{TRUE} to use match-paired approach (Marsh, Wen, & Hau, 2004). If \code{FALSE}, the resulting products are all possible products.} \item{meanC}{Specify \code{TRUE} for mean centering the main effect indicator before making the products} \item{residualC}{Specify \code{TRUE} for residual centering the products by the main effect indicators (Little, Bovaird, & Widaman, 2006).} \item{doubleMC}{Specify \code{TRUE} for centering the resulting products (Lin et. al., 2010)} \item{namesProd}{The names of resulting products} } \value{ The original data attached with the products. } \description{ The \code{indProd} function will make products of indicators using no centering, mean centering, double-mean centering, or residual centering. The \code{orthogonalize} function is the shortcut of the \code{indProd} function to make the residual-centered indicators products. } \examples{ ## Mean centering / two-way interaction / match-paired dat <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6) ## Residual centering / two-way interaction / match-paired dat2 <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6, match = FALSE, meanC = FALSE, residualC = TRUE, doubleMC = FALSE) ## Double-mean centering / two-way interaction / match-paired dat3 <- indProd(attitude[ , -1], var1 = 1:3, var2 = 4:6, match = FALSE, meanC = TRUE, residualC = FALSE, doubleMC = TRUE) ## Mean centering / three-way interaction / match-paired dat4 <- indProd(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6) ## Residual centering / three-way interaction / match-paired dat5 <- orthogonalize(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6, match = FALSE) ## Double-mean centering / three-way interaction / match-paired dat6 <- indProd(attitude[ , -1], var1 = 1:2, var2 = 3:4, var3 = 5:6, match = FALSE, meanC = TRUE, residualC = TRUE, doubleMC = TRUE) ## To add product-indicators to multiple-imputed data sets \donttest{ HSMiss <- HolzingerSwineford1939[ , c(paste0("x", 1:9), "ageyr","agemo")] set.seed(12345) HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) age <- HSMiss$ageyr + HSMiss$agemo/12 HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) library(Amelia) set.seed(12345) HS.amelia <- amelia(HSMiss, m = 3, p2s = FALSE) imps <- HS.amelia$imputations # extract a list of imputations ## apply indProd() to the list of data.frames imps2 <- lapply(imps, indProd, var1 = c("x1","x2","x3"), var2 = c("x4","x5","x6")) ## verify: lapply(imps2, head) } } \references{ Marsh, H. W., Wen, Z. & Hau, K. T. (2004). Structural equation models of latent interactions: Evaluation of alternative estimation strategies and indicator construction. \emph{Psychological Methods, 9}(3), 275--300. \doi{10.1037/1082-989X.9.3.275} Lin, G. C., Wen, Z., Marsh, H. W., & Lin, H. S. (2010). Structural equation models of latent interactions: Clarification of orthogonalizing and double-mean-centering strategies. \emph{Structural Equation Modeling, 17}(3), 374--391. \doi{10.1080/10705511.2010.488999} Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of orthogonalizing powered and product terms: Implications for modeling interactions among latent variables. \emph{Structural Equation Modeling, 13}(4), 497--519. \doi{10.1207/s15328007sem1304_1} } \seealso{ \itemize{ \item \code{\link[=probe2WayMC]{probe2WayMC()}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. \item \code{\link[=probe3WayMC]{probe3WayMC()}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. \item \code{\link[=probe2WayRC]{probe2WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=probe3WayRC]{probe3WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=plotProbe]{plotProbe()}} Plot the simple intercepts and slopes of the latent interaction. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Alexander Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) } semTools/man/lavaan2emmeans.Rd0000644000176200001440000001630114752750211016020 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/emmeans_lavaan.R \name{lavaan2emmeans} \alias{lavaan2emmeans} \alias{recover_data.lavaan} \alias{emm_basis.lavaan} \title{\code{emmeans} Support Functions for \code{lavaan} Models} \usage{ recover_data.lavaan(object, lavaan.DV, data = NULL, ...) emm_basis.lavaan(object, trms, xlev, grid, lavaan.DV, ...) } \arguments{ \item{object}{An object of class \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. See \strong{Details}.} \item{lavaan.DV}{\code{character} string naming the variable(s) for which expected marginal means / trends should be produced. A vector of names indicates a multivariate outcome, treated by default as repeated measures.} \item{data}{An optional \code{data.frame} without missing values, to be passed when \code{missing="FIML"} estimation was useed, thus avoiding a reference-grid with missing values.} \item{...}{Further arguments passed to \code{emmeans::recover_data.lm} or \code{emmeans::emm_basis.lm}} \item{trms, xlev, grid}{See \code{emmeans::emm_basis}} } \description{ Provide emmeans support for lavaan objects } \details{ \subsection{Supported DVs}{ \code{lavaan.DV} must be an \emph{endogenous variable}, by appearing on the left-hand side of either a regression operator (\code{"~"}) or an intercept operator (\code{"~1"}), or both. \cr\cr \code{lavaan.DV} can also be a vector of endogenous variable, in which case they will be treated by \code{emmeans} as a multivariate outcome (often, this indicates repeated measures) represented by an additional factor named \code{rep.meas} by default. The \verb{mult.name=} argument can be used to overwrite this default name. } \subsection{Unsupported Models}{ This functionality does not support the following models: \itemize{ \item Multi-level models are not supported. \item Models not fit to a \code{data.frame} (i.e., models fit to a covariance matrix). } } \subsection{Dealing with Fixed Parameters}{ Fixed parameters (set with \code{lavaan}'s modifiers) are treated as-is: their values are set by the users, and they have a \emph{SE} of 0 (as such, they do not co-vary with any other parameter). } \subsection{Dealing with Multigroup Models}{ If a multigroup model is supplied, a factor is added to the reference grid, the name matching the \code{group} argument supplied when fitting the model. \emph{Note that you must set} \code{nesting = NULL}. } \subsection{Dealing with Missing Data}{ Limited testing suggests that these functions do work when the model was fit to incomplete data. } \subsection{Dealing with Factors}{ By default \code{emmeans} recognizes binary variables (0,1) as a "factor" with two levels (and not a continuous variable). With some clever contrast defenitions it should be possible to get the desired emmeans / contasts. See example below. } } \examples{ \dontrun{ library(lavaan) library(emmeans) #### Moderation Analysis #### mean_sd <- function(x) mean(x) + c(-sd(x), 0, sd(x)) model <- ' # regressions Sepal.Length ~ b1 * Sepal.Width + b2 * Petal.Length + b3 * Sepal.Width:Petal.Length # define mean parameter label for centered math for use in simple slopes Sepal.Width ~ Sepal.Width.mean * 1 # define variance parameter label for centered math for use in simple slopes Sepal.Width ~~ Sepal.Width.var * Sepal.Width # simple slopes for condition effect SD.below := b2 + b3 * (Sepal.Width.mean - sqrt(Sepal.Width.var)) mean := b2 + b3 * (Sepal.Width.mean) SD.above := b2 + b3 * (Sepal.Width.mean + sqrt(Sepal.Width.var)) ' semFit <- sem(model = model, data = iris) ## Compare simple slopes # From `emtrends` test( emtrends(semFit, ~ Sepal.Width, "Petal.Length", lavaan.DV = "Sepal.Length", cov.red = mean_sd) ) # From lavaan parameterEstimates(semFit, output = "pretty")[13:15, ] # Identical slopes. # SEs differ due to lavaan estimating uncertainty of the mean / SD # of Sepal.Width, whereas emmeans uses the mean+-SD as is (fixed). #### Latent DV #### model <- ' LAT1 =~ Sepal.Length + Sepal.Width LAT1 ~ b1 * Petal.Width + 1 * Petal.Length Petal.Length ~ Petal.Length.mean * 1 V1 := 1 * Petal.Length.mean + 1 * b1 V2 := 1 * Petal.Length.mean + 2 * b1 ' semFit <- sem(model = model, data = iris, std.lv = TRUE) ## Compare emmeans # From emmeans test( emmeans(semFit, ~ Petal.Width, lavaan.DV = "LAT1", at = list(Petal.Width = 1:2)) ) # From lavaan parameterEstimates(semFit, output = "pretty")[15:16, ] # Identical means. # SEs differ due to lavaan estimating uncertainty of the mean # of Petal.Length, whereas emmeans uses the mean as is. #### Multi-Variate DV #### model <- ' ind60 =~ x1 + x2 + x3 # metric invariance dem60 =~ y1 + a*y2 + b*y3 + c*y4 dem65 =~ y5 + a*y6 + b*y7 + c*y8 # scalar invariance y1 + y5 ~ d*1 y2 + y6 ~ e*1 y3 + y7 ~ f*1 y4 + y8 ~ g*1 # regressions (slopes differ: interaction with time) dem60 ~ b1*ind60 dem65 ~ b2*ind60 + NA*1 + Mean.Diff*1 # residual correlations y1 ~~ y5 y2 ~~ y4 + y6 y3 ~~ y7 y4 ~~ y8 y6 ~~ y8 # conditional mean differences (besides mean(ind60) == 0) low := (-1*b2 + Mean.Diff) - (-1*b1) # 1 SD below M high := (b2 + Mean.Diff) - b1 # 1 SD above M ' semFit <- sem(model, data = PoliticalDemocracy) ## Compare contrasts # From emmeans emmeans(semFit, pairwise ~ rep.meas|ind60, lavaan.DV = c("dem60","dem65"), at = list(ind60 = c(-1,1)))[[2]] # From lavaan parameterEstimates(semFit, output = "pretty")[49:50, ] #### Multi Group #### model <- 'x1 ~ c(int1, int2)*1 + c(b1, b2)*ageyr diff_11 := (int2 + b2*11) - (int1 + b1*11) diff_13 := (int2 + b2*13) - (int1 + b1*13) diff_15 := (int2 + b2*15) - (int1 + b1*15) ' semFit <- sem(model, group = "school", data = HolzingerSwineford1939) ## Compare contrasts # From emmeans (note `nesting = NULL`) emmeans(semFit, pairwise ~ school | ageyr, lavaan.DV = "x1", at = list(ageyr = c(11, 13, 15)), nesting = NULL)[[2]] # From lavaan parameterEstimates(semFit, output = "pretty") #### Dealing with factors #### warpbreaks <- cbind(warpbreaks, model.matrix(~ wool + tension, data = warpbreaks)) model <- " # Split for convenience breaks ~ 1 breaks ~ woolB breaks ~ tensionM + tensionH breaks ~ woolB:tensionM + woolB:tensionH " semFit <- sem(model, warpbreaks) ## Compare contrasts # From lm -> emmeans lmFit <- lm(breaks ~ wool * tension, data = warpbreaks) lmEM <- emmeans(lmFit, ~ tension + wool) contrast(lmEM, method = data.frame(L_all = c(-1, .05, 0.5), M_H = c(0, 1, -1)), by = "wool") # From lavaan -> emmeans lavEM <- emmeans(semFit, ~ tensionM + tensionH + woolB, lavaan.DV = "breaks") contrast(lavEM, method = list( "L_all|A" = c(c(-1, .05, 0.5, 0), rep(0, 4)), "M_H |A" = c(c(0, 1, -1, 0), rep(0, 4)), "L_all|A" = c(rep(0, 4), c(-1, .05, 0.5, 0)), "M_H |A" = c(rep(0, 4), c(0, 1, -1, 0)) )) } } \author{ Mattan S. Ben-Shachar (Ben-Gurion University of the Negev; \email{matanshm@post.bgu.ac.il}) } semTools/man/probe2WayRC.Rd0000644000176200001440000001704114753073632015235 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/probeInteraction.R \name{probe2WayRC} \alias{probe2WayRC} \title{Probing two-way interaction on the residual-centered latent interaction} \usage{ probe2WayRC(fit, nameX, nameY, modVar, valProbe, group = 1L, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{fit}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object with a latent 2-way interaction.} \item{nameX}{\code{character} vector of all 3 factor names used as the predictors. The lower-order factors must be listed first, and the final name must be the latent interaction factor.} \item{nameY}{The name of factor that is used as the dependent variable.} \item{modVar}{The name of factor that is used as a moderator. The effect of the other independent factor will be probed at each value of the moderator variable listed in \code{valProbe}.} \item{valProbe}{The values of the moderator that will be used to probe the effect of the focal predictor.} \item{group}{In multigroup models, the label of the group for which the results will be returned. Must correspond to one of \code{lavInspect(fit, "group.label")}, or an integer corresponding to which of those group labels.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Ignored unless \code{fit} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ A list with two elements: \enumerate{ \item \code{SimpleIntercept}: The simple intercepts given each value of the moderator. \item \code{SimpleSlope}: The simple slopes given each value of the moderator. } In each element, the first column represents the values of the moderators specified in the \code{valProbe} argument. The second column is the simple intercept or simple slope. The third column is the standard error of the simple intercept or slope. The fourth column is the Wald (\emph{z}) statistic, and the fifth column is the associated \emph{p} value testing the null hypothesis that each simple intercept or slope is 0. } \description{ Probing interaction for simple intercept and simple slope for the residual-centered latent two-way interaction (Geldhof et al., 2013) } \details{ Before using this function, researchers need to make the products of the indicators between the first-order factors and residualize the products by the original indicators (Lance, 1988; Little, Bovaird, & Widaman, 2006). The process can be automated by the \code{\link[=indProd]{indProd()}} function. Note that the indicator products can be made for all possible combination or matched-pair approach (Marsh et al., 2004). Next, the hypothesized model with the regression with latent interaction will be used to fit all original indicators and the product terms. To use this function the model must be fit with a mean structure. See the example for how to fit the product term below. Once the lavaan result is obtained, this function will be used to probe the interaction. The probing process on residual-centered latent interaction is based on transforming the residual-centered result into the no-centered result. See Geldhof et al. (2013) for further details. Note that this approach is based on a strong assumption that the first-order latent variables are normally distributed. The probing process is applied after the no-centered result (parameter estimates and their covariance matrix among parameter estimates) has been computed. See the \code{\link[=probe2WayMC]{probe2WayMC()}} for further details. } \examples{ dat2wayRC <- orthogonalize(dat2way, 1:3, 4:6) model1 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f12 =~ x1.x4 + x2.x5 + x3.x6 f3 =~ x7 + x8 + x9 f3 ~ f1 + f2 + f12 f12 ~~ 0*f1 + 0*f2 x1 + x4 + x1.x4 + x7 ~ 0*1 # identify latent means f1 + f2 + f12 + f3 ~ NA*1 " fitRC2way <- sem(model1, data = dat2wayRC, meanstructure = TRUE) summary(fitRC2way) probe2WayRC(fitRC2way, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) ## can probe multigroup models, one group at a time dat2wayRC$g <- 1:2 model2 <- " f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f12 =~ x1.x4 + x2.x5 + x3.x6 f3 =~ x7 + x8 + x9 f3 ~ c(b1.g1, b1.g2)*f1 + c(b2.g1, b2.g2)*f2 + c(b12.g1, b12.g2)*f12 f12 ~~ 0*f1 + 0*f2 x1 + x4 + x1.x4 + x7 ~ 0*1 # identify latent means f1 + f2 + f12 ~ NA*1 f3 ~ NA*1 + c(b0.g1, b0.g2)*1 " fit2 <- sem(model2, data = dat2wayRC, group = "g") probe2WayRC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1)) # group = 1 by default probe2WayRC(fit2, nameX = c("f1", "f2", "f12"), nameY = "f3", modVar = "f2", valProbe = c(-1, 0, 1), group = 2) } \references{ Tutorial: Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting latent variable interactions using the \code{semTools} package. \emph{Psych, 3}(3), 322--335. \doi{10.3390/psych3030024} Background literature: Lance, C. E. (1988). Residual centering, exploratory and confirmatory moderator analysis, and decomposition of effects in path models containing interactions. \emph{Applied Psychological Measurement, 12}(2), 163--175. \doi{10.1177/014662168801200205} Little, T. D., Bovaird, J. A., & Widaman, K. F. (2006). On the merits of orthogonalizing powered and product terms: Implications for modeling interactions. \emph{Structural Equation Modeling, 13}(4), 497--519. \doi{10.1207/s15328007sem1304_1} Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of latent interactions: Evaluation of alternative estimation strategies and indicator construction. \emph{Psychological Methods, 9}(3), 275--300. \doi{10.1037/1082-989X.9.3.275} Geldhof, G. J., Pornprasertmanit, S., Schoemann, A. M., & Little, T. D. (2013). Orthogonalizing through residual centering: Extended applications and caveats. \emph{Educational and Psychological Measurement, 73}(1), 27--46. \doi{10.1177/0013164412445473} } \seealso{ \itemize{ \item \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. \item \code{\link[=probe2WayMC]{probe2WayMC()}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe3WayMC]{probe3WayMC()}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe3WayRC]{probe3WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=plotProbe]{plotProbe()}} Plot the simple intercepts and slopes of the latent interaction. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/singleParamTest.Rd0000644000176200001440000000761714632143417016243 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/singleParamTest.R \name{singleParamTest} \alias{singleParamTest} \title{Single Parameter Test Divided from Nested Model Comparison} \usage{ singleParamTest(model1, model2, return.fit = FALSE, method = "satorra.bentler.2001") } \arguments{ \item{model1}{Model 1.} \item{model2}{Model 2. Note that two models must be nested models. Further, the order of parameters in their parameter tables are the same. That is, nested models with different scale identifications may not be able to test by this function.} \item{return.fit}{Return the submodels fitted by this function} \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} for available options} } \value{ If \code{return.fit = FALSE}, the result tables are provided. \eqn{\chi^2} and \emph{p} value are provided for all methods. Note that the \eqn{\chi^2} is all based on 1 \emph{df}. Expected parameter changes and their standardized forms are also provided. If \code{return.fit = TRUE}, a list with two elements are provided. The first element is the tabular result. The second element is the submodels used in the \code{free} and \code{fix} methods. } \description{ In comparing two nested models, \eqn{\Delta\chi^2} test may indicate that two models are different. However, like other omnibus tests, researchers do not know which fixed parameters or constraints make these two models different. This function will help researchers identify the significant parameter. } \details{ This function first identifies the differences between these two models. The model with more free parameters is referred to as parent model and the model with fewer free parameters is referred to as nested model. Two tests are implemented here: \enumerate{ \item \code{free}: The nested model is used as a template. Then, one parameter indicating the differences between two models is freed. The new model is compared with the nested model. This process is repeated for all differences between two models. \item\code{fix}: The parent model is used as a template. Then, one parameter indicating the differences between two models is fixed or constrained to be equal to other parameters. The new model is then compared with the parent model. This process is repeated for all differences between two models. \item\code{mi}: No longer available because the test of modification indices is not consistent. For example, if two parameters are equality constrained, the modification index from the first parameter is not equal to the second parameter. } Note that this function does not adjust for the inflated Type I error rate from multiple tests. } \examples{ library(lavaan) # Nested model comparison by hand HS.model1 <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6' HS.model2 <- ' visual =~ a*x1 + a*x2 + a*x3 textual =~ b*x4 + b*x5 + b*x6' m1 <- cfa(HS.model1, data = HolzingerSwineford1939, std.lv = TRUE, estimator = "MLR") m2 <- cfa(HS.model2, data = HolzingerSwineford1939, std.lv = TRUE, estimator = "MLR") anova(m1, m2) singleParamTest(m1, m2) ## Nested model comparison from the measurementInvariance function HW.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' models <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, group = "school") singleParamTest(models[[1]], models[[2]]) ## Note that the comparison between metric (Model 2) and scalar invariance ## (Model 3) cannot be done by this function because the metric invariance ## model fixes factor means as 0 in Group 2 but the strong invariance model ## frees the factor means in Group 2. Users may use this function to compare ## scalar invariance (Model 3) to a homogeneous-means model. } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/dat3way.Rd0000644000176200001440000000246714632143413014507 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{dat3way} \alias{dat3way} \title{Simulated Dataset to Demonstrate Three-way Latent Interaction} \format{ A \code{data.frame} with 500 observations of 12 variables. \describe{ \item{x1}{The first indicator of the first independent factor} \item{x2}{The second indicator of the first independent factor} \item{x3}{The third indicator of the first independent factor} \item{x4}{The first indicator of the second independent factor} \item{x5}{The second indicator of the second independent factor} \item{x6}{The third indicator of the second independent factor} \item{x7}{The first indicator of the third independent factor} \item{x8}{The second indicator of the third independent factor} \item{x9}{The third indicator of the third independent factor} \item{x10}{The first indicator of the dependent factor} \item{x11}{The second indicator of the dependent factor} \item{x12}{The third indicator of the dependent factor} } } \source{ Data were generated by the \code{\link[MASS:mvrnorm]{MASS::mvrnorm()}} function in the \code{MASS} package. } \usage{ dat3way } \description{ A simulated data set with 3 independent factors and 1 dependent factor where each factor has three indicators } \examples{ head(dat3way) } \keyword{datasets} semTools/man/findRMSEApowernested.Rd0000644000176200001440000000363414632143415017122 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisNested.R \name{findRMSEApowernested} \alias{findRMSEApowernested} \title{Find power given a sample size in nested model comparison} \usage{ findRMSEApowernested(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, n, alpha = 0.05, group = 1) } \arguments{ \item{rmsea0A}{The \eqn{H_0} baseline RMSEA} \item{rmsea0B}{The \eqn{H_0} alternative RMSEA (trivial misfit)} \item{rmsea1A}{The \eqn{H_1} baseline RMSEA} \item{rmsea1B}{The \eqn{H_1} alternative RMSEA (target misfit to be rejected)} \item{dfA}{degree of freedom of the more-restricted model} \item{dfB}{degree of freedom of the less-restricted model} \item{n}{Sample size} \item{alpha}{The alpha level} \item{group}{The number of group in calculating RMSEA} } \description{ Find the sample size that the power in rejection the samples from the alternative pair of RMSEA is just over the specified power. } \examples{ findRMSEApowernested(rmsea0A = 0.06, rmsea0B = 0.05, rmsea1A = 0.08, rmsea1B = 0.05, dfA = 22, dfB = 20, n = 200, alpha = 0.05, group = 1) } \references{ MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing differences between nested covariance structure models: Power analysis and null hypotheses. \emph{Psychological Methods, 11}(1), 19--35. \doi{10.1037/1082-989X.11.1.19} } \seealso{ \itemize{ \item \code{\link[=plotRMSEApowernested]{plotRMSEApowernested()}} to plot the statistical power for nested model comparison based on population RMSEA given the sample size \item \code{\link[=findRMSEAsamplesizenested]{findRMSEAsamplesizenested()}} to find the minium sample size for a given statistical power in nested model comparison based on population RMSEA } } \author{ Bell Clinton Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/findRMSEApower.Rd0000644000176200001440000000517514632143415015721 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisRMSEA.R \name{findRMSEApower} \alias{findRMSEApower} \title{Find the statistical power based on population RMSEA} \usage{ findRMSEApower(rmsea0, rmseaA, df, n, alpha = 0.05, group = 1) } \arguments{ \item{rmsea0}{Null RMSEA} \item{rmseaA}{Alternative RMSEA} \item{df}{Model degrees of freedom} \item{n}{Sample size of a dataset} \item{alpha}{Alpha level used in power calculations} \item{group}{The number of group that is used to calculate RMSEA.} } \description{ Find the proportion of the samples from the sampling distribution of RMSEA in the alternative hypothesis rejected by the cutoff dervied from the sampling distribution of RMSEA in the null hypothesis. This function can be applied for both test of close fit and test of not-close fit (MacCallum, Browne, & Suguwara, 1996) } \details{ This function find the proportion of sampling distribution derived from the alternative RMSEA that is in the critical region derived from the sampling distribution of the null RMSEA. If \code{rmseaA} is greater than \code{rmsea0}, the test of close fit is used and the critical region is in the right hand side of the null sampling distribution. On the other hand, if \code{rmseaA} is less than \code{rmsea0}, the test of not-close fit is used and the critical region is in the left hand side of the null sampling distribution (MacCallum, Browne, & Suguwara, 1996). There is also a Shiny app called "power4SEM" that provides a graphical user interface for this functionality (Jak et al., in press). It can be accessed at \url{https://sjak.shinyapps.io/power4SEM/}. } \examples{ findRMSEApower(rmsea0 = .05, rmseaA = .08, df = 20, n = 200) } \references{ MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). Power analysis and determination of sample size for covariance structure modeling. \emph{Psychological Methods, 1}(2), 130--149. \doi{10.1037/1082-989X.1.2.130} Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. (2021). Analytical power calculations for structural equation modeling: A tutorial and Shiny app. \emph{Behavior Research Methods, 53}, 1385--1406. \doi{10.3758/s13428-020-01479-0} } \seealso{ \itemize{ \item \code{\link[=plotRMSEApower]{plotRMSEApower()}} to plot the statistical power based on population RMSEA given the sample size \item \code{\link[=plotRMSEAdist]{plotRMSEAdist()}} to visualize the RMSEA distributions \item \code{\link[=findRMSEAsamplesize]{findRMSEAsamplesize()}} to find the minium sample size for a given statistical power based on population RMSEA } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/measEq.syntax-class.Rd0000644000176200001440000001537214632152062016775 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/measEq.R \docType{class} \name{measEq.syntax-class} \alias{measEq.syntax-class} \alias{show,measEq.syntax-method} \alias{summary,measEq.syntax-method} \alias{as.character,measEq.syntax-method} \alias{update,measEq.syntax-method} \title{Class for Representing a Measurement-Equivalence Model} \usage{ \S4method{as.character}{measEq.syntax}(x, package = "lavaan", params = NULL, single = TRUE, groups.as.blocks = FALSE) \S4method{show}{measEq.syntax}(object) \S4method{summary}{measEq.syntax}(object, verbose = TRUE) \S4method{update}{measEq.syntax}(object, ..., evaluate = TRUE, change.syntax = NULL) } \arguments{ \item{x, object}{an object of class \code{measEq.syntax}} \item{package}{\code{character} indicating the package for which the model syntax should be generated. Currently, only \code{"lavaan"} and \code{"mplus"} are supported.} \item{params}{\code{character} vector indicating which type(s) of parameter to print syntax for. Must match a type that can be passed to \code{group.equal} or \code{long.equal}, but \code{"residual.covariances"} and \code{"lv.covariances"} will be silently ignored. Instead, requesting \code{"residuals"} or \code{"lv.variances"} will return covariances along with variances. By default (\code{NULL}), all types are printed.} \item{single}{\code{logical} indicating whether to concatenate lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} into a single \code{character} string. Setting \code{FALSE} will return a vector of strings, which may be convenient (or even necessary to prevent an error) in models with long variable names, many variables, or many groups.} \item{groups.as.blocks}{\code{logical} indicating whether to write lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} using vectors of labels and values for multiple groups (the default: \code{FALSE}), or whether to write a separate "block" of syntax per group. The block structure could allow users to apply the generated multigroup syntax (after some editing) to test invariance across levels in a multilevel SEM (see final example on \code{\link[=measEq.syntax]{measEq.syntax()}} help page).} \item{verbose}{\code{logical} indicating whether to print a summary to the screen (default). If \code{FALSE}, only a pattern matrix is returned.} \item{...}{Additional arguments to the \code{call}, or arguments with changed values.} \item{evaluate}{If \code{TRUE}, evaluate the new \code{call}; otherwise, return the new \code{call}.} \item{change.syntax}{\code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} specifying labels or fixed/free values of parameters in \code{object}. These provide some flexibility to customize existing parameters without having to copy/paste the output of \code{as.character(object)} into an R script. For example, \code{group.partial} will free a parameter across all groups, but \code{update} allows users to free the parameter in just one group while maintaining equality constraints among other groups.} } \value{ \item{summary}{\code{signature(object = "measEq.syntax", verbose = TRUE)}: A \code{character} matrix indicating the pattern of \code{numeric}, \code{ordered}, or latent indicators loading on common factors. By default (\code{verbose = TRUE}), \code{summary} also prints descriptive details about the model, including the numbers of indicators and factors, and which parameters are constrained to equality.} \item{show}{\code{signature(object = "measEq.syntax")}: Prints a message about how to use the \code{object} for model fitting. Invisibly returns the \code{object}.} \item{update}{\code{signature(object = "measEq.syntax", ..., evaluate = TRUE, change.syntax = NULL)}: Creates a new \code{object} with updated arguments in \code{...}, or updated parameter labels or fixed/free specifications in \code{object}.} \item{as.character}{\code{signature(x = "measEq.syntax", package = "lavaan")}: Converts the \code{measEq.syntax} object to model syntax that can be copy/pasted or written to a syntax file to be edited before analysis, or simply passed to \code{\link[lavaan:lavaan]{lavaan::lavaan()}} to fit the model to data. Generated M\emph{plus} syntax could also be utilized using the \pkg{MplusAuthomation} package.} } \description{ This class of object stores information used to automatically generate lavaan model syntax to represent user-specified levels of measurement equivalence/invariance across groups and/or repeated measures. See \code{\link[=measEq.syntax]{measEq.syntax()}} for details. } \section{Slots}{ \describe{ \item{\code{package}}{\code{character} indicating the software package used to represent the model. Currently, only \code{"lavaan"} is available, which uses the LISREL representation (see \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}). In the future, \code{"OpenMx"} may become available, using RAM representation.} \item{\code{model.type}}{\code{character}. Currently, only "cfa" is available. Future versions may allow for MIMIC / RFA models, where invariance can be tested across levels of exogenous variables explicitly included as predictors of indicators, controlling for their effects on (or correlation with) the common factors.} \item{\code{call}}{The function call as returned by \code{match.call()}, with some arguments updated if necessary for logical consistency.} \item{\code{meanstructure}}{\code{logical} indicating whether a mean structure is included in the model.} \item{\code{numeric}}{\code{character} vector naming \code{numeric} manifest indicators.} \item{\code{ordered}}{\code{character} vector naming \code{ordered} indicators.} \item{\code{parameterization}}{\code{character}. See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{\code{specify}}{\code{list} of parameter matrices, similar in form to the output of \code{lavInspect(fit, "free")}. These matrices are \code{logical}, indicating whether each parameter should be specified in the model syntax.} \item{\code{values}}{\code{list} of parameter matrices, similar in form to the output of \code{lavInspect(fit, "free")}. These matrices are \code{numeric}, indicating whether each parameter should be freely estimated (indicated by \code{NA}) or fixed to a particular value.} \item{\code{labels}}{\code{list} of parameter matrices, similar in form to the output of \code{lavInspect(fit, "free")}. These matrices contain \code{character} labels used to constrain parameters to equality.} \item{\code{constraints}}{\code{character} vector containing additional equality constraints used to identify the model when \code{ID.fac = "fx"}.} \item{\code{ngroups}}{\code{integer} indicating the number of groups.} }} \examples{ ## See ?measEq.syntax help page for examples using lavaan } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/lavTestLRT.mi-deprecated.Rd0000644000176200001440000001236314764333003017637 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI-LRT.R \name{lavTestLRT.mi-deprecated} \alias{lavTestLRT.mi-deprecated} \title{Likelihood Ratio Test for Multiple Imputations} \usage{ lavTestLRT.mi(object, h1 = NULL, test = c("D3","D2"), omit.imps = c("no.conv","no.se"), asymptotic = FALSE, pool.robust = FALSE, ...) } \arguments{ \item{object, h1}{An object of class \linkS4class{OLDlavaan.mi}. \code{object} should be nested within (more constrained than) \code{h1}.} \item{test}{\code{character} indicating which pooling method to use. \code{"D3"}, \code{"mr"}, or \code{"meng.rubin"} (default) requests the method described by Meng & Rubin (1992). \code{"D2"}, \code{"LMRR"}, or \code{"Li.et.al"} requests the complete-data LRT statistic should be calculated using each imputed data set, which will then be pooled across imputations, as described in Li, Meng, Raghunathan, & Rubin (1991). Find additional details in Enders (2010, chapter 8).} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. Specific imputation numbers can also be included in this argument, in case users want to apply their own custom omission criteria (or simulations can use different numbers of imputations without redundantly refitting the model).} \item{asymptotic}{\code{logical}. If \code{FALSE} (default), the pooled test will be returned as an \emph{F}-distributed statistic with numerator (\code{df1}) and denominator (\code{df2}) degrees of freedom. If \code{TRUE}, the pooled \emph{F} statistic will be multiplied by its \code{df1} on the assumption that its \code{df2} is sufficiently large enough that the statistic will be asymptotically \eqn{\chi^2} distributed with \code{df1}.} \item{pool.robust}{\code{logical}. Ignored unless \code{test = "D2"} and a robust test was requested. If \code{pool.robust = TRUE}, the robust test statistic is pooled, whereas \code{pool.robust = FALSE} will pool the naive test statistic (or difference statistic) and apply the average scale/shift parameter to it (unavailable for mean- and variance-adjusted difference statistics, so \code{pool.robust} will be set \code{TRUE}).} \item{...}{Additional arguments passed to \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}, only if \code{test = "D2"} and \code{pool.robust = TRUE}} } \value{ A vector containing the LRT statistic (either an \code{F} or \eqn{\chi^2} statistic, depending on the \code{asymptotic} argument), its degrees of freedom (numerator and denominator, if \code{asymptotic = FALSE}), its \emph{p} value, and 2 missing-data diagnostics: the relative invrease in variance (RIV, or average for multiparameter tests: ARIV) and the fraction missing information (FMI = ARIV / (1 + ARIV)). Robust statistics will also include the average (across imputations) scaling factor and (if relevant) shift parameter(s), unless \code{pool.robust = TRUE}. } \description{ Likelihood ratio test (LRT) for lavaan models fitted to multiple imputed data sets. Statistics for comparing nested models can be calculated by pooling the likelihood ratios across imputed data sets, as described by Meng & Rubin (1992), or by pooling the LRT statistics from each imputation, as described by Li, Meng, Raghunathan, & Rubin (1991). } \details{ The Meng & Rubin (1992) method, also referred to as the \code{"D3"} statistic, is only applicable when using a likelihood-based estimator. Otherwise (e.g., DWLS for categorical outcomes), users are notified that \code{test} was set to \code{"D2"}. \code{test = "Mplus"} implies \code{"D3"} and \code{asymptotic = TRUE} (see Asparouhov & Muthen, 2010). Note that unlike \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}, \code{lavTestLRT} can only be used to compare a single pair of models, not a longer list of models. To compare several nested models fitted to multiple imputations, see examples on the \code{\link[=compareFit]{compareFit()}} help page. } \examples{ ## See the new lavaan.mi package } \references{ Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Li, K.-H., Meng, X.-L., Raghunathan, T. E., & Rubin, D. B. (1991). Significance levels from repeated \emph{p}-values with multiply-imputed data. \emph{Statistica Sinica, 1}(1), 65--92. Retrieved from \url{https://www.jstor.org/stable/24303994} Meng, X.-L., & Rubin, D. B. (1992). Performing likelihood ratio tests with multiply-imputed data sets. \emph{Biometrika, 79}(1), 103--111. \doi{10.2307/2337151} Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. New York, NY: Wiley. } \seealso{ \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}}, \code{\link[=compareFit]{compareFit()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/reliability-deprecated.Rd0000644000176200001440000003144314753073632017547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reliability.R \name{reliability-deprecated} \alias{reliability-deprecated} \title{Composite Reliability using SEM} \usage{ reliability(object, what = c("alpha", "omega", "omega2", "omega3", "ave"), return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), omit.indicators = character(0), omit.imps = c("no.conv", "no.se")) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object, expected to contain only exogenous common factors (i.e., a CFA model).} \item{what}{\code{character} vector naming any reliability indices to calculate. All are returned by default. When indicators are ordinal, both traditional \code{"alpha"} and Zumbo et al.'s (2007) so-called "ordinal alpha" (\code{"alpha.ord"}) are returned, though the latter is arguably of dubious value (Chalmers, 2018).} \item{return.total}{\code{logical} indicating whether to return a final column containing the reliability of a composite of all indicators (not listed in \code{omit.indicators}) of factors not listed in \code{omit.factors}. Ignored in 1-factor models, and should only be set \code{TRUE} if all factors represent scale dimensions that could be meaningfully collapsed to a single composite (scale sum or scale mean).} \item{dropSingle}{\code{logical} indicating whether to exclude factors defined by a single indicator from the returned results. If \code{TRUE} (default), single indicators will still be included in the \code{total} column when \code{return.total = TRUE}.} \item{omit.factors}{\code{character} vector naming any common factors modeled in \code{object} whose composite reliability is not of interest. For example, higher-order or method factors. Note that \code{\link[=reliabilityL2]{reliabilityL2()}} should be used to calculate composite reliability of a higher-order factor.} \item{omit.indicators}{\code{character} vector naming any observed variables that should be ignored when calculating composite reliability. This can be useful, for example, to estimate reliability when an indicator is removed.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ Reliability values (coefficient alpha, coefficients omega, average variance extracted) of each factor in each group. If there are multiple factors, a \code{total} column can optionally be included. } \description{ Calculate composite reliability from estimated factor-model parameters } \details{ The coefficient alpha (Cronbach, 1951) can be calculated by \deqn{ \alpha = \frac{k}{k - 1}\left[ 1 - \frac{\sum^{k}_{i = 1} \sigma_{ii}}{\sum^{k}_{i = 1} \sigma_{ii} + 2\sum_{i < j} \sigma_{ij}} \right],} where \eqn{k} is the number of items in a factor, \eqn{\sigma_{ii}} is the item \emph{i} observed variances, \eqn{\sigma_{ij}} is the observed covariance of items \emph{i} and \emph{j}. Several coefficients for factor-analysis reliability have been termed "omega", which Cho (2021) argues is a misleading misnomer and argues for using \eqn{\rho} to represent them all, differentiated by descriptive subscripts. In our package, we number \eqn{\omega} based on commonly applied calculations. Bentler (1968) first introduced factor-analysis reliability for a unidimensional factor model with congeneric indicators. However, assuming there are no cross-loadings in a multidimensional CFA, this reliability coefficient can be calculated for each factor in the model. \deqn{ \omega_1 =\frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} Var\left( \psi \right)}{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} Var\left( \psi \right) + \sum^{k}_{i = 1} \theta_{ii} + 2\sum_{i < j} \theta_{ij} }, } where \eqn{\lambda_i} is the factor loading of item \emph{i}, \eqn{\psi} is the factor variance, \eqn{\theta_{ii}} is the variance of measurement errors of item \emph{i}, and \eqn{\theta_{ij}} is the covariance of measurement errors from item \emph{i} and \emph{j}. McDonald (1999) later referred to this \emph{and other reliability coefficients} as "omega", which is a source of confusion when reporting coefficients (Cho, 2021). The additional coefficients generalize the first formula by accounting for multidimenisionality (possibly with cross-loadings) and correlated errors. By setting \code{return.total=TRUE}, one can estimate reliability for a single composite calculated using all indicators in the multidimensional CFA (Bentler, 1972, 2009). \code{"omega2"} is calculated by \deqn{ \omega_2 = \frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} Var\left( \psi \right)}{\bold{1}^\prime \hat{\Sigma} \bold{1}}, } where \eqn{\hat{\Sigma}} is the model-implied covariance matrix, and \eqn{\bold{1}} is the \eqn{k}-dimensional vector of 1. The first and the second coefficients omega will have the same value per factor in models with simple structure, but they differ when there are (e.g.) cross-loadings or method factors. The first coefficient omega can be viewed as the reliability controlling for the other factors (like \eqn{\eta^2_{partial}} in ANOVA). The second coefficient omega can be viewed as the unconditional reliability (like \eqn{\eta^2} in ANOVA). The \code{"omega3"} coefficient (McDonald, 1999), sometimes referred to as hierarchical omega, can be calculated by \deqn{ \omega_3 =\frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} Var\left( \psi \right)}{\bold{1}^\prime \Sigma \bold{1}}, } where \eqn{\Sigma} is the observed covariance matrix. If the model fits the data well, \eqn{\omega_3} will be similar to \eqn{\omega_2}. Note that if there is a directional effect in the model, all coefficients are calculated from total factor variances: \code{lavInspect(object, "cov.lv")}. In conclusion, \eqn{\omega_1}, \eqn{\omega_2}, and \eqn{\omega_3} are different in the denominator. The denominator of the first formula assumes that a model is congeneric factor model where measurement errors are not correlated. The second formula accounts for correlated measurement errors. However, these two formulas assume that the model-implied covariance matrix explains item relationships perfectly. The residuals are subject to sampling error. The third formula use observed covariance matrix instead of model-implied covariance matrix to calculate the observed total variance. This formula is the most conservative method in calculating coefficient omega. The average variance extracted (AVE) can be calculated by \deqn{ AVE = \frac{\bold{1}^\prime \textrm{diag}\left(\Lambda\Psi\Lambda^\prime\right)\bold{1}}{\bold{1}^\prime \textrm{diag}\left(\hat{\Sigma}\right) \bold{1}}, } Note that this formula is modified from Fornell & Larcker (1981) in the case that factor variances are not 1. The proposed formula from Fornell & Larcker (1981) assumes that the factor variances are 1. Note that AVE will not be provided for factors consisting of items with dual loadings. AVE is the property of items but not the property of factors. AVE is calculated with polychoric correlations when ordinal indicators are used. Coefficient alpha is by definition applied by treating indicators as numeric (see Chalmers, 2018), which is consistent with the \code{alpha} function in the \code{psych} package. When indicators are ordinal, \code{reliability} additionally applies the standard alpha calculation to the polychoric correlation matrix to return Zumbo et al.'s (2007) "ordinal alpha". Coefficient omega for categorical items is calculated using Green and Yang's (2009, formula 21) approach. Three types of coefficient omega indicate different methods to calculate item total variances. The original formula from Green and Yang is equivalent to \eqn{\omega_3} in this function. Green and Yang did not propose a method for calculating reliability with a mixture of categorical and continuous indicators, and we are currently unaware of an appropriate method. Therefore, when \code{reliability} detects both categorical and continuous indicators of a factor, an error is returned. If the categorical indicators load on a different factor(s) than continuous indicators, then reliability will still be calculated separately for those factors, but \code{return.total} must be \code{FALSE} (unless \code{omit.factors} is used to isolate factors with indicators of the same type). } \examples{ data(HolzingerSwineford1939) HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) names(HSbinary) <- c("y7","y8","y9") HS <- cbind(HolzingerSwineford1939, HSbinary) HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ y7 + y8 + y9 ' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ## works for factors with exclusively continuous OR categorical indicators reliability(fit) ## reliability for ALL indicators only available when they are ## all continuous or all categorical reliability(fit, omit.factors = "speed", return.total = TRUE) ## loop over visual indicators to calculate alpha if one indicator is removed for (i in paste0("x", 1:3)) { cat("Drop x", i, ":\n") print(reliability(fit, omit.factors = c("textual","speed"), omit.indicators = i, what = "alpha")) } ## works for multigroup models and for multilevel models (and both) data(Demo.twolevel) ## assign clusters to arbitrary groups Demo.twolevel$g <- ifelse(Demo.twolevel$cluster \%\% 2L, "type1", "type2") model2 <- ' group: type1 level: within fac =~ y1 + L2*y2 + L3*y3 level: between fac =~ y1 + L2*y2 + L3*y3 group: type2 level: within fac =~ y1 + L2*y2 + L3*y3 level: between fac =~ y1 + L2*y2 + L3*y3 ' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") reliability(fit2, what = c("alpha","omega3")) } \references{ Bentler, P. M. (1972). A lower-bound method for the dimension-free measurement of internal consistency. \emph{Social Science Research, 1}(4), 343--357. \doi{10.1016/0049-089X(72)90082-8} Bentler, P. M. (2009). Alpha, dimension-free, and model-based internal consistency reliability. \emph{Psychometrika, 74}(1), 137--143. \doi{10.1007/s11336-008-9100-1} Chalmers, R. P. (2018). On misconceptions and the limited usefulness of ordinal alpha. \emph{Educational and Psychological Measurement, 78}(6), 1056--1071. \doi{10.1177/0013164417727036} Cho, E. (2021) Neither Cronbach’s alpha nor McDonald’s omega: A commentary on Sijtsma and Pfadt. \emph{Psychometrika, 86}(4), 877--886. \doi{10.1007/s11336-021-09801-1} Cronbach, L. J. (1951). Coefficient alpha and the internal structure of tests. \emph{Psychometrika, 16}(3), 297--334. \doi{10.1007/BF02310555} Fornell, C., & Larcker, D. F. (1981). Evaluating structural equation models with unobservable variables and measurement errors. \emph{Journal of Marketing Research, 18}(1), 39--50. \doi{10.2307/3151312} Green, S. B., & Yang, Y. (2009). Reliability of summed item scores using structural equation modeling: An alternative to coefficient alpha. \emph{Psychometrika, 74}(1), 155--167. \doi{10.1007/s11336-008-9099-3} McDonald, R. P. (1999). \emph{Test theory: A unified treatment}. Mahwah, NJ: Erlbaum. Raykov, T. (2001). Estimation of congeneric scale reliability using covariance structure analysis with nonlinear constraints \emph{British Journal of Mathematical and Statistical Psychology, 54}(2), 315--323. \doi{10.1348/000711001159582} Zumbo, B. D., Gadermann, A. M., & Zeisser, C. (2007). Ordinal versions of coefficients alpha and theta for Likert rating scales. \emph{Journal of Modern Applied Statistical Methods, 6}(1), 21--29. \doi{10.22237/jmasm/1177992180} Zumbo, B. D., & Kroc, E. (2019). A measurement is a choice and Stevens’ scales of measurement do not help make it: A response to Chalmers. \emph{Educational and Psychological Measurement, 79}(6), 1184--1197. \doi{10.1177/0013164419844305} } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/dat2way.Rd0000644000176200001440000000216414632143413014500 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{dat2way} \alias{dat2way} \title{Simulated Dataset to Demonstrate Two-way Latent Interaction} \format{ A \code{data.frame} with 500 observations of 9 variables. \describe{ \item{x1}{The first indicator of the first independent factor} \item{x2}{The second indicator of the first independent factor} \item{x3}{The third indicator of the first independent factor} \item{x4}{The first indicator of the second independent factor} \item{x5}{The second indicator of the second independent factor} \item{x6}{The third indicator of the second independent factor} \item{x7}{The first indicator of the dependent factor} \item{x8}{The second indicator of the dependent factor} \item{x9}{The third indicator of the dependent factor} } } \source{ Data were generated by the \code{\link[MASS:mvrnorm]{MASS::mvrnorm()}} function in the \code{MASS} package. } \usage{ dat2way } \description{ A simulated data set with 2 independent factors and 1 dependent factor where each factor has three indicators } \examples{ head(dat2way) } \keyword{datasets} semTools/man/combinequark.Rd0000644000176200001440000000300714632143416015605 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quark.R \name{combinequark} \alias{combinequark} \title{Combine the results from the quark function} \usage{ combinequark(quark, percent) } \arguments{ \item{quark}{Provide the \code{\link[=quark]{quark()}} object that was returned. It should be a list of objects. Make sure to include it in its entirety.} \item{percent}{Provide a percentage of variance that you would like to have explained. That many components (columns) will be extracted and kept with the output dataset. Enter this variable as a number WITHOUT a percentage sign.} } \value{ The output of this function is the original dataset used in quark combined with enough principal component scores to be able to account for the amount of variance that was requested. } \description{ This function builds upon the \code{\link[=quark]{quark()}} function to provide a final dataset comprised of the original dataset provided to \code{\link[=quark]{quark()}} and enough principal components to be able to account for a certain level of variance in the data. } \examples{ set.seed(123321) dat <- HolzingerSwineford1939[,7:15] misspat <- matrix(runif(nrow(dat) * 9) < 0.3, nrow(dat)) dat[misspat] <- NA dat <- cbind(HolzingerSwineford1939[,1:3], dat) quark.list <- quark(data = dat, id = c(1, 2)) final.data <- combinequark(quark = quark.list, percent = 80) } \seealso{ \code{\link[=quark]{quark()}} } \author{ Steven R. Chesnut (University of Southern Mississippi \email{Steven.Chesnut@usm.edu}) } semTools/man/moreFitIndices.Rd0000644000176200001440000002140714632143413016032 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fitIndices.R \name{moreFitIndices} \alias{moreFitIndices} \title{Calculate more fit indices} \usage{ moreFitIndices(object, fit.measures = "all", nPrior = 1) } \arguments{ \item{object}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions.} \item{fit.measures}{Additional fit measures to be calculated. All additional fit measures are calculated by default} \item{nPrior}{The sample size on which prior is based. This argument is used to compute \code{bic.priorN}.} } \value{ A \code{numeric} \code{lavaan.vector} including any of the following requested via \verb{fit.measures=} \enumerate{ \item \code{gammaHat}: Gamma-Hat \item \code{adjGammaHat}: Adjusted Gamma-Hat \item \code{baseline.rmsea}: RMSEA of the default baseline (i.e., independence) model \item \code{gammaHat.scaled}: Gamma-Hat using scaled \eqn{\chi^2} \item \code{adjGammaHat.scaled}: Adjusted Gamma-Hat using scaled \eqn{\chi^2} \item \code{baseline.rmsea.scaled}: RMSEA of the default baseline (i.e., independence) model using scaled \eqn{\chi^2} \item \code{aic.smallN}: Corrected (for small sample size) AIC \item \code{bic.priorN}: BIC with specified prior sample size \item \code{spbic}: Scaled Unit-Information Prior BIC (SPBIC) \item \code{hbic}: Haughton's BIC (HBIC) \item \code{ibic}: Information-matrix-based BIC (IBIC) \item \code{sic}: Stochastic Information Criterion (SIC) \item \code{hqc}: Hannan-Quinn Information Criterion (HQC) \item \code{icomp}: Bozdogan Information Complexity (ICOMP) Criteria } } \description{ Calculate more fit indices that are not already provided in lavaan. } \details{ See \code{\link[=nullRMSEA]{nullRMSEA()}} for the further details of the computation of RMSEA of the null model. Gamma-Hat (\code{gammaHat}; West, Taylor, & Wu, 2012) is a global goodness-of-fit index which can be computed (assuming equal number of indicators across groups) by \deqn{ \hat{\Gamma} =\frac{p}{p + 2 \times \frac{\chi^{2}_{k} - df_{k}}{N}},} where \eqn{p} is the number of variables in the model, \eqn{\chi^{2}_{k}} is the \eqn{\chi^2} test statistic value of the target model, \eqn{df_{k}} is the degree of freedom when fitting the target model, and \eqn{N} is the sample size (or sample size minus the number of groups if \code{mimic} is set to \code{"EQS"}). Adjusted Gamma-Hat (\code{adjGammaHat}; West, Taylor, & Wu, 2012) is a global fit index which can be computed by \deqn{ \hat{\Gamma}_\textrm{adj} = \left(1 - \frac{K \times p \times (p + 1)}{2 \times df_{k}} \right) \times \left( 1 - \hat{\Gamma} \right),} where \eqn{K} is the number of groups (please refer to Dudgeon, 2004, for the multiple-group adjustment for \code{adjGammaHat}). Note that if Satorra--Bentler's or Yuan--Bentler's method is used, the fit indices using the scaled \eqn{\chi^2} values are also provided. The remaining indices are information criteria calculated using the \code{object}'s \eqn{-2 \times} log-likelihood, abbreviated \eqn{-2LL}. Corrected Akaike Information Criterion (\code{aic.smallN}; Burnham & Anderson, 2003) is a corrected version of AIC for small sample size, often abbreviated AICc: \deqn{ \textrm{AIC}_{\textrm{small}-N} = AIC + \frac{2q(q + 1)}{N - q - 1},} where \eqn{AIC} is the original AIC: \eqn{-2LL + 2q} (where \eqn{q} = the number of estimated parameters in the target model). Note that AICc is a small-sample correction derived for univariate regression models, so it is probably \emph{not} appropriate for comparing SEMs. Corrected Bayesian Information Criterion (\code{bic.priorN}; Kuha, 2004) is similar to BIC but explicitly specifying the sample size on which the prior is based (\eqn{N_{prior}}) using the \code{nPrior} argument. \deqn{ \textrm{BIC}_{\textrm{prior}-N} = -2LL + q\log{( 1 + \frac{N}{N_{prior}} )}.} Bollen et al. (2012, 2014) discussed additional BICs that incorporate more terms from a Taylor series expansion, which the standard BIC drops. The "Scaled Unit-Information Prior" BIC is calculated depending on whether the product of the vector of estimated model parameters (\eqn{\hat{\theta}}) and the observed information matrix (FIM) exceeds the number of estimated model parameters (Case 1) or not (Case 2), which is checked internally: \deqn{ \textrm{SPBIC}_{\textrm{Case 1}} = -2LL + q(1 - \frac{q}{\hat{\theta}^{'} \textrm{FIM} \hat{\theta}}), \textrm{ or}} \deqn{ \textrm{SPBIC}_{\textrm{Case 2}} = -2LL + \hat{\theta}^{'} \textrm{FIM} \hat{\theta},} Note that this implementation of SPBIC is calculated on the assumption that priors for all estimated parameters are centered at zero, which is inappropriate for most SEMs (e.g., variances should not have priors centered at the lowest possible value; Bollen, 2014, p. 6). Bollen et al. (2014, eq. 14) credit the HBIC to Haughton (1988): \deqn{ \textrm{HBIC} = -2LL + q\log{\frac{N}{2 \pi}}.} Bollen et al. (2012, p. 305) proposed the information matrix (\eqn{I})-based BIC by adding another term: \deqn{ \textrm{IBIC} = -2LL + q\log{\frac{N}{2 \pi}} + \log{\det{\textrm{FIM}}},} or equivalently, using the inverse information (the asymptotic sampling covariance matrix of estimated parameters: ACOV): \deqn{ \textrm{IBIC} = -2LL - q\log{2 \pi} - \log{\det{\textrm{ACOV}}}.} Stochastic information criterion (SIC; see Preacher, 2006, for details) is similar to IBIC but does not include the \eqn{q\log{2 \pi}} term that is also in HBIC. SIC and IBIC both account for model complexity in a model's functional form, not merely the number of free parameters. The SIC can be computed as: \deqn{ \textrm{SIC} = -2LL + q\log{N} + \log{\det{\textrm{FIM}}} = -2LL - \log{\det{\textrm{ACOV}}}.} Hannan--Quinn Information Criterion (HQC; Hannan & Quinn, 1979) is used for model selection, similar to AIC or BIC. \deqn{ \textrm{HQC} = -2LL + 2q\log{(\log{N})},} Bozdogan Information Complexity (ICOMP) Criteria (Howe et al., 2011), instead of penalizing the number of free parameters directly, ICOMP penalizes the covariance complexity of the model. \deqn{ \textrm{ICOMP} = -2LL + s \times log(\frac{\bar{\lambda_a}}{\bar{\lambda_g}}) } } \examples{ HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' fit <- cfa(HS.model, data = HolzingerSwineford1939) moreFitIndices(fit) fit2 <- cfa(HS.model, data = HolzingerSwineford1939, estimator = "mlr") moreFitIndices(fit2) } \references{ Bollen, K. A., Ray, S., Zavisca, J., & Harden, J. J. (2012). A comparison of Bayes factor approximation methods including two new methods. \emph{Sociological Methods & Research, 41}(2), 294--324. \doi{10.1177/0049124112452393} Bollen, K. A., Harden, J. J., Ray, S., & Zavisca, J. (2014). BIC and alternative Bayesian information criteria in the selection of structural equation models. \emph{Structural Equation Modeling, 21}(1), 1--19. \doi{10.1080/10705511.2014.856691} Burnham, K., & Anderson, D. (2003). \emph{Model selection and multimodel inference: A practical--theoretic approach}. New York, NY: Springer--Verlag. Dudgeon, P. (2004). A note on extending Steiger's (1998) multiple sample RMSEA adjustment to other noncentrality parameter-based statistic. \emph{Structural Equation Modeling, 11}(3), 305--319. \doi{10.1207/s15328007sem1103_1} Howe, E. D., Bozdogan, H., & Katragadda, S. (2011). Structural equation modeling (SEM) of categorical and mixed-data using the novel Gifi transformations and information complexity (ICOMP) criterion. \emph{Istanbul University Journal of the School of Business Administration, 40}(1), 86--123. Kuha, J. (2004). AIC and BIC: Comparisons of assumptions and performance. \emph{Sociological Methods Research, 33}(2), 188--229. \doi{10.1177/0049124103262065} Preacher, K. J. (2006). Quantifying parsimony in structural equation modeling. \emph{Multivariate Behavioral Research, 43}(3), 227--259. \doi{10.1207/s15327906mbr4103_1} West, S. G., Taylor, A. B., & Wu, W. (2012). Model fit and model selection in structural equation modeling. In R. H. Hoyle (Ed.), \emph{Handbook of structural equation modeling} (pp. 209--231). New York, NY: Guilford. } \seealso{ \itemize{ \item \code{\link[=miPowerFit]{miPowerFit()}} For the modification indices and their power approach for model fit evaluation \item \code{\link[=nullRMSEA]{nullRMSEA()}} For RMSEA of the default independence model } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Aaron Boulton (University of Delaware) Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@gmail.com}) Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) Mauricio Garnier-Villarreal (Vrije Universiteit Amsterdam; \email{mgv@pm.me}) A great deal of feedback was provided by Kris Preacher regarding Bollen et al.'s (2012, 2014) extensions of BIC. } semTools/man/compRelSEM.Rd0000644000176200001440000005455414753073632015116 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reliability.R \name{compRelSEM} \alias{compRelSEM} \title{Composite Reliability using SEM} \usage{ compRelSEM(object, obs.var = TRUE, tau.eq = FALSE, ord.scale = TRUE, config = character(0), shared = character(0), higher = character(0), return.total = FALSE, dropSingle = TRUE, omit.factors = character(0), omit.indicators = character(0), omit.imps = c("no.conv", "no.se"), return.df = TRUE) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object, expected to contain only exogenous common factors (i.e., a CFA model).} \item{obs.var}{\code{logical} indicating whether to compute reliability using observed variances in the denominator. Setting \code{FALSE} triggers using model-implied variances in the denominator.} \item{tau.eq}{\code{logical} indicating whether to assume (essential) tau-equivalence, yielding a coefficient analogous to \eqn{\alpha}. Setting \code{FALSE} yields an \eqn{\omega}-type coefficient.} \item{ord.scale}{\code{logical} indicating whether to apply Green and Yang's (2009, formula 21) correction, so that reliability is calculated for the actual ordinal response scale (ignored for factors with continuous indicators). Setting \code{FALSE} yields coefficients that are only applicable to the continuous latent-response scale.} \item{config}{\code{character} vector naming any configural constructs in a multilevel CFA. For these constructs (and optional total composite), Lai's (2021) coefficients \eqn{\omega^\textrm{W}} and \eqn{\omega^\textrm{2L}} are returned (or corresponding \eqn{\alpha} coefficients when \code{tau.eq=TRUE}), rather than Geldhof et al.'s (2014) coefficients for hypothetical composites of latent components (although the same formula is used for \eqn{\omega^\textrm{W}} in either case). Note that the same name must be used for the factor component represented at each level of the model.} \item{shared}{\code{character} vector naming any shared constructs in a multilevel CFA. For these constructs (and optional total composite), Lai's (2021) coefficient \eqn{\omega^\textrm{B}} or \eqn{\alpha^\textrm{B}} is returned, rather than Geldhof et al.'s (2014) between-level coefficient for hypothetical composites of latent cluster means. Lai's (2021) coefficient quantifies reliability relative to error associated with both indicators (measurement error) and subjects (sampling error), like a generalizability coefficient. Given that subjects can be considered as raters of their cluster's shared construct, an interrater reliability (IRR) coefficient is also returned, quantifying reliability relative to rater/sampling error alone. To quantify reliability relative to indicator/measurement error alone (i.e., \eqn{\omega^\textrm{2L}}), the \verb{shared=} construct name(s) can additionally be included in \verb{config=} argument.} \item{higher}{\code{character} vector naming any higher-order constructs in \code{object} for which composite reliability should be calculated. Ignored when \code{tau.eq=TRUE} because alpha is not based on a CFA model; instead, users must fit a CFA with tau-equivalence constraints. To obtain Lai's (2021) multilevel composite-reliability indices for a higher-order factor, do not use this argument; instead, specify the higher-order factor(s) using the \verb{shared=} or \verb{config=} argument (\code{compRelSEM} will automatically check whether it includes latent indicators and apply the appropriate formula).} \item{return.total}{\code{logical} indicating whether to return a final column containing the reliability of a composite of all indicators (not listed in \code{omit.indicators}) of first-order factors not listed in \code{omit.factors}. Ignored in 1-factor models, and should only be set \code{TRUE} if all factors represent scale dimensions that could be meaningfully collapsed to a single composite (scale sum or scale mean). Setting a negative value (e.g., \code{-1} returns \strong{only} the total-composite reliability (excluding coefficients per factor), except when requesting Lai's (2021) coefficients for multilevel \code{config}ural or \verb{shared=} constructs.} \item{dropSingle}{\code{logical} indicating whether to exclude factors defined by a single indicator from the returned results. If \code{TRUE} (default), single indicators will still be included in the \code{total} column when \code{return.total = TRUE}.} \item{omit.factors}{\code{character} vector naming any common factors modeled in \code{object} whose composite reliability is not of interest. For example, higher-order or method factors. Note that \code{\link[=reliabilityL2]{reliabilityL2()}} should be used to calculate composite reliability of a higher-order factor.} \item{omit.indicators}{\code{character} vector naming any observed variables that should be omitted from the composite whose reliability is calculated.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} \item{return.df}{\code{logical} indicating whether to return reliability coefficients in a \code{data.frame} (one row per group/level), which is possible when every model block includes the same factors (after excluding those in \code{omit.factors} and applying \code{dropSingle}).} } \value{ A \code{numeric} vector of composite reliability coefficients per factor, or a \code{list} of vectors per "block" (group and/or level of analysis), optionally returned as a \code{data.frame} when possible (see \verb{return.df=} argument description for caveat). If there are multiple factors, whose multidimensional indicators combine into a single composite, users can request \code{return.total=TRUE} to add a column including a reliability coefficient for the total composite, or \code{return.total = -1} to return \strong{only} the total-composite reliability (ignored when \verb{config=} or \verb{shared=} is specified because each factor's specification must be checked across levels). } \description{ Calculate composite reliability from estimated factor-model parameters } \details{ Several coefficients for factor-analysis reliability have been termed "omega", which Cho (2021) argues is a misleading misnomer and argues for using \eqn{\rho} to represent them all, differentiated by descriptive subscripts. In our package, we strive to provide unlabeled coefficients, leaving it to the user to decide on a label in their report. But we do use the symbols \eqn{\alpha} and \eqn{\omega} in the formulas below in order to distinguish coefficients that do (not) assume essential tau-equivalence. For higher-order constructs with latent indicators, only \eqn{\omega} is available. Lai's (2021) multilevel coefficients are labeled in accordance with the symbols used in that article (more details below). Bentler (1968) first introduced factor-analysis reliability for a unidimensional factor model with congeneric indicators, labeling the coeficients \eqn{\alpha}. McDonald (1999) later referred to this \emph{and other reliability coefficients}, first as \eqn{\theta} (in 1970), then as \eqn{\omega}, which is a source of confusion when reporting coefficients (Cho, 2021). Coefficients based on factor models were later generalized to account for multidimenisionality (possibly with cross-loadings) and correlated errors. The general \eqn{\omega} formula implemented in this function is: \deqn{ \omega = \frac{\left( \sum^{k}_{i = 1} \lambda_i \right)^{2} Var\left( \psi \right)}{\bold{1}^\prime \hat{\Sigma} \bold{1}}, } where \eqn{\hat{\Sigma}} can be the model-implied covariance matrix from either the saturated model (i.e., the "observed" covariance matrix, used by default) or from the hypothesized CFA model, controlled by the \code{obs.var} argument. A \eqn{k}-dimensional vector \eqn{\bold{1}} is used to sum elements in the matrix. Note that if the model includes any directed effects (latent regression slopes), all coefficients are calculated from \strong{total} factor variances: \code{lavInspect(object, "cov.lv")}. Assuming (essential) tau-equivalence (\code{tau.eq=TRUE}) makes \eqn{\omega} equivalent to coefficient \eqn{\alpha} from classical test theory (Cronbach, 1951): \deqn{ \alpha = \frac{k}{k - 1}\left[ 1 - \frac{\sum^{k}_{i = 1} \sigma_{ii}}{\sum^{k}_{i = 1} \sigma_{ii} + 2\sum_{i < j} \sigma_{ij}} \right],} where \eqn{k} is the number of items in a factor's composite, \eqn{\sigma_{ii}} signifies item \emph{i}'s variance, and \eqn{\sigma_{ij}} signifies the covariance between items \emph{i} and \emph{j}. Again, the \code{obs.var} argument controls whether \eqn{\alpha} is calculated using the observed or model-implied covariance matrix. By setting \code{return.total=TRUE}, one can estimate reliability for a single composite calculated using all indicators in a multidimensional CFA (Bentler, 1972, 2009). Setting \code{return.total = -1} will return \strong{only} the total-composite reliability (not per factor). \strong{Higher-Order Factors}: The reliability of a composite that represents a higher-order construct requires partitioning the model-implied factor covariance matrix \eqn{\Phi} in order to isolate the common-factor variance associated only with the higher-order factor. Using a second-order factor model, the model-implied covariance matrix of observed indicators \eqn{\hat{\Sigma}} can be partitioned into 3 sources: \enumerate{ \item the second-order common-factor (co)variance: \eqn{\Lambda \bold{B} \Phi_2 \bold{B}^{\prime} \Lambda^{\prime}} \item the residual variance of the first-order common factors (i.e., not accounted for by the second-order factor): \eqn{\Lambda \Psi_{u} \Lambda^{\prime}} \item the measurement error of observed indicators: \eqn{\Theta} } where \eqn{\Lambda} contains first-order factor loadings, \eqn{\bold{B}} contains second-order factor loadings, \eqn{\Phi_2} is the model-implied covariance matrix of the second-order factor(s), and \eqn{\Psi_{u}} is the covariance matrix of first-order factor disturbances. In practice, we can use the full \eqn{\bold{B}} matrix and full model-implied \eqn{\Phi} matrix (i.e., including all latent factors) because the zeros in \eqn{\bold{B}} will cancel out unwanted components of \eqn{\Phi}. Thus, we can calculate the proportion of variance of a composite score calculated from the observed indicators (e.g., a total score or scale mean) that is attributable to the second-order factor (i.e., coefficient \eqn{\omega}): \deqn{\omega=\frac{\bold{1}^{\prime} \Lambda \bold{B} \Phi \bold{B}^{\prime} \Lambda^{\prime} \bold{1} }{ \bold{1}^{\prime} \hat{\Sigma} \bold{1}}, } where \eqn{\bold{1}} is the \emph{k}-dimensional vector of 1s and \emph{k} is the number of observed indicators in the composite. Note that if a higher-order factor also has observed indicators, it is necessary to model the observed indicators as single-indicator constructs, so that all of the higher-order factor indicators are latent (with loadings in the Beta matrix, not Lambda). \strong{Categorical Indicators}: When all indicators (per composite) are ordinal, the \code{ord.scale} argument controls whether the coefficient is calculated on the latent-response scale (\code{FALSE}) or on the observed ordinal scale (\code{TRUE}, the default). For \eqn{\omega}-type coefficients (\code{tau.eq=FALSE}), Green and Yang's (2009, formula 21) approach is used to transform factor-model results back to the ordinal response scale. When \code{ord.scale=TRUE} and \code{tau.eq=TRUE}, coefficient \eqn{\alpha} is calculated using the covariance matrix calculated from the integer-valued numeric weights for ordinal categories, consistent with its definition (Chalmers, 2018) and the \code{alpha} function in the \code{psych} package; this implies \code{obs.var=TRUE}, so \code{obs.var=FALSE} will be ignored When \code{ord.scale=FALSE}, the standard \eqn{\alpha} formula is applied to the polychoric correlation matrix ("ordinal \eqn{\alpha}"; Zumbo et al., 2007), estimated from the saturated or hypothesized model (see \code{obs.var}), and \eqn{\omega} is calculated from CFA results without applying Green and Yang's (2009) correction (see Zumbo & Kroc, 2019, for a rationalization). No method analogous to Green and Yang (2009) has been proposed for calculating reliability with a mixture of categorical and continuous indicators, so an error is returned if \code{object} includes factors with a mixture of indicator types (unless omitted using \code{omit.factors}). If categorical indicators load on a different factor(s) than continuous indicators, then reliability will still be calculated separately for those factors, but \code{return.total} must be \code{FALSE} (unless \code{omit.factors} is used to isolate factors with indicators of the same type). \strong{Multilevel Measurement Models}: Under the default settings, \code{compRelSEM()} will apply the same formula in each "block" (group and/or level of analysis). In the case of multilevel (ML-)SEMs, this yields "reliability" for latent within- and between-level components, as proposed by Geldhof et al. (2014). Although this works fine to calculate reliability per group, this is not recommended for ML-SEMs because the coefficients do not correspond to actual composites that would be calculated from the observed data. Lai (2021) proposed coefficients for reliability of actual composites, depending on the type of construct, which requires specifying the names of constructs for which reliability is desired (or multiple constructs whose indicators would compose a multidimensional composite). Configural (\verb{config=}) and/or \verb{shared=} constructs can be specified; the same construct can be specified in both arguments, so that overall scale-reliability can be estimated for a shared construct by including it in \code{config}. Instead of organizing the output by block (the default), specifying \verb{config=} and/or \verb{shared=} will prompt organizing the list of output by \verb{$config} and/or \verb{$shared}. \itemize{ \item The overall (\verb{_2L}) scale reliability for \code{config}ural constructs is returned, along with the reliability of a purely individual-level composite (\verb{_W}, calculated by cluster-mean centering). \item The reliability for a \code{shared} construct quantifies generalizability across both indicators and raters (i.e., subjects rating their cluster's construct). Lüdtke et al. (2011) refer to these as measurement error and sampling error, respectively. An interrater reliability (IRR) coefficient is also returned, quantifying generalizability across rater/sampling-error only. To obtain a scale-reliability coefficient (quantifying a shared construct's generalizability across indicator/measurement-error only), include the same factor name in \verb{config=}. Jak et al. (2021) recommended modeling components of the same construct at both levels, but users may also saturate the within-level model (Lai, 2021). } Be careful about including Level-2 variables in the model, especially whether it makes sense to include them in a total composite for a Level-2 construct. \code{dropSingle=TRUE} only prevents estimating reliability for a single-indicator construct, not from including such an indicator in a total composite. It is permissible for \verb{shared=} constructs to have additional indicators at Level-2 only. If it is necessary to model other Level-2 variables (e.g., to justify the missing-at-random assumption when using \verb{missing="FIML" estimation}), they should be placed in the \verb{omit.indicators=} argument to exclude them from total composites. } \examples{ data(HolzingerSwineford1939) HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) names(HSbinary) <- c("y7","y8","y9") HS <- cbind(HolzingerSwineford1939, HSbinary) HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ y7 + y8 + y9 ' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ## works for factors with exclusively continuous OR categorical indicators compRelSEM(fit) ## reliability for ALL indicators only available when they are ## all continuous or all categorical compRelSEM(fit, omit.factors = "speed", return.total = TRUE) ## loop over visual indicators to calculate alpha if one indicator is removed for (i in paste0("x", 1:3)) { cat("Drop ", i, ":\n", sep = "") print(compRelSEM(fit, omit.factors = c("textual","speed"), omit.indicators = i, tau.eq = TRUE)) } ## item-total correlations obtainable by adding a composite to the data HS$Visual <- HS$x1 + HS$x2 + HS$x3 cor(HS$Visual, y = HS[paste0("x", 1:3)]) ## comparable to psych::alpha(HS[paste0("x", 1:3)]) ## Reliability of a composite that represents a higher-order factor mod.hi <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 general =~ visual + textual + speed ' fit.hi <- cfa(mod.hi, data = HolzingerSwineford1939) compRelSEM(fit.hi, higher = "general") ## reliabilities for lower-order composites also returned ## works for multigroup models and for multilevel models (and both) data(Demo.twolevel) ## assign clusters to arbitrary groups Demo.twolevel$g <- ifelse(Demo.twolevel$cluster \%\% 2L, "type1", "type2") model2 <- ' group: type1 level: 1 f1 =~ y1 + L2*y2 + L3*y3 f2 =~ y4 + L5*y5 + L6*y6 level: 2 f1 =~ y1 + L2*y2 + L3*y3 f2 =~ y4 + L5*y5 + L6*y6 group: type2 level: 1 f1 =~ y1 + L2*y2 + L3*y3 f2 =~ y4 + L5*y5 + L6*y6 level: 2 f1 =~ y1 + L2*y2 + L3*y3 f2 =~ y4 + L5*y5 + L6*y6 ' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") compRelSEM(fit2) # Geldhof's indices (hypothetical, for latent components) ## Lai's (2021) indices for Level-1 and configural constructs compRelSEM(fit2, config = c("f1","f2")) ## Lai's (2021) indices for shared (Level-2) constructs ## (also an interrater reliability coefficient) compRelSEM(fit2, shared = c("f1","f2")) ## Shared construct using saturated within-level model mod.sat1 <- ' level: 1 y1 ~~ y1 + y2 + y3 + y4 + y5 + y6 y2 ~~ y2 + y3 + y4 + y5 + y6 y3 ~~ y3 + y4 + y5 + y6 y4 ~~ y4 + y5 + y6 y5 ~~ y5 + y6 y6 ~~ y6 level: 2 f1 =~ y1 + L2*y2 + L3*y3 f2 =~ y4 + L5*y5 + L6*y6 ' fit.sat1 <- sem(mod.sat1, data = Demo.twolevel, cluster = "cluster") compRelSEM(fit.sat1, shared = c("f1","f2")) ## Simultaneous shared-and-configural model (Stapleton et al, 2016, 2019), ## not recommended, but possible by omitting shared or configural factor. mod.both <- ' level: 1 fc =~ y1 + L2*y2 + L3*y3 + L4*y4 + L5*y5 + L6*y6 level: 2 ## configural construct fc =~ y1 + L2*y2 + L3*y3 + L4*y4 + L5*y5 + L6*y6 ## orthogonal shared construct fs =~ NA*y1 + y2 + y3 + y4 + y5 + y6 fs ~~ 1*fs + 0*fc ' fit.both <- sem(mod.both, data = Demo.twolevel, cluster = "cluster") compRelSEM(fit.both, shared = "fs", config = "fc") } \references{ Bentler, P. M. (1968). Alpha-maximized factor analysis (alphamax): Its relation to alpha and canonical factor analysis. \emph{Psychometrika, 33}(3), 335--345. \doi{10.1007/BF02289328} Bentler, P. M. (1972). A lower-bound method for the dimension-free measurement of internal consistency. \emph{Social Science Research, 1}(4), 343--357. \doi{10.1016/0049-089X(72)90082-8} Bentler, P. M. (2009). Alpha, dimension-free, and model-based internal consistency reliability. \emph{Psychometrika, 74}(1), 137--143. \doi{10.1007/s11336-008-9100-1} Chalmers, R. P. (2018). On misconceptions and the limited usefulness of ordinal alpha. \emph{Educational and Psychological Measurement, 78}(6), 1056--1071. \doi{10.1177/0013164417727036} Cho, E. (2021) Neither Cronbach’s alpha nor McDonald’s omega: A commentary on Sijtsma and Pfadt. \emph{Psychometrika, 86}(4), 877--886. \doi{10.1007/s11336-021-09801-1} Cronbach, L. J. (1951). Coefficient alpha and the internal structure of tests. \emph{Psychometrika, 16}(3), 297--334. \doi{10.1007/BF02310555} Geldhof, G. J., Preacher, K. J., & Zyphur, M. J. (2014). Reliability estimation in a multilevel confirmatory factor analysis framework. \emph{Psychological Methods, 19}(1), 72--91. \doi{10.1037/a0032138} Green, S. B., & Yang, Y. (2009). Reliability of summed item scores using structural equation modeling: An alternative to coefficient alpha. \emph{Psychometrika, 74}(1), 155--167. \doi{10.1007/s11336-008-9099-3} Jak, S., Jorgensen, T. D., & Rosseel, Y. (2021). Evaluating cluster-level factor models with \code{lavaan} and M\emph{plus}. \emph{Psych, 3}(2), 134--152. \doi{10.3390/psych3020012} Lai, M. H. C. (2021). Composite reliability of multilevel data: It’s about observed scores and construct meanings. \emph{Psychological Methods, 26}(1), 90--102. \doi{10.1037/met0000287} Lüdtke, O., Marsh, H. W., Robitzsch, A., & Trautwein, U. (2011). A 2 \eqn{\times} 2 taxonomy of multilevel latent contextual models: Accuracy--bias trade-offs in full and partial error correction models. \emph{Psychological Methods, 16}(4), 444--467. \doi{10.1037/a0024376} McDonald, R. P. (1999). \emph{Test theory: A unified treatment}. Mahwah, NJ: Erlbaum. Zumbo, B. D., Gadermann, A. M., & Zeisser, C. (2007). Ordinal versions of coefficients alpha and theta for Likert rating scales. \emph{Journal of Modern Applied Statistical Methods, 6}(1), 21--29. \doi{10.22237/jmasm/1177992180} Zumbo, B. D., & Kroc, E. (2019). A measurement is a choice and Stevens’ scales of measurement do not help make it: A response to Chalmers. \emph{Educational and Psychological Measurement, 79}(6), 1184--1197. \doi{10.1177/0013164419844305} } \seealso{ \code{\link[=maximalRelia]{maximalRelia()}} for the maximal reliability of weighted composite } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) Uses hidden functions written by Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) for the old \code{reliability()} function. } semTools/man/datCat.Rd0000644000176200001440000000133014631670013014317 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{datCat} \alias{datCat} \title{Simulated Data set to Demonstrate Categorical Measurement Invariance} \format{ A \code{data.frame} with 200 observations of 9 variables. \describe{ \item{g}{Sex of respondents} \item{u1}{Indicator 1} \item{u2}{Indicator 2} \item{u3}{Indicator 3} \item{u4}{Indicator 4} \item{u5}{Indicator 5} \item{u6}{Indicator 6} \item{u7}{Indicator 7} \item{u8}{Indicator 8} } } \source{ Data were generated using the \code{lavaan} package. } \usage{ datCat } \description{ A simulated data set with 2 factors with 4 indicators each separated into two groups } \examples{ head(datCat) } \keyword{datasets} semTools/man/runMI-deprecated.Rd0000644000176200001440000000764614764333003016271 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/runMI.R \name{runMI-deprecated} \alias{runMI-deprecated} \alias{lavaan.mi-deprecated} \alias{cfa.mi-deprecated} \alias{sem.mi-deprecated} \alias{growth.mi-deprecated} \title{Fit a lavaan Model to Multiple Imputed Data Sets} \usage{ runMI(model, data, fun = "lavaan", ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) lavaan.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) cfa.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) sem.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) growth.mi(model, data, ..., m, miArgs = list(), miPackage = "Amelia", seed = 12345) } \arguments{ \item{model}{The analysis model can be specified using \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} or a \code{\link[lavaan:parTable]{lavaan::parTable()}}} \item{data}{A \code{data.frame} with missing observations, or a \code{list} of imputed data sets (if data are imputed already). If \code{runMI()} has already been called, then imputed data sets are stored in the \verb{@DataList} slot, so \verb{data=} can also be an \code{OLDlavaan.mi} object from which the same imputed data will be used for additional analyses.} \item{fun}{\code{character}. Name of a specific lavaan function used to fit \verb{model=} to \verb{data=} (i.e., \code{"lavaan"}, \code{"cfa"}, \code{"sem"}, or \code{"growth"}). Only required for \code{runMI()}.} \item{\dots}{additional arguments to pass to \code{\link[lavaan:lavaan]{lavaan::lavaan()}} or \code{\link[lavaan:lavaanList]{lavaan::lavaanList()}}. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}. Note that \code{lavaanList} provides parallel computing options, as well as a \code{FUN} argument so the user can extract custom output after the model is fitted to each imputed data set (see \strong{Examples}). TIP: If a custom \code{FUN} is used \emph{and} \code{parallel = "snow"} is requested, the user-supplied function should explicitly call \code{library} or use \code{\link[base]{::}} for any functions not part of the base distribution.} \item{m}{\code{integer}. Request the number of imputations. Ignored if \verb{data=} is already a \code{list} of imputed data sets or an \code{OLDlavaan.mi} object.} \item{miArgs}{Addition arguments for the multiple-imputation function (\code{miPackage}). The arguments should be put in a list (see example below). Ignored if \verb{data=} is already a \code{list} of imputed data sets or an \code{OLDlavaan.mi} object.} \item{miPackage}{Package to be used for imputation. Currently these functions only support \code{"Amelia"} or \code{"mice"} for imputation. Ignored if \code{data} is already a \code{list} of imputed data sets or an \code{OLDlavaan.mi} object.} \item{seed}{\code{integer}. Random number seed to be set before imputing the data. Ignored if \code{data} is already a \code{list} of imputed data sets or an \code{OLDlavaan.mi} object.} } \value{ A \linkS4class{OLDlavaan.mi} object } \description{ This function fits a lavaan model to a list of imputed data sets, and can also implement multiple imputation for a single \code{data.frame} with missing observations, using either the Amelia package or the mice package. } \examples{ ## See the new lavaan.mi package } \references{ Enders, C. K. (2010). \emph{Applied missing data analysis}. New York, NY: Guilford. Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. New York, NY: Wiley. } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/BootMiss-class.Rd0000644000176200001440000000442214632143414015767 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/missingBootstrap.R \docType{class} \name{BootMiss-class} \alias{BootMiss-class} \alias{show,BootMiss-method} \alias{summary,BootMiss-method} \alias{hist,BootMiss-method} \title{Class For the Results of Bollen-Stine Bootstrap with Incomplete Data} \usage{ \S4method{show}{BootMiss}(object) \S4method{summary}{BootMiss}(object) \S4method{hist}{BootMiss}(x, ..., alpha = 0.05, nd = 2, printLegend = TRUE, legendArgs = list(x = "topleft")) } \arguments{ \item{object, x}{object of class \code{BootMiss}} \item{...}{Additional arguments to pass to \code{\link[graphics:hist]{graphics::hist()}}} \item{alpha}{alpha level used to draw confidence limits} \item{nd}{number of digits to display} \item{printLegend}{\code{logical}. If \code{TRUE} (default), a legend will be printed with the histogram} \item{legendArgs}{\code{list} of arguments passed to the \code{\link[graphics:legend]{graphics::legend()}} function. The default argument is a list placing the legend at the top-left of the figure.} } \value{ The \code{hist} method returns a list of \code{length == 2}, containing the arguments for the call to \code{hist} and the arguments to the call for \code{legend}, respectively. } \description{ This class contains the results of Bollen-Stine bootstrap with missing data. } \section{Slots}{ \describe{ \item{\code{time}}{A list containing 2 \code{difftime} objects (\code{transform} and \code{fit}), indicating the time elapsed for data transformation and for fitting the model to bootstrap data sets, respectively.} \item{\code{transData}}{Transformed data} \item{\code{bootDist}}{The vector of \eqn{chi^2} values from bootstrap data sets fitted by the target model} \item{\code{origChi}}{The \eqn{chi^2} value from the original data set} \item{\code{df}}{The degree of freedom of the model} \item{\code{bootP}}{The \emph{p} value comparing the original \eqn{chi^2} with the bootstrap distribution} }} \section{Objects from the Class}{ Objects can be created via the \code{\link[=bsBootMiss]{bsBootMiss()}} function. } \examples{ # See the example from the bsBootMiss function } \seealso{ \code{\link[=bsBootMiss]{bsBootMiss()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/fmi.Rd0000644000176200001440000001213014764331400013673 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fmi.R \name{fmi} \alias{fmi} \title{Fraction of Missing Information.} \usage{ fmi(data, method = "saturated", group = NULL, ords = NULL, varnames = NULL, exclude = NULL, return.fit = FALSE) } \arguments{ \item{data}{Either a single \code{data.frame} with incomplete observations, or a \code{list} of imputed data sets.} \item{method}{character. If \code{"saturated"} or \code{"sat"} (default), the model used to estimate FMI is a freely estimated covariance matrix and mean vector for numeric variables, and/or polychoric correlations and thresholds for ordered categorical variables, for each group (if applicable). If \code{"null"}, only means and variances are estimated for numeric variables, and/or thresholds for ordered categorical variables (i.e., covariances and/or polychoric/polyserial correlations are constrained to zero). See \strong{Details} for more information.} \item{group}{\code{character}. The optional name of a grouping variable, to request FMI in each group.} \item{ords}{Optional \code{character} vector naming ordered-categorical variables, if they are not already stored as class \code{ordered} in \code{data}.} \item{varnames}{Optional \code{character} vector of variable names, to calculate FMI for a subset of variables in \code{data}. By default, all numeric and \verb{ordered=} variables will be included, unless \verb{data=} is a single incomplete \code{data.frame}, in which case only numeric variables can be used with FIML estimation. Other variable types will be removed.} \item{exclude}{Optional \code{character} vector naming variables to exclude from the analysis.} \item{return.fit}{logical. If \code{TRUE}, the fitted \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} model is returned, so FMI can be found from \code{summary(..., fmi=TRUE)}.} } \value{ \code{fmi()} returns a list with at least 2 of the following: \item{Covariances}{A list of symmetric matrices: (1) the estimated/pooled covariance matrix, or a list of group-specific matrices (if applicable) and (2) a matrix of FMI, or a list of group-specific matrices (if applicable). Only available if \code{method = "saturated"}. When \code{method="cor"}, this element is replaced by \code{Correlations}.} \item{Variances}{The estimated/pooled variance for each numeric variable. Only available if \code{method = "null"} (otherwise, it is on the diagonal of Covariances).} \item{Means}{The estimated/pooled mean for each numeric variable.} \item{Thresholds}{The estimated/pooled threshold(s) for each ordered-categorical variable.} } \description{ This function estimates the Fraction of Missing Information (FMI) for summary statistics of each variable, using either an incomplete data set or a list of imputed data sets. } \details{ The function estimates a saturated model with \code{\link[lavaan:lavaan]{lavaan::lavaan()}} for a single incomplete data set using FIML, or with \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}} for a list of imputed data sets. If method = \code{"saturated"}, FMI will be estiamted for all summary statistics, which could take a lot of time with big data sets. If method = \code{"null"}, FMI will only be estimated for univariate statistics (e.g., means, variances, thresholds). The saturated model gives more reliable estimates, so it could also help to request a subset of variables from a large data set. } \examples{ HSMiss <- HolzingerSwineford1939[ , c(paste("x", 1:9, sep = ""), "ageyr","agemo","school")] set.seed(12345) HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) age <- HSMiss$ageyr + HSMiss$agemo/12 HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) ## calculate FMI (using FIML, provide partially observed data set) (out1 <- fmi(HSMiss, exclude = "school")) (out2 <- fmi(HSMiss, exclude = "school", method = "null")) (out3 <- fmi(HSMiss, varnames = c("x5","x6","x7","x8","x9"))) (out4 <- fmi(HSMiss, method = "cor", group = "school")) # correlations by group ## significance tests in lavaan(.mi) object out5 <- fmi(HSMiss, method = "cor", return.fit = TRUE) summary(out5) # factor loading == SD, covariance = correlation if(requireNamespace("lavaan.mi")){ ## ordered-categorical data data(binHS5imps, package = "lavaan.mi") ## calculate FMI, using list of imputed data sets fmi(binHS5imps, group = "school") } } \references{ Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. New York, NY: Wiley. Savalei, V. & Rhemtulla, M. (2012). On obtaining estimates of the fraction of missing information from full information maximum likelihood. \emph{Structural Equation Modeling, 19}(3), 477--494. \doi{10.1080/10705511.2012.687669} Wagner, J. (2010). The fraction of missing information as a tool for monitoring the quality of survey data. \emph{Public Opinion Quarterly, 74}(2), 223--243. \doi{10.1093/poq/nfq007} } \author{ Mauricio Garnier Villarreal (Vrije Universiteit Amsterdam; \email{m.garniervillarreal@vu.nl}) Terrence Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/twostage.Rd0000644000176200001440000001316414753125077014776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/TSML.R \name{twostage} \alias{twostage} \alias{cfa.2stage} \alias{sem.2stage} \alias{growth.2stage} \alias{lavaan.2stage} \title{Fit a lavaan model using 2-Stage Maximum Likelihood (TSML) estimation for missing data.} \usage{ twostage(..., aux, fun, baseline.model = NULL) lavaan.2stage(..., aux = NULL, baseline.model = NULL) cfa.2stage(..., aux = NULL, baseline.model = NULL) sem.2stage(..., aux = NULL, baseline.model = NULL) growth.2stage(..., aux = NULL, baseline.model = NULL) } \arguments{ \item{\dots}{Arguments passed to the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function specified in the \code{fun} argument. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}. At a minimum, the user must supply the first two named arguments to \code{\link[lavaan:lavaan]{lavaan::lavaan()}} (i.e., \code{model} and \code{data}).} \item{aux}{An optional character vector naming auxiliary variable(s) in \code{data}} \item{fun}{The character string naming the lavaan function used to fit the Step-2 hypothesized model (\code{"cfa"}, \code{"sem"}, \code{"growth"}, or \code{"lavaan"}).} \item{baseline.model}{An optional character string, specifying the lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} for a user-specified baseline model. Interested users can use the fitted baseline model to calculate incremental fit indices (e.g., CFI and TLI) using the corrected chi-squared values (see the \code{anova} method in \linkS4class{twostage}). If \code{NULL}, the default "independence model" (i.e., freely estimated means and variances, but all covariances constrained to zero) will be specified internally.} } \value{ The \linkS4class{twostage} object contains 3 fitted lavaan models (saturated, target/hypothesized, and baseline) as well as the names of auxiliary variables. None of the individual models provide the correct model results (except the point estimates in the target model are unbiased). Use the methods in \linkS4class{twostage} to extract corrected \emph{SE}s and test statistics. } \description{ This function automates 2-Stage Maximum Likelihood (TSML) estimation, optionally with auxiliary variables. Step 1 involves fitting a saturated model to the partially observed data set (to variables in the hypothesized model as well as auxiliary variables related to missingness). Step 2 involves fitting the hypothesized model to the model-implied means and covariance matrix (also called the "EM" means and covariance matrix) as if they were complete data. Step 3 involves correcting the Step-2 standard errors (\emph{SE}s) and chi-squared statistic to account for additional uncertainty due to missing data (using information from Step 1; see References section for sources with formulas). } \details{ All variables (including auxiliary variables) are treated as endogenous varaibles in the Step-1 saturated model (\code{fixed.x = FALSE}), so data are assumed continuous, although not necessarily multivariate normal (dummy-coded auxiliary variables may be included in Step 1, but categorical endogenous variables in the Step-2 hypothesized model are not allowed). To avoid assuming multivariate normality, request \code{se = "robust.huber.white"}. CAUTION: In addition to setting \code{fixed.x = FALSE} and \code{conditional.x = FALSE} in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}, this function will automatically set \code{meanstructure = TRUE}, \code{estimator = "ML"}, \code{missing = "fiml"}, and \code{test = "standard"}. \code{\link[lavaan:lavaan]{lavaan::lavaan()}}'s \code{se} option can only be set to \code{"standard"} to assume multivariate normality or to \code{"robust.huber.white"} to relax that assumption. } \examples{ ## impose missing data for example HSMiss <- HolzingerSwineford1939[ , c(paste("x", 1:9, sep = ""), "ageyr","agemo","school")] set.seed(12345) HSMiss$x5 <- ifelse(HSMiss$x5 <= quantile(HSMiss$x5, .3), NA, HSMiss$x5) age <- HSMiss$ageyr + HSMiss$agemo/12 HSMiss$x9 <- ifelse(age <= quantile(age, .3), NA, HSMiss$x9) ## specify CFA model from lavaan's ?cfa help page HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' ## use ageyr and agemo as auxiliary variables out <- cfa.2stage(model = HS.model, data = HSMiss, aux = c("ageyr","agemo")) ## two versions of a corrected chi-squared test results are shown out ## see Savalei & Bentler (2009) and Savalei & Falk (2014) for details ## the summary additionally provides the parameter estimates with corrected ## standard errors, test statistics, and confidence intervals, along with ## any other options that can be passed to parameterEstimates() summary(out, standardized = TRUE) ## use parameter labels to fit a more constrained model modc <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + a*x8 + a*x9 ' outc <- cfa.2stage(model = modc, data = HSMiss, aux = c("ageyr","agemo")) ## use the anova() method to test this constraint anova(out, outc) ## like for a single model, two corrected statistics are provided } \references{ Savalei, V., & Bentler, P. M. (2009). A two-stage approach to missing data: Theory and application to auxiliary variables. \emph{Structural Equation Modeling, 16}(3), 477--497. \doi{10.1080/10705510903008238} Savalei, V., & Falk, C. F. (2014). Robust two-stage approach outperforms robust full information maximum likelihood with incomplete nonnormal data. \emph{Structural Equation Modeling, 21}(2), 280--302. \doi{10.1080/10705511.2014.882692} } \seealso{ \linkS4class{twostage} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/semTools.Rd0000644000176200001440000000611014633512056014731 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/semTools.R \name{semTools} \alias{semTools} \alias{semTools-package} \title{semTools: Useful Tools for Structural Equation Modeling} \description{ The \pkg{semTools} package provides many miscellaneous functions that are useful for statistical analysis involving SEM in R. Many functions extend the funtionality of the \pkg{lavaan} package. Some sets of functions in \pkg{semTools} correspond to the same theme. We call such a collection of functions a \emph{suite}. Our suites include: \itemize{ \item{Model Fit Evaluation: \code{\link[=moreFitIndices]{moreFitIndices()}}, \code{\link[=nullRMSEA]{nullRMSEA()}}, \code{\link[=singleParamTest]{singleParamTest()}}, \code{\link[=miPowerFit]{miPowerFit()}}, and \code{\link[=chisqSmallN]{chisqSmallN()}}} \item{Measurement Invariance: \code{\link[=measEq.syntax]{measEq.syntax()}}, \code{\link[=partialInvariance]{partialInvariance()}}, \code{\link[=partialInvarianceCat]{partialInvarianceCat()}}, and \code{\link[=permuteMeasEq]{permuteMeasEq()}}} \item{Power Analysis: \code{\link[=SSpower]{SSpower()}}, \code{\link[=findRMSEApower]{findRMSEApower()}}, \code{\link[=plotRMSEApower]{plotRMSEApower()}}, \code{\link[=plotRMSEAdist]{plotRMSEAdist()}}, \code{\link[=findRMSEAsamplesize]{findRMSEAsamplesize()}}, \code{\link[=findRMSEApowernested]{findRMSEApowernested()}}, \code{\link[=plotRMSEApowernested]{plotRMSEApowernested()}}, and \code{\link[=findRMSEAsamplesizenested]{findRMSEAsamplesizenested()}}} \item{Missing Data Analysis: \code{\link[=auxiliary]{auxiliary()}}, \code{\link[=twostage]{twostage()}}, \code{\link[=fmi]{fmi()}}, \code{\link[=bsBootMiss]{bsBootMiss()}}, \code{\link[=quark]{quark()}}, and \code{\link[=combinequark]{combinequark()}}} \item{Latent Interactions: \code{\link[=indProd]{indProd()}}, \code{\link[=orthogonalize]{orthogonalize()}}, \code{\link[=probe2WayMC]{probe2WayMC()}}, \code{\link[=probe3WayMC]{probe3WayMC()}}, \code{\link[=probe2WayRC]{probe2WayRC()}}, \code{\link[=probe3WayRC]{probe3WayRC()}}, and \code{\link[=plotProbe]{plotProbe()}}} \item{Exploratory Factor Analysis (EFA): \code{\link[=efa.ekc]{efa.ekc()}}} \item{Reliability Estimation: \code{\link[=compRelSEM]{compRelSEM()}} and \code{\link[=maximalRelia]{maximalRelia()}} (see also \code{\link[=AVE]{AVE()}})} \item{Parceling: \code{\link[=parcelAllocation]{parcelAllocation()}}, \code{\link[=PAVranking]{PAVranking()}}, and \code{\link[=poolMAlloc]{poolMAlloc()}}} \item{Non-Normality: \code{\link[=skew]{skew()}}, \code{\link[=kurtosis]{kurtosis()}}, \code{\link[=mardiaSkew]{mardiaSkew()}}, \code{\link[=mardiaKurtosis]{mardiaKurtosis()}}, and \code{\link[=mvrnonnorm]{mvrnonnorm()}}} } All users of R (or SEM) are invited to submit functions or ideas for functions by contacting the maintainer, Terrence Jorgensen (\email{TJorgensen314@gmail.com}). Contributors are encouraged to use \code{Roxygen} comments to document their contributed code, which is consistent with the rest of \pkg{semTools}. Read the vignette from the \pkg{roxygen2} package for details: \code{vignette("rd", package = "roxygen2")} } semTools/man/probe3WayMC.Rd0000644000176200001440000002236714753073632015240 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/probeInteraction.R \name{probe3WayMC} \alias{probe3WayMC} \title{Probing three-way interaction on the no-centered or mean-centered latent interaction} \usage{ probe3WayMC(fit, nameX, nameY, modVar, valProbe1, valProbe2, group = 1L, omit.imps = c("no.conv", "no.se")) } \arguments{ \item{fit}{A fitted \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object with a latent 2-way interaction.} \item{nameX}{\code{character} vector of all 7 factor names used as the predictors. The 3 lower-order factors must be listed first, followed by the 3 second-order factors (specifically, the 4th element must be the interaction between the factors listed first and second, the 5th element must be the interaction between the factors listed first and third, and the 6th element must be the interaction between the factors listed second and third). The final name will be the factor representing the 3-way interaction.} \item{nameY}{The name of factor that is used as the dependent variable.} \item{modVar}{The name of two factors that are used as the moderators. The effect of the independent factor will be probed at each combination of the moderator variables' chosen values.} \item{valProbe1}{The values of the first moderator that will be used to probe the effect of the independent factor.} \item{valProbe2}{The values of the second moderator that will be used to probe the effect of the independent factor.} \item{group}{In multigroup models, the label of the group for which the results will be returned. Must correspond to one of \code{lavInspect(fit, "group.label")}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Ignored unless \code{fit} is of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} } \value{ A list with two elements: \enumerate{ \item \code{SimpleIntercept}: The model-implied intercepts given each combination of moderator values. \item \code{SimpleSlope}: The model-implied slopes given each combination of moderator values. } In each element, the first column represents values of the first moderator specified in the \code{valProbe1} argument. The second column represents values of the second moderator specified in the \code{valProbe2} argument. The third column is the simple intercept or simple slope. The fourth column is the standard error of the simple intercept or simple slope. The fifth column is the Wald (\emph{z}) statistic, and the sixth column is its associated \emph{p} value to test the null hypothesis that each simple intercept or simple slope equals 0. } \description{ Probing interaction for simple intercept and simple slope for the no-centered or mean-centered latent two-way interaction } \details{ Before using this function, researchers need to make the products of the indicators between the first-order factors using mean centering (Marsh, Wen, & Hau, 2004). Note that the double-mean centering may not be appropriate for probing interaction if researchers are interested in simple intercepts. The mean or double-mean centering can be done by the \code{\link[=indProd]{indProd()}} function. The indicator products can be made for all possible combination or matched-pair approach (Marsh et al., 2004). Next, the hypothesized model with the regression with latent interaction will be used to fit all original indicators and the product terms. See the example for how to fit the product term below. Once the lavaan result is obtained, this function will be used to probe the interaction. Let that the latent interaction model regressing the dependent variable (\eqn{Y}) on the independent variable (\eqn{X}) and two moderators (\eqn{Z} and \eqn{W}) be \deqn{ Y = b_0 + b_1X + b_2Z + b_3W + b_4XZ + b_5XW + b_6ZW + b_7XZW + r, } where \eqn{b_0} is the estimated intercept or the expected value of \eqn{Y} when \eqn{X}, \eqn{Z}, and \eqn{W} are 0, \eqn{b_1} is the effect of \eqn{X} when \eqn{Z} and \eqn{W} are 0, \eqn{b_2} is the effect of \eqn{Z} when \eqn{X} and \eqn{W} is 0, \eqn{b_3} is the effect of \eqn{W} when \eqn{X} and \eqn{Z} are 0, \eqn{b_4} is the interaction effect between \eqn{X} and \eqn{Z} when \eqn{W} is 0, \eqn{b_5} is the interaction effect between \eqn{X} and \eqn{W} when \eqn{Z} is 0, \eqn{b_6} is the interaction effect between \eqn{Z} and \eqn{W} when \eqn{X} is 0, \eqn{b_7} is the three-way interaction effect between \eqn{X}, \eqn{Z}, and \eqn{W}, and \eqn{r} is the residual term. To probe a three-way interaction, the simple intercept of the independent variable at the specific values of the moderators (Aiken & West, 1991) can be obtained by \deqn{ b_{0|X = 0, Z, W} = b_0 + b_2Z + b_3W + b_6ZW. } The simple slope of the independent variable at the specific values of the moderators can be obtained by \deqn{ b_{X|Z, W} = b_1 + b_3Z + b_4W + b_7ZW.} The variance of the simple intercept formula is \deqn{ Var\left(b_{0|X = 0, Z, W}\right) = Var\left(b_0\right) + Z^2Var\left(b_2\right) + W^2Var\left(b_3\right) + Z^2W^2Var\left(b_6\right)} \deqn{+ 2ZCov\left(b_0, b_2\right) + 2WCov\left(b_0, b_3\right) + 2ZWCov\left(b_0, b_6\right) + 2ZWCov\left(b_2, b_3\right) + 2Z^2WCov\left(b_2, b_6\right) + 2ZW^2Cov\left(b_3, b_6\right), } where \eqn{Var} denotes the variance of a parameter estimate and \eqn{Cov} denotes the covariance of two parameter estimates. The variance of the simple slope formula is \deqn{ Var\left(b_{X|Z, W}\right) = Var\left(b_1\right) + Z^2Var\left(b_4\right) + W^2Var\left(b_5\right) + Z^2W^2Var\left(b_7\right) } \deqn{+ 2ZCov\left(b_1, b_4\right) + 2WCov\left(b_1, b_5\right) + 2ZWCov\left(b_1, b_7\right) + 2ZWCov\left(b_4, b_5\right) + 2Z^2WCov\left(b_4, b_7\right) + 2ZW^2Cov\left(b_5, b_7\right). } Wald \emph{z} statistics are calculated (even for objects of class \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi}) to test null hypotheses that simple intercepts or slopes are 0. } \examples{ dat3wayMC <- indProd(dat3way, 1:3, 4:6, 7:9) model3 <- " ## define latent variables f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 f3 =~ x7 + x8 + x9 ## 2-way interactions f12 =~ x1.x4 + x2.x5 + x3.x6 f13 =~ x1.x7 + x2.x8 + x3.x9 f23 =~ x4.x7 + x5.x8 + x6.x9 ## 3-way interaction f123 =~ x1.x4.x7 + x2.x5.x8 + x3.x6.x9 ## outcome variable f4 =~ x10 + x11 + x12 ## latent regression model f4 ~ b1*f1 + b2*f2 + b3*f3 + b12*f12 + b13*f13 + b23*f23 + b123*f123 ## orthogonal terms among predictors ## (not necessary, but implied by double mean centering) f1 ~~ 0*f12 + 0*f13 + 0*f123 f2 ~~ 0*f12 + 0*f23 + 0*f123 f3 ~~ 0*f13 + 0*f23 + 0*f123 f12 + f13 + f23 ~~ 0*f123 " fitMC3way <- sem(model3, data = dat3wayMC, meanstructure = TRUE) summary(fitMC3way) probe3WayMC(fitMC3way, nameX = c("f1" ,"f2" ,"f3", "f12","f13","f23", # this order matters! "f123"), # 3-way interaction nameY = "f4", modVar = c("f1", "f2"), valProbe1 = c(-1, 0, 1), valProbe2 = c(-1, 0, 1)) } \references{ Tutorial: Schoemann, A. M., & Jorgensen, T. D. (2021). Testing and interpreting latent variable interactions using the \code{semTools} package. \emph{Psych, 3}(3), 322--335. \doi{10.3390/psych3030024} Background literature: Aiken, L. S., & West, S. G. (1991). \emph{Multiple regression: Testing and interpreting interactions}. Newbury Park, CA: Sage. Marsh, H. W., Wen, Z., & Hau, K. T. (2004). Structural equation models of latent interactions: Evaluation of alternative estimation strategies and indicator construction. \emph{Psychological Methods, 9}(3), 275--300. \doi{10.1037/1082-989X.9.3.275} } \seealso{ \itemize{ \item \code{\link[=indProd]{indProd()}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. \item \code{\link[=probe2WayMC]{probe2WayMC()}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering \item \code{\link[=probe2WayRC]{probe2WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=probe3WayRC]{probe3WayRC()}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. \item \code{\link[=plotProbe]{plotProbe()}} Plot the simple intercepts and slopes of the latent interaction. } } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/splitSample.Rd0000644000176200001440000000616614631670137015437 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/splitSample.R \name{splitSample} \alias{splitSample} \title{Randomly Split a Data Set into Halves} \usage{ splitSample(dataset, path = "default", div = 2, type = "default", name = "splitSample") } \arguments{ \item{dataset}{The original data set to be divided. Can be a file path to a *.csv or *.dat file (headers will automatically be detected) or an R object (matrix or dataframe). (Windows users: file path must be specified using FORWARD SLASHES (\code{/}) ONLY.)} \item{path}{File path to folder for output data sets. NOT REQUIRED if dataset is a filename. Specify ONLY if dataset is an R object, or desired output folder is not that of original data set. If path is specified as "object", output data sets will be returned as a list, and not saved to hard drive.} \item{div}{Number of output data sets. NOT REQUIRED if default, 2 halves.} \item{type}{Output file format ("dat" or "csv"). NOT REQUIRED unless desired output formatting differs from that of input, or dataset is an R object and csv formatting is desired.} \item{name}{Output file name. NOT REQUIRED unless desired output name differs from that of input, or input dataset is an R object. (If input is an R object and name is not specified, name will be "splitSample".)} } \value{ If \code{path = "object"}, \code{list} of output data sets. Otherwise, output will saved to hard drive in the same format as input. } \description{ This function randomly splits a data set into two halves, and saves the resulting data sets to the same folder as the original. } \details{ This function randomly orders the rows of a data set, divides the data set into two halves, and saves the halves to the same folder as the original data set, preserving the original formatting. Data set type (*.csv or \emph{.dat) and formatting (headers) are automatically detected, and output data sets will preserve input type and formatting unless specified otherwise. Input can be in the form of a file path (}.dat or *.csv), or an R object (matrix or dataframe). If input is an R object and path is default, output data sets will be returned as a list object. } \examples{ #### Input is .dat file #splitSample("C:/Users/Default/Desktop/MYDATA.dat") #### Output saved to "C:/Users/Default/Desktop/" in .dat format #### Names are "MYDATA_s1.dat" and "MYDATA_s2.dat" #### Input is R object ## Split C02 dataset from the datasets package library(datasets) splitMyData <- splitSample(CO2, path = "object") summary(splitMyData[[1]]) summary(splitMyData[[2]]) #### Output object splitMyData becomes list of output data sets #### Input is .dat file in "C:/" folder #splitSample("C:/testdata.dat", path = "C:/Users/Default/Desktop/", type = "csv") #### Output saved to "C:/Users/Default/Desktop/" in *.csv format #### Names are "testdata_s1.csv" and "testdata_s2.csv" #### Input is R object #splitSample(myData, path = "C:/Users/Default/Desktop/", name = "splitdata") #### Output saved to "C:/Users/Default/Desktop/" in *.dat format #### Names are "splitdata_s1.dat" and "splitdata_s2.dat" } \author{ Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) } semTools/man/measurementInvariance-deprecated.Rd0000644000176200001440000000772514753125077021572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/measurementInvariance.R \name{measurementInvariance-deprecated} \alias{measurementInvariance-deprecated} \title{Measurement Invariance Tests} \usage{ measurementInvariance(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001") } \arguments{ \item{...}{The same arguments as for any lavaan model. See \code{\link[lavaan:cfa]{lavaan::cfa()}} for more information.} \item{std.lv}{If \code{TRUE}, the fixed-factor method of scale identification is used. If \code{FALSE}, the first variable for each factor is used as marker variable.} \item{strict}{If \code{TRUE}, the sequence requires `strict' invariance. See details for more information.} \item{quiet}{If \code{FALSE} (default), a summary is printed out containing an overview of the different models that are fitted, together with some model comparison tests. If \code{TRUE}, no summary is printed.} \item{fit.measures}{Fit measures used to calculate the differences between nested models.} \item{baseline.model}{custom baseline model passed to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}} \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} for available options} } \value{ Invisibly, all model fits in the sequence are returned as a list. } \description{ Testing measurement invariance across groups using a typical sequence of model comparison tests. } \details{ If \code{strict = FALSE}, the following four models are tested in order: \enumerate{ \item Model 1: configural invariance. The same factor structure is imposed on all groups. \item Model 2: weak invariance. The factor loadings are constrained to be equal across groups. \item Model 3: strong invariance. The factor loadings and intercepts are constrained to be equal across groups. \item Model 4: The factor loadings, intercepts and means are constrained to be equal across groups. } Each time a more restricted model is fitted, a \eqn{\Delta\chi^2} test is reported, comparing the current model with the previous one, and comparing the current model to the baseline model (Model 1). In addition, the difference in CFI is also reported (\eqn{\Delta}CFI). If \code{strict = TRUE}, the following five models are tested in order: \enumerate{ \item Model 1: configural invariance. The same factor structure is imposed on all groups. \item Model 2: weak invariance. The factor loadings are constrained to be equal across groups. \item Model 3: strong invariance. The factor loadings and intercepts are constrained to be equal across groups. \item Model 4: strict invariance. The factor loadings, intercepts and residual variances are constrained to be equal across groups. \item Model 5: The factor loadings, intercepts, residual variances and means are constrained to be equal across groups. } Note that if the \eqn{\chi^2} test statistic is scaled (e.g., a Satorra-Bentler or Yuan-Bentler test statistic), a special version of the \eqn{\Delta\chi^2} test is used as described in \url{http://www.statmodel.com/chidiff.shtml} } \examples{ HW.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' measurementInvariance(model = HW.model, data = HolzingerSwineford1939, group = "school", fit.measures = c("cfi","aic")) } \references{ Vandenberg, R. J., and Lance, C. E. (2000). A review and synthesis of the measurement invariance literature: Suggestions, practices, and recommendations for organizational research. \emph{Organizational Research Methods, 3,} 4--70. } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/miPowerFit.Rd0000644000176200001440000002013414632143414015210 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/miPowerFit.R \name{miPowerFit} \alias{miPowerFit} \title{Modification indices and their power approach for model fit evaluation} \usage{ miPowerFit(lavaanObj, stdLoad = 0.4, cor = 0.1, stdBeta = 0.1, intcept = 0.2, stdDelta = NULL, delta = NULL, cilevel = 0.9, ...) } \arguments{ \item{lavaanObj}{The lavaan model object used to evaluate model fit} \item{stdLoad}{The amount of standardized factor loading that one would like to be detected (rejected). The default value is 0.4, which is suggested by Saris and colleagues (2009, p. 571).} \item{cor}{The amount of factor or error correlations that one would like to be detected (rejected). The default value is 0.1, which is suggested by Saris and colleagues (2009, p. 571).} \item{stdBeta}{The amount of standardized regression coefficients that one would like to be detected (rejected). The default value is 0.1, which is suggested by Saris and colleagues (2009, p. 571).} \item{intcept}{The amount of standardized intercept (similar to Cohen's \emph{d} that one would like to be detected (rejected). The default value is 0.2, which is equivalent to a low effect size proposed by Cohen (1988, 1992).} \item{stdDelta}{The vector of the standardized parameters that one would like to be detected (rejected). If this argument is specified, the value here will overwrite the other arguments above. The order of the vector must be the same as the row order from modification indices from the \code{lavaan} object. If a single value is specified, the value will be applied to all parameters.} \item{delta}{The vector of the unstandardized parameters that one would like to be detected (rejected). If this argument is specified, the value here will overwrite the other arguments above. The order of the vector must be the same as the row order from modification indices from the \code{lavaan} object. If a single value is specified, the value will be applied to all parameters.} \item{cilevel}{The confidence level of the confidence interval of expected parameter changes. The confidence intervals are used in the equivalence testing.} \item{\dots}{arguments passed to \code{\link[lavaan:modificationIndices]{lavaan::modificationIndices()}}, except for \code{delta}, which is already an argument (which can be substituted for \code{stdDelta} or specific sets of parameters using \code{stdLoad}, \code{cor}, \code{stdBeta}, and \code{intcept}).} } \value{ A data frame with these variables: \enumerate{ \item \code{lhs}: The left-hand side variable, with respect to the operator in in the lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} \item \code{op}: The lavaan syntax operator: "~~" represents covariance, "=~" represents factor loading, "~" represents regression, and "~1" represents intercept. \item \code{rhs}: The right-hand side variable \item \code{group}: The level of the group variable for the parameter in question \item \code{mi}: The modification index of the fixed parameter \item \code{epc}: The EPC if the parameter is freely estimated \item \code{target.epc}: The target EPC that represents the minimum size of misspecification that one would like to be detected by the test with a high power \item \code{std.epc}: The standardized EPC if the parameter is freely estimated \item \code{std.target.epc}: The standardized target expected parameter change \item \code{significant.mi}: Represents whether the modification index value is significant \item \code{high.power}: Represents whether the power is enough to detect the target expected parameter change \item \code{decision.pow}: The decision whether the parameter is misspecified or not based on Saris et al's method: \code{"M"} represents the parameter is misspecified, \code{"NM"} represents the parameter is not misspecified, \code{"EPC:M"} represents the parameter is misspecified decided by checking the expected parameter change value, \code{"EPC:NM"} represents the parameter is not misspecified decided by checking the expected parameter change value, and \code{"I"} represents the decision is inconclusive. \item \code{se.epc}: The standard errors of the expected parameter changes. \item \code{lower.epc}: The lower bound of the confidence interval of expected parameter changes. \item \code{upper.epc}: The upper bound of the confidence interval of expected parameter changes. \item \code{lower.std.epc}: Lower confidence limit of standardized EPCs \item \code{upper.std.epc}: Upper confidence limit of standardized EPCs \item \code{decision.ci}: Decision whether the parameter is misspecified based on the CI method: \code{"M"} represents the parameter is misspecified, \code{"NM"} represents the parameter is not misspecified, and \code{"I"} represents the decision is inconclusive. } The row numbers matches with the results obtained from the \code{inspect(object, "mi")} function. } \description{ The model fit evaluation approach using modification indices and expected parameter changes. } \details{ To decide whether a parameter should be freed, one can inspect its modification index (MI) and expected parameter change (EPC). Those values can be used to evaluate model fit by 2 methods. Method 1: Saris, Satorra, and van der Veld (2009, pp. 570--573) used power (probability of detecting a significant MI) and EPC to decide whether to free a parametr. First, one should evaluate whether a parameter's MI is significant. Second, one should evaluate whether the power to detect a target EPC is high enough. The combination of criteria leads to the so-called "JRule" first implemented with LISREL (van der Veld et al., 2008): \itemize{ \item If the MI is not significant and the power is low, the test is inconclusive. \item If the MI is not significant and the power is high, there is no misspecification. \item If the MI is significant and the power is low, the fixed parameter is misspecified. \item If the MI is significant and the power is high, the EPC is investigated. If the EPC is large (greater than the the target EPC), the parameter is misspecified. If the EPC is low (lower than the target EPC), the parameter is not misspecificied. } Method 2: The confidence interval (CI) of an EPC is calculated. These CIs are compared with the range of trivial misspecification, which could be (-\code{delta}, \code{delta}) or (0, \code{delta}) for nonnegative parameters. \itemize{ \item If a CI overlaps with the range of trivial misspecification, the test is inconclusive. \item If a CI completely exceeds the range of trivial misspecification, the fixed parameters are severely misspecified. \item If a CI is completely within the range of trivial misspecification, the fixed parameters are trivially misspecified. } } \examples{ library(lavaan) HS.model <- ' visual =~ x1 + x2 + x3 ' fit <- cfa(HS.model, data = HolzingerSwineford1939, group = "sex", group.equal = c("loadings","intercepts")) miPowerFit(fit, free.remove = FALSE, op = "=~") # loadings miPowerFit(fit, free.remove = FALSE, op = "~1") # intercepts model <- ' # latent variable definitions ind60 =~ x1 + x2 + x3 dem60 =~ y1 + a*y2 + b*y3 + c*y4 dem65 =~ y5 + a*y6 + b*y7 + c*y8 # regressions dem60 ~ ind60 dem65 ~ ind60 + dem60 # residual correlations y1 ~~ y5 y2 ~~ y4 + y6 y3 ~~ y7 y4 ~~ y8 y6 ~~ y8 ' fit2 <- sem(model, data = PoliticalDemocracy, meanstructure = TRUE) miPowerFit(fit2, stdLoad = 0.3, cor = 0.2, stdBeta = 0.2, intcept = 0.5) } \references{ Cohen, J. (1988). \emph{Statistical power analysis for the behavioral sciences} (2nd ed.). Hillsdale, NJ: Erlbaum. Cohen, J. (1992). A power primer. \emph{Psychological Bulletin, 112}(1), 155--159. \doi{10.1037/0033-2909.112.1.155} Saris, W. E., Satorra, A., & van der Veld, W. M. (2009). Testing structural equation models or detection of misspecifications? \emph{Structural Equation Modeling, 16}(4), 561--582. \doi{10.1080/10705510903203433} van der Veld, W. M., Saris, W. E., & Satorra, A. (2008). \emph{JRule 3.0 Users Guide}. \doi{10.13140/RG.2.2.13609.90729} } \seealso{ \code{\link[=moreFitIndices]{moreFitIndices()}} For the additional fit indices information } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/AVE.Rd0000644000176200001440000001162214753073632013550 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reliability.R \name{AVE} \alias{AVE} \title{Calculate average variance extracted} \usage{ AVE(object, obs.var = TRUE, omit.imps = c("no.conv", "no.se"), omit.factors = character(0), dropSingle = TRUE, return.df = TRUE) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object, expected to contain only exogenous common factors (i.e., a CFA model). Cross-loadings are not allowed and will result in \code{NA} for any factor with indicator(s) that cross-load.} \item{obs.var}{\code{logical} indicating whether to compute AVE using observed variances in the denominator. Setting \code{FALSE} triggers using model-implied variances in the denominator.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Can include any of \code{c("no.conv", "no.se", "no.npd")}, the first 2 of which are the default setting, which excludes any imputations that did not converge or for which standard errors could not be computed. The last option (\code{"no.npd"}) would exclude any imputations which yielded a nonpositive definite covariance matrix for observed or latent variables, which would include any "improper solutions" such as Heywood cases. NPD solutions are not excluded by default because they are likely to occur due to sampling error, especially in small samples. However, gross model misspecification could also cause NPD solutions, users can compare pooled results with and without this setting as a sensitivity analysis to see whether some imputations warrant further investigation.} \item{omit.factors}{\code{character} vector naming any common factors modeled in \code{object} whose indicators' AVE is not of interest.} \item{dropSingle}{\code{logical} indicating whether to exclude factors defined by a single indicator from the returned results. If \code{TRUE} (default), single indicators will still be included in the \code{total} column when \code{return.total = TRUE}.} \item{return.df}{\code{logical} indicating whether to return reliability coefficients in a \code{data.frame} (one row per group/level), which is possible when every model block includes the same factors (after excluding those in \code{omit.factors} and applying \code{dropSingle}).} } \value{ \code{numeric} vector of average variance extracted from indicators per factor. For models with multiple "blocks" (any combination of groups and levels), vectors may be returned as columns in a \code{data.frame} with additional columns indicating the group/level (see \verb{return.df=} argument description for caveat). } \description{ Calculate average variance extracted (AVE) per factor from \code{lavaan} object } \details{ The average variance extracted (AVE) can be calculated by \deqn{ AVE = \frac{\bold{1}^\prime \textrm{diag}\left(\Lambda\Psi\Lambda^\prime\right)\bold{1}}{\bold{1}^\prime \textrm{diag}\left(\hat{\Sigma}\right) \bold{1}}, } Note that this formula is modified from Fornell & Larcker (1981) in the case that factor variances are not 1. The proposed formula from Fornell & Larcker (1981) assumes that the factor variances are 1. Note that AVE will not be provided for factors consisting of items with dual loadings. AVE is the property of items but not the property of factors. AVE is calculated with polychoric correlations when ordinal indicators are used. } \examples{ data(HolzingerSwineford1939) HS9 <- HolzingerSwineford1939[ , c("x7","x8","x9")] HSbinary <- as.data.frame( lapply(HS9, cut, 2, labels=FALSE) ) names(HSbinary) <- c("y7","y8","y9") HS <- cbind(HolzingerSwineford1939, HSbinary) HS.model <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ y7 + y8 + y9 ' fit <- cfa(HS.model, data = HS, ordered = c("y7","y8","y9"), std.lv = TRUE) ## works for factors with exclusively continuous OR categorical indicators AVE(fit) # uses observed (or unconstrained polychoric/polyserial) by default AVE(fit, obs.var = FALSE) ## works for multigroup models and for multilevel models (and both) data(Demo.twolevel) ## assign clusters to arbitrary groups Demo.twolevel$g <- ifelse(Demo.twolevel$cluster \%\% 2L, "type1", "type2") model2 <- ' group: type1 level: within fac =~ y1 + L2*y2 + L3*y3 level: between fac =~ y1 + L2*y2 + L3*y3 group: type2 level: within fac =~ y1 + L2*y2 + L3*y3 level: between fac =~ y1 + L2*y2 + L3*y3 ' fit2 <- sem(model2, data = Demo.twolevel, cluster = "cluster", group = "g") AVE(fit2) } \references{ Fornell, C., & Larcker, D. F. (1981). Evaluating structural equation models with unobservable variables and measurement errors. \emph{Journal of Marketing Research, 18}(1), 39--50. \doi{10.2307/3151312} } \seealso{ \code{\link[=compRelSEM]{compRelSEM()}} for composite reliability estimates } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/measEq.syntax.Rd0000644000176200001440000006452314764270501015701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/measEq.R \name{measEq.syntax} \alias{measEq.syntax} \title{Syntax for measurement equivalence} \usage{ measEq.syntax(configural.model, ..., ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", ID.thr = c(1L, 2L), group = NULL, group.equal = "", group.partial = "", longFacNames = list(), longIndNames = list(), long.equal = "", long.partial = "", auto = "all", warn = TRUE, debug = FALSE, return.fit = FALSE) } \arguments{ \item{configural.model}{A model with no measurement-invariance constraints (i.e., representing only configural invariance), unless required for model identification. \code{configural.model} can be either: \itemize{ \item \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} or a \code{\link[lavaan:parTable]{lavaan::parTable()}} specifying the configural model. Using this option, the user can also provide either raw \code{data} or summary statistics via \code{sample.cov} and (optionally) \code{sample.mean}. See argument descriptions in \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. In order to include thresholds in the generated syntax, either users must provide raw \code{data}, or the \code{configural.model} syntax must specify all thresholds (see first example). If raw \code{data} are not provided, the number of blocks (groups, levels, or combination) must be indicated using an arbitrary \code{sample.nobs} argument (e.g., 3 groups could be specified using \code{sample.nobs=rep(1, 3)}). \item a fitted \link[lavaan:lavaan-class]{lavaan::lavaan} model (e.g., as returned by \code{\link[lavaan:cfa]{lavaan::cfa()}}) estimating the configural model } Note that the specified or fitted model must not contain any latent structural parameters (i.e., it must be a CFA model), unless they are higher-order constructs with latent indicators (i.e., a second-order CFA).} \item{...}{Additional arguments (e.g., \code{data}, \code{ordered}, or \code{parameterization}) passed to the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{ID.fac}{\code{character}. The method for identifying common-factor variances and (if \code{meanstructure = TRUE}) means. Three methods are available, which go by different names in the literature: \itemize{ \item Standardize the common factor (mean = 0, \emph{SD} = 1) by specifying any of: \code{"std.lv"}, \code{"unit.variance"}, \code{"UV"}, \code{"fixed.factor"}, \code{"fixed-factor"} \item Choose a reference indicator by specifying any of: \code{"auto.fix.first"}, \code{"unit.loading"}, \code{"UL"}, \code{"marker"}, \code{"ref"}, \code{"ref.indicator"}, \code{"reference.indicator"}, \code{"reference-indicator"}, \code{"marker.variable"}, \code{"marker-variable"} \item Apply effects-code constraints to loadings and intercepts by specifying any of: \code{"FX"}, \code{"EC"}, \code{"effects"}, \code{"effects.coding"}, \code{"effects-coding"}, \code{"effects.code"}, \code{"effects-code"} } See Kloessner & Klopp (2019) for details about all three methods.} \item{ID.cat}{\code{character}. The method for identifying (residual) variances and intercepts of latent item-responses underlying any \code{ordered} indicators. Four methods are available: \itemize{ \item To follow Wu & Estabrook's (2016) guidelines (default), specify any of: \code{"Wu.Estabrook.2016"}, \code{"Wu.2016"}, \code{"Wu.Estabrook"}, \code{"Wu"}, \code{"Wu2016"}. For consistency, specify \code{ID.fac = "std.lv"}. \item To use the default settings of M\emph{plus} and \code{lavaan}, specify any of: \code{"default"}, \code{"Mplus"}, \code{"Muthen"}. Details provided in Millsap & Tein (2004). \item To use the constraints recommended by Millsap & Tein (2004; see also Liu et al., 2017, for the longitudinal case) specify any of: \code{"millsap"}, \code{"millsap.2004"}, \code{"millsap.tein.2004"}. For consistency, specify \code{ID.fac = "marker"} and \code{parameterization = "theta"}. \item To use the default settings of LISREL, specify \code{"LISREL"} or \code{"Joreskog"}. Details provided in Millsap & Tein (2004). For consistency, specify \code{parameterization = "theta"}. } See \strong{Details} and \strong{References} for more information.} \item{ID.thr}{\code{integer}. Only relevant when \code{ID.cat = "Millsap.Tein.2004"}. Used to indicate which thresholds should be constrained for identification. The first integer indicates the threshold used for all indicators, the second integer indicates the additional threshold constrained for a reference indicator (ignored if binary).} \item{group}{optional \code{character} indicating the name of a grouping variable. See \code{\link[lavaan:cfa]{lavaan::cfa()}}.} \item{group.equal}{optional \code{character} vector indicating type(s) of parameter to equate across groups. Ignored if \code{is.null(group)}. See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{group.partial}{optional \code{character} vector or a parameter table indicating exceptions to \code{group.equal} (see \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}). Any variables not appearing in the \code{configural.model} will be ignored, and any parameter constraints needed for identification (e.g., two thresholds per indicator when \code{ID.cat = "Millsap"}) will be removed.} \item{longFacNames}{optional named \code{list} of \code{character} vectors, each indicating multiple factors in the model that are actually the same construct measured repeatedly. See \strong{Details} and \strong{Examples}.} \item{longIndNames}{optional named \code{list} of \code{character} vectors, each indicating multiple indicators in the model that are actually the same indicator measured repeatedly. See \strong{Details} and \strong{Examples}.} \item{long.equal}{optional \code{character} vector indicating type(s) of parameter to equate across repeated measures. Ignored if no factors are indicated as repeatedly measured in \code{longFacNames}.} \item{long.partial}{optional \code{character} vector or a parameter table indicating exceptions to \code{long.equal}. Any longitudinal variable names not appearing in \code{names(longFacNames)} or \code{names(longIndNames)} will be ignored, and any parameter constraints needed for identification will be removed.} \item{auto}{Used to automatically included autocorrelated measurement errors among repeatedly measured indicators in \code{longIndNames}. Specify a single \code{integer} to set the maximum order (e.g., \code{auto = 1L} indicates that an indicator's unique factors should only be correlated between adjacently measured occasions). \code{auto = TRUE} or \code{"all"} will specify residual covariances among all possible lags per repeatedly measured indicator in \code{longIndNames}.} \item{warn, debug}{\code{logical}. Passed to \code{\link[lavaan:lavaan]{lavaan::lavaan()}} and \code{\link[lavaan:model.syntax]{lavaan::lavParseModelString()}}. See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{return.fit}{\code{logical} indicating whether the generated syntax should be fitted to the provided \code{data} (or summary statistics, if provided via \code{sample.cov}). If \code{configural.model} is a fitted lavaan model, the generated syntax will be fitted using the \code{update} method (see \link[lavaan:lavaan-class]{lavaan::lavaan}), and \dots will be passed to \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. If neither data nor a fitted lavaan model were provided, this must be \code{FALSE}. If \code{TRUE}, the generated \code{measEq.syntax} object will be included in the \code{lavaan} object's \verb{@external} slot, accessible by \code{fit@external$measEq.syntax}.} } \value{ By default, an object of class \linkS4class{measEq.syntax}. If \code{return.fit = TRUE}, a fitted \code{\link[lavaan:lavaan]{lavaan::lavaan()}} model, with the \code{measEq.syntax} object stored in the \verb{@external} slot, accessible by \code{fit@external$measEq.syntax}. } \description{ Automatically generates \code{lavaan} model syntax to specify a confirmatory factor analysis (CFA) model with equality constraints imposed on user-specified measurement (or structural) parameters. Optionally returns the fitted model (if data are provided) representing some chosen level of measurement equivalence/invariance across groups and/or repeated measures. } \details{ This function is a pedagogical and analytical tool to generate model syntax representing some level of measurement equivalence/invariance across any combination of multiple groups and/or repeated measures. Support is provided for confirmatory factor analysis (CFA) models with simple or complex structure (i.e., cross-loadings and correlated residuals are allowed). For any complexities that exceed the limits of automation, this function is intended to still be useful by providing a means to generate syntax that users can easily edit to accommodate their unique situations. Limited support is provided for bifactor models and higher-order constructs. Because bifactor models have cross-loadings by definition, the option \code{ID.fac = "effects.code"} is unavailable. \code{ID.fac = "UV"} is recommended for bifactor models, but \code{ID.fac = "UL"} is available on the condition that each factor has a unique first indicator in the \code{configural.model}. In order to maintain generality, higher-order factors may include a mix of manifest and latent indicators, but they must therefore require \code{ID.fac = "UL"} to avoid complications with differentiating lower-order vs. higher-order (or mixed-level) factors. The keyword \code{"loadings"} in \code{group.equal} or \code{long.equal} constrains factor loadings of all manifest indicators (including loadings on higher-order factors that also have latent indicators), whereas the keyword \code{"regressions"} constrains factor loadings of latent indicators. Users can edit the model syntax manually to adjust constraints as necessary, or clever use of the \code{group.partial} or \code{long.partial} arguments could make it possible for users to still automated their model syntax. The keyword \code{"intercepts"} constrains the intercepts of all manifest indicators, and the keyword \code{"means"} constrains intercepts and means of all latent common factors, regardless of whether they are latent indicators of higher-order factors. To test equivalence of lower-order and higher-order intercepts/means in separate steps, the user can either manually edit their generated syntax or conscientiously exploit the \code{group.partial} or \code{long.partial} arguments as necessary. \strong{\code{ID.fac}:} If the \code{configural.model} fixes any (e.g., the first) factor loadings, the generated syntax object will retain those fixed values. This allows the user to retain additional constraints that might be necessary (e.g., if there are only 1 or 2 indicators). Some methods must be used in conjunction with other settings: \itemize{ \item \code{ID.cat = "Millsap"} requires \code{ID.fac = "UL"} and \code{parameterization = "theta"}. \item \code{ID.cat = "LISREL"} requires \code{parameterization = "theta"}. \item \code{ID.fac = "effects.code"} is unavailable when there are any cross-loadings. } \strong{\code{ID.cat}:} Wu & Estabrook (2016) recommended constraining thresholds to equality first, and doing so should allow releasing any identification constraints no longer needed. For each \code{ordered} indicator, constraining one threshold to equality will allow the item's intercepts to be estimated in all but the first group or repeated measure. Constraining a second threshold (if applicable) will allow the item's (residual) variance to be estimated in all but the first group or repeated measure. For binary data, there is no independent test of threshold, intercept, or residual-variance equality. Equivalence of thresholds must also be assumed for three-category indicators. These guidelines provide the least restrictive assumptions and tests, and are therefore the default. The default setting in M\emph{plus} is similar to Wu & Estabrook (2016), except that intercepts are always constrained to zero (so they are assumed to be invariant without testing them). Millsap & Tein (2004) recommended \code{parameterization = "theta"} and identified an item's residual variance in all but the first group (or occasion; Liu et al., 2017) by constraining its intercept to zero and one of its thresholds to equality. A second threshold for the reference indicator (so \code{ID.fac = "UL"}) is used to identify the common-factor means in all but the first group/occasion. The LISREL software fixes the first threshold to zero and (if applicable) the second threshold to 1, and assumes any remaining thresholds to be equal across groups / repeated measures; thus, the intercepts are always identified, and residual variances (\code{parameterization = "theta"}) are identified except for binary data, when they are all fixed to one. \strong{Repeated Measures:} If each repeatedly measured factor is measured by the same indicators (specified in the same order in the \code{configural.model}) on each occasion, without any cross-loadings, the user can let \code{longIndNames} be automatically generated. Generic names for the repeatedly measured indicators are created using the name of the repeatedly measured factors (i.e., \code{names(longFacNames)}) and the number of indicators. So the repeatedly measured first indicator (\code{"ind"}) of a longitudinal construct called "factor" would be generated as \code{"._factor_ind.1"}. The same types of parameter can be specified for \code{long.equal} as for \code{group.equal} (see \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}} for a list), except for \code{"residual.covariances"} or \code{"lv.covariances"}. Instead, users can constrain \emph{auto}covariances using keywords \code{"resid.autocov"} or \code{"lv.autocov"}. Note that \code{group.equal = "lv.covariances"} or \code{group.equal = "residual.covariances"} will constrain any autocovariances across groups, along with any other covariances the user specified in the \code{configural.model}. Note also that autocovariances cannot be specified as exceptions in \code{long.partial}, so anything more complex than the \code{auto} argument automatically provides should instead be manually specified in the \code{configural.model}. When users set \code{orthogonal=TRUE} in the \code{configural.model} (e.g., in bifactor models of repeatedly measured constructs), autocovariances of each repeatedly measured factor will still be freely estimated in the generated syntax. \strong{Missing Data:} If users wish to utilize the \code{\link[=auxiliary]{auxiliary()}} function to automatically include auxiliary variables in conjunction with \code{missing = "FIML"}, they should first generate the hypothesized-model syntax, then submit that syntax as the model to \code{auxiliary()}. If users utilized \code{\link[lavaan.mi:lavaan.mi]{lavaan.mi::lavaan.mi()}} to fit their \code{configural.model} to multiply imputed data, that model can also be passed to the \code{configural.model} argument, and if \code{return.fit = TRUE}, the generated model will be fitted to the multiple imputations. } \examples{ mod.cat <- ' FU1 =~ u1 + u2 + u3 + u4 FU2 =~ u5 + u6 + u7 + u8 ' ## the 2 factors are actually the same factor (FU) measured twice longFacNames <- list(FU = c("FU1","FU2")) ## CONFIGURAL model: no constraints across groups or repeated measures syntax.config <- measEq.syntax(configural.model = mod.cat, # NOTE: data provides info about numbers of # groups and thresholds data = datCat, ordered = paste0("u", 1:8), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", longFacNames = longFacNames) ## print lavaan syntax to the Console cat(as.character(syntax.config)) ## print a summary of model features summary(syntax.config) ## THRESHOLD invariance: ## only necessary to specify thresholds if you have no data mod.th <- ' u1 | t1 + t2 + t3 + t4 u2 | t1 + t2 + t3 + t4 u3 | t1 + t2 + t3 + t4 u4 | t1 + t2 + t3 + t4 u5 | t1 + t2 + t3 + t4 u6 | t1 + t2 + t3 + t4 u7 | t1 + t2 + t3 + t4 u8 | t1 + t2 + t3 + t4 ' syntax.thresh <- measEq.syntax(configural.model = c(mod.cat, mod.th), # NOTE: data not provided, so syntax must # include thresholds, and number of # groups == 2 is indicated by: sample.nobs = c(1, 1), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", group.equal = "thresholds", longFacNames = longFacNames, long.equal = "thresholds") ## notice that constraining 4 thresholds allows intercepts and residual ## variances to be freely estimated in all but the first group & occasion cat(as.character(syntax.thresh)) ## print a summary of model features summary(syntax.thresh) ## Fit a model to the data either in a subsequent step (recommended): mod.config <- as.character(syntax.config) fit.config <- cfa(mod.config, data = datCat, group = "g", ordered = paste0("u", 1:8), parameterization = "theta") ## or in a single step (not generally recommended): fit.thresh <- measEq.syntax(configural.model = mod.cat, data = datCat, ordered = paste0("u", 1:8), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", group.equal = "thresholds", longFacNames = longFacNames, long.equal = "thresholds", return.fit = TRUE) ## compare their fit to test threshold invariance anova(fit.config, fit.thresh) ## -------------------------------------------------------- ## RECOMMENDED PRACTICE: fit one invariance model at a time ## -------------------------------------------------------- ## - A downside of setting return.fit=TRUE is that if the model has trouble ## converging, you don't have the opportunity to investigate the syntax, ## or even to know whether an error resulted from the syntax-generator or ## from lavaan itself. ## - A downside of automatically fitting an entire set of invariance models ## (like the old measurementInvariance() function did) is that you might ## end up testing models that shouldn't even be fitted because less ## restrictive models already fail (e.g., don't test full scalar ## invariance if metric invariance fails! Establish partial metric ## invariance first, then test equivalent of intercepts ONLY among the ## indicators that have invariate loadings.) ## The recommended sequence is to (1) generate and save each syntax object, ## (2) print it to the screen to verify you are fitting the model you expect ## to (and potentially learn which identification constraints should be ## released when equality constraints are imposed), and (3) fit that model ## to the data, as you would if you had written the syntax yourself. ## Continuing from the examples above, after establishing invariance of ## thresholds, we proceed to test equivalence of loadings and intercepts ## (metric and scalar invariance, respectively) ## simultaneously across groups and repeated measures. \donttest{ ## metric invariance syntax.metric <- measEq.syntax(configural.model = mod.cat, data = datCat, ordered = paste0("u", 1:8), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", longFacNames = longFacNames, group.equal = c("thresholds","loadings"), long.equal = c("thresholds","loadings")) summary(syntax.metric) # summarize model features mod.metric <- as.character(syntax.metric) # save as text cat(mod.metric) # print/view lavaan syntax ## fit model to data fit.metric <- cfa(mod.metric, data = datCat, group = "g", ordered = paste0("u", 1:8), parameterization = "theta") ## test equivalence of loadings, given equivalence of thresholds anova(fit.thresh, fit.metric) ## scalar invariance syntax.scalar <- measEq.syntax(configural.model = mod.cat, data = datCat, ordered = paste0("u", 1:8), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", longFacNames = longFacNames, group.equal = c("thresholds","loadings", "intercepts"), long.equal = c("thresholds","loadings", "intercepts")) summary(syntax.scalar) # summarize model features mod.scalar <- as.character(syntax.scalar) # save as text cat(mod.scalar) # print/view lavaan syntax ## fit model to data fit.scalar <- cfa(mod.scalar, data = datCat, group = "g", ordered = paste0("u", 1:8), parameterization = "theta") ## test equivalence of intercepts, given equal thresholds & loadings anova(fit.metric, fit.scalar) ## For a single table with all results, you can pass the models to ## summarize to the compareFit() function Comparisons <- compareFit(fit.config, fit.thresh, fit.metric, fit.scalar) summary(Comparisons) ## ------------------------------------------------------ ## NOT RECOMMENDED: fit several invariance models at once ## ------------------------------------------------------ test.seq <- c("thresholds","loadings","intercepts","means","residuals") meq.list <- list() for (i in 0:length(test.seq)) { if (i == 0L) { meq.label <- "configural" group.equal <- "" long.equal <- "" } else { meq.label <- test.seq[i] group.equal <- test.seq[1:i] long.equal <- test.seq[1:i] } meq.list[[meq.label]] <- measEq.syntax(configural.model = mod.cat, data = datCat, ordered = paste0("u", 1:8), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", group.equal = group.equal, longFacNames = longFacNames, long.equal = long.equal, return.fit = TRUE) } evalMeasEq <- compareFit(meq.list) summary(evalMeasEq) ## ----------------- ## Binary indicators ## ----------------- ## borrow example data from Mplus user guide myData <- read.table("http://www.statmodel.com/usersguide/chap5/ex5.16.dat") names(myData) <- c("u1","u2","u3","u4","u5","u6","x1","x2","x3","g") bin.mod <- ' FU1 =~ u1 + u2 + u3 FU2 =~ u4 + u5 + u6 ' ## Must SIMULTANEOUSLY constrain thresholds, loadings, and intercepts test.seq <- list(strong = c("thresholds","loadings","intercepts"), means = "means", strict = "residuals") meq.list <- list() for (i in 0:length(test.seq)) { if (i == 0L) { meq.label <- "configural" group.equal <- "" long.equal <- "" } else { meq.label <- names(test.seq)[i] group.equal <- unlist(test.seq[1:i]) # long.equal <- unlist(test.seq[1:i]) } meq.list[[meq.label]] <- measEq.syntax(configural.model = bin.mod, data = myData, ordered = paste0("u", 1:6), parameterization = "theta", ID.fac = "std.lv", ID.cat = "Wu.Estabrook.2016", group = "g", group.equal = group.equal, #longFacNames = longFacNames, #long.equal = long.equal, return.fit = TRUE) } evalMeasEq <- compareFit(meq.list) summary(evalMeasEq) ## --------------------- ## Multilevel Invariance ## --------------------- ## To test invariance across levels in a MLSEM, specify syntax as though ## you are fitting to 2 groups instead of 2 levels. mlsem <- ' f1 =~ y1 + y2 + y3 f2 =~ y4 + y5 + y6 ' ## metric invariance syntax.metric <- measEq.syntax(configural.model = mlsem, meanstructure = TRUE, ID.fac = "std.lv", sample.nobs = c(1, 1), group = "cluster", group.equal = "loadings") ## by definition, Level-1 means must be zero, so fix them syntax.metric <- update(syntax.metric, change.syntax = paste0("y", 1:6, " ~ c(0, NA)*1")) ## save as a character string mod.metric <- as.character(syntax.metric, groups.as.blocks = TRUE) ## convert from multigroup to multilevel mod.metric <- gsub(pattern = "group:", replacement = "level:", x = mod.metric, fixed = TRUE) ## fit model to data fit.metric <- lavaan(mod.metric, data = Demo.twolevel, cluster = "cluster") summary(fit.metric) } } \references{ Kloessner, S., & Klopp, E. (2019). Explaining constraint interaction: How to interpret estimated model parameters under alternative scaling methods. \emph{Structural Equation Modeling, 26}(1), 143--155. \doi{10.1080/10705511.2018.1517356} Liu, Y., Millsap, R. E., West, S. G., Tein, J.-Y., Tanaka, R., & Grimm, K. J. (2017). Testing measurement invariance in longitudinal data with ordered-categorical measures. \emph{Psychological Methods, 22}(3), 486--506. \doi{10.1037/met0000075} Millsap, R. E., & Tein, J.-Y. (2004). Assessing factorial invariance in ordered-categorical measures. \emph{Multivariate Behavioral Research, 39}(3), 479--515. \doi{10.1207/S15327906MBR3903_4} Wu, H., & Estabrook, R. (2016). Identification of confirmatory factor analysis models of different levels of invariance for ordered categorical outcomes. \emph{Psychometrika, 81}(4), 1014--1045. \doi{10.1007/s11336-016-9506-0} } \seealso{ \code{\link[=compareFit]{compareFit()}} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/SSpower.Rd0000644000176200001440000001270314632143415014531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisSS.R \name{SSpower} \alias{SSpower} \title{Power for model parameters} \usage{ SSpower(powerModel, n, nparam, popModel, mu, Sigma, fun = "sem", alpha = 0.05, ...) } \arguments{ \item{powerModel}{lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} for the model to be analyzed. This syntax should constrain at least one nonzero parameter to 0 (or another number).} \item{n}{\code{integer}. Sample size used in power calculation, or a vector of sample sizes if analyzing a multigroup model. If \code{length(n) < length(Sigma)} when \code{Sigma} is a list, \code{n} will be recycled. If \code{popModel} is used instead of \code{Sigma}, \code{n} must specify a sample size for each group, because that is used to infer the number of groups.} \item{nparam}{\code{integer}. Number of invalid constraints in \code{powerModel}.} \item{popModel}{lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} specifying the data-generating model. This syntax should specify values for all nonzero parameters in the model. If \code{length(n) > 1}, the same population values will be used for each group, unless different population values are specified per group, either in the lavaan \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} or by utilizing a list of \code{Sigma} (and optionally \code{mu}).} \item{mu}{\code{numeric} or \code{list}. For a single-group model, a vector of population means. For a multigroup model, a list of vectors (one per group). If \code{mu} and \code{popModel} are missing, mean structure will be excluded from the analysis.} \item{Sigma}{\code{matrix} or \code{list}. For a single-group model, a population covariance matrix. For a multigroup model, a list of matrices (one per group). If missing, \code{popModel} will be used to generate a model-implied Sigma.} \item{fun}{character. Name of \code{lavaan} function used to fit \code{powerModel} (i.e., \code{"cfa"}, \code{"sem"}, \code{"growth"}, or \code{"lavaan"}).} \item{alpha}{Type I error rate used to set a criterion for rejecting H0.} \item{...}{additional arguments to pass to \code{\link[lavaan:lavaan]{lavaan::lavaan()}}. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} } \description{ Apply Satorra & Saris (1985) method for chi-squared power analysis. } \details{ Specify all non-zero parameters in a population model, either by using lavaan syntax (\code{popModel}) or by submitting a population covariance matrix (\code{Sigma}) and optional mean vector (\code{mu}) implied by the population model. Then specify an analysis model that places at least one invalid constraint (note the number in the \code{nparam} argument). There is also a Shiny app called "power4SEM" that provides a graphical user interface for this functionality (Jak et al., in press). It can be accessed at \url{https://sjak.shinyapps.io/power4SEM/}. } \examples{ ## Specify population values. Note every parameter has a fixed value. modelP <- ' f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 f1 ~~ .3*f2 f1 ~~ 1*f1 f2 ~~ 1*f2 V1 ~~ .51*V1 V2 ~~ .51*V2 V3 ~~ .51*V3 V4 ~~ .51*V4 V5 ~~ .51*V5 V6 ~~ .51*V6 V7 ~~ .51*V7 V8 ~~ .51*V8 ' ## Specify analysis model. Note parameter of interest f1~~f2 is fixed to 0. modelA <- ' f1 =~ V1 + V2 + V3 + V4 f2 =~ V5 + V6 + V7 + V8 f1 ~~ 0*f2 ' ## Calculate power SSpower(powerModel = modelA, popModel = modelP, n = 150, nparam = 1, std.lv = TRUE) ## Get power for a range of sample sizes Ns <- seq(100, 500, 40) Power <- rep(NA, length(Ns)) for(i in 1:length(Ns)) { Power[i] <- SSpower(powerModel = modelA, popModel = modelP, n = Ns[i], nparam = 1, std.lv = TRUE) } plot(x = Ns, y = Power, type = "l", xlab = "Sample Size") ## Optionally specify different values for multiple populations modelP2 <- ' f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 f1 ~~ c(-.3, .3)*f2 # DIFFERENT ACROSS GROUPS f1 ~~ 1*f1 f2 ~~ 1*f2 V1 ~~ .51*V1 V2 ~~ .51*V2 V3 ~~ .51*V3 V4 ~~ .51*V4 V5 ~~ .51*V5 V6 ~~ .51*V6 V7 ~~ .51*V7 V8 ~~ .51*V8 ' modelA2 <- ' f1 =~ V1 + V2 + V3 + V4 f2 =~ V5 + V6 + V7 + V8 f1 ~~ c(psi21, psi21)*f2 # EQUALITY CONSTRAINT ACROSS GROUPS ' ## Calculate power SSpower(powerModel = modelA2, popModel = modelP2, n = c(100, 100), nparam = 1, std.lv = TRUE) ## Get power for a range of sample sizes Ns2 <- cbind(Group1 = seq(10, 100, 10), Group2 = seq(10, 100, 10)) Power2 <- apply(Ns2, MARGIN = 1, FUN = function(nn) { SSpower(powerModel = modelA2, popModel = modelP2, n = nn, nparam = 1, std.lv = TRUE) }) plot(x = rowSums(Ns2), y = Power2, type = "l", xlab = "Total Sample Size", ylim = 0:1) abline(h = c(.8, .9), lty = c("dotted","dashed")) legend("bottomright", c("80\% Power","90\% Power"), lty = c("dotted","dashed")) } \references{ Satorra, A., & Saris, W. E. (1985). Power of the likelihood ratio test in covariance structure analysis. \emph{Psychometrika, 50}(1), 83--90. \doi{10.1007/BF02294150} Jak, S., Jorgensen, T. D., Verdam, M. G., Oort, F. J., & Elffers, L. (2021). Analytical power calculations for structural equation modeling: A tutorial and Shiny app. \emph{Behavior Research Methods, 53}, 1385--1406. \doi{10.3758/s13428-020-01479-0} } \author{ Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/chisqSmallN.Rd0000644000176200001440000000661514751406177015363 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fitIndices.R \name{chisqSmallN} \alias{chisqSmallN} \title{Small-\emph{N} correction for \eqn{chi^2} test statistic} \usage{ chisqSmallN(fit0, fit1 = NULL, smallN.method = if (is.null(fit1)) c("swain", "yuan.2015") else "yuan.2005", ..., omit.imps = c("no.conv", "no.se")) } \arguments{ \item{fit0, fit1}{\link[lavaan:lavaan-class]{lavaan::lavaan} or \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object(s)} \item{smallN.method}{\code{character} indicating the small-\emph{N} correction method to use. Multiple may be chosen (all of which assume normality), as described in Shi et al. (2018): \code{c("swain","yuan.2015","yuan.2005","bartlett")}. Users may also simply select \code{"all"}.} \item{\dots}{Additional arguments to the \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} or \code{\link[lavaan.mi:lavTestLRT.mi]{lavaan.mi::lavTestLRT.mi()}} functions. Ignored when \code{is.null(fit1)}.} \item{omit.imps}{\code{character} vector specifying criteria for omitting imputations from pooled results. Ignored unless \code{fit0} (and optionally \code{fit1}) is a \link[lavaan.mi:lavaan.mi-class]{lavaan.mi::lavaan.mi} object. See \code{\link[lavaan.mi:lavTestLRT.mi]{lavaan.mi::lavTestLRT.mi()}} for a description of options and defaults.} } \value{ A \code{list} of \code{numeric} vectors: one for the originally requested statistic(s), along with one per requested \code{smallN.method}. All include the the (un)adjusted test statistic, its \emph{df}, and the \emph{p} value for the test under the null hypothesis that the model fits perfectly (or that the 2 models have equivalent fit). The adjusted chi-squared statistic(s) also include(s) the scaling factor for the small-\emph{N} adjustment. } \description{ Calculate small-\emph{N} corrections for \eqn{chi^2} model-fit test statistic to adjust for small sample size (relative to model size). } \details{ Four finite-sample adjustments to the chi-squared statistic are currently available, all of which are described in Shi et al. (2018). These all assume normally distributed data, and may not work well with severely nonnormal data. Deng et al. (2018, section 4) review proposed small-\emph{N} adjustments that do not assume normality, which rarely show promise, so they are not implemented here. This function currently will apply small-\emph{N} adjustments to scaled test statistics with a warning that they do not perform well (Deng et al., 2018). } \examples{ HS.model <- ' visual =~ x1 + b1*x2 + x3 textual =~ x4 + b2*x5 + x6 speed =~ x7 + b3*x8 + x9 ' fit1 <- cfa(HS.model, data = HolzingerSwineford1939[1:50,]) ## test a single model (implicitly compared to a saturated model) chisqSmallN(fit1) ## fit a more constrained model fit0 <- cfa(HS.model, data = HolzingerSwineford1939[1:50,], orthogonal = TRUE) ## compare 2 models chisqSmallN(fit1, fit0) } \references{ Deng, L., Yang, M., & Marcoulides, K. M. (2018). Structural equation modeling with many variables: A systematic review of issues and developments. \emph{Frontiers in Psychology, 9}, 580. \doi{10.3389/fpsyg.2018.00580} Shi, D., Lee, T., & Terry, R. A. (2018). Revisiting the model size effect in structural equation modeling. \emph{Structural Equation Modeling, 25}(1), 21--40. \doi{10.1080/10705511.2017.1369088} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/net.Rd0000644000176200001440000000475314764270501013726 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/NET.R \name{net} \alias{net} \title{Nesting and Equivalence Testing} \usage{ net(..., crit = 1e-04) } \arguments{ \item{\dots}{The \code{lavaan} objects used for test of nesting and equivalence} \item{crit}{The upper-bound criterion for testing the equivalence of models. Models are considered nested (or equivalent) if the difference between their \eqn{\chi^2} fit statistics is less than this criterion.} } \value{ The \linkS4class{Net} object representing the outputs for nesting and equivalent testing, including a logical matrix of test results and a vector of degrees of freedom for each model. } \description{ This test examines whether pairs of SEMs are nested or equivalent. } \details{ The concept of nesting/equivalence should be the same regardless of estimation method. However, the particular method of testing nesting/equivalence (as described in Bentler & Satorra, 2010) employed by the \code{net} function analyzes summary statistics (model-implied means and covariance matrices, not raw data). In the case of robust methods like MLR, the raw data is only utilized for the robust adjustment to SE and chi-sq, and the net function only checks the unadjusted chi-sq for the purposes of testing nesting/equivalence. This method also applies to models for categorical data, following the procedure described by Asparouhov & Muthen (2019). } \examples{ m1 <- ' visual =~ x1 + x2 + x3 textual =~ x4 + x5 + x6 speed =~ x7 + x8 + x9 ' m2 <- ' f1 =~ x1 + x2 + x3 + x4 f2 =~ x5 + x6 + x7 + x8 + x9 ' m3 <- ' visual =~ x1 + x2 + x3 textual =~ eq*x4 + eq*x5 + eq*x6 speed =~ x7 + x8 + x9 ' fit1 <- cfa(m1, data = HolzingerSwineford1939) fit1a <- cfa(m1, data = HolzingerSwineford1939, std.lv = TRUE) # Equivalent to fit1 fit2 <- cfa(m2, data = HolzingerSwineford1939) # Not equivalent to or nested in fit1 fit3 <- cfa(m3, data = HolzingerSwineford1939) # Nested in fit1 and fit1a \donttest{ tests <- net(fit1, fit1a, fit2, fit3) tests summary(tests) } } \references{ Bentler, P. M., & Satorra, A. (2010). Testing model nesting and equivalence. \emph{Psychological Methods, 15}(2), 111--123. \doi{10.1037/a0019625} Asparouhov, T., & Muthen, B. (2019). Nesting and equivalence testing for structural equation models. \emph{Structural Equation Modeling, 26}(2), 302--309. \doi{10.1080/10705511.2018.1513795} } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/man/loadingFromAlpha.Rd0000644000176200001440000000127214006342740016332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/loadingFromAlpha.R \name{loadingFromAlpha} \alias{loadingFromAlpha} \title{Find standardized factor loading from coefficient alpha} \usage{ loadingFromAlpha(alpha, ni) } \arguments{ \item{alpha}{A desired coefficient alpha value.} \item{ni}{A desired number of items.} } \value{ \item{result}{The standardized factor loadings that make desired coefficient alpha with specified number of items.} } \description{ Find standardized factor loading from coefficient alpha assuming that all items have equal loadings. } \examples{ loadingFromAlpha(0.8, 4) } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/plotRMSEApowernested.Rd0000644000176200001440000000400114632143415017145 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/powerAnalysisNested.R \name{plotRMSEApowernested} \alias{plotRMSEApowernested} \title{Plot power of nested model RMSEA} \usage{ plotRMSEApowernested(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, nlow, nhigh, steps = 1, alpha = 0.05, group = 1, ...) } \arguments{ \item{rmsea0A}{The \eqn{H_0} baseline RMSEA} \item{rmsea0B}{The \eqn{H_0} alternative RMSEA (trivial misfit)} \item{rmsea1A}{The \eqn{H_1} baseline RMSEA} \item{rmsea1B}{The \eqn{H_1} alternative RMSEA (target misfit to be rejected)} \item{dfA}{degree of freedom of the more-restricted model} \item{dfB}{degree of freedom of the less-restricted model} \item{nlow}{Lower bound of sample size} \item{nhigh}{Upper bound of sample size} \item{steps}{Step size} \item{alpha}{The alpha level} \item{group}{The number of group in calculating RMSEA} \item{\dots}{The additional arguments for the plot function.} } \description{ Plot power of nested model RMSEA over a range of possible sample sizes. } \examples{ plotRMSEApowernested(rmsea0A = 0, rmsea0B = 0, rmsea1A = 0.06, rmsea1B = 0.05, dfA = 22, dfB = 20, nlow = 50, nhigh = 500, steps = 1, alpha = .05, group = 1) } \references{ MacCallum, R. C., Browne, M. W., & Cai, L. (2006). Testing differences between nested covariance structure models: Power analysis and null hypotheses. \emph{Psychological Methods, 11}(1), 19--35. \doi{10.1037/1082-989X.11.1.19} } \seealso{ \itemize{ \item \code{\link[=findRMSEApowernested]{findRMSEApowernested()}} to find the power for a given sample size in nested model comparison based on population RMSEA \item \code{\link[=findRMSEAsamplesizenested]{findRMSEAsamplesizenested()}} to find the minium sample size for a given statistical power in nested model comparison based on population RMSEA } } \author{ Bell Clinton Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}) Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/goricaSEM.Rd0000644000176200001440000000740014753073632014745 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gorica.R \name{goricaSEM} \alias{goricaSEM} \title{Wrapper for \code{goric.lavaan()} from the \code{restriktor} package} \usage{ goricaSEM(object, ..., hypotheses = NULL, comparison = NULL, type = "gorica", standardized = FALSE, debug = FALSE) } \arguments{ \item{object}{A \link[lavaan:lavaan-class]{lavaan::lavaan} object.} \item{...}{Additional arguments passed to \code{\link[restriktor:goric]{restriktor::goric.lavaan()}}.} \item{hypotheses}{A named \code{list} of hypotheses to test. See \strong{Details} for information on how to specify hypotheses.} \item{comparison}{A \code{character} string specifying the type of comparison. Options are \code{"unconstrained"}, \code{"complement"}, or \code{"none"}. Default behavior depends on the number of hypotheses.} \item{type}{A \code{character} string indicating the type of analysis, either \code{"gorica"} (default) or \code{"goricac"}.} \item{standardized}{\code{logical} indicating whether standardized estimates are used in the analysis. Defaults to \code{FALSE}.} \item{debug}{\code{logical} indicating whether to print debugging information. Defaults to \code{FALSE}.} } \value{ A \code{list} containing the results of the \code{goric.lavaan} function, including: \itemize{ \item The log-likelihood. \item Penalty term. \item GORIC(A) values and weights. \item Relative GORIC(A) weights. } } \description{ The \code{goricaSEM()} function is an interface to \code{\link[restriktor:goric]{restriktor::goric.lavaan()}}, allowing users to perform generalized order-restricted information criterion approximation (GORICA) analysis specifically for structural equation models fitted using the \pkg{lavaan} package. } \details{ This function is designed as a wrapper for the \code{\link[restriktor:goric]{restriktor::goric.lavaan()}} function. It calculates GORICA values and weights, which can be used to compare models or hypotheses under inequality constraints. The \verb{hypotheses=} argument allows users to specify constraints in text-based syntax or matrix notation. For text-based syntax, constraints are specified as a string (e.g., \code{"a1 > a2"}). For matrix notation, a named list with \verb{$constraints}, \verb{$rhs}, and \verb{$neq} elements can be provided. The \verb{comparison=} argument determines whether the specified hypothesis is compared against its \code{"complement"}, the \code{"unconstrained"} model, or neither (\code{"none"}). } \examples{ ## Example: Perform GORICA analysis on a lavaan model library(lavaan) library(restriktor) ## Define the SEM model model <- ' ind60 =~ x1 + x2 + x3 dem60 =~ y1 + a1*y2 + b1*y3 + c1*y4 dem65 =~ y5 + a2*y6 + b2*y7 + c2*y8 dem60 ~ ind60 dem65 ~ ind60 + dem60 y1 ~~ y5 y2 ~~ y4 + y6 y3 ~~ y7 y4 ~~ y8 y6 ~~ y8 ' ## Fit the model data(PoliticalDemocracy) fit <- sem(model, data = PoliticalDemocracy) ## Define hypotheses myHypothesis <- 'a1 > a2, b1 > b2, c1 > c2' ## Perform GORICA analysis result <- goricaSEM(fit, hypotheses = list(H1 = myHypothesis), standardized = FALSE, comparison = "complement", type = "gorica") ## Print result print(result) } \references{ Kuiper, R. M., Hoijtink, H., & Silvapulle, M. J. (2011). An Akaike-type information criterion for model selection under inequality constraints. \emph{Biometrika, 98}(2), 495--501. \doi{10.1093/biomet/asr002} Vanbrabant, L., Van Loey, N., & Kuiper, R. M. (2020). Evaluating a theory-based hypothesis against its complement using an AIC-type information criterion with an application to facial burn injury. \emph{Psychological Methods, 25}(2), 129--142. \doi{10.1037/met0000238} } \seealso{ \code{\link[restriktor:goric]{restriktor::goric.lavaan()}} } \author{ Leonard Vanbrabant and Rebecca Kuiper } semTools/man/longInvariance-deprecated.Rd0000644000176200001440000001451514753125077020177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/longInvariance.R \name{longInvariance-deprecated} \alias{longInvariance-deprecated} \title{Measurement Invariance Tests Within Person} \usage{ longInvariance(model, varList, auto = "all", constrainAuto = FALSE, fixed.x = TRUE, std.lv = FALSE, group = NULL, group.equal = "", group.partial = "", strict = FALSE, warn = TRUE, debug = FALSE, quiet = FALSE, fit.measures = "default", baseline.model = NULL, method = "satorra.bentler.2001", ...) } \arguments{ \item{model}{lavaan syntax or parameter table} \item{varList}{A list containing indicator names of factors used in the invariance testing, such as the list that the first element is the vector of indicator names in the first timepoint and the second element is the vector of indicator names in the second timepoint. The order of indicator names should be the same (but measured in different times or different units).} \item{auto}{The order of autocorrelation on the measurement errors on the similar items across factor (e.g., Item 1 in Time 1 and Time 2). If 0 is specified, the autocorrelation will be not imposed. If 1 is specified, the autocorrelation will imposed for the adjacent factor listed in \code{varList}. The maximum number can be specified is the number of factors specified minus 1. If \code{"all"} is specified, the maximum number of order will be used.} \item{constrainAuto}{If \code{TRUE}, the function will equate the auto-\emph{covariance} to be equal within the same item across factors. For example, the covariance of item 1 in time 1 and time 2 is equal to the covariance of item 1 in time 2 and time 3.} \item{fixed.x}{See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{std.lv}{See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{group}{See \code{\link[lavaan:lavaan]{lavaan::lavaan()}}.} \item{group.equal}{See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{group.partial}{See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{strict}{If \code{TRUE}, the sequence requires strict invariance. See} \item{warn}{See See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}.} \item{debug}{See See \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}. details for more information.} \item{quiet}{If \code{FALSE} (default), a summary is printed out containing an overview of the different models that are fitted, together with some model comparison tests. If \code{TRUE}, no summary is printed.} \item{fit.measures}{Fit measures used to calculate the differences between nested models.} \item{baseline.model}{custom baseline model passed to \code{\link[lavaan:fitMeasures]{lavaan::fitMeasures()}}} \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan:lavTestLRT]{lavaan::lavTestLRT()}} for available options} \item{...}{Additional arguments in the \code{\link[lavaan:lavaan]{lavaan::lavaan()}} function. See also \code{\link[lavaan:lavOptions]{lavaan::lavOptions()}}} } \value{ Invisibly, all model fits in the sequence are returned as a list. } \description{ Testing measurement invariance across timepoints (longitudinal) or any context involving the use of the same scale in one case (e.g., a dyad case with husband and wife answering the same scale). The measurement invariance uses a typical sequence of model comparison tests. This function currently works with only one scale, and only with continuous indicators. } \details{ If \code{strict = FALSE}, the following four models are tested in order: \enumerate{ \item Model 1: configural invariance. The same factor structure is imposed on all units. \item Model 2: weak invariance. The factor loadings are constrained to be equal across units. \item Model 3: strong invariance. The factor loadings and intercepts are constrained to be equal across units. \item Model 4: The factor loadings, intercepts and means are constrained to be equal across units. } Each time a more restricted model is fitted, a \eqn{\Delta\chi^2} test is reported, comparing the current model with the previous one, and comparing the current model to the baseline model (Model 1). In addition, the difference in CFA is also reported (\eqn{\Delta}CFI). If \code{strict = TRUE}, the following five models are tested in order: \enumerate{ \item Model 1: configural invariance. The same factor structure is imposed on all units. \item Model 2: weak invariance. The factor loadings are constrained to be equal across units. \item Model 3: strong invariance. The factor loadings and intercepts are constrained to be equal across units. \item Model 4: strict invariance. The factor loadings, intercepts and residual variances are constrained to be equal across units. \item Model 5: The factor loadings, intercepts, residual variances and means are constrained to be equal across units. } Note that if the \eqn{\chi^2} test statistic is scaled (eg. a Satorra-Bentler or Yuan-Bentler test statistic), a special version of the \eqn{\Delta\chi^2} test is used as described in \url{http://www.statmodel.com/chidiff.shtml} } \examples{ model <- ' f1t1 =~ y1t1 + y2t1 + y3t1 f1t2 =~ y1t2 + y2t2 + y3t2 f1t3 =~ y1t3 + y2t3 + y3t3 ' ## Create list of variables var1 <- c("y1t1", "y2t1", "y3t1") var2 <- c("y1t2", "y2t2", "y3t2") var3 <- c("y1t3", "y2t3", "y3t3") constrainedVar <- list(var1, var2, var3) ## Invariance of the same factor across timepoints longInvariance(model, auto = 1, constrainAuto = TRUE, varList = constrainedVar, data = exLong) ## Invariance of the same factor across timepoints and groups longInvariance(model, auto = 1, constrainAuto = TRUE, varList = constrainedVar, data = exLong, group = "sex", group.equal = c("loadings", "intercepts")) } \references{ Vandenberg, R. J., and Lance, C. E. (2000). A review and synthesis of the measurement invariance literature: Suggestions, practices, and recommendations for organizational research. \emph{Organizational Research Methods, 3}(1), 4--70. \doi{10.1177/109442810031002} } \seealso{ \code{\link[=semTools-deprecated]{semTools-deprecated()}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } \keyword{internal} semTools/man/EFA-class.Rd0000644000176200001440000000352014764270501014625 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/efa.R \docType{class} \name{EFA-class} \alias{EFA-class} \alias{show,EFA-method} \alias{summary,EFA-method} \title{Class For Rotated Results from EFA} \usage{ \S4method{show}{EFA}(object) \S4method{summary}{EFA}(object, suppress = 0.1, sort = TRUE) } \arguments{ \item{object}{object of class \code{EFA}} \item{suppress}{any standardized loadings less than the specified value will not be printed to the screen} \item{sort}{\code{logical}. If \code{TRUE} (default), factor loadings will be sorted by their size in the console output} } \description{ This class contains the results of rotated exploratory factor analysis } \section{Slots}{ \describe{ \item{\code{loading}}{Rotated standardized factor loading matrix} \item{\code{rotate}}{Rotation matrix} \item{\code{gradRotate}}{gradient of the objective function at the rotated loadings} \item{\code{convergence}}{Convergence status} \item{\code{phi:}}{Factor correlation matrix. Will be an identity matrix if orthogonal rotation is used.} \item{\code{se}}{Standard errors of the rotated standardized factor loading matrix} \item{\code{method}}{Method of rotation} \item{\code{call}}{The command used to generate this object} }} \section{Objects from the Class}{ Objects can be created via the \code{\link{orthRotate}} or \code{\link{oblqRotate}} function. } \examples{ \donttest{ unrotated <- efaUnrotate(HolzingerSwineford1939, nf = 3, varList = paste0("x", 1:9), estimator = "mlr") summary(unrotated, std = TRUE) lavInspect(unrotated, "std") # Rotated by Quartimin rotated <- oblqRotate(unrotated, method = "quartimin") summary(rotated) } } \seealso{ \code{\link{efaUnrotate}}; \code{\link{orthRotate}}; \code{\link{oblqRotate}} } \author{ Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) } semTools/man/simParcel.Rd0000644000176200001440000000240214631670013015037 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/data.R \docType{data} \name{simParcel} \alias{simParcel} \title{Simulated Data set to Demonstrate Random Allocations of Parcels} \format{ A \code{data.frame} with 800 observations of 18 variables. \describe{ \item{f1item1}{Item 1 loading on factor 1} \item{f1item2}{Item 2 loading on factor 1} \item{f1item3}{Item 3 loading on factor 1} \item{f1item4}{Item 4 loading on factor 1} \item{f1item5}{Item 5 loading on factor 1} \item{f1item6}{Item 6 loading on factor 1} \item{f1item7}{Item 7 loading on factor 1} \item{f1item8}{Item 8 loading on factor 1} \item{f1item9}{Item 9 loading on factor 1} \item{f2item1}{Item 1 loading on factor 2} \item{f2item2}{Item 2 loading on factor 2} \item{f2item3}{Item 3 loading on factor 2} \item{f2item4}{Item 4 loading on factor 2} \item{f2item5}{Item 5 loading on factor 2} \item{f2item6}{Item 6 loading on factor 2} \item{f2item7}{Item 7 loading on factor 2} \item{f2item8}{Item 8 loading on factor 2} \item{f2item9}{Item 9 loading on factor 2} } } \source{ Data were generated using the \code{simsem} package. } \usage{ simParcel } \description{ A simulated data set with 2 factors with 9 indicators for each factor } \examples{ head(simParcel) } \keyword{datasets} semTools/man/monteCarloCI.Rd0000644000176200001440000002020314764333644015453 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/monteCarloCI.R \name{monteCarloCI} \alias{monteCarloCI} \alias{monteCarloMed} \title{Monte Carlo Confidence Intervals to Test Functions of Parameter Estimates} \usage{ monteCarloCI(object = NULL, expr, coefs, ACM, nRep = 20000, standardized = FALSE, fast = TRUE, level = 0.95, na.rm = TRUE, append.samples = FALSE, plot = FALSE, ask = getOption("device.ask.default"), ...) } \arguments{ \item{object}{A object of class \link[lavaan:lavaan-class]{lavaan::lavaan} in which functions of parameters have already been defined using the \verb{:=} operator in \code{lavaan}'s \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}}. When \code{NULL}, users must specify \code{expr}, \code{coefs}, and \code{ACM}.} \item{expr}{Optional \code{character} vector specifying functions of model parameters (e.g., an indirect effect). Ideally, the vector should have names, which is necessary if any user-defined parameters refer to other user-defined parameters defined earlier in the vector (order matters!). All parameters appearing in the vector must be provided in \code{coefs}, or defined (as functions of \code{coefs}) earlier in \code{expr}. If \code{length(expr) > 1L}, \code{nRep} samples will be drawn simultaneously from a single multivariate distribution; thus, \code{ACM} must include all parameters in \code{coefs}.} \item{coefs}{\code{numeric} vector of parameter estimates used in \code{expr}. Ignored when \code{object} is used.} \item{ACM}{Symmetric \code{matrix} representing the asymptotic sampling covariance matrix (ACOV) of the parameter estimates in \code{coefs}. Ignored when \code{object} is used. Information on how to obtain the ACOV in popular SEM software is described in \strong{Details}.} \item{nRep}{\code{integer}. The number of samples to draw, to obtain an empirical sampling distribution of model parameters. Many thousand are recommended to minimize Monte Carlo error of the estimated CIs.} \item{standardized}{\code{logical} indicating whether to obtain CIs for the fully standardized (\code{"std.all"}) estimates, using their asymptotic sampling covariance matrix.} \item{fast}{\code{logical} indicating whether to use a fast algorithm that assumes all functions of parameters (in \code{object} or \code{expr}) use standard operations. Set to \code{FALSE} if using (e.g.) \code{\link[=c]{c()}} to concatenate parameters in the definition, which would have unintended consequences when vectorizing functions in \code{expr} across sampled parameters.} \item{level}{\code{numeric} confidence level, between 0--1} \item{na.rm}{\code{logical} passed to \code{\link[stats:quantile]{stats::quantile()}}} \item{append.samples}{\code{logical} indicating whether to return the simulated empirical sampling distribution of parameters (in \code{coefs}) and functions (in \code{expr}) in a \code{list} with the results. This could be useful to calculate more precise highest-density intervals (see examples).} \item{plot}{\code{logical} indicating whether to plot the empirical sampling distribution of each function in \code{expr}} \item{ask}{whether to prompt user before printing each plot} \item{\dots}{arguments passed to \code{\link[graphics:hist]{graphics::hist()}} when \code{plot = TRUE}.} } \value{ A \code{lavaan.data.frame} (to use lavaan's \code{print} method) with point estimates and confidence limits of each requested function of parameters in \code{expr} is returned. If \code{append.samples = TRUE}, output will be a \code{list} with the same \verb{$Results} along with a second \code{data.frame} with the \verb{$Samples} (in rows) of each parameter (in columns), and an additional column for each requested function of those parameters. } \description{ Robust confidence intervals for functions of parameter estimates, based on empirical sampling distributions of estimated model parameters. } \details{ This function implements the Monte Carlo method of obtaining an empirical sampling distribution of estimated model parameters, as described by MacKinnon et al. (2004) for testing indirect effects in mediation models. This is essentially a parametric bootstrap method, which (re)samples parameters (rather than raw data) from a multivariate-normal distribution with mean vector equal to estimates in \code{coef()} and covariance matrix equal to the asymptotic covariance matrix \code{vcov()} of estimated parameters. The easiest way to use the function is to fit a SEM to data with \code{\link[lavaan:lavaan]{lavaan::lavaan()}}, using the \verb{:=} operator in the \code{\link[lavaan:model.syntax]{lavaan::model.syntax()}} to specify user-defined parameters. All information is then available in the resulting \link[lavaan:lavaan-class]{lavaan::lavaan} object. Alternatively (especially when using external SEM software to fit the model), the expression(s) can be explicitly passed to the function, along with the vector of estimated model parameters and their associated asymptotic sampling covariance matrix (ACOV). For further information on the Monte Carlo method, see MacKinnon et al. (2004) and Preacher & Selig (2012). The asymptotic covariance matrix can be obtained easily from many popular SEM software packages. \itemize{ \item{LISREL: Including the EC option on the OU line will print the ACM to a seperate file. The file contains the lower triangular elements of the ACM in free format and scientific notation.} \item{M\emph{plus}: Include the command TECH3; in the OUTPUT section. The ACM will be printed in the output.} \item{\code{lavaan}: Use the \code{\link[=vcov]{vcov()}} method on the fitted \link[lavaan:lavaan-class]{lavaan::lavaan} object to return the ACM.} } } \examples{ ## From the mediation tutorial: ## http://lavaan.ugent.be/tutorial/mediation.html set.seed(1234) X <- rnorm(100) M <- 0.5*X + rnorm(100) Y <- 0.7*M + rnorm(100) dat <- data.frame(X = X, Y = Y, M = M) mod <- ' # direct effect Y ~ c*X # mediator M ~ a*X Y ~ b*M # indirect effect (a*b) ind := a*b # total effect total := ind + c ' fit <- sem(mod, data = dat) summary(fit, ci = TRUE) # print delta-method CIs ## Automatically extract information from lavaan object set.seed(1234) monteCarloCI(fit) # CIs more robust than delta method in smaller samples ## delta method for standardized solution standardizedSolution(fit) ## compare to Monte Carlo CIs: set.seed(1234) monteCarloCI(fit, standardized = TRUE) \donttest{ ## save samples to calculate more precise intervals: set.seed(1234) foo <- monteCarloCI(fit, append.samples = TRUE) # library(HDInterval) # not a dependency; must be installed # hdi(foo$Samples) } ## Parameters can also be obtained from an external analysis myParams <- c("a","b","c") (coefs <- coef(fit)[myParams]) # names must match those in the "expression" ## Asymptotic covariance matrix from an external analysis (AsyCovMat <- vcov(fit)[myParams, myParams]) ## Compute CI, include a plot set.seed(1234) monteCarloCI(expr = c(ind = 'a*b', total = 'ind + c', ## other arbitrary functions are also possible meaningless = 'sqrt(a)^b / log(abs(c))'), coefs = coefs, ACM = AsyCovMat, plot = TRUE, ask = TRUE) # print a plot for each } \references{ MacKinnon, D. P., Lockwood, C. M., & Williams, J. (2004). Confidence limits for the indirect effect: Distribution of the product and resampling methods. \emph{Multivariate Behavioral Research, 39}(1) 99--128. \doi{10.1207/s15327906mbr3901_4} Preacher, K. J., & Selig, J. P. (2010, July). Monte Carlo method for assessing multilevel mediation: An interactive tool for creating confidence intervals for indirect effects in 1-1-1 multilevel models. Computer software available from \url{http://quantpsy.org/}. Preacher, K. J., & Selig, J. P. (2012). Advantages of Monte Carlo confidence intervals for indirect effects. \emph{Communication Methods and Measures, 6}(2), 77--98. \doi{10.1080/19312458.2012.679848} Selig, J. P., & Preacher, K. J. (2008, June). Monte Carlo method for assessing mediation: An interactive tool for creating confidence intervals for indirect effects. Computer software available from \url{http://quantpsy.org/}. } \author{ Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) } semTools/DESCRIPTION0000644000176200001440000001265114764514742013610 0ustar liggesusersEncoding: UTF-8 Package: semTools Version: 0.5-7 Title: Useful Tools for Structural Equation Modeling Description: Provides miscellaneous tools for structural equation modeling, many of which extend the 'lavaan' package. For example, latent interactions can be estimated using product indicators (Lin et al., 2010, ) and simple effects probed; analytical power analyses can be conducted (Jak et al., 2021, ); and scale reliability can be estimated based on estimated factor-model parameters. Authors@R: c(person(given = c("Terrence","D."), family = "Jorgensen", role = c("aut","cre"), email="TJorgensen314@gmail.com", comment = c(ORCID = "0000-0001-5111-6773")), person(given = "Sunthud", family = "Pornprasertmanit", role = "aut", email = "psunthud@gmail.com"), person(given = c("Alexander","M."), family = "Schoemann", role = "aut", email="schoemanna@ecu.edu", comment = c(ORCID = "0000-0002-8479-8798")), person(given = "Yves", family = "Rosseel", role = "aut", email="Yves.Rosseel@UGent.be", comment = c(ORCID = "0000-0002-4129-4477")), person(given = "Patrick", family = "Miller", role = "ctb", email="pmille13@nd.edu"), person(given = "Corbin", family = "Quick", role = "ctb", email="corbinq@umich.edu"), person(given = "Mauricio", family = "Garnier-Villarreal", role = "ctb", email="m.garniervillarreal@vu.nl", comment = c(ORCID = "0000-0002-2951-6647")), person(given = "James", family = "Selig", role = "ctb", email="selig@unm.edu"), person(given = "Aaron", family = "Boulton", role = "ctb", email="aboulton@email.unc.edu"), person(given = "Kristopher", family = "Preacher", role = "ctb", email="kris.preacher@vanderbilt.edu"), person(given = "Donna", family = "Coffman", role = "ctb", email="dlc30@psu.edu"), person(given = "Mijke", family = "Rhemtulla", role = "ctb", email="mrhemtulla@ucdavis.edu", comment = c(ORCID = "0000-0003-2572-2424")), person(given = "Alexander", family = "Robitzsch", role = "ctb", email="a.robitzsch@bifie.at", comment = c(ORCID = "0000-0002-8226-3132")), person(given = "Craig", family = "Enders", role = "ctb", email="cenders@psych.ucla.edu"), person(given = "Ruben", family = "Arslan", role = "ctb", email="rubenarslan@gmail.com", comment = c(ORCID = "0000-0002-6670-5658")), person(given = "Bell", family = "Clinton", role = "ctb", email="clintonbell@ku.edu"), person(given = "Pavel", family = "Panko", role = "ctb", email="pavel.panko@ttu.edu"), person(given = "Edgar", family = "Merkle", role = "ctb", email="merklee@missouri.edu", comment = c(ORCID = "0000-0001-7158-0653")), person(given = "Steven", family = "Chesnut", role = "ctb", email="Steven.Chesnut@usm.edu"), person(given = "Jarrett", family = "Byrnes", role = "ctb", email="Jarrett.Byrnes@umb.edu"), person(given = c("Jason","D."), family = "Rights", role = "ctb", email="jrights@psych.ubc.ca"), person(given = "Ylenio", family = "Longo", role = "ctb", email="yleniolongo@gmail.com"), person(given = "Maxwell", family = "Mansolf", role = "ctb", email="mamansolf@gmail.com", comment = c(ORCID = "0000-0001-6861-8657")), person(given = "Mattan S.", family = "Ben-Shachar", role = "ctb", email="matanshm@post.bgu.ac.il", comment = c(ORCID = "0000-0002-4287-4801")), person(given = "Mikko", family = "Rönkkö", role = "ctb", email = "mikko.ronkko@jyu.fi", comment = c(ORCID = "0000-0001-7988-7609")), person(given = "Andrew R.", family = "Johnson", role = "ctb", email = "andrew.johnson@curtin.edu.au", comment = c(ORCID = "0000-0001-7000-8065")), person(given = "Leonard", family = "Vanbrabant", role = "ctb", email = "L.Vanbrabant@ggdwestbrabant.nl") ) Depends: R(>= 4.0), lavaan(>= 0.6-12), methods Imports: graphics, pbivnorm, stats, utils Suggests: Amelia, blavaan, emmeans, lavaan.mi, MASS, mice, mnormt, parallel, restriktor, testthat, GPArotation License: GPL (>= 2) LazyData: yes LazyLoad: yes URL: https://github.com/simsem/semTools/wiki BugReports: https://github.com/simsem/semTools/issues Date: 2025-03-12 RoxygenNote: 7.3.2 NeedsCompilation: no Packaged: 2025-03-12 21:15:08 UTC; terrence Author: Terrence D. Jorgensen [aut, cre] (), Sunthud Pornprasertmanit [aut], Alexander M. Schoemann [aut] (), Yves Rosseel [aut] (), Patrick Miller [ctb], Corbin Quick [ctb], Mauricio Garnier-Villarreal [ctb] (), James Selig [ctb], Aaron Boulton [ctb], Kristopher Preacher [ctb], Donna Coffman [ctb], Mijke Rhemtulla [ctb] (), Alexander Robitzsch [ctb] (), Craig Enders [ctb], Ruben Arslan [ctb] (), Bell Clinton [ctb], Pavel Panko [ctb], Edgar Merkle [ctb] (), Steven Chesnut [ctb], Jarrett Byrnes [ctb], Jason D. Rights [ctb], Ylenio Longo [ctb], Maxwell Mansolf [ctb] (), Mattan S. Ben-Shachar [ctb] (), Mikko Rönkkö [ctb] (), Andrew R. Johnson [ctb] (), Leonard Vanbrabant [ctb] Maintainer: Terrence D. Jorgensen Repository: CRAN Date/Publication: 2025-03-13 08:40:02 UTC