Binary files /tmp/tmpb5EK43/ZewBwPYI7t/r-cran-semtools-0.4.14/build/vignette.rds and /tmp/tmpb5EK43/rsirHWHNzG/r-cran-semtools-0.5.0/build/vignette.rds differ diff -Nru r-cran-semtools-0.4.14/debian/changelog r-cran-semtools-0.5.0/debian/changelog --- r-cran-semtools-0.4.14/debian/changelog 2018-06-02 07:25:09.000000000 +0000 +++ r-cran-semtools-0.5.0/debian/changelog 2018-07-01 06:52:09.000000000 +0000 @@ -1,3 +1,11 @@ +r-cran-semtools (0.5.0-1) unstable; urgency=medium + + * Team upload. + * New upstream version + * dh-update-R to update Build-Depends + + -- Andreas Tille Sun, 01 Jul 2018 08:52:09 +0200 + r-cran-semtools (0.4.14-3) unstable; urgency=medium * Team upload. diff -Nru r-cran-semtools-0.4.14/debian/control r-cran-semtools-0.5.0/debian/control --- r-cran-semtools-0.4.14/debian/control 2018-06-02 07:25:09.000000000 +0000 +++ r-cran-semtools-0.5.0/debian/control 2018-07-01 06:52:09.000000000 +0000 @@ -7,7 +7,7 @@ Build-Depends: debhelper (>= 11~), dh-r, r-base-dev, - r-cran-lavaan + r-cran-lavaan (>= 0.6.1) Standards-Version: 4.1.4 Vcs-Browser: https://salsa.debian.org/r-pkg-team/r-cran-semtools Vcs-Git: https://salsa.debian.org/r-pkg-team/r-cran-semtools.git diff -Nru r-cran-semtools-0.4.14/DESCRIPTION r-cran-semtools-0.5.0/DESCRIPTION --- r-cran-semtools-0.4.14/DESCRIPTION 2016-10-22 17:06:27.000000000 +0000 +++ r-cran-semtools-0.5.0/DESCRIPTION 2018-06-27 13:13:01.000000000 +0000 @@ -1,42 +1,50 @@ Package: semTools +Version: 0.5-0 Title: Useful Tools for Structural Equation Modeling -Version: 0.4-14 -Authors@R: c(person(given = c("Terrence","D."), family = "Jorgensen", role = c("aut", "cre"), email="TJorgensen314@gmail.com"), - person(given = "Sunthud", family = "Pornprasertmanit", role = "aut", email = "psunthud@gmail.com"), - person(given = "Patrick", family = "Miller", role = "aut", email="pmille13@nd.edu"), +Description: Provides useful tools for structural equation modeling. +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 = "Alexander", family = "Schoemann", role = "aut", email="schoemanna@ecu.edu"), person(given = "Yves", family = "Rosseel", role = "aut", email="Yves.Rosseel@UGent.be"), + 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="mgv@ku.edu"), + person(given = "Mauricio", family = "Garnier-Villarreal", role = "ctb", email="mauricio.garniervillarreal@marquette.edu"), 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="M.T.Rhemtulla@uva.nl"), - person(given = "Alexander", family = "Robitzsch", role = "ctb", email="a.robitzsch@bifie.at"), + 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"), + person(given = "Alexander", family = "Robitzsch", role = "ctb", email="a.robitzsch@bifie.at"), person(given = "Craig", family = "Enders", role = "ctb", email="Craig.Enders@asu.edu"), person(given = "Ruber", family = "Arslan", role = "ctb", email="rubenarslan@gmail.com"), - person(given = "Bell", family = "Clinton", role = "ctb", email="clintonbell@ku.edu"), + 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"), 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 = "Jason", family = "Rights", role = "ctb", email="jason.d.rights@vanderbilt.edu"), - person(given = "Ylenio", family = "Longo", role = "ctb", email="yleniolongo@gmail.com") + person(given = "Jarrett", family = "Byrnes", role = "ctb", email="Jarrett.Byrnes@umb.edu"), + person(given = c("Jason","D."), family = "Rights", role = "ctb", email="jason.d.rights@vanderbilt.edu"), + person(given = "Ylenio", family = "Longo", role = "ctb", email="yleniolongo@gmail.com"), + person(given = "Maxwell", family = "Mansolf", role = "ctb", email="mamansolf@gmail.com") ) -Description: Provides useful tools for structural equation modeling packages. -Depends: R(>= 3.0), methods, lavaan(>= 0.5-22), utils, stats, graphics -Suggests: MASS, parallel, Amelia, mice, foreign, OpenMx(>= 2.0.0), - GPArotation, mnormt, boot +Depends: R(>= 3.3), utils, stats, graphics, lavaan(>= 0.6.1) +Imports: methods +Suggests: MASS, foreign, parallel, boot, Amelia, mice, GPArotation, + mnormt, OpenMx License: GPL (>= 2) LazyData: yes LazyLoad: yes URL: https://github.com/simsem/semTools/wiki -Author: Terrence D. Jorgensen [aut, cre], +BugReports: https://github.com/simsem/semTools/issues +Date/Publication: 2018-06-27 13:13:01 UTC +RoxygenNote: 6.0.1 +NeedsCompilation: no +Packaged: 2018-06-27 12:31:18 UTC; tjorgen2 +Author: Terrence D. Jorgensen [aut, cre] + (), Sunthud Pornprasertmanit [aut], - Patrick Miller [aut], Alexander Schoemann [aut], Yves Rosseel [aut], + Patrick Miller [ctb], Corbin Quick [ctb], Mauricio Garnier-Villarreal [ctb], James Selig [ctb], @@ -51,11 +59,9 @@ Pavel Panko [ctb], Edgar Merkle [ctb], Steven Chesnut [ctb], - Jarrett Byrnes [ctb], - Jason Rights [ctb], - Ylenio Longo [ctb] + Jarrett Byrnes [ctb], + Jason D. Rights [ctb], + Ylenio Longo [ctb], + Maxwell Mansolf [ctb] Maintainer: Terrence D. Jorgensen -Date/Publication: 2016-10-22 19:06:27 -NeedsCompilation: no -Packaged: 2016-10-21 11:47:45 UTC; tdjorgen Repository: CRAN diff -Nru r-cran-semtools-0.4.14/inst/CITATION r-cran-semtools-0.5.0/inst/CITATION --- r-cran-semtools-0.4.14/inst/CITATION 2016-10-21 11:47:28.000000000 +0000 +++ r-cran-semtools-0.5.0/inst/CITATION 2018-06-21 12:08:56.000000000 +0000 @@ -1,4 +1,4 @@ -citHeader("We think that the development of the package is a collaborative work. The maintainers cannot take the credits of others' contributions. If it is possible to cite a paper describing the development of a particular function (e.g., permuteMeasEq), please cite that paper. Otherwise, please use the following citation for the package as a whole:") +citHeader("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), listed in the References section of its associated help page. Otherwise, please use the following citation for the package as a whole:") year <- sub(".*(2[[:digit:]]{3})-.*", "\\1", meta$Date, perl = TRUE) vers <- paste("R package version", meta$Version) @@ -6,14 +6,14 @@ citEntry(entry = "Manual", title = "{semTools}: Useful tools for structural equation modeling", - author = as.person("semTools Contributors"), + author = c(as.person("Jorgensen, T. D."), as.person("Pornprasertmanit, S."), + as.person("Schoemann, A. M."), as.person("Rosseel, Y.")), year = year, note = vers, url = url, textVersion = - paste("semTools Contributors. (", year, "). ", - "semTools: Useful tools for structural equation modeling. ", - vers, - ". Retrieved from ", url, sep = "") -) \ No newline at end of file + paste("Jorgensen, T. D., Pornprasertmanit, S., Schoemann, A. M., & Rosseel, Y. (", + year, "). semTools: Useful tools for structural equation modeling. ", + vers, ". Retrieved from ", url, sep = "") +) Binary files /tmp/tmpb5EK43/ZewBwPYI7t/r-cran-semtools-0.4.14/inst/doc/partialInvariance.pdf and /tmp/tmpb5EK43/rsirHWHNzG/r-cran-semtools-0.5.0/inst/doc/partialInvariance.pdf differ diff -Nru r-cran-semtools-0.4.14/man/auxiliary.Rd r-cran-semtools-0.5.0/man/auxiliary.Rd --- r-cran-semtools-0.4.14/man/auxiliary.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/auxiliary.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,120 +1,113 @@ -\name{auxiliary} -\alias{auxiliary} -\alias{cfa.auxiliary} -\alias{sem.auxiliary} -\alias{growth.auxiliary} -\alias{lavaan.auxiliary} -\title{ - Analyzing data with full-information maximum likelihood with auxiliary variables -} -\description{ - Analyzing data with full-information maximum likelihood with auxiliary variables. The techniques used to account for auxiliary variables are both extra-dependent-variables and saturated-correlates approaches (Enders, 2008). The extra-dependent-variables approach is used for all single variables in the model (such as covariates or single-indicator dependent varaible) For variables that are belong to a multiple-indicator factor, the saturated-correlates approach is used. Note that all covariates are treated as endogenous varaibles in this model (fixed.x = FALSE) so multivariate normality is assumed for the covariates. CAUTION: (1) this function will automatically change the missing data handling method to full-information maximum likelihood and (2) this function is still not applicable for categorical variables (because the maximum likelhood method is not available in lavaan for estimating models with categorical variables currently). -} -\usage{ -auxiliary(model, aux, fun, ...) -cfa.auxiliary(model, aux, ...) -sem.auxiliary(model, aux, ...) -growth.auxiliary(model, aux, ...) -lavaan.auxiliary(model, aux, ...) -} -\arguments{ - \item{model}{ - The \code{lavaan} object, the parameter table, or lavaan script. If the \code{lavaan} object is provided, the \code{lavaan} object must be evaluated with mean structure. -} - \item{aux}{ - The list of auxiliary variable - } - \item{fun}{ - The character of the function name used in running lavaan model (\code{"cfa"}, \code{"sem"}, \code{"growth"}, \code{"lavaan"}). - } - \item{\dots}{ - The additional arguments in the \code{\link[lavaan]{lavaan}} function. - } -} -\value{ - The \code{\linkS4class{lavaanStar}} object which contains the original \code{lavaan} object and the additional values of the null model, which need to be adjusted to account for auxiliary variables. -} -\references{ -Enders, C. K. (2008). A note of the use of missing auxiliary variables in full information maximum likelihood-based structural equation models. \emph{Structural Equation Modeling, 15}, 434-448. -} -\seealso{ - \code{\linkS4class{lavaanStar}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -# Example of confirmatory factor analysis - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -dat <- data.frame(HolzingerSwineford1939, z=rnorm(nrow(HolzingerSwineford1939), 0, 1)) - -fit <- cfa(HS.model, data=dat, meanstructure=TRUE) -fitaux <- auxiliary(HS.model, aux="z", data=dat, fun="cfa") # Use lavaan script -fitaux <- cfa.auxiliary(fit, aux="z", data=dat) # Use lavaan output - -# Example of multiple groups confirmatory factor analysis - -fitgroup <- cfa(HS.model, data=dat, group="school", meanstructure=TRUE) -fitgroupaux <- cfa.auxiliary(fitgroup, aux="z", data=dat, group="school") - -\dontrun{ -# Example of path analysis - -mod <- ' x5 ~ x4 -x4 ~ x3 -x3 ~ x1 + x2' - -fitpath <- sem(mod, data=dat, fixed.x=FALSE, meanstructure=TRUE) # fixed.x must be FALSE -fitpathaux <- sem.auxiliary(fitpath, aux="z", data=dat) - -# Example of full structural equation modeling - -dat2 <- data.frame(PoliticalDemocracy, z=rnorm(nrow(PoliticalDemocracy), 0, 1)) -model <- ' - ind60 =~ x1 + x2 + x3 - dem60 =~ y1 + a*y2 + b*y3 + c*y4 - dem65 =~ y5 + a*y6 + b*y7 + c*y8 - - dem60 ~ ind60 - dem65 ~ ind60 + dem60 - - y1 ~~ y5 - y2 ~~ y4 + y6 - y3 ~~ y7 - y4 ~~ y8 - y6 ~~ y8 -' -fitsem <- sem(model, data=dat2, meanstructure=TRUE) -fitsemaux <- sem.auxiliary(fitsem, aux="z", data=dat2, meanstructure=TRUE) - -# Example of covariate at the factor level - -HS.model.cov <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 - visual ~ sex - textual ~ sex - speed ~ sex' - -fitcov <- cfa(HS.model.cov, data=dat, fixed.x=FALSE, meanstructure=TRUE) -fitcovaux <- cfa.auxiliary(fitcov, aux="z", data=dat) - -# Example of Endogenous variable with single indicator -HS.model.cov2 <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - x7 ~ visual + textual' - -fitcov2 <- sem(HS.model.cov2, data=dat, fixed.x=FALSE, meanstructure=TRUE) -fitcov2aux <- sem.auxiliary(fitcov2, aux="z", data=dat) - -# Multiple auxiliary variables -HS.model2 <- ' visual =~ x1 + x2 + x3 - speed =~ x7 + x8 + x9' -fit <- cfa(HS.model2, data=HolzingerSwineford1939) -fitaux <- cfa.auxiliary(HS.model2, data=HolzingerSwineford1939, aux=c("x4", "x5")) -} -} +% 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} +\alias{lavaan.auxiliary} +\alias{cfa.auxiliary} +\alias{sem.auxiliary} +\alias{growth.auxiliary} +\title{Implement Saturated Correlates with FIML} +\usage{ +auxiliary(model, data, aux, fun, ...) + +lavaan.auxiliary(model, data, aux, ...) + +cfa.auxiliary(model, data, aux, ...) + +sem.auxiliary(model, data, aux, ...) + +growth.auxiliary(model, data, aux, ...) +} +\arguments{ +\item{model}{The analysis model can be specified with 1 of 2 objects: +\enumerate{ + \item lavaan \code{\link[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}}, + 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 \code{\link[lavaan]{lavaan}}.} +} +\value{ +a fitted \code{\linkS4class{lavaan}} object. Additional + information is stored as a \code{list} in the \code{\@external} slot: + \itemize{ + \item \code{baseline.model}. a fitted \code{\linkS4class{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}}. + \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}}, but you +\emph{must} pass your full \code{data.frame} to the \code{data} argument. +Because the saturated-correlates approaches (Enders, 2008) treates 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}) +} diff -Nru r-cran-semtools-0.4.14/man/BootMiss-class.Rd r-cran-semtools-0.5.0/man/BootMiss-class.Rd --- r-cran-semtools-0.4.14/man/BootMiss-class.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/BootMiss-class.Rd 2018-06-25 21:15:29.000000000 +0000 @@ -1,41 +1,81 @@ -\name{BootMiss-class} -\docType{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 -} -\description{ - This class contains the results of Bollen-Stine bootstrap with missing data. -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link{bsBootMiss}} function. -} -\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 chi-square values from Bootstrap data sets fitted by the target model} - \item{\code{origChi}:}{The chi-square value from the original data set} - \item{\code{df}:}{The degree of freedom of the model} - \item{\code{bootP}:}{The p-value comparing the original chi-square with the bootstrap distribution} - } -} -\section{methods}{ - \describe{ - \item{show}{\code{signature(object = "BootMiss"):} The \code{show} function is used to display the results of the Bollen-Stine bootstrap.} - \item{summary}{\code{signature(object = "BootMiss"):} The summary function prints the same information from the \code{show} method, but also provides information about the time elapsed, as well as the expected (theoretical) and observed (bootstrap) mean and variance of the chi-squared distribution.} - \item{hist}{\code{signature(x = "BootMiss", ..., alpha = .05, nd = 2, printLegend = TRUE, legendArgs = list(x = "topleft")):} The \code{hist} function provides a histogram for the bootstrap distribution of chi-squared, including observed and critical values from the specified \code{alpha} level. The user can also specify additional graphical parameters to \code{\link[graphics]{hist}} via \code{...}, as well as pass a list of arguments to an optional \code{\link[graphics]{legend}} via \code{legendArgs}. If the user wants more control over customization, \code{hist} 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.} - } -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\seealso{ -\code{\link{bsBootMiss}} -} -\examples{ -# See the example from the bsBootMiss function -} +% 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} +\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}}} + +\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}} 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}} function. +} + +\examples{ + +# See the example from the bsBootMiss function + +} +\seealso{ +\code{\link{bsBootMiss}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/bsBootMiss.Rd r-cran-semtools-0.5.0/man/bsBootMiss.Rd --- r-cran-semtools-0.4.14/man/bsBootMiss.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/bsBootMiss.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,121 +1,149 @@ -\name{bsBootMiss} -\alias{bsBootMiss} -\title{ - Bollen-Stine Bootstrap with the Existence of Missing Data -} -\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{bsBootMis}. - - The second is designed for users of other software packages (e.g., LISREL, EQS, Amos, or Mplus). Users can import their data, chi-squared 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. -} -\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 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. - } - \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-implied mean vector 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{transDataOnly}{ - Logical. If \code{TRUE}, the result will provide the transformed data only. - } - \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{bootSamplesOnly}{ - Logical. If \code{TRUE}, the result will provide bootstrap data sets 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{writeArgs}{ - Optional \code{list}. If \code{writeBootData = TRUE} or \code{writeBootData = TRUE}, user can pass arguments to the \code{\link[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}} function. - } -} -\value{ - As a default, this function returns a \code{\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}. -} -\references{ - -Bollen, K. A., \& Stine, R. A. (1992). Bootstrapping goodness-of-fit measures in structural equation models. \emph{Sociological Methods \& Research, 21}, 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}, 741-763. doi:10.1080/00273170903333590 -} -\seealso{ - \code{\linkS4class{BootMiss}} -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\examples{ -\dontrun{ -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) - -# The number of bootstrap samples should be much higher. -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)) -} -} +% 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}} 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}} +function. See also \code{\link[lavaan]{lavOptions}}} +} +\value{ +As a default, this function returns a \code{\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{ + +\dontrun{ +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) + +# The number of bootstrap samples should be much higher. +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{ +\code{\linkS4class{BootMiss}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) + +Syntax for transformations borrowed from http://www2.psych.ubc.ca/~vsavalei/ +} diff -Nru r-cran-semtools-0.4.14/man/chisqSmallN.Rd r-cran-semtools-0.5.0/man/chisqSmallN.Rd --- r-cran-semtools-0.4.14/man/chisqSmallN.Rd 2016-10-17 15:10:15.000000000 +0000 +++ r-cran-semtools-0.5.0/man/chisqSmallN.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,49 +1,66 @@ -\name{chisqSmallN} -\alias{chisqSmallN} -\title{ - \emph{k}-factor correction for chi-squared test statistic -} -\description{ - Calculate \emph{k}-factor correction for chi-squared model-fit test statistic to adjust for small sample size. -} -\usage{ - chisqSmallN(fit0, fit1 = NULL, ...) -} -\arguments{ - \item{fit0}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions.} - \item{fit1}{Optional additional \linkS4class{lavaan} model, in which \code{fit0} is nested. If \code{fit0} has fewer \emph{df} than \code{fit1}, the models will be swapped, still on the assumption that they are nested.} - \item{\dots}{Additional arguments to the \code{\link[lavaan]{lavTestLRT}} function.} -} -\details{ -The \emph{k}-factor correction (Nevitt & Hancock, 2004) is a global fit index which can be computed by: - -\deqn{ kc = 1 - \frac{2 \times P + 4 \times K + 5}{6 \times N}} - -where \eqn{N} is the sample size when using normal likelihood, or \eqn{N - 1} when using \code{likelihood = 'wishart'}. -} - -\value{ - A numeric vector including the unadjusted (naive) chi-squared test statistic, the \emph{k}-factor correction, the corrected test statistic, the \emph{df} for the test, 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). -} -\references{ - Nevitt, J., & Hancock, G. R. (2004). Evaluating small sample approaches for model test statistics in structural equation modeling. \emph{Multivariate Behavioral Research, 39}(3), 439-478. doi:10.1207/S15327906MBR3903_3 -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\examples{ -HS.model <- ' - visual =~ x1 + b1*x2 + x3 - textual =~ x4 + b2*x5 + x6 - speed =~ x7 + b3*x8 + x9 -' -fit1 <- cfa(HS.model, data = HolzingerSwineford1939) -## test a single model (implicitly compared to a saturated model) -chisqSmallN(fit1) - -## fit a more constrained model -fit0 <- cfa(HS.model, data = HolzingerSwineford1939, - orthogonal = TRUE) -## compare 2 models -chisqSmallN(fit1, fit0) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fitIndices.R +\name{chisqSmallN} +\alias{chisqSmallN} +\title{\emph{k}-factor correction for \eqn{chi^2} test statistic} +\usage{ +chisqSmallN(fit0, fit1 = NULL, ...) +} +\arguments{ +\item{fit0}{The lavaan model object provided after running the \code{cfa}, +\code{sem}, \code{growth}, or \code{lavaan} functions.} + +\item{fit1}{Optional additional \linkS4class{lavaan} model, in which +\code{fit0} is nested. If \code{fit0} has fewer \emph{df} than \code{fit1}, +the models will be swapped, still on the assumption that they are nested.} + +\item{\dots}{Additional arguments to the \code{\link[lavaan]{lavTestLRT}} +function.} +} +\value{ +A numeric vector including the unadjusted (naive) chi-squared test +statistic, the \emph{k}-factor correction, the corrected test statistic, the +\emph{df} for the test, 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). +} +\description{ +Calculate \emph{k}-factor correction for \eqn{chi^2} model-fit test +statistic to adjust for small sample size. +} +\details{ +The \emph{k}-factor correction (Nevitt & Hancock, 2004) is a global fit +index which can be computed by: + +\deqn{ kc = 1 - \frac{2 \times P + 4 \times K + 5}{6 \times N}} + +where \eqn{N} is the sample size when using normal likelihood, or \eqn{N - +1} when using \code{likelihood = 'wishart'}. +} +\examples{ + +HS.model <- ' + visual =~ x1 + b1*x2 + x3 + textual =~ x4 + b2*x5 + x6 + speed =~ x7 + b3*x8 + x9 +' +fit1 <- cfa(HS.model, data = HolzingerSwineford1939) +## test a single model (implicitly compared to a saturated model) +chisqSmallN(fit1) + +## fit a more constrained model +fit0 <- cfa(HS.model, data = HolzingerSwineford1939, orthogonal = TRUE) +## compare 2 models +chisqSmallN(fit1, fit0) + +} +\references{ +Nevitt, J., & Hancock, G. R. (2004). Evaluating small sample +approaches for model test statistics in structural equation modeling. +\emph{Multivariate Behavioral Research, 39}(3), 439--478. +doi:10.1207/S15327906MBR3903_3 +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/clipboard.Rd r-cran-semtools-0.5.0/man/clipboard.Rd --- r-cran-semtools-0.4.14/man/clipboard.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/clipboard.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,83 +1,106 @@ -\name{clipboard_saveFile} -\alias{clipboard} -\alias{saveFile} -\title{ - Copy or save the result of \code{lavaan} or \code{FitDiff} objects into a clipboard or a file -} -\description{ -Copy or save the result of \code{lavaan} or \code{\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. -} -\usage{ -clipboard(object, what="summary", ...) -saveFile(object, file, what="summary", tableFormat=FALSE, ...) -} -\arguments{ - \item{object}{ - The \code{lavaan} or \code{\linkS4class{FitDiff}} object -} - \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}} function. Other attributes listed in the \code{inspect} method in the \link[lavaan]{lavaan-class} could also be used, such as \code{"coef"}, \code{"se"}, \code{"fit"}, \code{"samp"}, and so on. For the The \code{\linkS4class{FitDiff}} object, this argument is not active yet. -} - \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 seperation. Otherwise, save the result as the output screen printed in the R console. -} - \item{\dots}{ - Additional argument listed in the \code{\link{miPowerFit}} function (for \code{lavaan} object only). -} -} -\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. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -\dontrun{ -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", meanstructure=TRUE) - -# Copy the summary of the lavaan object -clipboard(fit) - -# Copy the modification indices and the model fit 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 the modification indices and the model fit 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") -} -} - +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/clipboard.R +\name{clipboard} +\alias{clipboard} +\alias{saveFile} +\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}{The \code{lavaan} or \code{\linkS4class{FitDiff}} object} + +\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}} function. Other attributes listed in the +\code{inspect} method in the \link[lavaan]{lavaan-class} could also be used, +such as \code{"coef"}, \code{"se"}, \code{"fit"}, \code{"samp"}, and so on. +For the The \code{\linkS4class{FitDiff}} object, this argument is not active +yet.} + +\item{\dots}{Additional argument listed in the \code{\link{miPowerFit}} +function (for \code{lavaan} object only).} + +\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 seperation. 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}} to be copied/saved. Only +relevant if \code{object} is class \code{\linkS4class{FitDiff}}.} + +\item{writeArgs}{\code{list} of additional arguments to be passed to +\code{\link[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 \code{\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{ + +\dontrun{ +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", meanstructure=TRUE) + +# Copy the summary of the lavaan object +clipboard(fit) + +# Copy the modification indices and the model fit 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 the modification indices and the model fit 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}) +} diff -Nru r-cran-semtools-0.4.14/man/combinequark.Rd r-cran-semtools-0.5.0/man/combinequark.Rd --- r-cran-semtools-0.4.14/man/combinequark.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/combinequark.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,35 +1,48 @@ -\name{combinequark} -\alias{combinequark} -\title{ -Combine the results from the quark function -} -\description{ -This function builds upon the \code{\link{quark}} function to provide a final dataset comprised of the original dataset provided to \code{\link{quark}} and enough principal components to be able to account for a certain level of variance in the data. -} -\usage{ -combinequark(quark, percent) -} -\arguments{ - \item{quark}{Provide the \code{\link{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. -} -\author{ -Steven R. Chesnut (University of Southern Mississippi \email{Steven.Chesnut@usm.edu}) -} -\seealso{ -\code{\link{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) -} +% 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}} 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}} function to provide a +final dataset comprised of the original dataset provided to +\code{\link{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}} +} +\author{ +Steven R. Chesnut (University of Southern Mississippi +\email{Steven.Chesnut@usm.edu}) +} diff -Nru r-cran-semtools-0.4.14/man/compareFit.Rd r-cran-semtools-0.5.0/man/compareFit.Rd --- r-cran-semtools-0.4.14/man/compareFit.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/compareFit.Rd 2018-06-25 21:26:10.000000000 +0000 @@ -1,47 +1,55 @@ -\name{compareFit} -\alias{compareFit} -\title{ - Build an object summarizing fit indices across multiple models -} -\description{ -This function will create the template that compare fit indices across multiple lavaan outputs. The results can be exported to a clipboard or a file later. -} -\usage{ -compareFit(..., nested = TRUE) -} -\arguments{ - \item{...}{ - \code{lavaan} outputs or lists of \code{lavaan} outputs -} - \item{nested}{ - Logical whether the specified models are nested -} -} -\value{ - A \code{\linkS4class{FitDiff}} object that saves model fit comparisons across multiple models. If the output is not assigned as an object, the output is printed in two parts: 1) nested model comparison (if models are nested) and 2) fit indices summaries. In the fit indices summaries, daggers are tagged to the model with the best fit for each fit index. -} -\seealso{ - \code{\linkS4class{FitDiff}}, \code{\link{clipboard}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -m1 <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -fit1 <- cfa(m1, data=HolzingerSwineford1939) - -m2 <- ' f1 =~ x1 + x2 + x3 + x4 - f2 =~ x5 + x6 + x7 + x8 + x9 ' -fit2 <- cfa(m2, data=HolzingerSwineford1939) -compareFit(fit1, fit2, nested=FALSE) - -HW.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -out <- measurementInvariance(HW.model, data=HolzingerSwineford1939, group="school", quiet=TRUE) -compareFit(out) -} +% 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) +} +\arguments{ +\item{...}{fitted \code{lavaan} models or list(s) of \code{lavaan} objects} + +\item{nested}{\code{logical} indicating whether the models in \code{...} are +nested. See the \code{\link{net}} function for an empirical test of nesting.} +} +\value{ +A \code{\linkS4class{FitDiff}} object that saves model fit +comparisons across multiple models. If the output is not assigned as an +object, the output is printed in two parts: (1) nested model comparison (if +models are nested) and (2) summary of fit indices. In the fit indices +summaries, daggers are tagged to the model with the best fit according to +each fit index. +} +\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{ + +m1 <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 ' + +fit1 <- cfa(m1, data = HolzingerSwineford1939) + +m2 <- ' f1 =~ x1 + x2 + x3 + x4 + f2 =~ x5 + x6 + x7 + x8 + x9 ' +fit2 <- cfa(m2, data = HolzingerSwineford1939) +compareFit(fit1, fit2, nested = FALSE) + +HW.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 ' + +out <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, + group = "school", quiet = TRUE) +compareFit(out) + +} +\seealso{ +\code{\linkS4class{FitDiff}}, \code{\link{clipboard}} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/dat2way.Rd r-cran-semtools-0.5.0/man/dat2way.Rd --- r-cran-semtools-0.4.14/man/dat2way.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/dat2way.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,31 +1,33 @@ -\name{dat2way} -\alias{dat2way} -\title{ -Simulated Dataset to Demonstrate Two-way Latent Interaction -} -\description{ -A simulated data set with 2 independent factors and 1 dependent factor where each factor has three indicators -} -\usage{ -data(dat2way) -} -\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 was generated by the \link[MASS]{mvrnorm} function in the \code{MASS} package. -} -\examples{ -head(dat2way) -} \ No newline at end of file +% 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}} 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} diff -Nru r-cran-semtools-0.4.14/man/dat3way.Rd r-cran-semtools-0.5.0/man/dat3way.Rd --- r-cran-semtools-0.4.14/man/dat3way.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/dat3way.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,34 +1,36 @@ -\name{dat3way} -\alias{dat3way} -\title{ -Simulated Dataset to Demonstrate Three-way Latent Interaction -} -\description{ -A simulated data set with 3 independent factors and 1 dependent factor where each factor has three indicators -} -\usage{ -data(dat3way) -} -\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 was generated by the \link[MASS]{mvrnorm} function in the \code{MASS} package. -} -\examples{ -head(dat3way) -} +% 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}} 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} diff -Nru r-cran-semtools-0.4.14/man/datCat.Rd r-cran-semtools-0.5.0/man/datCat.Rd --- r-cran-semtools-0.4.14/man/datCat.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/datCat.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,31 +1,32 @@ -\name{datCat} -\alias{datCat} -\title{ -Simulated Data set to Demonstrate Categorical Measurement Invariance -} -\description{ -A simulated data set with 2 factors with 4 indicators each separated into two groups -} -\usage{ -data(datCat) -} -\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 was generated using the \code{lavaan} package. -} -\examples{ -head(datCat) -} \ No newline at end of file +% 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} diff -Nru r-cran-semtools-0.4.14/man/EFA-class.Rd r-cran-semtools-0.5.0/man/EFA-class.Rd --- r-cran-semtools-0.4.14/man/EFA-class.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/EFA-class.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,47 +1,72 @@ -\name{EFA-class} -\docType{class} -\alias{EFA-class} -\alias{show,EFA-method} -\alias{summary,EFA-method} -\title{ - Class For Rotated Results from EFA -} -\description{ - This class contains the results of rotated exploratory factor analysis -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link{orthRotate}} or \code{\link{oblqRotate}} function. -} -\section{Slots}{ - \describe{ - \item{\code{loading}:}{Rotated standardized factor loading matrix} - \item{\code{rotate}:}{Rotation matrix} - \item{\code{gradRotate}:}{The gradient of the objective function at the rotated loadings} - \item{\code{convergence}:}{Convergence status} - \item{\code{phi}:}{Factor correlation. 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{methods}{ - \itemize{ - \item \code{summary} The \code{summary} function shows the detailed results of the rotated solution. This function has two arguments: \code{suppress} and \code{sort}. The \code{suppress} argument is used to not show the standardized loading values that less than the specified value. The default is 0.1. The \code{sort} is used to sort the factor loadings by the sizes of factor loadings in each factor. The default is \code{TRUE}. - } -} -\seealso{ -\code{\link{efaUnrotate}}; \code{\link{orthRotate}}; \code{\link{oblqRotate}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -library(lavaan) -unrotated <- efaUnrotate(HolzingerSwineford1939, nf=3, varList=paste0("x", 1:9), estimator="mlr") -summary(unrotated, std=TRUE) -inspect(unrotated, "std") - -# Rotated by Quartimin -rotated <- oblqRotate(unrotated, method="quartimin") -summary(rotated) -} +% 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} +\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{ + +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}) +} diff -Nru r-cran-semtools-0.4.14/man/efa.ekc.Rd r-cran-semtools-0.5.0/man/efa.ekc.Rd --- r-cran-semtools-0.4.14/man/efa.ekc.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/efa.ekc.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -0,0 +1,92 @@ +% 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 \code{sample.cov} is used.} + +\item{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 \link[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 == TRUE} in +\code{data}). (see also \link[lavaan]{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 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. (in press). 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}) +} diff -Nru r-cran-semtools-0.4.14/man/efaUnrotate.Rd r-cran-semtools-0.5.0/man/efaUnrotate.Rd --- r-cran-semtools-0.4.14/man/efaUnrotate.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/efaUnrotate.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,48 +1,64 @@ -\name{efaUnrotate} -\alias{efaUnrotate} -\title{ - Analyze Unrotated Exploratory Factor Analysis Model -} -\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. -} -\usage{ -efaUnrotate(data, nf, varList=NULL, start=TRUE, aux=NULL, ...) -} -\arguments{ - \item{data}{ - A target data frame. -} - \item{nf}{ - The desired number of factors -} - \item{varList}{ - Target observed variables. If not specified, all variables in the target data frame will be used. -} - \item{start}{ - Use starting values in the analysis from the \code{\link{factanal}} function. If \code{FALSE}, the starting values from the \code{lavaan} package will be 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}, or \code{estimator} -} -} -\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 and Wichern, 2002). The reason for creating this function in addition to the \code{\link{factanal}} function is that users can enjoy some advanced features from the \code{lavaan} package such as scaled chi-square, diagonal weighted least square for ordinal indicators, or full-information maximum likelihood. -} -\value{ - A \code{lavaan} output of unrotated exploratory factor analysis solution. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -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") -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/efa.R +\name{efaUnrotate} +\alias{efaUnrotate} +\title{Analyze Unrotated Exploratory Factor Analysis Model} +\usage{ +efaUnrotate(data, 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.} + +\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}, or +\code{estimator}} +} +\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 +in addition to the \code{\link{factanal}} function is that users can enjoy +some advanced features from the \code{lavaan} package such as scaled +\eqn{\chi^2}, diagonal weighted least squares for ordinal indicators, or +full-information maximum likelihood (FIML). +} +\examples{ + +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") + +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/exLong.Rd r-cran-semtools-0.5.0/man/exLong.Rd --- r-cran-semtools-0.4.14/man/exLong.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/exLong.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,32 +1,32 @@ -\name{exLong} -\alias{exLong} -\title{ -Simulated Data set to Demonstrate Longitudinal Measurement Invariance -} -\description{ -A simulated data set with 1 factors with 3 indicators in three timepoints -} -\usage{ -data(exLong) -} -\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 was generated using the \code{simsem} package. -} -\examples{ -head(exLong) -} \ No newline at end of file +% 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} diff -Nru r-cran-semtools-0.4.14/man/findRMSEApowernested.Rd r-cran-semtools-0.5.0/man/findRMSEApowernested.Rd --- r-cran-semtools-0.4.14/man/findRMSEApowernested.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/findRMSEApowernested.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,38 +1,61 @@ -\name{findRMSEApowernested} -\alias{findRMSEApowernested} -\title{Find power given a sample size in nested model comparison} -\description{ -Find the sample size that the power in rejection the samples from the alternative pair of RMSEA is just over the specified power. -} -\usage{ -findRMSEApowernested(rmsea0A = NULL, rmsea0B = NULL, - rmsea1A, rmsea1B = NULL, dfA, dfB, n, alpha=.05, - group=1) -} -\arguments{ - \item{rmsea0A}{The H0 baseline RMSEA.} - \item{rmsea0B}{The H0 alternative RMSEA (trivial misfit).} - \item{rmsea1A}{The H1 baseline RMSEA.} - \item{rmsea1B}{The H1 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.} -} -\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}, 19-35. -} -\author{ - Bell Clinton; Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}); Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{plotRMSEApowernested}} to plot the statistical power for nested model comparison based on population RMSEA given the sample size - \item \code{\link{findRMSEAsamplesizenested}} to find the minium sample size for a given statistical power in nested model comparison based on population RMSEA - } -} -\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) -} +% 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}} to plot the statistical power for + nested model comparison based on population RMSEA given the sample size + \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/findRMSEApower.Rd r-cran-semtools-0.5.0/man/findRMSEApower.Rd --- r-cran-semtools-0.4.14/man/findRMSEApower.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/findRMSEApower.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,38 +1,60 @@ -\name{findRMSEApower} -\alias{findRMSEApower} -\title{ -Find the statistical power based on population 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) -} -\usage{ -findRMSEApower(rmsea0, rmseaA, df, n, alpha=.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.} - } -\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). -} -\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,} 130-149. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{plotRMSEApower}} to plot the statistical power based on population RMSEA given the sample size - \item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions - \item \code{\link{findRMSEAsamplesize}} to find the minium sample size for a given statistical power based on population RMSEA - } -} -\examples{ -findRMSEApower(rmsea0=.05, rmseaA=.08, df=20, n=200) -} \ No newline at end of file +% 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). +} +\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 +} +\seealso{ +\itemize{ + \item \code{\link{plotRMSEApower}} to plot the statistical power based on + population RMSEA given the sample size + \item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions + \item \code{\link{findRMSEAsamplesize}} to find the minium sample size for + a given statistical power based on population RMSEA +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/findRMSEAsamplesizenested.Rd r-cran-semtools-0.5.0/man/findRMSEAsamplesizenested.Rd --- r-cran-semtools-0.4.14/man/findRMSEAsamplesizenested.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/findRMSEAsamplesizenested.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,37 +1,60 @@ -\name{findRMSEAsamplesizenested} -\alias{findRMSEAsamplesizenested} -\title{Find sample size given a power in nested model comparison} -\description{ -Find the sample size that the power in rejection the samples from the alternative pair of RMSEA is just over the specified power. -} -\usage{ -findRMSEAsamplesizenested(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, -rmsea1B = NULL, dfA, dfB, power=0.80, alpha=.05, group=1) -} -\arguments{ - \item{rmsea0A}{The H0 baseline RMSEA.} - \item{rmsea0B}{The H0 alternative RMSEA (trivial misfit).} - \item{rmsea1A}{The H1 baseline RMSEA.} - \item{rmsea1B}{The H1 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.} -} -\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}, 19-35. -} -\author{ - Bell Clinton; Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}); Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{plotRMSEApowernested}} to plot the statistical power for nested model comparison based on population RMSEA given the sample size - \item \code{\link{findRMSEApowernested}} to find the power for a given sample size in nested model comparison based on population RMSEA - } -} -\examples{ -findRMSEAsamplesizenested(rmsea0A = 0, rmsea0B = 0, rmsea1A = 0.06, -rmsea1B = 0.05, dfA = 22, dfB = 20, power=0.80, alpha=.05, group=1) -} +% 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}} to plot the statistical power for + nested model comparison based on population RMSEA given the sample size + \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/findRMSEAsamplesize.Rd r-cran-semtools-0.5.0/man/findRMSEAsamplesize.Rd --- r-cran-semtools-0.4.14/man/findRMSEAsamplesize.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/findRMSEAsamplesize.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,38 +1,58 @@ -\name{findRMSEAsamplesize} -\alias{findRMSEAsamplesize} -\title{ -Find the minimum sample size for a given statistical power based on population 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) -} -\usage{ -findRMSEAsamplesize(rmsea0, rmseaA, df, power=0.80, alpha=.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.} - } -\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}} function is just over the specified power. If \code{group} is greater than 1, the resulting sample size is the sample size per group. -} -\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,} 130-149. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{plotRMSEApower}} to plot the statistical power based on population RMSEA given the sample size - \item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions - \item \code{\link{findRMSEApower}} to find the statistical power based on population RMSEA given a sample size - } -} -\examples{ -findRMSEAsamplesize(rmsea0=.05, rmseaA=.08, df=20, power=0.80) -} \ No newline at end of file +% 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}} 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 +} +\seealso{ +\itemize{ + \item \code{\link{plotRMSEApower}} to plot the statistical power based on + population RMSEA given the sample size + \item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions + \item \code{\link{findRMSEApower}} to find the statistical power based on + population RMSEA given a sample size +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/FitDiff-class.Rd r-cran-semtools-0.5.0/man/FitDiff-class.Rd --- r-cran-semtools-0.4.14/man/FitDiff-class.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/FitDiff-class.Rd 2018-06-25 21:15:29.000000000 +0000 @@ -1,52 +1,74 @@ -\name{FitDiff-class} -\docType{class} -\alias{FitDiff-class} -\alias{show,FitDiff-method} -\alias{summary,FitDiff-method} -\title{ - Class For Representing A Template of Model Fit Comparisons -} -\description{ - This class contains model fit measures and model fit comparisons among multiple models -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link{compareFit}} function. -} -\section{Slots}{ - \describe{ - \item{\code{name}:}{The name of each model} - \item{\code{nested}:}{Model fit comparisons between adjacent nested models that are ordered based on their degrees of freedom} - \item{\code{ordernested}:}{The order of nested models regarding to their degrees of freedom} - \item{\code{fit}:}{Fit measures of all models specified in the \code{name} slot} - } -} -\section{methods}{ - \itemize{ - \item \code{summary} The summary function is used to provide the nested model comparison results and the summary of the fit indices across models. This function has one argument: \code{fit.measures}. If \code{"default"} is specified, chi-square values, degree of freedom, \emph{p} value, CFI, TLI, RMSEA, SRMR, AIC, and BIC are provided. If \code{"all"} is specified, all information given in the \code{\link[lavaan]{fitMeasures}} function is provided. Users may specify a vector of the name of fit indices that they wish. - } -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ -\code{\link{compareFit}}; \code{\link{clipboard}} -} -\examples{ -HW.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -out <- measurementInvariance(HW.model, data=HolzingerSwineford1939, group="school", quiet=TRUE) -modelDiff <- compareFit(out) -summary(modelDiff) -summary(modelDiff, fit.measures="all") -summary(modelDiff, fit.measures=c("aic", "bic")) - -\dontrun{ -# Save results to a file -saveFile(modelDiff, file="modelDiff.txt") - -# Copy to a clipboard -clipboard(modelDiff) -} -} +% 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} +\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") +} +\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}}. 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.} +} +\description{ +This class contains model fit measures and model fit comparisons among +multiple models +} +\section{Slots}{ + +\describe{ +\item{\code{name}}{The name of each model} + +\item{\code{nested}}{Model fit comparisons between adjacent nested models that are +ordered based on their degrees of freedom (\emph{df})} + +\item{\code{ordernested}}{The order of nested models regarding to their \emph{df}} + +\item{\code{fit}}{Fit measures of all models specified in the \code{name} slot} +}} + +\section{Objects from the Class}{ + Objects can be created via the + \code{\link{compareFit}} function. +} + +\examples{ + +HW.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 ' + +out <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, + group = "school", quiet = TRUE) +modelDiff <- compareFit(out) +summary(modelDiff) +summary(modelDiff, fit.measures = "all") +summary(modelDiff, fit.measures = c("aic", "bic")) + +\dontrun{ +## Save results to a file +saveFile(modelDiff, file = "modelDiff.txt") + +## Copy to a clipboard +clipboard(modelDiff) +} + +} +\seealso{ +\code{\link{compareFit}}; \code{\link{clipboard}} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/fitMeasuresMx.Rd r-cran-semtools-0.5.0/man/fitMeasuresMx.Rd --- r-cran-semtools-0.4.14/man/fitMeasuresMx.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/fitMeasuresMx.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -\name{fitMeasuresMx} -\alias{fitMeasuresMx} -\title{ - Find fit measures from an MxModel result -} -\description{ - Find fit measures from MxModel result. The saturate and null models are analyzed in the function and fit measures are calculated based on the comparison with the null and saturate models. The function is adjusted from the \code{fitMeasures} function in the lavaan package. -} -\usage{ -fitMeasuresMx(object, fit.measures="all") -} -\arguments{ - \item{object}{ - The target \code{MxModel} object -} - \item{fit.measures}{ - Target fit measures - } -} -\value{ - A vector of fit measures -} -\seealso{ - \code{\link{nullMx}}, \code{\link{saturateMx}}, \code{\link{standardizeMx}} -} -\author{ - The original function is the \code{fitMeasures} function written by Yves Rosseel in the \code{lavaan} package. The function is adjusted for an \code{MxModel} object by Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -\dontrun{ -library(OpenMx) -data(demoOneFactor) -manifests <- names(demoOneFactor) -latents <- c("G") -factorModel <- mxModel("One Factor", - type="RAM", - manifestVars=manifests, - latentVars=latents, - mxPath(from=latents, to=manifests), - mxPath(from=manifests, arrows=2), - mxPath(from=latents, arrows=2, free=FALSE, values=1.0), - mxData(observed=cov(demoOneFactor), type="cov", numObs=500) -) -factorFit <- mxRun(factorModel) -round(fitMeasuresMx(factorFit), 3) - -# Compare with lavaan -library(lavaan) -script <- "f1 =~ x1 + x2 + x3 + x4 + x5" -fitMeasures(cfa(script, sample.cov = cov(demoOneFactor), sample.nobs = 500, std.lv = TRUE)) -} -} diff -Nru r-cran-semtools-0.4.14/man/fmi.Rd r-cran-semtools-0.5.0/man/fmi.Rd --- r-cran-semtools-0.4.14/man/fmi.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/fmi.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,86 +1,121 @@ -\name{fmi} -\alias{fmi} -\title{ -Fraction of Missing Information. -} -\description{ - This function takes a list of imputed data sets and estimates the Fraction of Missing Information of the Variances and Means for each variable. -} -\usage{ -fmi(dat.imp, method="saturated", varnames=NULL, group=NULL, exclude=NULL, -digits=3) -} -\arguments{ - \item{dat.imp}{ - List of imputed data sets, the function only accept a list of data frames. -} - \item{method}{ - Specified the model used to estimated the variances and means. Can be one of the following: \code{"saturated"} (\code{"sat"}) or \code{"null"}, the default is \code{"saturated"}. See Details for more information. -} - \item{varnames}{ - A vector of variables names. This argument allow the user to get the fmi of a subset of variables. The function by default will estimate the fmi for all the variables. -} - \item{group}{ - A variable name defining the groups. This will give the fmi for each group. -} - \item{exclude}{ - A vector of variables names. These variables will be excluded from the analysis. -} - \item{digits}{ - Number of decimals to print in the results. -} -} -\details{ -The function estimates a variance/covariance model for each data set using lavaan. If method = \code{"saturated"} the function will estimate all the variances and covariances, -if method = \code{"null"} the function will only estimate the variances. The saturated model gives more reliable estimates. -With big data sets using the saturated model could take a lot of time. -In the case of having problems with big data sets it is helpful to select a subset of variables with \code{varnames} and/or use the \code{"null"} model. -The function does not accept character variables. -} -\value{ -fmi returns a list with the Fraction of Missing Information of the Variances and Means for each variable in the data set. -\item{Variances}{The estimated variance for each variable, and the respective standard error. -Two estimates Fraction of Missing Information of the Variances. The first estimate of fmi (fmi.1) is asymptotic fmi and the second estimate of fmi (fmi.2) is corrected for small numbers of imputations} -\item{Means}{The estimated mean for each variable, and the respective standard error. -Two estimates Fraction of Missing Information of the Means. The first estimate of fmi (fmi.1) is asymptotic fmi and the second estimate of fmi (fmi.2) is corrected for small numbers of imputations} -} -\references{ -Rubin, D.B. (1987) \emph{Multiple Imputation for Nonresponse in Surveys.} J. Wiley & Sons, New York. - -Savalei, V. & Rhemtulla, M. (2012) On Obtaining Estimates of the Fraction -of Missing Information From Full Information Maximum Likelihood, \emph{Structural Equation Modeling: A Multidisciplinary Journal, 19:3}, 477-494. - -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. -} -\author{Mauricio Garnier Villarreal (University of Kansas; \email{mgv@ku.edu}) -} -\examples{ -library(Amelia) -library(lavaan) - -modsim <- ' -f1 =~ 0.7*y1+0.7*y2+0.7*y3 -f2 =~ 0.7*y4+0.7*y5+0.7*y6 -f3 =~ 0.7*y7+0.7*y8+0.7*y9' - -datsim <- simulateData(modsim,model.type="cfa", meanstructure=TRUE, - std.lv=TRUE, sample.nobs=c(200,200)) -randomMiss2 <- rbinom(prod(dim(datsim)), 1, 0.1) -randomMiss2 <- matrix(as.logical(randomMiss2), nrow=nrow(datsim)) -randomMiss2[,10] <- FALSE -datsim[randomMiss2] <- NA -datsimMI <- amelia(datsim,m=3,idvars="group") - -out1 <- fmi(datsimMI$imputations, exclude="group") -out1 - -out2 <- fmi(datsimMI$imputations, exclude="group", method="null") -out2 - -out3 <- fmi(datsimMI$imputations, varnames=c("y1","y2","y3","y4")) -out3 - -out4 <- fmi(datsimMI$imputations, group="group") -out4 - -} +% 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, fewImps = 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 correlations are constrained to zero). +See Details for more information.} + +\item{group}{character. The optional name of a grouping variable, to request +FMI in each group.} + +\item{ords}{character. Optional vector of names of ordered-categorical +variables, which are not already stored as class \code{ordered} in +\code{data}.} + +\item{varnames}{character. Optional vector of variable names, to calculate +FMI for a subset of variables in \code{data}. By default, all numeric and +ordered variables will be included, unless \code{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}{character. Optional vector of variable names to exclude from +the analysis.} + +\item{fewImps}{logical. If \code{TRUE}, use the estimate of FMI that applies +a correction to the estimated between-imputation variance. Recommended when +there are few imputations; makes little difference when there are many +imputations. Ignored when \code{data} is not a list of imputed data sets.} +} +\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"}.} \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.} \item{message}{A message indicating caution +when the null model is used.} +} +\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}} +for a single incomplete data set using FIML, or with \code{\link{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, group = "school")) + +\dontrun{ +## ordered-categorical data +data(datCat) +lapply(datCat, class) +## impose missing values +set.seed(123) +for (i in 1:8) datCat[sample(1:nrow(datCat), size = .1*nrow(datCat)), i] <- NA +## impute data m = 3 times +library(Amelia) +set.seed(456) +impout <- amelia(datCat, m = 3, noms = "g", ords = paste0("u", 1:8), p2s = FALSE) +imps <- impout$imputations +## calculate FMI, using list of imputed data sets +fmi(imps, group = "g") +} + +} +\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 (University of Kansas; +\email{mauricio.garniervillarreal@marquette.edu}) Terrence Jorgensen +(University of Amsterdam; \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/htmt.Rd r-cran-semtools-0.5.0/man/htmt.Rd --- r-cran-semtools-0.4.14/man/htmt.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/htmt.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,39 +1,71 @@ -\name{htmt} -\alias{htmt} -\title{ - Assessing Discriminant Validity using Heterotrait-Monotrait Ratio -} -\description{ - This function assesses discriminant validity through the heterotrait-monotrait ratio (HTMT) of the correlations (Henseler, Ringlet & Sarstedt, 2015). Specifically, it assesses the average correlation among indicators across constructs (i.e. heterotrait-heteromethod correlations), relative to the average correlation among indicators within the same construct (i.e. monotrait-heteromethod correlations). The resulting HTMT values are interpreted as estimates of inter-construct correlations. Absolute values of the correlations are used to calculate the HTMT matrix. -} -\usage{ -htmt(data, model, ...) -} -\arguments{ - \item{data}{ - A desired data set -} - \item{model}{ - lavaan syntax of a confirmatory factor analysis model where at least two factors are required to indicate indicators measuring the same construct. - } - \item{\dots}{ - Other arguments shown in \link[lavaan]{lavCor} - } -} -\value{ - A matrix showing HTMT values (i.e., discriminant validity) between each pair of factors. -} -\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}, 115-135. -} -\author{ - Ylenio Longo (University of Nottingham; \email{yleniolongo@gmail.com}) -} -\examples{ -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -dat <- HolzingerSwineford1939[, paste0("x", 1:9)] -htmt(dat, HS.model) -} +% 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) +} +\arguments{ +\item{model}{lavaan \link[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 +\code{data}, to estimate the HTMT values.} + +\item{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 \link[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 == TRUE} in +\code{data}). (see also \link[lavaan]{lavCor})} + +\item{absolute}{logical. Whether HTMT values should be estimated based on +absolute correlations (recommended and default is \code{TRUE})} +} +\value{ +A matrix showing HTMT 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 average correlation among +indicators across constructs (i.e. heterotrait-heteromethod correlations), +relative to the average correlation among indicators within the same +construct (i.e. monotrait-heteromethod correlations). The resulting HTMT +values are interpreted as estimates of inter-construct correlations. +Absolute values of the correlations are recommended to calculate the HTMT +matrix. Correlations are estimated using the lavCor function in the lavaan +package. +} +\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) + +} +\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 +} +\author{ +Ylenio Longo (University of Nottingham; \email{yleniolongo@gmail.com}) + +Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/imposeStart.Rd r-cran-semtools-0.5.0/man/imposeStart.Rd --- r-cran-semtools-0.4.14/man/imposeStart.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/imposeStart.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,145 +1,149 @@ -\name{imposeStart} -\alias{imposeStart} -\title{ - Specify starting values from a lavaan output -} -\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). -} -\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 -} -\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) -} +% 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}) +} diff -Nru r-cran-semtools-0.4.14/man/indProd.Rd r-cran-semtools-0.5.0/man/indProd.Rd --- r-cran-semtools-0.4.14/man/indProd.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/indProd.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,89 +1,107 @@ -\name{indProd} -\alias{indProd} -\alias{orthogonalize} -\title{ - Make products of indicators using no centering, mean centering, double-mean centering, or residual centering -} -\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. -} -\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. -} -\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,} 275-300. - - 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}, 374-391. - - 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}, 497-519. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) - Alexander Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) -} -\seealso{ - \itemize{ - \item \code{\link{probe2WayMC}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe3WayMC}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe2WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{probe3WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the latent interaction. - } -} -\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 <- indProd(attitude[,-1], var1=1:2, var2=3:4, var3=5:6, match=FALSE, meanC=FALSE, - residualC=TRUE, doubleMC=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) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/indProd.R +\name{indProd} +\alias{indProd} +\alias{orthogonalize} +\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) + +} +\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}} For probing the two-way +latent interaction when the results are obtained from mean-centering, or +double-mean centering. \item \code{\link{probe3WayMC}} For probing the +three-way latent interaction when the results are obtained from +mean-centering, or double-mean centering. \item \code{\link{probe2WayRC}} +For probing the two-way latent interaction when the results are obtained +from residual-centering approach. \item \code{\link{probe3WayRC}} For +probing the two-way latent interaction when the results are obtained from +residual-centering approach. \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/kd.Rd r-cran-semtools-0.5.0/man/kd.Rd --- r-cran-semtools-0.4.14/man/kd.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/kd.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,75 +1,81 @@ -\name{kd} -\alias{kd} -\title{ -Generate data via the Kaiser-Dickman (1962) algorithm. -} -\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. -} -\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}.} -} -\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. -} -\value{ -\code{kd} returns a data matrix of dimension \code{n} by \code{nrow(covmat)}. -} -\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}, 179-182. -} -\author{ -Ed Merkle (University of Missouri; \email{merklee@missouri.edu}) -} - -\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) -} +% 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}) +} diff -Nru r-cran-semtools-0.4.14/man/kurtosis.Rd r-cran-semtools-0.5.0/man/kurtosis.Rd --- r-cran-semtools-0.4.14/man/kurtosis.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/kurtosis.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,57 +1,63 @@ -\name{kurtosis} -\alias{kurtosis} -\title{ - Finding excessive kurtosis -} -\description{ - Finding excessive kurtosis (g2) of an object -} -\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} -} -\details{ - The excessive kurtosis computed is g2. The 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}},} - - 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. -} -\references{ -Weisstein, Eric W. (n.d.). \emph{Kurtosis.} Retrived from MathWorld--A Wolfram Web Resource \url{http://mathworld.wolfram.com/Kurtosis.html} -} -\seealso{ - \itemize{ - \item \code{\link{skew}} Find the univariate skewness of a variable - \item \code{\link{mardiaSkew}} Find the Mardia's multivariate skewness of a set of variables - \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate kurtosis of a set of variables - } -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -kurtosis(1:5) -} +% 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 is \eqn{g_{2}}. The 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}},} + +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.} Retrived from +\emph{MathWorld}--A Wolfram Web Resource: +\url{http://mathworld.wolfram.com/Kurtosis.html} +} +\seealso{ +\itemize{ + \item \code{\link{skew}} Find the univariate skewness of a variable + \item \code{\link{mardiaSkew}} Find the Mardia's multivariate + skewness of a set of variables + \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate kurtosis + of a set of variables +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/lavaan.mi-class.Rd r-cran-semtools-0.5.0/man/lavaan.mi-class.Rd --- r-cran-semtools-0.4.14/man/lavaan.mi-class.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/lavaan.mi-class.Rd 2018-06-26 12:19:09.000000000 +0000 @@ -0,0 +1,334 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runMI-methods.R +\docType{class} +\name{lavaan.mi-class} +\alias{lavaan.mi-class} +\alias{show,lavaan.mi-method} +\alias{summary,lavaan.mi-method} +\alias{anova,lavaan.mi-method} +\alias{nobs,lavaan.mi-method} +\alias{coef,lavaan.mi-method} +\alias{vcov,lavaan.mi-method} +\alias{fitted,lavaan.mi-method} +\alias{fitted.values,lavaan.mi-method} +\alias{residuals,lavaan.mi-method} +\alias{resid,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{show,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{summary,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{nobs,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{coef,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{vcov,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{anova,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{fitMeasures,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{fitmeasures,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{fitted,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{fitted.values,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{residuals,lavaan.mi-method} +\alias{lavaan.mi-class} +\alias{resid,lavaan.mi-method} +\title{Class for a lavaan Model Fitted to Multiple Imputations} +\usage{ +\S4method{show}{lavaan.mi}(object) + +\S4method{summary}{lavaan.mi}(object, se = TRUE, ci = FALSE, level = 0.95, + standardized = FALSE, rsquare = FALSE, fmi = FALSE, header = TRUE, + scale.W = TRUE, asymptotic = FALSE, add.attributes = TRUE) + +\S4method{nobs}{lavaan.mi}(object, total = TRUE) + +\S4method{coef}{lavaan.mi}(object, type = "free", labels = TRUE) + +\S4method{vcov}{lavaan.mi}(object, type = c("pooled", "between", "within", + "ariv"), scale.W = TRUE) + +\S4method{anova}{lavaan.mi}(object, h1 = NULL, test = c("D3", "D2", "D1"), + pool.robust = FALSE, scale.W = FALSE, asymptotic = FALSE, + constraints = NULL, indices = FALSE, baseline.model = NULL, + method = "default", A.method = "delta", scaled.shifted = TRUE, + H1 = TRUE, type = "Chisq") + +\S4method{fitMeasures}{lavaan.mi}(object, fit.measures = "all", + baseline.model = NULL) + +\S4method{fitmeasures}{lavaan.mi}(object, fit.measures = "all", + baseline.model = NULL) + +\S4method{fitted}{lavaan.mi}(object) + +\S4method{fitted.values}{lavaan.mi}(object) + +\S4method{residuals}{lavaan.mi}(object, type = c("raw", "cor")) + +\S4method{resid}{lavaan.mi}(object, type = c("raw", "cor")) +} +\arguments{ +\item{object}{An object of class \code{lavaan.mi}} + +\item{se, ci, level, standardized, rsquare, header, add.attributes}{See +\code{\link[lavaan]{parameterEstimates}}.} + +\item{fmi}{\code{logical} indicating whether to include the Fraction Missing +Information (FMI) for parameter estimates in the \code{summary} output +(see \bold{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 calcualtes its pooled standard errors, as +well as the Wald test (\code{anova(..., test = "D1")}).} + +\item{asymptotic}{\code{logical}. If \code{FALSE} (typically a default, but +see \bold{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{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 \bold{Value} section +under \code{coef}, \code{vcov}, \code{residuals}, and \code{anova}.} + +\item{labels}{\code{logical} indicating whether the \code{coef} output should +include parameter labels. Default is \code{TRUE}.} + +\item{h1}{An object of class \code{lavaan.mi} in which \code{object} is +nested, so that their difference in fit can be tested using +\code{anova} (see \bold{Value} section for details).} + +\item{test}{\code{character} indicating the method used to pool model-fit or + model-comparison test statistics: +\itemize{ + \item{\code{"D3": }}{The default test (\code{"D3"}, or any of + \code{"mr", "Meng.Rubin", "likelihood", "LRT"}) is a pooled + likeliehood-ratio test (see Enders, 2010, ch. 8). + \code{test = "mplus"} implies \code{"D3"} and \code{asymptotic = + TRUE} (see Asparouhov & Muthen, 2010). When using a non-likelihood + estimator (e.g., DWLS for categorical outcomes), \code{"D3"} is + unavailable, so the default is changed to \code{"D2"}.} + \item{\code{"D2": }}{Returns a pooled test statistic, as described by + Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010, chapter 8). + Aliases include \code{"lmrr", "Li.et.al", "pooled.wald"}).} + \item{\code{"D1": }}{Returns a Wald test calculated for constraints on + the pooled point estimates, using the pooled covariance matrix of + parameter estimates; see \code{\link[lavaan]{lavTestWald}} for + details. \code{h1} is ignored when \code{test = "D1"}, and + \code{constraints} is ignored when \code{test != "D1"}. The + \code{scale.W} argument is passed to the \code{vcov} method (see + \bold{Value} section for details).} + }} + +\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}). +If \code{test = "D2"} and \code{pool.robust = TRUE}, further options +can be passed to \code{\link[lavaan]{lavTestLRT}} (see below).} + +\item{constraints}{See \code{\link[lavaan]{lavTestWald}}.} + +\item{indices}{\code{logical}, or \code{character} vector naming fit indices +to be printed with test of model fit. Ignored \code{if (!is.null(h1))}. +See description of \code{anova} in \bold{Value} section for details.} + +\item{method, A.method, H1, scaled.shifted}{See \code{\link[lavaan]{lavTestLRT}}.} + +\item{fit.measures, baseline.model}{See \code{\link[lavaan]{fitMeasures}}.} +} +\value{ +\item{coef}{\code{signature(object = "lavaan.mi", type = "free", labels = TRUE)}: + See \code{\linkS4class{lavaan}}. Returns the pooled point estimates (i.e., + averaged across imputed data sets; see Rubin, 1987).} + +\item{vcov}{\code{signature(object = "lavaan.mi", scale.W = TRUE, + 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 = "lavaan.mi")}: See + \code{\linkS4class{lavaan}}. Returns model-implied moments, evaluated at the + pooled point estimates.} +\item{fitted}{\code{signature(object = "lavaan.mi")}: + alias for \code{fitted.values}} + +\item{residuals}{\code{signature(object = "lavaan.mi", type = c("raw","cor"))}: + See \code{\linkS4class{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}{\code{signature(object = "lavaan.mi", type = c("raw","cor"))}: + alias for \code{residuals}} + +\item{nobs}{\code{signature(object = "lavaan.mi", total = TRUE)}: either + the total (default) sample size or a vector of group sample sizes + (\code{total = FALSE}).} + +\item{anova}{\code{signature(object = "lavaan.mi", h1 = NULL, + test = c("D3","D2","D1"), pool.robust = FALSE, scale.W = TRUE, + asymptotic = FALSE, constraints = NULL, indices = FALSE, baseline.model = NULL, + method = "default", A.method = "delta", H1 = TRUE, type = "Chisq")}: + Returns a test of model fit if \code{h1} is \code{NULL}, or a test + of the difference in fit between nested models if \code{h1} is another + \code{lavaan.mi} object, assuming \code{object} is nested in \code{h1}. If + \code{asymptotic}, the returned test statistic will follow a \eqn{\chi^2} + distribution in sufficiently large samples; otherwise, it will follow an + \emph{F} distribution. If a robust test statistic is detected in the + \code{object} results (it is assumed the same was requested in \code{h1}, + if provided), then \code{asymptotic} will be set to \code{TRUE} and the + pooled test statistic will be scaled using the average scaling factor (and + average shift parameter or \emph{df}, if applicable) across imputations + (unless \code{pool.robust = FALSE} and \code{test = "D2"}; see below). + + When \code{indices = TRUE} and \code{is.null(h1)}, popular indices of + approximate fit (CFI, TLI/NNFI, RMSEA with CI, and SRMR) will be returned + for \code{object}; see \code{\link[lavaan]{fitMeasures}} for more details. + Specific indices can be requested with a \code{character} vector (any of + \code{"mfi", "rmsea", "gammaHat", "rmr", "srmr", "cfi", "tli", "nnfi", + "rfi", "nfi", "pnfi", "ifi", "rni"}), or all available indices will be + returned if \code{indices = "all"}. Users can specify a custom + \code{baseline.model}, also fit using \code{runMI}, to calculate + incremental fit indices (e.g., CFI, TLI). If \code{baseline.model = NULL}, + the default independence model will be used.} + +\item{fitMeasures}{\code{signature(object = "lavaan.mi", + fit.measures = "all", baseline.model = NULL)}: arguments are consistent + with lavaan's \code{\link[lavaan]{fitMeasures}}. This merely calls the + \code{anova} method described above, with \code{indices = fit.measures} + and \code{baseline.model = baseline.model}, and default values for the + remaining arguments. The user has more control (e.g., over pooling methods) + using \code{anova} directly.} +\item{fitmeasures}{alias for \code{fitMeasures}.} + +\item{show}{\code{signature(object = "lavaan.mi")}: returns a message about + convergence rates and estimation problems (if applicable) across imputed + data sets.} + +\item{summary}{\code{signature(object = "lavaan.mi", se = TRUE, ci = FALSE, + level = .95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, + scale.W = FALSE, asymptotic = FALSE, add.attributes = TRUE)}: see + \code{\link[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 intervales + 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{add.attributes = FALSE}, the returned \code{data.frame} will resemble + the \code{parameterEstimates} output. The \code{scale.W} argument is + passed to \code{vcov} (see description above).} +} +\description{ +This class extends the \code{\linkS4class{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{\link[lavaan]{lavInspect}(fit, "est")}} + +\item{\code{GLIST}}{pooled \code{list} of coefficients in GLIST format} + +\item{\code{miList}}{\code{list} of modification indices output by +\code{\link[lavaan]{modindices}}} + +\item{\code{seed}}{\code{integer} seed set before running imputations} + +\item{\code{lavListCall}}{call to \code{\link[lavaan]{lavaanList}} used to fit the +model to the list of imputed data sets in \code{@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 +\code{\linkS4class{lavaanList}}, but \code{\link{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{\link[lavaan]{lavInspect}(fit, "sampstat")} applied to each fitted +model} + +\item{\code{ParTableList}}{See \code{\linkS4class{lavaanList}}} + +\item{\code{vcovList}}{See \code{\linkS4class{lavaanList}}} + +\item{\code{testList}}{See \code{\linkS4class{lavaanList}}} +}} + +\section{Objects from the Class}{ + See the \code{\link{runMI}} function for +details. Wrapper functions include \code{\link{lavaan.mi}}, +\code{\link{cfa.mi}}, \code{\link{sem.mi}}, and \code{\link{growth.mi}}. +} + +\examples{ + +## See ?runMI help page + +} +\references{ +Asparouhov, T., & Muthen, B. (2010). \emph{Chi-square statistics +with multiple imputation}. Technical Report. Retrieved from +\url{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{http://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. Retrieved +from \url{http://www.jstor.org/stable/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}) +} diff -Nru r-cran-semtools-0.4.14/man/lavaanStar-class.Rd r-cran-semtools-0.5.0/man/lavaanStar-class.Rd --- r-cran-semtools-0.4.14/man/lavaanStar-class.Rd 2016-10-17 15:29:56.000000000 +0000 +++ r-cran-semtools-0.5.0/man/lavaanStar-class.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -\name{lavaanStar-class} -\docType{class} -\alias{lavaanStar-class} -\alias{inspect,lavaanStar-method} -\alias{summary,lavaanStar-method} -\alias{anova,lavaanStar-method} -\alias{vcov,lavaanStar-method} - -\title{Class For Representing A (Fitted) Latent Variable Model with Additional Elements} -\description{This is the \code{lavaan} class that contains additional information about the fit values from the null model. Some functions are adjusted according to the change.} -\section{Objects from the Class}{ -Objects can be created via the \code{\link{auxiliary}} function or \code{\link{runMI}}. -} -\section{Slots}{ - \describe{ - \item{\code{call}:}{The function call as returned by \code{match.called()}.} - \item{\code{timing}:}{The elapsed time (user+system) for various parts of - the program as a list, including the total time.} - \item{\code{Options}:}{Named list of options that were provided by - the user, or filled-in automatically.} - \item{\code{ParTable}:}{Named list describing the model parameters. Can be coerced to a data.frame. In the documentation, this is called the `parameter table'.} - \item{\code{Data}:}{Object of internal class \code{"Data"}: information -about the data.} - \item{\code{SampleStats}:}{Object of internal class \code{"SampleStats"}: sample - statistics} - \item{\code{Model}:}{Object of internal class \code{"Model"}: the - internal (matrix) representation of the model} - \item{\code{Fit}:}{Object of internal class \code{"Fit"}: the - results of fitting the model} - \item{\code{nullfit}:}{The fit-indices information from the null model} - \item{\code{imputed}:}{The list of information from running multiple imputation. The first element is the convergence rate of the target and null models. The second element is the fraction missing information. The first estimate of FMI (FMI.1) is asymptotic FMI and the second estimate of FMI (FMI.2) is corrected for small numbers of imputation. The third element is the fit values of the target model by the specified chi-squared methods. The fourth element is the fit values of the null model by the specified chi-square methods. The fifth element is the adjusted log-likelihood for target model and satuated model. The sixth element is the chi-square values and the log-likehood values (based on fixing parameter estimates as the estimated values) from each imputed data set.} - \item{\code{imputedResults}:}{Results from fitting models for imputed data sets.} - \item{\code{auxNames}:}{The list of auxiliary variables in the analysis.} - } -} -\references{ -see \code{\linkS4class{lavaan}}} -\seealso{ -\code{\link{auxiliary}}; \code{\link{runMI}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -dat <- data.frame(HolzingerSwineford1939, z=rnorm(nrow(HolzingerSwineford1939), 0, 1)) - -fit <- cfa(HS.model, data=dat) -fitaux <- auxiliary(HS.model, aux="z", data=dat, fun="cfa") -} diff -Nru r-cran-semtools-0.4.14/man/lavTestScore.mi.Rd r-cran-semtools-0.5.0/man/lavTestScore.mi.Rd --- r-cran-semtools-0.4.14/man/lavTestScore.mi.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/lavTestScore.mi.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -0,0 +1,152 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runMI-score.R +\name{lavTestScore.mi} +\alias{lavTestScore.mi} +\title{Score Test for Multiple Imputations} +\usage{ +lavTestScore.mi(object, add = NULL, release = NULL, type = c("D2", + "Rubin"), scale.W = FALSE, asymptotic = !is.null(add), + univariate = TRUE, cumulative = FALSE, epc = FALSE, verbose = FALSE, + warn = TRUE) +} +\arguments{ +\item{object}{An object of class \code{\linkS4class{lavaan}}.} + +\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{type}{\code{character} indicating which pooling method to use. +\code{"Rubin"} indicates Rubin's (1987) rules will be applied to the + gradient and information, and those pooled values will be used to + calculate modification indices in the usual manner. \code{"D2"} (default), +\code{"LMRR"}, or \code{"Li.et.al"} indicate that modification indices + calculated from each imputed data set will be pooled across imputations, + as described in Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010).} + +\item{scale.W}{\code{logical}. If \code{FALSE} (default), 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; see Enders, 2010, p. 235). +Not recommended, and ignored (irrelevant) if \code{type = "D2"}.} + +\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{verbose}{\code{logical}. Not used for now.} + +\item{warn}{\code{logical}. If \code{TRUE}, print out warnings if they occur.} +} +\value{ +A list containing at least one \code{data.frame}: + \itemize{ + \item{\code{$test}: The total score test, with columns for the score + test statistic (\code{X2}), the degrees of freedom (\code{df}), and + a \emph{p} value under the \eqn{\chi^2} distribution (\code{p.value}).} + \item{\code{$uni}: Optional (if \code{univariate=TRUE}). + Each 1-\emph{df} score test, equivalent to modification indices.} + \item{\code{$cumulative}: Optional (if \code{cumulative=TRUE}). + Cumulative score tests.} + \item{\code{$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}} 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 +using Rubin's (1987) rules, or by pooling the score test statistics +across imputed data sets (Li, Meng, Raghunathan, & Rubin, 1991). +} +\examples{ + \dontrun{ +## 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) + +## impute missing data +library(Amelia) +set.seed(12345) +HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +imps <- HS.amelia$imputations + +## specify CFA model from lavaan's ?cfa help page +HS.model <- ' + speed =~ c(L1, L1)*x7 + c(L1, L1)*x8 + c(L1, L1)*x9 +' + +out <- cfa.mi(HS.model, data = imps, group = "school", std.lv = TRUE) + +## Mode 1: Score test for releasing equality constraints + +## default type: Li et al.'s (1991) "D2" method +lavTestScore.mi(out, cumulative = TRUE) +## Rubin's rules +lavTestScore.mi(out, type = "Rubin") + +## Mode 2: Score test for adding currently fixed-to-zero parameters +lavTestScore.mi(out, add = 'x7 ~~ x8 + x9') + +} + +} +\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{http://www.jstor.org/stable/24303994} + +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}) + +Adapted from \pkg{lavaan} source code, written by + Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) + +\code{type = "Rubin"} method proposed by + Maxwell Mansolf (University of California, Los Angeles; + \email{mamansolf@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/lisrel2lavaan-deprecated.Rd r-cran-semtools-0.5.0/man/lisrel2lavaan-deprecated.Rd --- r-cran-semtools-0.4.14/man/lisrel2lavaan-deprecated.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/lisrel2lavaan-deprecated.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -0,0 +1,128 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lisrel2lavaan.R +\name{lisrel2lavaan-deprecated} +\alias{lisrel2lavaan-deprecated} +\title{Translate LISREL syntax to lavaan \code{\link[lavaan]{model.syntax}}} +\usage{ +lisrel2lavaan(filename = NULL, analyze = TRUE, silent = FALSE, ...) +} +\arguments{ +\item{filename}{Filename of the LISREL syntax file. If the \code{filename} +arguement is not specified, the user will be prompted with a file browser +with which LISREL syntax file can be selected (recommended).} + +\item{analyze}{Logical. If \code{analyze==TRUE} (default), data will be +automatically imported and analyzed; \code{\linkS4class{lavaan}} summary +output displayed and fit object will be returned silently. If +\code{analyze==FALSE}, data will not be imported or analyzed; instead, a +\code{\linkS4class{lavaan}} parameter table containing the model +specifications will be returned.} + +\item{silent}{Logical. If false (default) the data will be analyzed and +output displayed. If true, a fit object will be returned and summary output +will not be displayed.} + +\item{\dots}{Additional arguments to be passed to +\code{\link[lavaan]{lavaan}}. See also \code{\link[lavaan]{lavOptions}}} +} +\value{ +Output summary is printed to screen and \code{\linkS4class{lavaan}} +fit object is returned. +} +\description{ +\bold{This function is deprecated} because it is based on an old template + for lavaan's parameter table, which is expected to differ more as + development continues. +} +\details{ +This function can be used to estimate a structural equation model in +\code{\linkS4class{lavaan}} using LISREL syntax. Data are automatically +imported from the LISREL syntax file, or, if data files names are provided +within LISREL syntax, from the same directory as the syntax itself, as per +standard LISREL data importation. +} +\note{ +\code{lisrel2lavaan} is still in development, and not all LISREL +commands are currently functional. A number of known limitations are +outlined below. If an error is encountered that is not listed, please +contact \email{corbinq@ku.edu}. + +\enumerate{ + \item data importation: \code{lisrel2lavaan} currently supports .csv, + .dat, and most other delimited data formats. However, formats that are + specific to LISREL or PRELIS (e.g., the .PSF file format) cannot be + imported. \code{lisrel2lavaan} supports raw data, covariance matrices, + and correlation matrices (accompanied by a variance vector). Symmetric + matrices can either contain lower triangle or full matrix. For MACS + structure models, either raw data or summary statistics (that include a + mean vector) are supported. + +\item variable labels: Certain variable labels that are permitted in LISREL +cannot be supported in \code{lisrel2lavaan}. + +\item duplicate labels: Most importantly, no two variables of any kind + (including phantom variables) should be given the same label when using + \code{lisrel2lavaan}. If multiple variables are given the same label, + \code{\link[lavaan]{lavaan}} will estimate an incorrect model. + +\item numeric character labels: All variable labels are recommended to include +non-numeric characters. In addition, the first character in each variable +label is recommended to be non-numeric. + +\item labels not specified: If variable labels are not provided by the user, +names will be generated reflecting variable assignment (e.g. 'eta1', +'ksi1'); manifest variables will be in lower case and latent variables in +upper case. + +\item OU paragraph Not all commands in the OU paragraph are presently +supported in \code{lisrel2lavaan}. The ME command can be used to specify +estimation method; however, not all estimations available in LISREL are +currently supported by \code{\link[lavaan]{lavaan}}. If the specified ME is +unsupported, \code{lisrel2lavaan} will revert to default estimation. The AD, +EP, IT, ND and NP keywords will be ignored. Requests for text files +containing starting values (e.g., \code{OU BE}) will also be ignored. + +\item starting values: Certain functionalities related to starting values in +LISREL are not yet operational in \code{lisrel2lavaan}. Note that due to +differences in estimation, starting values are not as important in +\code{\link[lavaan]{lavaan}} model estimation as in LISREL. + +\item text file output: Requests for text files containing starting + values for individual matrices in the in the \code{OU} command (e.g., + \code{OU BE}) are not currently supported. These requests will be ignored. + +\item MA paragraph: Specification of matrix starting values using the MA +command is permitted by providing starting values within syntax directly. +However, \code{lisrel2lavaan} has sometimes encountered problems with +importation when files are specified following the MA paragraph. + +} +} +\examples{ + +\dontrun{ + ## calling lisrel2lavaan without specifying the filename argument will + ## open a file browser window with which LISREL syntax can be selected. + + ## any additional arguments to be passed to lavaan for data analysis can + ## be specified normally. + + lisrel2lavaan(se = "standard") + ## lavaan output summary printed to screen + ## lavaan fit object returned silently + + ## manual file specification + + lisrel2lavaan(filename = "myFile.LS8", se = "standard") + ## lavaan output summary printed to screen + ## lavaan fit object returned silently +} + +} +\seealso{ +\code{\link{semTools-deprecated}} +} +\author{ +Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) +} +\keyword{internal} diff -Nru r-cran-semtools-0.4.14/man/lisrel2lavaan.Rd r-cran-semtools-0.5.0/man/lisrel2lavaan.Rd --- r-cran-semtools-0.4.14/man/lisrel2lavaan.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/lisrel2lavaan.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -\name{lisrel2lavaan} -\alias{lisrel2lavaan} -\title{ - Latent variable modeling in \code{\linkS4class{lavaan}} using LISREL syntax -} -\description{ - This function can be used to estimate a structural equation model in \code{\linkS4class{lavaan}} using LISREL syntax. Data are automatically imported from the LISREL syntax file, or, if data files names are provided within LISREL syntax, from the same directory as the syntax itself, as per standard LISREL data importation. -} -\usage{ -lisrel2lavaan(filename = NULL, analyze = TRUE, silent = FALSE, ...) -} -\arguments{ - \item{filename}{ - Filename of the LISREL syntax file. If the \code{filename} arguement is not specified, the user will be prompted with a file browser with which LISREL syntax file can be selected (recommended). -} - \item{analyze}{ - Logical. If \code{analyze==TRUE} (default), data will be automatically imported and analyzed; \code{\linkS4class{lavaan}} summary output displayed and fit object will be returned silently. If \code{analyze==FALSE}, data will not be imported or analyzed; instead, a \code{\linkS4class{lavaan}} parameter table containing the model specifications will be returned. -} - \item{silent}{ - Logical. If false (default) the data will be analyzed and output displayed. If true, a fit object will be returned and summary output will not be displayed. -} - \item{\dots}{ - Additional arguments to be passed to \code{\link[lavaan]{lavaan}}. -} -} -\value{ - Output summary is printed to screen and \code{\linkS4class{lavaan}} fit object is returned. -} -\note{ - \code{lisrel2lavaan} is still in development, and not all LISREL commands are currently functional. A number of known limitations are outlined below. If an error is encountered that is not listed, please contact \email{corbinq@ku.edu}. - \enumerate{ - \item{data importation}{ - \code{lisrel2lavaan} currently supports .csv, .dat, and most other delimited data formats. However, formats that are specific to LISREL or PRELIS (e.g., the .PSF file format) cannot be imported. \code{lisrel2lavaan} supports raw data, covariance matrices, and correlation matrices (accompanied by a variance vector). Symmetric matrices can either contain lower triangle or full matrix. For MACS structure models, either raw data or summary statistics (that include a mean vector) are supported. -} - \item{variable labels}{ - Certain variable labels that are permitted in LISREL cannot be supported in \code{lisrel2lavaan}. - \item{duplicate labels}{ - Most importantly, no two variables of any kind (including phantom variables) should be given the same label when using \code{lisrel2lavaan}. If multiple variables are given the same label, \code{\link[lavaan]{lavaan}} will estimate an incorrect model. -} - \item{numeric character labels}{ - All variable labels are recommended to include non-numeric characters. In addition, the first character in each variable label is recommended to be non-numeric. -} - \item{labels not specified}{ - If variable labels are not provided by the user, names will be generated reflecting variable assignment (e.g. 'eta1', 'ksi1'); manifest variables will be in lower case and latent variables in upper case. -} -} - \item{OU paragraph}{ - Not all commands in the OU paragraph are presently supported in \code{lisrel2lavaan}. The ME command can be used to specify estimation method; however, not all estimations available in LISREL are currently supported by \code{\link[lavaan]{lavaan}}. If the specified ME is unsupported, \code{lisrel2lavaan} will revert to default estimation. The AD, EP, IT, ND and NP keywords will be ignored. Requests for text files containing starting values (e.g., \code{OU BE}) will also be ignored. -} - \item{starting values}{ - Certain functionalities related to starting values in LISREL are not yet operational in \code{lisrel2lavaan}. Note that due to differences in estimation, starting values are not as important in \code{\link[lavaan]{lavaan}} model estimation as in LISREL. - \item{text file output}{ - Requests for text files containing starting values for individual matrices in the in the \code{OU} command (e.g., \code{OU BE}) are not currently supported. These requests will be ignored. -} - \item{MA paragraph}{ - Specification of matrix starting values using the MA command is permitted by providing starting values within syntax directly. However, \code{lisrel2lavaan} has sometimes encountered problems with importation when files are specified following the MA paragraph. -} -} -} -} -\author{ - Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) -} -\examples{ -\dontrun{ - ## calling lisrel2lavaan without specifying the filename argument will - ## open a file browser window with which LISREL syntax can be selected. - - ## any additional arguments to be passed to lavaan for data analysis can - ## be specified normally. - - lisrel2lavaan(se="standard") - ## lavaan output summary printed to screen - ## lavaan fit object returned silently - - ## manual file specification - - lisrel2lavaan(filename="myFile.LS8", se="standard") - ## lavaan output summary printed to screen - ## lavaan fit object returned silently -} -} - diff -Nru r-cran-semtools-0.4.14/man/loadingFromAlpha.Rd r-cran-semtools-0.5.0/man/loadingFromAlpha.Rd --- r-cran-semtools-0.4.14/man/loadingFromAlpha.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/loadingFromAlpha.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,22 +1,29 @@ -\name{loadingFromAlpha} -\alias{loadingFromAlpha} -\title{Find standardized factor loading from coefficient alpha} -\description{ - Find standardized factor loading from coefficient alpha assuming that all items have equal loadings. -} -\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.} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ - loadingFromAlpha(0.8, 4) -} +% 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}) +} diff -Nru r-cran-semtools-0.4.14/man/longInvariance.Rd r-cran-semtools-0.5.0/man/longInvariance.Rd --- r-cran-semtools-0.4.14/man/longInvariance.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/longInvariance.Rd 2018-05-14 13:41:19.000000000 +0000 @@ -1,100 +1,153 @@ -\name{longInvariance} -\alias{longInvariance} -\alias{longInvariance} -\title{ -Measurement Invariance Tests Within Person -} -\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. -} -\usage{ -longInvariance(model, varList, auto = "all", constrainAuto = FALSE, -fixed.x = TRUE, std.lv = FALSE, group=NULL, group.equal="", -group.partial="", warn=TRUE, debug=FALSE, strict = FALSE, quiet = FALSE, -fit.measures = "default", 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]{lavaan}.}} - \item{std.lv}{See \code{\link[lavaan]{lavaan}.}} - \item{group}{See \code{\link[lavaan]{lavaan}.}} - \item{group.equal}{See \code{\link[lavaan]{lavaan}.}} - \item{group.partial}{See \code{\link[lavaan]{lavaan}.}} - \item{warn}{See \code{\link[lavaan]{lavaan}.}} - \item{debug}{See \code{\link[lavaan]{lavaan}.}} - \item{strict}{If \code{TRUE}, the sequence requires `strict' invariance. See details for more information.} - \item{quiet}{If \code{TRUE}, a summary is printed out containing an overview of the different models that are fitted, together with some model comparison tests.} - \item{fit.measures}{Fit measures used to calculate the differences between nested models.} - \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan]{lavTestLRT}} for available options} - \item{...}{Additional arguments in the \code{\link[lavaan]{lavaan}} function.} -} -\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 chi-square difference 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 (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 chi-square test statistic is scaled (eg. a -Satorra-Bentler or Yuan-Bentler test statistic), a special version of the -chi-square difference test is used as described in -\url{http://www.statmodel.com/chidiff.shtml} -} - -\value{ -Invisibly, all model fits in the sequence are returned as a list. -} -\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. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}); Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) -} -\seealso{ - \code{\link{measurementinvariance}} For the measurement invariance test between groups -} -\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")) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/longInvariance.R +\name{longInvariance} +\alias{longInvariance} +\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]{lavaan}.}} + +\item{std.lv}{See \code{\link[lavaan]{lavaan}.}} + +\item{group}{See \code{\link[lavaan]{lavaan}.}} + +\item{group.equal}{See \code{\link[lavaan]{lavaan}.}} + +\item{group.partial}{See \code{\link[lavaan]{lavaan}.}} + +\item{strict}{If \code{TRUE}, the sequence requires strict invariance. See} + +\item{warn}{See \code{\link[lavaan]{lavaan}.}} + +\item{debug}{See \code{\link[lavaan]{lavaan}.} +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}}} + +\item{method}{The method used to calculate likelihood ratio test. See +\code{\link[lavaan]{lavTestLRT}} for available options} + +\item{...}{Additional arguments in the \code{\link[lavaan]{lavaan}} +function. See also \code{\link[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. +} +\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{measurementinvariance}} For the measurement invariance +test between groups +} +\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}) +} diff -Nru r-cran-semtools-0.4.14/man/mardiaKurtosis.Rd r-cran-semtools-0.5.0/man/mardiaKurtosis.Rd --- r-cran-semtools-0.4.14/man/mardiaKurtosis.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/mardiaKurtosis.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,46 +1,56 @@ -\name{mardiaKurtosis} -\alias{mardiaKurtosis} -\title{ - Finding Mardia's multivariate kurtosis -} -\description{ - Finding Mardia's multivariate kurtosis of multiple variables -} -\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]{cov}} function. -} -} -\value{ - A value of a Mardia's multivariate kurtosis with a test statistic -} -\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}. -} -\references{ -Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications. \emph{Biometrika, 57}, 519-530. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{skew}} Find the univariate skewness of a variable - \item \code{\link{kurtosis}} Find the univariate excessive kurtosis of a variable - \item \code{\link{mardiaSkew}} Find the Mardia's multivariate skewness of a set of variables - } -} -\examples{ -library(lavaan) -mardiaKurtosis(HolzingerSwineford1939[,paste("x", 1:9, sep="")]) -} +% 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]{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}} Find the univariate skewness of a variable + \item \code{\link{kurtosis}} Find the univariate excessive kurtosis + of a variable + \item \code{\link{mardiaSkew}} Find the Mardia's multivariate skewness + of a set of variables +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/mardiaSkew.Rd r-cran-semtools-0.5.0/man/mardiaSkew.Rd --- r-cran-semtools-0.4.14/man/mardiaSkew.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/mardiaSkew.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,46 +1,56 @@ -\name{mardiaSkew} -\alias{mardiaSkew} -\title{ - Finding Mardia's multivariate skewness -} -\description{ - Finding Mardia's multivariate skewness of multiple variables -} -\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]{cov}} function. -} -} -\value{ - A value of a Mardia's multivariate skewness with a test statistic -} -\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 chi-square distribution with \eqn{d(d + 1)(d + 2)/6} degrees of freedom. -} -\references{ -Mardia, K. V. (1970). Measures of multivariate skewness and kurtosis with applications. \emph{Biometrika, 57}, 519-530. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{skew}} Find the univariate skewness of a variable - \item \code{\link{kurtosis}} Find the univariate excessive kurtosis of a variable - \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate kurtosis of a set of variables - } -} -\examples{ -library(lavaan) -mardiaSkew(HolzingerSwineford1939[,paste("x", 1:9, sep="")]) -} +% 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]{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}} Find the univariate skewness of a variable + \item \code{\link{kurtosis}} Find the univariate excessive + kurtosis of a variable + \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate + kurtosis of a set of variables +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/maximalRelia.Rd r-cran-semtools-0.5.0/man/maximalRelia.Rd --- r-cran-semtools-0.4.14/man/maximalRelia.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/maximalRelia.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,66 +1,101 @@ -\name{maximalRelia} -\alias{maximalRelia} -\title{ -Calculate maximal reliability -} -\description{ -Calculate maximal reliability of a scale -} -\usage{ -maximalRelia(object) -} -\arguments{ - \item{object}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions.} -} -\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}. -} -\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). -} -\references{ -Li, H. (1997). A unifying expression for the maximal reliability of a linear composite. \emph{Psychometrika, 62}, 245-249. - -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: Guilford. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \code{\link{reliability}} for reliability of an unweighted composite score -} -\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") -} +% 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) +} +\arguments{ +\item{object}{The lavaan model object provided after running the \code{cfa}, +\code{sem}, \code{growth}, or \code{lavaan} functions.} +} +\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}} for reliability of an unweighted +composite score +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/measurementInvarianceCat.Rd r-cran-semtools-0.5.0/man/measurementInvarianceCat.Rd --- r-cran-semtools-0.4.14/man/measurementInvarianceCat.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/measurementInvarianceCat.Rd 2018-06-02 22:28:46.000000000 +0000 @@ -1,72 +1,97 @@ -\name{measurementInvarianceCat} -\alias{measurementInvarianceCat} -\title{ -Measurement Invariance Tests for Categorical Items -} -\description{ -Testing measurement invariance across groups using a typical sequence of -model comparison tests. -} -\usage{ -measurementInvarianceCat(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, -fit.measures = "default", method = "satorra.bentler.2001") -} -\arguments{ - \item{...}{The same arguments as for any lavaan model. - See \code{\link{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{TRUE}, a summary is printed out containing an - overview of the different models that are fitted, together with some - model comparison tests.} - \item{fit.measures}{Fit measures used to calculate the differences between nested models.} - \item{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan]{lavTestLRT}} for available options} -} -\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). -} -\value{ -Invisibly, all model fits in the sequence are returned as a list. -} -\references{ -Millsap, R. E., & Yun-Tein, J. (2004). Assessing factorial invariance in ordered-categorical measures. \emph{Multivariate Behavioral Research, 39}, 479-515. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) - Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) -} -\seealso{ - \code{\link{measurementInvariance}} for measurement invariance for continuous variables; - \code{\link{longInvariance}} For the measurement invariance test within person with continuous variables; - \code{partialInvariance} for the automated function for finding partial invariance models -} -\examples{ -\dontrun{ -model <- ' f1 =~ u1 + u2 + u3 + u4' - -measurementInvarianceCat(model, data = datCat, group = "g", parameterization="theta", - estimator="wlsmv", ordered = c("u1", "u2", "u3", "u4")) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/measurementInvarianceCat.R +\name{measurementInvarianceCat} +\alias{measurementInvarianceCat} +\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{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}}} + +\item{method}{The method used to calculate likelihood ratio test. See +\code{\link[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{ + +\dontrun{ +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{measurementInvariance}} for measurement invariance for +continuous variables; \code{\link{longInvariance}} For the measurement +invariance test within person with continuous variables; +\code{partialInvariance} for the automated function for finding partial +invariance models +} +\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}) +} diff -Nru r-cran-semtools-0.4.14/man/measurementInvariance.Rd r-cran-semtools-0.5.0/man/measurementInvariance.Rd --- r-cran-semtools-0.4.14/man/measurementInvariance.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/measurementInvariance.Rd 2018-06-25 21:15:29.000000000 +0000 @@ -1,82 +1,106 @@ -\name{measurementInvariance} -\alias{measurementInvariance} -\alias{measurementinvariance} -\title{ -Measurement Invariance Tests -} -\description{ -Testing measurement invariance across groups using a typical sequence of -model comparison tests. -} -\usage{ -measurementInvariance(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, -fit.measures = "default", method = "satorra.bentler.2001") -} -\arguments{ - \item{...}{The same arguments as for any lavaan model. - See \code{\link{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{method}{The method used to calculate likelihood ratio test. See \code{\link[lavaan]{lavTestLRT}} for available options} -} -\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 chi-square difference 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 (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 chi-square test statistic is scaled (eg. a -Satorra-Bentler or Yuan-Bentler test statistic), a special version of the -chi-square difference test is used as described in -\url{http://www.statmodel.com/chidiff.shtml} -} -\value{ -Invisibly, all model fits in the sequence are returned as a list. -} -\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. -} -\author{ - Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}); - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \code{\link{longInvariance}} for the measurement invariance test within person; \code{partialInvariance} for the automated function for finding partial invariance models -} -\examples{ -HW.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -measurementInvariance(HW.model, data=HolzingerSwineford1939, group="school") -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/measurementInvariance.R +\name{measurementInvariance} +\alias{measurementInvariance} +\alias{measurementinvariance} +\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{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}}} + +\item{method}{The method used to calculate likelihood ratio test. See +\code{\link[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{longInvariance}} for the measurement invariance test +within person; \code{partialInvariance} for the automated function for +finding partial invariance models +} +\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}) +} diff -Nru r-cran-semtools-0.4.14/man/miPowerFit.Rd r-cran-semtools-0.5.0/man/miPowerFit.Rd --- r-cran-semtools-0.4.14/man/miPowerFit.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/miPowerFit.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,97 +1,181 @@ -\name{miPowerFit} -\alias{miPowerFit} -\alias{miPowerFit} -\title{ -Modification indices and their power approach for model fit evaluation -} -\description{ -The model fit evaluation approach using modification indices and expected parameter changes. -} -\usage{ -miPowerFit(lavaanObj, stdLoad=0.4, cor=0.1, stdBeta=0.1, intcept=0.2, stdDelta=NULL, - delta=NULL, cilevel = 0.90) -} -\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.} -} -\details{ -In the lavaan object, one can inspect the modification indices and expected parameter changes. Those values can be used to evaluate model fit by two methods. - -First, Saris, Satorra, and van der Veld (2009, pp. 570-573) used the power to detect modification indices and expected parameter changes to evaluate model fit. First, one should evaluate whether the modification index of each parameter is significant. Second, one should evaluate whether the power to detect a target expected parameter change is high enough. If the modification index is not significant and the power is high, there is no misspecification. If the modification index is significant and the power is low, the fixed parameter is misspecified. If the modification index is significant and the power is high, the expected parameter change is investigated. If the expected parameter change is large (greater than the the target expected parameter change), the parameter is misspecified. If the expected parameter change is low (lower than the target expected parameter change), the parameter is not misspecificied. If the modification index is not significant and the power is low, the decision is inconclusive. - -Second, the confidence intervals of the expected parameter changes are formed. These confidence intervals are compared with the range of trivial misspecification, which could be (-\code{delta}, \code{delta}) or (0, \code{delta}) for nonnegative parameters. If the confidence intervals are outside of the range of trivial misspecification, the fixed parameters are severely misspecified. If the confidence intervals are inside the range of trivial misspecification, the fixed parameters are trivially misspecified. If confidence intervals are overlapped the range of trivial misspecification, the decision is inconclusive. -} -\value{ -A data frame with these variables: -\enumerate{ - \item{lhs} The left-hand side variable (with respect to the lavaan operator) - \item{op} The lavaan syntax operator: "~~" represents covariance, "=~" represents factor loading, "~" represents regression, and "~1" represents intercept. - \item{rhs} The right-hand side variable (with respect to the lavaan operator) - \item{group} The group of the parameter - \item{mi} The modification index of the fixed parameter - \item{epc} The expected parameter change if the parameter is freely estimated - \item{target.epc} The target expected parameter change 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 expected parameter change 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: \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{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} The lower bound of the confidence interval of standardized expected parameter changes. - \item{upper.std.epc} The upper bound of the confidence interval of standardized expected parameter changes. - \item{decision.ci} The decision whether the parameter is misspecified or not based on the confidence interval 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. -} -\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}, 155-159. - -Saris, W. E., Satorra, A., & van der Veld, W. M. (2009). Testing structural equation models or detection of misspecifications? \emph{Structural Equation Modeling, 16}, 561-582. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \code{\link{moreFitIndices}} For the additional fit indices information -} -\examples{ -library(lavaan) - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -fit <- cfa(HS.model, data=HolzingerSwineford1939, group="sex", meanstructure=TRUE) -miPowerFit(fit) - -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) -} +% 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.} +} +\value{ +A data frame with these variables: + \enumerate{ + \item lhs: The left-hand side variable, with respect to the operator in + in the lavaan \code{\link[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 expected parameter change if the parameter is freely + estimated + \item target.epc: The target expected parameter change 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 expected parameter change 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: \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 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: The lower bound of the confidence interval of + standardized expected parameter changes. + \item upper.std.epc: The upper bound of the confidence interval of + standardized expected parameter changes. + \item decision.ci: The decision whether the parameter is misspecified or + not based on the confidence interval 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{ +In the lavaan object, one can inspect the modification indices and expected +parameter changes. Those values can be used to evaluate model fit by two +methods. + +First, Saris, Satorra, and van der Veld (2009, pp. 570-573) used the power +to detect modification indices and expected parameter changes to evaluate +model fit. First, one should evaluate whether the modification index of each +parameter is significant. Second, one should evaluate whether the power to +detect a target expected parameter change is high enough. If the +modification index is not significant and the power is high, there is no +misspecification. If the modification index is significant and the power is +low, the fixed parameter is misspecified. If the modification index is +significant and the power is high, the expected parameter change is +investigated. If the expected parameter change is large (greater than the +the target expected parameter change), the parameter is misspecified. If the +expected parameter change is low (lower than the target expected parameter +change), the parameter is not misspecificied. If the modification index is +not significant and the power is low, the decision is inconclusive. + +Second, the confidence intervals of the expected parameter changes are +formed. These confidence intervals are compared with the range of trivial +misspecification, which could be (-\code{delta}, \code{delta}) or (0, +\code{delta}) for nonnegative parameters. If the confidence intervals are +outside of the range of trivial misspecification, the fixed parameters are +severely misspecified. If the confidence intervals are inside the range of +trivial misspecification, the fixed parameters are trivially misspecified. +If confidence intervals are overlapped the range of trivial +misspecification, the decision is inconclusive. +} +\examples{ + +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 ' + +fit <- cfa(HS.model, data = HolzingerSwineford1939, + group = "sex", meanstructure = TRUE) +miPowerFit(fit) + +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 +} +\seealso{ +\code{\link{moreFitIndices}} For the additional fit indices +information +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/modindices.mi.Rd r-cran-semtools-0.5.0/man/modindices.mi.Rd --- r-cran-semtools-0.4.14/man/modindices.mi.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/modindices.mi.Rd 2018-06-25 17:22:47.000000000 +0000 @@ -0,0 +1,146 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runMI-modification.R +\name{modindices.mi} +\alias{modindices.mi} +\alias{modificationIndices.mi} +\alias{modificationindices.mi} +\title{Modification Indices for Multiple Imputations} +\usage{ +modindices.mi(object, type = c("D2", "Rubin"), standardized = TRUE, + cov.std = TRUE, 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 \code{\linkS4class{lavaan.mi}}} + +\item{type}{\code{character} indicating which pooling method to use. +\code{type = "D2"} (default), \code{"LMRR"}, or \code{"Li.et.al"} indicates +that modification indices that were calculated within each imputed data set +will be pooled across imputations, as described in Li, Meng, Raghunathan, +& Rubin (1991) and Enders (2010). +\code{"Rubin"} indicates Rubin's (1987) rules will be applied to the +gradient and information, and those pooled values will be used to +calculate modification indices in the usual manner.} + +\item{standardized}{\code{logical}. If \code{TRUE}, two extra columns +(\code{$sepc.lv} and \code{$sepc.all}) will contain standardized values for +the EPCs. In the first column (\code{$sepc.lv}), standardizization is based +on the variances of the (continuous) latent variables. In the second column +(\code{$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{type == "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{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 \code{$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 \code{$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 using Rubin's (1987) rules, or by pooling the +test statistics across imputed data sets (Li, Meng, Raghunathan, & +Rubin, 1991). +} +\note{ +When \code{type = "D2"}, each (S)EPC will be pooled by taking its + average across imputations. When \code{type = "Rubin"}, 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{ + \dontrun{ +## 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) + +## impute missing data +library(Amelia) +set.seed(12345) +HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +imps <- HS.amelia$imputations + +## specify CFA model from lavaan's ?cfa help page +HS.model <- ' + visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 +' + +out <- cfa.mi(HS.model, data = imps) + +modindices.mi(out) # default: Li et al.'s (1991) "D2" method +modindices.mi(out, type = "Rubin") # Rubin's rules + +} + +} +\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{http://www.jstor.org/stable/24303994} + +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}) + +Adapted from \pkg{lavaan} source code, written by + Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) + +\code{type = "Rubin"} method proposed by + Maxwell Mansolf (University of California, Los Angeles; + \email{mamansolf@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/monteCarloMed.Rd r-cran-semtools-0.5.0/man/monteCarloMed.Rd --- r-cran-semtools-0.4.14/man/monteCarloMed.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/monteCarloMed.Rd 2018-06-25 21:15:29.000000000 +0000 @@ -1,81 +1,148 @@ -\name{monteCarloMed} -\alias{monteCarloMed} -\title{ -Monte Carlo Confidence Intervals to Test Complex Indirect Effects -} -\description{ -This function takes an expression for an indirect effect, the parameters and standard errors associated with the expression and returns a confidence interval based on a Monte Carlo test of mediation (MacKinnon, Lockwood, & Williams, 2004). -} -\usage{ -monteCarloMed(expression, ..., ACM=NULL, object=NULL, rep=20000, CI=95, plot=FALSE, - outputValues=FALSE) -} -\arguments{ - \item{expression}{A character scalar representing the computation of an indirect effect. Different parameters in the expression should have different alphanumeric values. Expressions can use either addition (+) or multiplication (*) operators.} - \item{\dots}{Parameter estimates for all parameters named in \code{expression}. The order of parameters should follow from \code{expression} (the first parameter named in \code{expression} should be the first parameter listed in \dots). Alternatively \dots can be a vector of parameter estimates.} - \item{ACM}{A matrix representing the asymptotic covariance matrix of the parameters described in \code{expression}. This matrix should be a symetric matrix with dimensions equal to the number of parameters names in \code{expression}. Information on finding the ACOV is popular SEM software is described below.)} - \item{object}{A lavaan model object fitted after running the running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions. The model must have parameters labelled with the same labels used in \code{expression}. When using this option do not specify values for \dots or \code{ACM}} - \item{rep}{The number of replications to compute. Many thousand are reccomended.} - \item{CI}{Width of the confidence interval computed.} - \item{plot}{Should the function output a plot of simulated values of the indirect effect?} - \item{outputValues}{Should the function output all simulated values of the indirect effect?} - } -\details{ -This function implements the Monte Carlo test of mediation first described in MacKinnon, Lockwood, & Williams (2004) and extends it to complex cases where the indirect effect is more than a function of two parameters. The function takes an expression for the indirect effect, randomly simulated values of the indirect effect based on the values of the parameters (and the associated standard errors) comprising the indirect effect, and outputs a confidence interval of the indirect effect based on the simulated values. For further information on the Monte Carlo test of mediation see MacKinnon, Lockwood, & Williams (2004), Preacher & Selig (in press), and Selig & Preacher (2008). For a Monte Carlo test of mediation with a random effects model see Selig & Preacher (2010). - -The asymptotic covariance matrix can be easily found in many popular SEM software applications. - \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{Mplus}{Include the command TECH3; in the OUTPUT section. The ACM will be printed in the output.} - \item{lavaan} {Use the command \code{vcov} on the fitted lavaan object to print the ACM to the screen} - } -} -\value{ -A list with two elements. The first element is the point estimate for the indirect effect. The second element is a matrix with values for the upper and lower limits of the confidence interval generated from the Monte Carlo test of mediation. If \code{outputValues=TRUE}, output will be a list with a list with the point estimate and values for the upper and lower limits of the confidence interval as the first element and a vector of simulated values of the indirect effect as the second element. -} -\references{ -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}, 77-98. - -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{ - Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) - Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) - James P. Selig (University of New Mexico; \email{selig@unm.edu}) -} -\examples{ -#Simple two path mediation -#Write expression of indirect effect -med <- 'a*b' -#Paramter values from analyses -aparam <- 1 -bparam<-2 -#Asymptotic covariance matrix from analyses -AC <- matrix(c(.01,.00002, - .00002,.02), nrow=2, byrow=TRUE) -#Compute CI, include a plot -monteCarloMed(med, coef1=aparam, coef2=bparam, outputValues=FALSE, plot=TRUE, ACM=AC) - -#Use a vector of parameter estimates as input -aparam<-c(1,2) -monteCarloMed(med, coef1=aparam, outputValues=FALSE, plot=TRUE, ACM=AC) - - - -#Complex mediation with two paths for the indirect effect -#Write expression of indirect effect -med <- 'a1*b1 + a1*b2' -#Paramter values and standard errors from analyses -aparam <- 1 -b1param<-2 -b2param<-1 -#Asymptotic covariance matrix from analyses -AC <- matrix(c(1,.00002, .00003, - .00002,1, .00002, - .00003, .00002, 1), nrow=3, byrow=TRUE) -#Compute CI do not include a plot -monteCarloMed(med, coef1=aparam, coef2=b1param, coef3=b2param, ACM=AC) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/monteCarloMed.R +\name{monteCarloMed} +\alias{monteCarloMed} +\title{Monte Carlo Confidence Intervals to Test Complex Indirect Effects} +\usage{ +monteCarloMed(expression, ..., ACM = NULL, object = NULL, rep = 20000, + CI = 95, plot = FALSE, outputValues = FALSE) +} +\arguments{ +\item{expression}{A character scalar representing the computation of an +indirect effect. Different parameters in the expression should have +different alphanumeric values. Expressions can use either addition (+) or +multiplication (*) operators.} + +\item{\dots}{Parameter estimates for all parameters named in +\code{expression}. The order of parameters should follow from +\code{expression} (the first parameter named in \code{expression} should be +the first parameter listed in \dots{}). Alternatively \dots can be a +vector of parameter estimates.} + +\item{ACM}{A matrix representing the asymptotic covariance matrix of the +parameters described in \code{expression}. This matrix should be a symetric +matrix with dimensions equal to the number of parameters names in +\code{expression}. Information on finding the ACOV is popular SEM software +is described below.)} + +\item{object}{A lavaan model object fitted after running the running the +\code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions. The model +must have parameters labelled with the same labels used in +\code{expression}. When using this option do not specify values for \dots +or \code{ACM}} + +\item{rep}{The number of replications to compute. Many thousand are +reccomended.} + +\item{CI}{Width of the confidence interval computed.} + +\item{plot}{Should the function output a plot of simulated values of the +indirect effect?} + +\item{outputValues}{Should the function output all simulated values of the +indirect effect?} +} +\value{ +A list with two elements. The first element is the point estimate +for the indirect effect. The second element is a matrix with values for the +upper and lower limits of the confidence interval generated from the Monte +Carlo test of mediation. If \code{outputValues = TRUE}, output will be a list +with a list with the point estimate and values for the upper and lower +limits of the confidence interval as the first element and a vector of +simulated values of the indirect effect as the second element. +} +\description{ +This function takes an expression for an indirect effect, the parameters and +standard errors associated with the expression and returns a confidence +interval based on a Monte Carlo test of mediation (MacKinnon, Lockwood, & +Williams, 2004). +} +\details{ +This function implements the Monte Carlo test of mediation first described +in MacKinnon, Lockwood, & Williams (2004) and extends it to complex cases +where the indirect effect is more than a function of two parameters. The +function takes an expression for the indirect effect, randomly simulated +values of the indirect effect based on the values of the parameters (and the +associated standard errors) comprising the indirect effect, and outputs a +confidence interval of the indirect effect based on the simulated values. +For further information on the Monte Carlo test of mediation see MacKinnon, +Lockwood, & Williams (2004) and Preacher & Selig (2012). + +The asymptotic covariance matrix can be easily found in many popular SEM +software applications. +\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 Mplus Include the command TECH3; in the OUTPUT section. The ACM will be + printed in the output. + \item lavaan: Use the command \code{vcov} on the fitted lavaan object to + print the ACM to the screen +} +} +\examples{ + +## Simple two path mediation +## Write expression of indirect effect +med <- 'a*b' +## Paramter values from analyses +aparam <- 1 +bparam <- 2 +## Asymptotic covariance matrix from analyses +AC <- matrix(c(.01,.00002, + .00002,.02), nrow=2, byrow=TRUE) +## Compute CI, include a plot +monteCarloMed(med, coef1 = aparam, coef2 = bparam, outputValues = FALSE, + plot = TRUE, ACM = AC) + +## Use a vector of parameter estimates as input +aparam <- c(1,2) +monteCarloMed(med, coef1 = aparam, outputValues = FALSE, + plot = TRUE, ACM = AC) + + +## Complex mediation with two paths for the indirect effect +## Write expression of indirect effect +med <- 'a1*b1 + a1*b2' +## Paramter values and standard errors from analyses +aparam <- 1 +b1param <- 2 +b2param <- 1 +## Asymptotic covariance matrix from analyses +AC <- matrix(c(1, .00002, .00003, + .00002, 1, .00002, + .00003, .00002, 1), nrow = 3, byrow = TRUE) +## Compute CI do not include a plot +monteCarloMed(med, coef1 = aparam, coef2 = b1param, + coef3 = b2param, ACM = AC) + +} +\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{ +Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) + +Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) + +James P. Selig (University of New Mexico; \email{selig@unm.edu}) + +Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/moreFitIndices.Rd r-cran-semtools-0.5.0/man/moreFitIndices.Rd --- r-cran-semtools-0.4.14/man/moreFitIndices.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/moreFitIndices.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,103 +1,145 @@ -\name{moreFitIndices} -\alias{moreFitIndices} -\title{ -Calculate more fit indices -} -\description{ -Calculate more fit indices that are not already provided in lavaan. -} -\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 BIC*.} -} -\details{ -Gamma Hat (gammaHat; West, Taylor, & Wu, 2012) is a global fit index which can be computed by - -\deqn{ gammaHat =\frac{p}{p + 2 \times \frac{\chi^{2}_{k} - df_{k}}{N - 1}},} - -where \eqn{p} is the number of variables in the model, \eqn{\chi^{2}_{k}} is the chi-square 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. This formula assumes equal number of indicators across groups. - -Adjusted Gamma Hat (adjGammaHat; West, Taylor, & Wu, 2012) is a global fit index which can be computed by - -\deqn{ adjGammaHat = \left(1 - \frac{K \times p \times (p + 1)}{2 \times df_{k}} \right) \times \left( 1 - gammaHat \right) ,} - -where \eqn{K} is the number of groups (please refer to Dudgeon, 2004 for the multiple-group adjustment for agfi*). - -Corrected Akaike Information Criterion (aic.smallN; Burnham & Anderson, 2003) is the corrected version of aic for small sample size: - -\deqn{ aic.smallN = f + \frac{2k(k + 1)}{N - k - 1},} - -where \eqn{f} is the minimized discrepancy function, which is the product of the log likelihood and -2, and \eqn{k} is the number of parameters in the target model. - -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}}). - -\deqn{ bic.priorN = f + k\log{(1 + N/N_{prior})},} - -Stochastic information criterion (sic; Preacher, 2006) is similar to aic or bic. This index will account for model complexity in the model's function form, in addition to the number of free parameters. This index will be provided only when the chi-squared value is not scaled. The sic can be computed by - -\deqn{ sic = \frac{1}{2}\left(f - \log{\det{I(\hat{\theta})}}\right),} - -where \eqn{I(\hat{\theta})} is the information matrix of the parameters. - -Hannan-Quinn Information Criterion (hqc; Hannan & Quinn, 1979) is used for model selection similar to aic or bic. - -\deqn{ hqc = f + 2k\log{(\log{N})},} - -Note that if Satorra-Bentler or Yuan-Bentler's method is used, the fit indices using the scaled chi-square values are also provided. - -See \code{\link{nullRMSEA}} for the further details of the computation of RMSEA of the null model. -} - -\value{ -\enumerate{ - \item{gammaHat} Gamma Hat - \item{adjGammaHat} Adjusted Gamma Hat - \item{baseline.rmsea} RMSEA of the Baseline (Null) Model - \item{aic.smallN} Corrected (for small sample size) Akaike Information Criterion - \item{bic.priorN} Bayesian Information Criterion with specifying the prior sample size - \item{sic} Stochastic Information Criterion - \item{hqc} Hannan-Quinn Information Criterion - \item{gammaHat.scaled} Gamma Hat using Scaled Chi-square - \item{adjGammaHat.scaled} Adjusted Gamma Hat using Scaled Chi-square - \item{baseline.rmsea.scaled} RMSEA of the Baseline (Null) Model using Scaled Chi-square -} -} -\references{ -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}, 305-319. - -Kuha, J. (2004). AIC and BIC: Comparisons of assumptions and performance. \emph{Sociological Methods Research, 33}, 188-229. - -Preacher, K. J. (2006). Quantifying parsimony in structural equation modeling. \emph{Multivariate Behavioral Research, 43}, 227-259. - -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.} New York: Guilford. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) - Terrence Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) - Aaron Boulton (University of North Carolina, Chapel Hill; \email{aboulton@email.unc.edu}) - Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@gmail.com}) - Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) -} -\seealso{ - \itemize{ - \item \code{\link{miPowerFit}} For the modification indices and their power approach for model fit evaluation - \item \code{\link{nullRMSEA}} For RMSEA of the null model - } -} -\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) -} +% 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 BIC*.} +} +\value{ +\enumerate{ + \item \code{gammaHat}: Gamma Hat + \item \code{adjGammaHat}: Adjusted Gamma Hat + \item \code{baseline.rmsea}: RMSEA of the Baseline (Null) Model + \item \code{aic.smallN}: Corrected (for small sample size) Akaike Information Criterion + \item \code{bic.priorN}: Bayesian Information Criterion with specified prior sample size + \item \code{sic}: Stochastic Information Criterion + \item \code{hqc}: Hannan-Quinn Information Criterion + \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 Baseline (Null) Model using scaled \eqn{\chi^2} +} +} +\description{ +Calculate more fit indices that are not already provided in lavaan. +} +\details{ +Gamma Hat (gammaHat; West, Taylor, & Wu, 2012) is a global fit index which +can be computed (assuming equal number of indicators across groups) by + +\deqn{ gammaHat =\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 (adjGammaHat; West, Taylor, & Wu, 2012) is a global fit +index which can be computed by + +\deqn{ adjGammaHat = \left(1 - \frac{K \times p \times (p + 1)}{2 \times +df_{k}} \right) \times \left( 1 - gammaHat \right) ,} + +where \eqn{K} is the number of groups (please refer to Dudgeon, 2004 for the +multiple-group adjustment for agfi*). + +Corrected Akaike Information Criterion (aic.smallN; Burnham & Anderson, +2003) is a corrected version of AIC for small sample size, often abbreviated +AICc: + +\deqn{ aic.smallN = AIC + \frac{2k(k + 1)}{N - k - 1},} + +where \eqn{AIC} is the original AIC: \eqn{-2 \times LL + 2k} (where \eqn{k} += 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 (bic.priorN; Kuha, 2004) is similar +to BIC but explicitly specifying the sample size on which the prior is based +(\eqn{N_{prior}}). + +\deqn{ bic.priorN = f + k\log{(1 + N/N_{prior})},} + +Stochastic information criterion (SIC; Preacher, 2006) is similar to AIC or +BIC. This index will account for model complexity in the model's function +form, in addition to the number of free parameters. This index will be +provided only when the \eqn{\chi^2} value is not scaled. The SIC can be +computed by + +\deqn{ sic = \frac{1}{2}\left(f - \log{\det{I(\hat{\theta})}}\right),} + +where \eqn{I(\hat{\theta})} is the information matrix of the parameters. + +Hannan-Quinn Information Criterion (hqc; Hannan & Quinn, 1979) is used for +model selection similar to AIC or BIC. + +\deqn{ hqc = f + 2k\log{(\log{N})},} + +Note that if Satorra--Bentler or Yuan--Bentler's method is used, the fit +indices using the scaled \eqn{\chi^2} values are also provided. + +See \code{\link{nullRMSEA}} for the further details of the computation of +RMSEA of the null model. +} +\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{ +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 + +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}} For the modification +indices and their power approach for model fit evaluation \item +\code{\link{nullRMSEA}} For RMSEA of the null model } +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) + +Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) + +Aaron Boulton (University of North Carolina, Chapel Hill; \email{aboulton@email.unc.edu}) + +Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@gmail.com}) + +Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) +} diff -Nru r-cran-semtools-0.4.14/man/mvrnonnorm.Rd r-cran-semtools-0.5.0/man/mvrnonnorm.Rd --- r-cran-semtools-0.4.14/man/mvrnonnorm.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/mvrnonnorm.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,32 +1,59 @@ -\name{mvrnonnorm} -\alias{mvrnonnorm} -\title{ -Generate Non-normal Data using Vale and Maurelli (1983) method -} -\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. -} -\usage{ -mvrnonnorm(n, mu, Sigma, skewness = NULL, kurtosis = NULL, empirical = FALSE) -} -\arguments{ - \item{n}{Sample size} - \item{mu}{A mean vector} - \item{Sigma}{A positive-definite symmetric matrix specifying the covariance matrix of the variables} - \item{skewness}{A vector of skewness of the variables} - \item{kurtosis}{A vector of excessive kurtosis of the variables} - \item{empirical}{If \code{TRUE}, \code{mu} and \code{Sigma} specify the empirical not population mean and covariance matrix} -} -\value{ - A data matrix -} -\references{ -Vale, C. D. & Maurelli, V. A. (1983) Simulating multivariate nonormal distributions. \emph{Psychometrika, 48}, 465-471. -} -\author{ - The original function is the \code{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}) -} -\examples{ -mvrnonnorm(100, c(1, 2), matrix(c(10, 2, 2, 5), 2, 2), - skewness = c(5, 2), kurtosis = c(3, 3)) -} +% 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}{If \code{TRUE}, \code{mu} and \code{Sigma} specify the +empirical rather than population mean and covariance matrix} +} +\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}} +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}. +} diff -Nru r-cran-semtools-0.4.14/man/Net-class.Rd r-cran-semtools-0.5.0/man/Net-class.Rd --- r-cran-semtools-0.4.14/man/Net-class.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/Net-class.Rd 2018-06-26 12:19:09.000000000 +0000 @@ -1,34 +1,53 @@ -\name{Net-class} -\docType{class} -\alias{Net-class} -\alias{show,Net-method} -\alias{summary,Net-method} -\title{ - Class For the Result of Nesting and Equivalence Testing -} -\description{ - This class contains the results of nesting and equivalence testing among multiple models -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link{net}} function. -} -\section{Slots}{ - \describe{ - \item{\code{test}:}{Logical matrix of results of nesting and equivalence testing across models} - \item{\code{df}:}{The degrees of freedom of tested models} - } -} -\section{methods}{ - \itemize{ - \item \code{summary} The summary function is used to provide the results in narrative. - } -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\seealso{ -\code{\link{net}} -} -\examples{ -# See the example in the net function. -} +% 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} +\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.} +\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}} function. +} + +\examples{ + +# See the example in the net function. + +} +\seealso{ +\code{\link{net}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/net.Rd r-cran-semtools-0.5.0/man/net.Rd --- r-cran-semtools-0.4.14/man/net.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/net.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,57 +1,72 @@ -\name{net} -\alias{net} -\title{ - Nesting and Equivalence Testing -} -\description{ -This test examines whether models are nested or equivalent based on Bentler and Satorra's (2010) procedure. -} -\usage{ -net(..., crit = .0001) -} -\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 chi-squared fit statistics is less than this criterion. -} -} -\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 net function is based on a limited-information estimator (analyzing 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 does not apply to models that estimate thresholds for categorical data, so an error message will be issued if such a model is provided. -} -\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. -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\references{ -Bentler, P. M., & Satorra, A. (2010). Testing model nesting and equivalence. \emph{Psychological Methods, 15}, 111-123. doi:10.1037/a0019625 -} -\examples{ -\dontrun{ -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 - -tests <- net(fit1, fit1a, fit2, fit3) -tests -summary(tests) -} -} - +% 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 +chi-squared 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 models are nested or equivalent based on Bentler +and Satorra's (2010) procedure. +} +\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 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 does not apply to models that +estimate thresholds for categorical data, so an error message will be issued +if such a model is provided. +} +\examples{ + +\dontrun{ +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 + +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 +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/nullMx.Rd r-cran-semtools-0.5.0/man/nullMx.Rd --- r-cran-semtools-0.4.14/man/nullMx.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/nullMx.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -\name{nullMx} -\alias{nullMx} -\title{ - Analyzing data using a null model -} -\description{ - Analyzing data using a null model by full-information maximum likelihood. In the null model, all means and covariances are free if items are continuous. All covariances are fixed to 0. For ordinal variables, their means are fixed as 0 and their variances are fixed as 1 where their thresholds are estimated. In multiple-group model, all means are variances are separately estimated. -} -\usage{ -nullMx(data, groupLab = NULL) -} -\arguments{ - \item{data}{ - The target data frame -} - \item{groupLab}{ - The name of grouping variable - } -} -\value{ - The \code{MxModel} object which contains the analysis result of the null model. -} -\seealso{ - \code{\link{saturateMx}}, \code{\link{fitMeasuresMx}}, \code{\link{standardizeMx}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -\dontrun{ -library(OpenMx) -data(demoOneFactor) -nullModel <- nullMx(demoOneFactor) -} -} diff -Nru r-cran-semtools-0.4.14/man/nullRmsea.Rd r-cran-semtools-0.5.0/man/nullRmsea.Rd --- r-cran-semtools-0.4.14/man/nullRmsea.Rd 2016-10-17 15:10:15.000000000 +0000 +++ r-cran-semtools-0.5.0/man/nullRmsea.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -\name{nullRMSEA} -\alias{nullRMSEA} -\title{ -Calculate the RMSEA of the null model -} -\description{ -Calculate the RMSEA of the null (baseline) 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}, calculate the null model from the scaled test.} - \item{silent}{If \code{TRUE}, do not print anything on the screen.} -} -\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 \url{http://davidakenny.net/cm/fit.htm}. -} -\value{ - A value of RMSEA of the null model. This value is hidden. Users may be assigned the output of this function to any object for further usage. -} -\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 -} -\author{ - Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{miPowerFit}} For the modification indices and their power approach for model fit evaluation - \item \code{\link{moreFitIndices}} For other fit indices - } -} -\examples{ -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -fit <- cfa(HS.model, data=HolzingerSwineford1939) -nullRMSEA(fit) -} diff -Nru r-cran-semtools-0.4.14/man/nullRMSEA.Rd r-cran-semtools-0.5.0/man/nullRMSEA.Rd --- r-cran-semtools-0.4.14/man/nullRMSEA.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/nullRMSEA.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -0,0 +1,72 @@ +% 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}} For the modification indices and their + power approach for model fit evaluation + \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/parcelAllocation.Rd r-cran-semtools-0.5.0/man/parcelAllocation.Rd --- r-cran-semtools-0.4.14/man/parcelAllocation.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/parcelAllocation.Rd 2018-06-25 21:50:54.000000000 +0000 @@ -1,57 +1,177 @@ -\name{parcelAllocation} -\alias{parcelAllocation} -\title{ -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. -} -\usage{ -parcelAllocation(nPerPar, facPlc, nAlloc=100, syntax, dataset, names='default', - leaveout=0, ...) -} -\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 (there should NOT be parcels of size "1").} - \item{facPlc}{A list of vectors, each corresponding to a factor, specifying the variables in 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{nAlloc}{The number of random allocations of items to parcels to generate.} - \item{syntax}{\link{lavaan} syntax. If substituted with a file name, parcelAllocation will print output data sets to a specified folder rather than analyzing using lavaan (note for Windows users: file path must be specified using forward slashes).} - \item{dataset}{Data set. Can be file path or R object (matrix or dataframe). If the data has missing values multiple imputation before parceling is recommended.} - \item{names}{(Optional) A character vector containing the names of parceled variables.} - \item{leaveout}{A vector of variables to be left out of randomized parceling. Either variable names or column numbers are allowed.} - \item{\dots}{Additional arguments to be passed to \link{lavaan}} -} -\details{ -This function implements the random item to parcel allocation procedure described in Sterba (2011) and Sterba and MccCallum (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 \link{lavaan}), and repeats this process for a user specified number of random allocations. Results from all fitted models are summarized and output. For further details on the benefits of the random allocation of itesm to parcels see Sterba (2011) and Sterba and MccCallum (2010). -} -\value{ -\item{Estimates}{A data frame containing results related to parameter estimates with columns corresponding to parameter names, average parameter estimates across allocations, the standard deviation of parameter estimates across allocations, the minimum parameter estimate across allocations, the maximum parameter estimate across allocations, the range of parameter estimates across allocations, and the proportions of allocations in which the parameter estimate is significant.} -\item{SE}{A data frame containing results related to standard errors with columns corresponding to parameter names, average standard errors across allocations, the standard deviation of standard errors across allocations, the minimum standard error across allocations, the maximum standard error across allocations, and the range of standard errors across allocations.} -\item{Fit}{A data frame containing results related to model fit with columns corresponding to fit index names, the average of each index across allocations, the standard deviation of each fit index across allocations, the minimum of each fit index across allocations, the maximum of each fit index across allocations, and the range of each fit index across allocations.} -} -\references{ -Sterba, S.K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling, 18,} 554-577. - -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,} 322-358. -} -\seealso{ - \code{\link{PAVranking}}, \code{\link{poolMAlloc}} -} -\author{ - Corbin Quick (University of Michigan; \email{corbinq@umich.edu}) - Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) -} -\examples{ -#Fit 3 factor CFA to simulated data. -#Each factor has 9 indicators that are randomly parceled into 3 parcels -#Lavaan syntax for the model to be fit to parceled data -library(lavaan) - -syntax <- 'La =~ V1 + V2 + V3 - Lb =~ V4 + V5 + V6 -' -#Parcel and fit data 20 times. The actual parcel number should be higher than 20 times. -name1 <- colnames(simParcel)[1:9] -name2 <- colnames(simParcel)[10:18] -parcelAllocation(list(c(3,3,3),c(3,3,3)), list(name1, name2), nAlloc=20, syntax=syntax, - dataset=simParcel) -} +% 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, do.fit = TRUE) +} +\arguments{ +\item{model}{\code{\link[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]{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}{\link[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 \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}} 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}} model. See the +output of \code{\link[lavaan]{fitMeasures}} for a list of available measures.} + +\item{\dots}{Additional arguments to be passed to +\code{\link[lavaan]{lavaanList}}} + +\item{show.progress}{If \code{TRUE}, show a \code{\link[utils]{txtProgressBar}} +indicating how fast the model-fitting iterates over allocations.} + +\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).} +} +\value{ +\item{Estimates}{A data frame containing results related to +parameter estimates with columns corresponding to parameter names, average +parameter estimates across allocations, the standard deviation of parameter +estimates across allocations, the minimum parameter estimate across +allocations, the maximum parameter estimate across allocations, the range of +parameter estimates across allocations, and the proportions of allocations +in which the parameter estimate is significant.} \item{SE}{A data frame +containing results related to standard errors with columns corresponding to +parameter names, average standard errors across allocations, the standard +deviation of standard errors across allocations, the minimum standard error +across allocations, the maximum standard error across allocations, and the +range of standard errors across allocations.} \item{Fit}{A data frame +containing results related to model fit with columns corresponding to fit +index names, the average of each index across allocations, the standard +deviation of each fit index across allocations, the minimum of each fit +index across allocations, the maximum of each fit index across allocations, +and the range of each fit index across allocations.} +} +\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 +\link[lavaan]{lavaan}), 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 the random allocation of +itesm to parcels, see Sterba (2011) and Sterba and MccCallum (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)) + +\dontrun{ +parcelAllocation(mod.parcels, data = simParcel, parcel.names, item.syntax, + nAlloc = 20, std.lv = TRUE, parallel = "snow", iseed = 12345) +} + + +## 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)) + +set.seed(12345) +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)) + +set.seed(12345) +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)) + +set.seed(12345) +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 +} +\seealso{ +\code{\link{PAVranking}}, \code{\link{poolMAlloc}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/partialInvariance.Rd r-cran-semtools-0.5.0/man/partialInvariance.Rd --- r-cran-semtools-0.4.14/man/partialInvariance.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/partialInvariance.Rd 2018-06-25 21:57:00.000000000 +0000 @@ -1,170 +1,294 @@ -\name{partialInvariance} -\alias{partialInvariance} -\alias{partialInvarianceCat} -\title{ -Partial Measurement Invariance Testing Across Groups -} -\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. -} -\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}} or \code{\link{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}} 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}} for available options} -} -\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{wald}} 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")}. -} -\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 z-score equals -\code{bound} (the default is -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 \code{bound} (the default is 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. Chi-square and 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. } - } -} -\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: Guilford. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \code{\link{measurementInvariance}} for measurement invariance for continuous variables; \code{\link{measurementInvarianceCat}} for measurement invariance for categorical variables; \code{\link{wald}} for multivariate Wald test -} -\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") - -\dontrun{ -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(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(configural = outConfigural2, metric = 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, data = datCat, group = "g", - parameterization="theta", estimator="wlsmv", strict = TRUE) - -partialInvarianceCat(modelsCat2, type = "scalar") -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/partialInvariance.R +\name{partialInvariance} +\alias{partialInvariance} +\alias{partialInvarianceCat} +\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}} or +\code{\link{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}} 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}} 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}} 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") + +\dontrun{ +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}} for measurement invariance for +continuous variables; \code{\link{measurementInvarianceCat}} for measurement +invariance for categorical variables; \code{\link[lavaan]{lavTestWald}} for +multivariate Wald test +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/PAVranking.Rd r-cran-semtools-0.5.0/man/PAVranking.Rd --- r-cran-semtools-0.4.14/man/PAVranking.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/PAVranking.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,144 +1,243 @@ -\name{PAVranking} -\alias{PAVranking} -\title{ -Parcel-Allocation Variability in Model Ranking -} -\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 is a modified version of \code{\link{parcelAllocation}} which can be used with only one SEM in isolation. The \code{PAVranking} function repeatedly generates a specified number of random item-to-parcel allocations, and then fits two models to each allocation. 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 \code{seed}). -} -\usage{ -PAVranking(nPerPar, facPlc, nAlloc=100, parceloutput = 0, - syntaxA, syntaxB, dataset, names = NULL, - leaveout=0, seed=NA, ...) -} -\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{nAlloc}{ - The number of random allocations of items to parcels to generate. - } - \item{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). - } - \item{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). - } - \item{dataset}{ - Item-level dataset - } - \item{parceloutput}{ - folder where parceled data sets will be outputted (note for Windows users: file path must specified using forward slashes). - } - \item{seed}{ - (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. - } - \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{\dots}{ - Additional arguments to be passed to \code{\link[lavaan]{lavaan}} - } -} -\details{ -This is a modified version of \code{\link{parcelAllocation}} which was, in turn, based on the 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 uses a modified version of parcelAllocation to generate a given number (\code{nAlloc}) of item-to-parcel allocations. Then, \code{PAVranking} provides the following new developments: specifying more than one SEM and producing results for Model A and Model B separately that summarize parcel allocation variability in estimates, standard errors, and fit indices. \code{PAVranking} also newly produces results summarizing parcel allocation variability in model selection index values and model ranking between Models A and B. Additionally, \code{PAVranking} newly allows for nonconverged solutions and outputs the proportion of allocations that converged as well as the proportion of proper solutions (results are summarized for 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). - -NOTE: This function requires the \code{lavaan} package. Missing data code needs to be \code{NA}. If function returns \code{"Error in plot.new() : figure margins too large,"} user may need to increase size of the plot window and rerun. -} -\value{ -\item{Estimates_A, Estimates_B}{A table containing results related to parameter estimates (in table Estimates_A for Model A and in table Estimates_B for Model B) with columns corresponding to parameter name, average parameter estimate across allocations, standard deviation of parameter estimate across allocations, the maximum parameter estimate across allocations, the minimum parameter estimate across allocations, the range of parameter estimates across allocations, and the percent of allocations in which the parameter estimate is significant.} -\item{SE_A, SE_B}{A table containing results related to standard errors (in table SE_A for Model A and in table SE_B for Model B) with columns corresponding to parameter name, average standard error across allocations, the standard deviation of standard errors across allocations, the maximum standard error across allocations, the minimum standard error across allocations, and the range of standard errors across allocations.} -\item{Fit_A, Fit_B}{A table containing results related to model fit (in table Fit_A for Model A and in table Fit_B for Model B) with columns corresponding to fit index name, the average of the fit index across allocations, the standard deviation of the fit index across allocations, the maximum of the fit index across allocations, the minimum of the fit index across allocations, the range of the fit index across allocations, and the percent of allocations where the chi-square test of absolute fit was significant.} -\item{LRT Summary, Model A vs. Model B}{A table with columns corresponding to: average likelihood ratio test (LRT) statistic for comparing Model A vs. Model B (null hypothesis is no difference in fit between Models A and B in the population), degrees of freedom (i.e. difference in the number of free parameters between Models A and B), as well as the standard deviation, maximum, and minimum of LRT statistics across allocations, and the percent of allocations where the LRT was significant (indicating preference for the more complex Model B). } -\item{LRT Summary, Model A vs. Model B}{A table with columns corresponding to: average likelihood ratio test (LRT) statistic for comparing Model A vs. Model B (null hypothesis is no difference in fit between Models A and B in the population), degrees of freedom (i.e. difference in the number of free parameters between Models A and B), as well as the standard deviation, maximum, and minimum of LRT statistics across allocations, and the percent of allocations where the LRT was significant (indicating preference for the more complex Model B). } -\item{Fit index differences}{A table containing percentage of allocations where Model A is preferred over Model B according to BIC, AIC, RMSEA, CFI, TLI and SRMR and where Model B is preferred over Model A according to the same indices. Also includes the average amount by which the given model is preferred (calculated only using allocations where it was preferred).} -\item{Fit index difference histograms}{Histograms are automatically outputted showing the distribution of the differences (Model A - Model B) for each fit index and for the p-value of the likelihood ratio difference test.} -\item{Percent of Allocations with | BIC Diff | > 10}{A table containing the percentage of allocations with (BIC for Model A) - (BIC for Model B) < -10, indicating "very strong evidence" to prefer Model A over Model B and the percentage of allocations with (BIC for Model A) - (BIC for Model B) > 10, indicating "very strong evidence" to prefer Model B over Model A (Raftery, 1995).} -\item{Converged and proper}{A table containing the proportion of allocations that converged for Model A, Model B, and both models, and the proportion of allocations with converged and proper solutions for Model A, Model B, and both models.} -} -\references{ -Raftery, A. E. (1995). Bayesian model selection in social research. \emph{Sociological Methodology, 25}, 111-163. - -Sterba, S. K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling: A Multidisciplinary Journal, 18}(4), 554-577. - -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. - -"Sterba, S. K., & Rights, J. D. (2016). Effects of parceling on model selection: Parcel-allocation variability in model ranking. \emph{Psychological Methods}. \url{http://dx.doi.org/10.1037/met0000067} -} -\seealso{ - \code{\link{parcelAllocation}}, \code{\link{poolMAlloc}} -} -\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 on which this function is based. -} -\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, syntaxA=parmodelA, - syntaxB=parmodelB, dataset = simParcel, - names=list("p1f1","p2f1","p3f1","p1f2","p2f2","p3f2"), - leaveout=0) -} -} +% 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(nPerPar, facPlc, nAlloc = 100, parceloutput = 0, syntaxA, + syntaxB, dataset, names = NULL, leaveout = 0, seed = NA, ...) +} +\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{nAlloc}{The number of random allocations of items to parcels to +generate.} + +\item{parceloutput}{folder where parceled data sets will be outputted (note +for Windows users: file path must specified using forward slashes).} + +\item{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).} + +\item{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).} + +\item{dataset}{Item-level dataset} + +\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{seed}{(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.} + +\item{\dots}{Additional arguments to be passed to +\code{\link[lavaan]{lavaan}}. See also \code{\link[lavaan]{lavOptions}}} +} +\value{ +\item{Estimates_A, Estimates_B}{A table containing results related +to parameter estimates (in table Estimates_A for Model A and in table +Estimates_B for Model B) with columns corresponding to parameter name, +average parameter estimate across allocations, standard deviation of +parameter estimate across allocations, the maximum parameter estimate across +allocations, the minimum parameter estimate across allocations, the range of +parameter estimates across allocations, and the percent of allocations in +which the parameter estimate is significant.} +\item{SE_A, SE_B}{A table containing results related to standard errors (in +table SE_A for Model A and in table SE_B for Model B) with columns +corresponding to parameter name, average standard error across allocations, +the standard deviation of standard errors across allocations, the maximum +standard error across allocations, the minimum standard error across +allocations, and the range of standard errors across allocations.} +\item{Fit_A, Fit_B}{A table containing results related to model fit (in +table Fit_A for Model A and in table Fit_B for Model B) with columns +corresponding to fit index name, the average of the fit index across +allocations, the standard deviation of the fit index across allocations, +the maximum of the fit index across allocations, the minimum of the fit +index across allocations, the range of the fit index across allocations, and +the percent of allocations where the chi-square test of absolute fit was +significant.} +\item{LRT Summary, Model A vs. Model B}{A table with columns corresponding +to: average likelihood ratio test (LRT) statistic for comparing Model A vs. +Model B (null hypothesis is no difference in fit between Models A and B in +the population), degrees of freedom (i.e. difference in the number of free +parameters between Models A and B), as well as the standard deviation, +maximum, and minimum of LRT statistics across allocations, and the percent of +allocations where the LRT was significant (indicating preference for the more +complex Model B). } +\item{LRT Summary, Model A vs. Model B}{A table with columns corresponding +to: average likelihood ratio test (LRT) statistic for comparing Model A vs. +Model B (null hypothesis is no difference in fit between Models A and B in +the population), degrees of freedom (i.e. difference in the number of free +parameters between Models A and B), as well as the standard deviation, +maximum, and minimum of LRT statistics across allocations, and the percent +of allocations where the LRT was significant (indicating preference for the +more complex Model B). } +\item{Fit index differences}{A table containing percentage of allocations +where Model A is preferred over Model B according to BIC, AIC, RMSEA, CFI, +TLI and SRMR and where Model B is preferred over Model A according to the +same indices. Also includes the average amount by which the given model is +preferred (calculated only using allocations where it was preferred).} +\item{Fit index difference histograms}{Histograms are automatically outputted +showing the distribution of the differences (Model A - Model B) for each fit +index and for the p-value of the likelihood ratio difference test.} +\item{Percent of Allocations with | BIC Diff | > 10}{A table containing the +percentage of allocations with (BIC for Model A) - (BIC for Model B) < -10, +indicating "very strong evidence" to prefer Model A over Model B and the +percentage of allocations with (BIC for Model A) - (BIC for Model B) > 10, +indicating "very strong evidence" to prefer Model B over Model A (Raftery, +1995).} +\item{Converged and proper}{A table containing the proportion of allocations +that converged for Model A, Model B, and both models, and the proportion of +allocations with converged and proper solutions for Model A, Model B, and +both models.} +} +\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 is a +modified version of \code{\link{parcelAllocation}} which can be used with +only one SEM in isolation. The \code{PAVranking} function repeatedly +generates a specified number of random item-to-parcel allocations, and then +fits two models to each allocation. 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 \code{seed}). +} +\details{ +This is a modified version of \code{\link{parcelAllocation}} which was, in +turn, based on the 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 uses a modified version of parcelAllocation to generate a +given number (\code{nAlloc}) of item-to-parcel allocations. Then, +\code{PAVranking} provides the following new developments: specifying more +than one SEM and producing results for Model A and Model B separately that +summarize parcel allocation variability in estimates, standard errors, and +fit indices. \code{PAVranking} also newly produces results summarizing +parcel allocation variability in model selection index values and model +ranking between Models A and B. Additionally, \code{PAVranking} newly allows +for nonconverged solutions and outputs the proportion of allocations that +converged as well as the proportion of proper solutions (results are +summarized for 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). + +\emph{Note}: This function requires the \code{lavaan} package. Missing data + codeneeds to be \code{NA}. If function returns \code{"Error in plot.new() : +figure margins too large,"} user may need to increase size of the plot +window and rerun. +} +\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")) +} + +} +\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: A Multidisciplinary Journal, 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. (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}}, \code{\link{poolMAlloc}} +} +\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 on which this function +is based. +} diff -Nru r-cran-semtools-0.4.14/man/permuteMeasEq-class.Rd r-cran-semtools-0.5.0/man/permuteMeasEq-class.Rd --- r-cran-semtools-0.4.14/man/permuteMeasEq-class.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/permuteMeasEq-class.Rd 2018-06-25 21:15:29.000000000 +0000 @@ -1,51 +1,166 @@ -\name{permuteMeasEq-class} -\docType{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 -} -\description{ - This class contains the results of tests of Measurement Equivalence and Differential Item Functioning (DIF). -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link[semTools]{permuteMeasEq}} function. -} -\section{Slots}{ - \describe{ - \item{\code{PT}:}{A \code{data.frame} returned by a call to \code{\link[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 vector indicating the results of the observed chi-squared (difference) test, based on the central chi-squared 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}} 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 integer indicating the number of permutations requested by the user} - \item{\code{n.Converged}:}{An integer indicating the number of permuation iterations which yielded a converged solution} - \item{\code{n.nonConverged}:}{A 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"}. A 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 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{Methods}{ - \describe{ - \item{show}{\code{signature(object = "permuteMeasEq"):} The \code{show} function is used to summarize the results of the multiparameter omnibus test of measurement equivalence, using the user-specified AFIs. The parametric chi-squared (difference) test is also displayed.} - \item{summary}{\code{signature(object = "permuteMeasEq", alpha = .05, nd = 3, extra = FALSE):} The summary function 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 chi-squared 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[semTools]{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{hist}{\code{signature(x = "permuteMeasEq", ..., AFI, alpha = .05, nd = 3, printLegend = TRUE, legendArgs = list(x = "topleft")):} The \code{hist} function provides a histogram for the permutation distribution of the specified \code{AFI}, including observed and critical values from the specified \code{alpha} level. Distributions of modification indices and any extra output are not available with this method, but they can be created manually by accessing the distributions in slot \code{MI.dist} or \code{extra.dist}. The user can also specify additional graphical parameters to \code{\link[graphics]{hist}} via \code{...}, as well as pass a list of arguments to an optional \code{\link[graphics]{legend}} via \code{legendArgs}. If \code{AFI = "chisq"}, then the probability density and critical value from the central chi-squared distribution are also included in the plot. If the user wants more control over customization, \code{hist} 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}.} - } -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\seealso{ -\code{\link[semTools]{permuteMeasEq}} -} -\examples{ -# See the example from the permuteMeasEq function -} - +% 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} +\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}}} + +\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}} 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[semTools]{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}} 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}} 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[semTools]{permuteMeasEq}} function. +} + +\examples{ + +# See the example from the permuteMeasEq function + +} +\seealso{ +\code{\link[semTools]{permuteMeasEq}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; + \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/permuteMeasEq.Rd r-cran-semtools-0.5.0/man/permuteMeasEq.Rd --- r-cran-semtools-0.4.14/man/permuteMeasEq.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/permuteMeasEq.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,299 +1,509 @@ -\name{permuteMeasEq} -\alias{permuteMeasEq} -\title{ - Permutation Randomization Tests of Measurement Equivalence and Differential Item Functioning (DIF) -} -\description{ -The function \code{permuteMeasEq} provides tests of hypotheses involving measurement equivalence, in one of two frameworks: - -(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. - -(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}}. -} -\usage{ -permuteMeasEq(nPermute, modelType = c("mgcfa","mimic"), - con, uncon = NULL, null = NULL, - param = NULL, freeParam = NULL, covariates = NULL, - AFIs = NULL, moreAFIs = NULL, - maxSparse = 10L, maxNonconv = 10L, showProgress = TRUE, - warn = -1L, datafun, extra, - parallelType = c("none", "multicore", "snow"), - ncpus = NULL, cl = NULL, iseed = 12345L) -} -\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-\code{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}}). 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{\link[lavaan]{lavTestScore}}\code{(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}}). -} - \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}} 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[semTools]{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}}. -} - \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}}. 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}} 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]{RNGkind}} is set to \code{"L'Ecuyer-CMRG"} with a message. See \code{\link[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]{set.seed}} before calling \code{permuteMeasEq}. -} - -} -\details{ - 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[semTools]{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}}'s \code{group.label} argument is used to preserve the order of groups seen in \code{con} when permuting the data. -} -\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. -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\references{ -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}}, \code{\link[lavaan]{lavTestScore}}, \code{\link[semTools]{measurementInvariance}}, \code{\link[semTools]{measurementInvarianceCat}} -} -\examples{ -\dontrun{ - -######################## -## 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 -' -miout <- measurementInvariance(mod.config, data = HS, std.lv = TRUE, - group = "ageGroup") - -(fit.config <- miout[["fit.configural"]]) -(fit.metric <- miout[["fit.loadings"]]) -(fit.scalar <- miout[["fit.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 the interaction terms after permuting the covariate -datafun <- function(data) { - d <- data[, !names(data) \%in\% 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) - -} -} - +% 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-\code{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}}). 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{\link[lavaan]{lavTestScore}}\code{(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}}).} + +\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}} +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[semTools]{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}}.} + +\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}}. 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}} 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]{RNGkind}} is set to +\code{"L'Ecuyer-CMRG"} with a message. See +\code{\link[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]{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}}. + +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[semTools]{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}}'s \code{group.label} +argument is used to preserve the order of groups seen in \code{con} when +permuting the data. +} +\examples{ + +\dontrun{ + +######################## +## 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 +' +miout <- measurementInvariance(mod.config, data = HS, std.lv = TRUE, + group = "ageGroup") + +(fit.config <- miout[["fit.configural"]]) +(fit.metric <- miout[["fit.loadings"]]) +(fit.scalar <- miout[["fit.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[, !names(data) \%in\% 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{ +\bold{Papers about permutation tests of measurement equivalence:} + +Jorgensen, T. D., Kite, B. A., Chen, P.-Y., & Short, S. D. (in press). +Permutation randomization methods for testing measurement equivalence and +detecting differential item functioning in multiple-group confirmatory +factor analysis. \emph{Psychological Methods}. doi:10.1037/met0000152 + +Kite, B. A., Jorgensen, T. D., & Chen, P.-Y. (in press). Random permutation +testing applied to measurement invariance testing with ordered-categorical +indicators. \emph{Structural Equation Modeling}. +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 + +\bold{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}}, \code{\link[lavaan]{lavTestScore}}, +\code{\link[semTools]{measurementInvariance}}, +\code{\link[semTools]{measurementInvarianceCat}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/plotProbe.Rd r-cran-semtools-0.5.0/man/plotProbe.Rd --- r-cran-semtools-0.4.14/man/plotProbe.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/plotProbe.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,118 +1,135 @@ -\name{plotProbe} -\alias{plotProbe} -\title{ - Plot the graphs for probing latent interaction -} -\description{ -This function will plot the line graphs representing the simple effect of the independent variable given the values of the moderator. -} -\usage{ -plotProbe(object, xlim, xlab="Indepedent Variable", ylab="Dependent Variable", ...) -} -\arguments{ - \item{object}{ - The result of probing latent interaction obtained from \code{\link{probe2WayMC}}, \code{\link{probe2WayRC}}, \code{\link{probe3WayMC}}, or \code{\link{probe3WayRC}} function. -} - \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{\dots}{ - Any addition argument for the \code{\link{plot}} function -} -} -\value{ - None. This function will plot the simple main effect only. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. - \item \code{\link{probe2WayMC}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe3WayMC}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe2WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{probe3WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - } -} -\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, std.lv=FALSE) -result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), "f3", "f2", 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, meanstructure=TRUE, std.lv=FALSE) -result3wayMC <- probe3WayMC(fitMC3way, c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), - "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) -plotProbe(result3wayMC, xlim=c(-2, 2)) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/probeInteraction.R +\name{plotProbe} +\alias{plotProbe} +\title{Plot the graphs for probing latent interaction} +\usage{ +plotProbe(object, xlim, xlab = "Indepedent Variable", + ylab = "Dependent Variable", legend = TRUE, legendArgs = list(), ...) +} +\arguments{ +\item{object}{The result of probing latent interaction obtained from +\code{\link{probe2WayMC}}, \code{\link{probe2WayRC}}, +\code{\link{probe3WayMC}}, or \code{\link{probe3WayRC}} function.} + +\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}} +function if \code{legend=TRUE}.} + +\item{\dots}{Any addition argument for the \code{\link{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. +} +\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, std.lv = FALSE, + meanstructure = TRUE) +result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), + "f3", "f2", 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, + c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), + "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) +plotProbe(result3wayMC, xlim = c(-2, 2)) + +} +\seealso{ +\itemize{ + \item \code{\link{indProd}} For creating the indicator products with no + centering, mean centering, double-mean centering, or residual centering. + \item \code{\link{probe2WayMC}} For probing the two-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe3WayMC}} For probing the three-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe2WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/plotRMSEAdist.Rd r-cran-semtools-0.5.0/man/plotRMSEAdist.Rd --- r-cran-semtools-0.4.14/man/plotRMSEAdist.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/plotRMSEAdist.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,48 +1,78 @@ -\name{plotRMSEAdist} -\alias{plotRMSEAdist} -\title{ -Plot the sampling distributions of RMSEA -} -\description{ -Plots the sampling distributions of RMSEA based on the noncentral chi-square distributions -} -\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.} - } -\details{ -This function creates overlappling plots of the sampling distribution of RMSEA based on noncentral chi-square 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 groupand \eqn{\varepsilon} is the population RMSEA. Next, the noncentral chi-square distribution with a specified degree of freedom and noncentrality parameter is plotted. Thus, the x-axis represent the sample chi-square value. The sample chi-square 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 chi-square value obtained from the noncentral chi-square distribution. -} -\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}, 305-319. - -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,} 130-149. - -Steiger, J. H. (1998). A note on multiple sample extensions of the RMSEA fit index. \emph{Structural Equation Modeling, 5}, 411-419. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{plotRMSEApower}} to plot the statistical power based on population RMSEA given the sample size - \item \code{\link{findRMSEApower}} to find the statistical power based on population RMSEA given a sample size - \item \code{\link{findRMSEAsamplesize}} to find the minium sample size for a given statistical power based on population RMSEA - } -} -\examples{ -plotRMSEAdist(rmsea=c(.05, .08), n=200, df=20, ptile=0.95, rmseaScale = TRUE) -plotRMSEAdist(rmsea=c(.05, .01), n=200, df=20, ptile=0.05, rmseaScale = FALSE) -} \ No newline at end of file +% 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}} to plot the statistical power + based on population RMSEA given the sample size + \item \code{\link{findRMSEApower}} to find the statistical power based on + population RMSEA given a sample size + \item \code{\link{findRMSEAsamplesize}} to find the minium sample size for + a given statistical power based on population RMSEA +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/plotRMSEApowernested.Rd r-cran-semtools-0.5.0/man/plotRMSEApowernested.Rd --- r-cran-semtools-0.4.14/man/plotRMSEApowernested.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/plotRMSEApowernested.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,40 +1,67 @@ -\name{plotRMSEApowernested} -\alias{plotRMSEApowernested} -\title{Plot power of nested model RMSEA} -\description{ -Plot power of nested model RMSEA over a range of possible sample sizes. -} -\usage{ -plotRMSEApowernested(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, -dfA, dfB, nlow, nhigh, steps=1, alpha=.05, group=1, ...) -} -\arguments{ - \item{rmsea0A}{The H0 baseline RMSEA.} - \item{rmsea0B}{The H0 alternative RMSEA (trivial misfit).} - \item{rmsea1A}{The H1 baseline RMSEA.} - \item{rmsea1B}{The H1 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.} -} -\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}, 19-35. -} -\author{ - Bell Clinton; Pavel Panko (Texas Tech University; \email{pavel.panko@ttu.edu}); Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{findRMSEApowernested}} to find the power for a given sample size in nested model comparison based on population RMSEA - \item \code{\link{findRMSEAsamplesizenested}} to find the minium sample size for a given statistical power in nested model comparison based on population RMSEA - } -} -\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) -} +% 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}} to find the power for a given + sample size in nested model comparison based on population RMSEA + \item \code{\link{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}) +} diff -Nru r-cran-semtools-0.4.14/man/plotRMSEApower.Rd r-cran-semtools-0.5.0/man/plotRMSEApower.Rd --- r-cran-semtools-0.4.14/man/plotRMSEApower.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/plotRMSEApower.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,59 +1,95 @@ -\name{plotRMSEApower} -\alias{plotRMSEApower} -\title{ -Plot power curves for RMSEA -} -\description{ -Plots power of RMSEA over a range of sample sizes -} -\usage{ -plotRMSEApower(rmsea0, rmseaA, df, nlow, nhigh, steps=1, alpha=.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.} - } -\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}. -} - -\value{ - \enumerate{ - \item{plot} Plot of power for RMSEA against a range of sample sizes - } -} -\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,} 19-35. - -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,} 130-149. - -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,} 23-41. - -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,} 411-419. - -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. -} -\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 \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions - \item \code{\link{findRMSEApower}} to find the statistical power based on population RMSEA given a sample size - \item \code{\link{findRMSEAsamplesize}} to find the minium sample size for a given statistical power based on population RMSEA - } -} -\examples{ -plotRMSEApower(.025, .075, 23, 100, 500, 10) -} \ No newline at end of file +% 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}. +} +\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. +} +\seealso{ +\itemize{ +\item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions +\item \code{\link{findRMSEApower}} to find the statistical power based on + population RMSEA given a sample size +\item \code{\link{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.}) +} diff -Nru r-cran-semtools-0.4.14/man/poolMAlloc.Rd r-cran-semtools-0.5.0/man/poolMAlloc.Rd --- r-cran-semtools-0.4.14/man/poolMAlloc.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/poolMAlloc.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,135 +1,260 @@ -\name{poolMAlloc} -\alias{poolMAlloc} -\title{ -Pooled estimates and standard errors across M parcel-allocations: Combining sampling variability and parcel-allocation variability. -} -\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 parameter and standard error estimates from this SEM can be outputted at this final selected number of allocations. 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 using a modified version of the \code{\link{parcelAllocation}} function (Quick & Schoemann, 2012), fits a SEM to each allocation, pools results 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). -} -\usage{ -poolMAlloc(nPerPar, facPlc, nAllocStart, nAllocAdd = 0, - parceloutput=0, syntax, dataset, stopProp, stopValue, - selectParam = NULL, 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 0 and results will be output for \code{nAllocStart} allocations only. - } - \item{syntax}{ - lavaan syntax that defines the model. - } - \item{dataset}{ - Item-level dataset - } - \item{parceloutput}{ - (Optional) folder 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). - } - \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}) x (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 and Rights (2016) \code{selectParam} included all free parameters except item intercepts and in another example \code{selectParam} included only structural parameters. - } - \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{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{checkConv}{ - (Optional) If set to TRUE, function will output pooled estimates and standard errors from 10 iterations post-convergence. - } - \item{\dots}{ - Additional arguments to be passed to \code{\link[lavaan]{lavaan}} - } -} -\details{ -This is a modified version of \code{\link{parcelAllocation}}. It implements a new algorithm for choosing the number of allocations (\emph{M}), (described in Sterba & Rights (2016)), newly pools parameter estimate and standard error results across these \emph{M} allocations, and produces indices for assessing the relative contributions of parcel-allocation variability vs. sampling variability in each estimate. 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 parameter estimates and pooled standard errors fulfill stopping criteria (\code{stopProp} and \code{stopValue}, defined above). Results from the model that was fit to the \emph{M} allocations are outputted. - -Additionally, this function newly 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. The original parcelAllocation function could not be employed if any allocations yielded nonconverged solutions. - -For further details on the benefits of the random allocation of items to parcels, see Sterba (2011) and Sterba and MacCallum (2010). - -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. -} -\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, \emph{z}-based 95\% confidence interval, \emph{p}-value for a \emph{t}-test of the parameter (using degrees of freedom described in Sterba & Rights, 2016), and \emph{t}-based 95\% confidence interval 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 average of each index across allocations, the standard deviation of each fit index across allocations, the maximum of each fit index across allocations, the minimum of each fit index across allocations, the 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{Proportion of converged and proper allocations}{A table containing the proportion of the final \emph{M} allocations that converged (using a maximum likelihood estimator) and the proportion of allocations that converged to proper solutions. Note that pooled estimates, pooled standard errors, and other results are computed using only the converged, proper allocations.} -\item{Allocations needed for stability (M)}{The number of allocations (\emph{M}) at which the algorithm's stopping criteria (defined above) were met.} -\item{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 and Rights (2016) for more detail.} -\item{Total runtime (minutes)}{The total runtime of the function, in minutes. Note that the total runtime will be greater when the the specified model encounters convergence problems for some allocations, as is the case with the \code{\link{simParcel}} dataset used below.} -} -\references{ -Sterba, S. K. (2011). Implications of parcel-allocation variability for comparing fit of item-solutions and parcel-solutions. \emph{Structural Equation Modeling: A Multidisciplinary Journal, 18}(4), 554-577. - -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. - -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}. \url{http://www.tandfonline.com/doi/pdf/10.1080/00273171.2016.1144502} -} -\seealso{ - \code{\link{parcelAllocation}}, \code{\link{PAVranking}} -} -\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 on which this function is based. -} -\examples{ -\dontrun{ -## 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) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/poolMAlloc.R +\name{poolMAlloc} +\alias{poolMAlloc} +\title{Pooled estimates and standard errors across M parcel-allocations: Combining +sampling variability and parcel-allocation variability.} +\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} + allocationsonly.} + +\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 (\code{\\}). See \code{\link[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}) x +(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}} 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}}), \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}}. See also \code{\link[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, \emph{z}-based +95\% confidence interval, \emph{p}-value for a \emph{t}-test of the +parameter (using degrees of freedom described in Sterba & Rights, 2016), and +\emph{t}-based 95\% confidence interval 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 average of each index across allocations, +the standard deviation of each fit index across allocations, the maximum of +each fit index across allocations, the minimum of each fit index across +allocations, the 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{Proportion of converged and proper allocations}{A table +containing the proportion of the final \emph{M} allocations that converged +(using a maximum likelihood estimator) and the proportion of allocations +that converged to proper solutions. Note that pooled estimates, pooled +standard errors, and other results are computed using only the converged, +proper allocations.} +\item{Allocations needed for stability (M)}{The number of allocations +(\emph{M}) at which the algorithm's stopping criteria (defined above) were +met.} +\item{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{Total runtime (minutes)}{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}} 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 "Details" below for more +information). Pooled parameter and standard error estimates from this SEM +can be outputted at this final selected number of allocations. 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 using a modified version +of the \code{\link{parcelAllocation}} function (Quick & Schoemann, 2012), +fits a SEM to each allocation, pools results 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 is a modified version of \code{\link{parcelAllocation}}. It implements +a new algorithm for choosing the number of allocations (\emph{M}), +(described in Sterba & Rights (2016)), newly pools parameter estimate and +standard error results across these \emph{M} allocations, and produces +indices for assessing the relative contributions of parcel-allocation +variability vs. sampling variability in each estimate. 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 parameter +estimates and pooled standard errors fulfill stopping criteria +(\code{stopProp} and \code{stopValue}, defined above). Results from the +model that was fit to the \emph{M} allocations are outputted. + +Additionally, this function newly 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. The original parcelAllocation function +could not be employed if any allocations yielded nonconverged solutions. + +For further details on the benefits of the random allocation of items to +parcels, see Sterba (2011) and Sterba & MacCallum (2010). + +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. +} +\examples{ + +\dontrun{ +## 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, AllocAdd = 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) +} + +} +\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 +} +\seealso{ +\code{\link{parcelAllocation}}, \code{\link{PAVranking}} +} +\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 on which this function +is based. +} diff -Nru r-cran-semtools-0.4.14/man/probe2WayMC.Rd r-cran-semtools-0.5.0/man/probe2WayMC.Rd --- r-cran-semtools-0.4.14/man/probe2WayMC.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/probe2WayMC.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,108 +1,152 @@ -\name{probe2WayMC} -\alias{probe2WayMC} -\title{ -Probing two-way interaction on the no-centered or mean-centered latent interaction -} -\description{ -Probing interaction for simple intercept and simple slope for the no-centered or mean-centered latent two-way interaction -} -\usage{ -probe2WayMC(fit, nameX, nameY, modVar, valProbe) -} -\arguments{ - \item{fit}{The lavaan model object used to evaluate model fit} - \item{nameX}{The vector of the factor names used as the predictors. The first-order factor will be listed first. The last name must be the name representing the interaction term.} - \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 on each moderator variable value will be probed.} - \item{valProbe}{The values of the moderator that will be used to probe the effect of the other independent factor.} -} -\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}} 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 varaible (\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. - -For probing 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_2Z. -} - -The simple slope of the independent varaible at each value of the moderator can be obtained by -\deqn{ - b_{X|Z} = b_1 + b_3Z. -} - -The variance of the simple intercept formula is -\deqn{ - Var\left(b_{0|X = 0, Z}\right) = Var\left(b_0\right) + 2ZCov\left(b_0, b_2\right) + Z^2Var\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) + 2ZCov\left(b_1, b_3\right) + Z^2Var\left(b_3\right) -} - -Wald statistic is used for test statistic. -} -\value{ -A list with two elements: -\enumerate{ - \item{SimpleIntercept} The intercepts given each value of the moderator. This element will be shown only if the factor intercept is estimated (e.g., not fixed as 0). - \item{SimpleSlope} The 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 simple slope. The fourth column is the Wald (\emph{z}) statistic. The fifth column is the \emph{p}-value testing whether the simple intercepts or slopes are different from 0. -} -\references{ -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: 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}, 275-300. - -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}, 437-448. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. - \item \code{\link{probe3WayMC}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe2WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{probe3WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the latent interaction. - } -} -\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, std.lv=FALSE) -summary(fitMC2way) - -result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), "f3", "f2", c(-1, 0, 1)) -result2wayMC -} +% 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) +} +\arguments{ +\item{fit}{The lavaan model object used to evaluate model fit} + +\item{nameX}{The vector of the factor names used as the predictors. The +first-order factor will be listed first. The last name must be the name +representing the interaction term.} + +\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 on each moderator variable value will be +probed.} + +\item{valProbe}{The values of the moderator that will be used to probe the +effect of the other independent factor.} +} +\value{ +A list with two elements: +\enumerate{ + \item \code{SimpleIntercept}: The intercepts given each value of the + moderator. This element will be shown only if the factor intercept is + estimated (e.g., not fixed as 0). + \item \code{SimpleSlope}: The 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 \emph{SE} of the simple +intercept or simple slope. The fourth column is the Wald (\emph{z}) +statistic. The fifth column is the \emph{p} value testing whether the simple +intercepts or slopes are different from 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}} +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 varaible (\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. + +For probing 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_2Z. } + +The simple slope of the independent varaible at each value of the moderator +can be obtained by \deqn{ b_{X|Z} = b_1 + b_3Z. } + +The variance of the simple intercept formula is \deqn{ Var\left(b_{0|X = 0, +Z}\right) = Var\left(b_0\right) + 2ZCov\left(b_0, b_2\right) + +Z^2Var\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) + 2ZCov\left(b_1, b_3\right) + Z^2Var\left(b_3\right) } + +Wald statistic is used for test statistic. +} +\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, std.lv = FALSE, + meanstructure = TRUE) +summary(fitMC2way) + +result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), + "f3", "f2", c(-1, 0, 1)) +result2wayMC + +} +\references{ +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}} For creating the indicator products with no + centering, mean centering, double-mean centering, or residual centering. + \item \code{\link{probe3WayMC}} For probing the three-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe2WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{probe3WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the + latent interaction. +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/probe2WayRC.Rd r-cran-semtools-0.5.0/man/probe2WayRC.Rd --- r-cran-semtools-0.4.14/man/probe2WayRC.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/probe2WayRC.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,83 +1,137 @@ -\name{probe2WayRC} -\alias{probe2WayRC} -\title{ -Probing two-way interaction on the residual-centered latent interaction -} -\description{ -Probing interaction for simple intercept and simple slope for the residual-centered latent two-way interaction (Pornprasertmanit, Schoemann, Geldhof, & Little, submitted) -} -\usage{ -probe2WayRC(fit, nameX, nameY, modVar, valProbe) -} -\arguments{ - \item{fit}{The lavaan model object used to evaluate model fit} - \item{nameX}{The vector of the factor names used as the predictors. The first-order factor will be listed first. The last name must be the name representing the interaction term.} - \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 on each moderator variable value will be probed.} - \item{valProbe}{The values of the moderator that will be used to probe the effect of the other independent factor.} -} -\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}} 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 Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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{probe2WayMC}} for further details. -} -\value{ -A list with two elements: -\enumerate{ - \item{SimpleIntercept} The intercepts given each value of the moderator. This element will be shown only if the factor intercept is estimated (e.g., not fixed as 0). - \item{SimpleSlope} The 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 simple slope. The fourth column is the Wald (\emph{z}) statistic. The fifth column is the \emph{p}-value testing whether the simple intercepts or slopes are different from 0. -} -\references{ - -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}, 163-175. - -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}, 497-519. - -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}, 275-300. - -Pornprasertmanit, S., Schoemann, A. M., Geldhof, G. J., & Little, T. D. (submitted). \emph{Probing latent interaction estimated with a residual centering approach.} - -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. - \item \code{\link{probe2WayMC}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe3WayMC}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe3WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the latent interaction. - } -} -\examples{ -library(lavaan) - -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 -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 -" - -fitRC2way <- sem(model1, data=dat2wayRC, meanstructure=TRUE, std.lv=FALSE) -summary(fitRC2way) - -result2wayRC <- probe2WayRC(fitRC2way, c("f1", "f2", "f12"), "f3", "f2", c(-1, 0, 1)) -result2wayRC -} +% 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) +} +\arguments{ +\item{fit}{The lavaan model object used to evaluate model fit} + +\item{nameX}{The vector of the factor names used as the predictors. The +first-order factor will be listed first. The last name must be the name +representing the interaction term.} + +\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 on each moderator variable value will be +probed.} + +\item{valProbe}{The values of the moderator that will be used to probe the +effect of the other independent factor.} +} +\value{ +A list with two elements: +\enumerate{ + \item \code{SimpleIntercept}: The intercepts given each value of the + moderator. This element will be shown only if the factor intercept is + estimated (e.g., not fixed as 0). + \item \code{SimpleSlope}: The 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 simple slope. The fourth column is the Wald (\emph{z}) +statistic. The fifth column is the \emph{p} value testing whether the simple +intercepts or slopes are different from 0. +} +\description{ +Probing interaction for simple intercept and simple slope for the +residual-centered latent two-way interaction (Pornprasertmanit, Schoemann, +Geldhof, & Little, submitted) +} +\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}} 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 +Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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{probe2WayMC}} for further details. +} +\examples{ + +library(lavaan) + +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 +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 +" + +fitRC2way <- sem(model1, data = dat2wayRC, std.lv = FALSE, + meanstructure = TRUE) +summary(fitRC2way) + +result2wayRC <- probe2WayRC(fitRC2way, c("f1", "f2", "f12"), + "f3", "f2", c(-1, 0, 1)) +result2wayRC + +} +\references{ +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}} For creating the indicator products with no + centering, mean centering, double-mean centering, or residual centering. + \item \code{\link{probe2WayMC}} For probing the two-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe3WayMC}} For probing the three-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe3WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the + latent interaction. +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/probe3WayMC.Rd r-cran-semtools-0.5.0/man/probe3WayMC.Rd --- r-cran-semtools-0.4.14/man/probe3WayMC.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/probe3WayMC.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,128 +1,187 @@ -\name{probe3WayMC} -\alias{probe3WayMC} -\title{ -Probing two-way interaction on the no-centered or mean-centered latent interaction -} -\description{ -Probing interaction for simple intercept and simple slope for the no-centered or mean-centered latent two-way interaction -} -\usage{ -probe3WayMC(fit, nameX, nameY, modVar, valProbe1, valProbe2) -} -\arguments{ - \item{fit}{The lavaan model object used to evaluate model fit} - \item{nameX}{The vector of the factor names used as the predictors. The three first-order factors will be listed first. Then the second-order factors will be listeed. The last element of the name will represent the three-way interaction. Note that the fourth element must be the interaction between the first and the second variables. The fifth element must be the interaction between the first and the third variables. The sixth element must be the interaction between the second and the third variables.} - \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.} -} -\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}} 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 varaible (\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. - -For probing 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 varaible 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) + 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) + 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 statistic is used for test statistic. -} -\value{ -A list with two elements: -\enumerate{ - \item{SimpleIntercept} The intercepts given each value of the moderator. This element will be shown only if the factor intercept is estimated (e.g., not fixed as 0). - \item{SimpleSlope} The slopes given each value of the moderator. -} -In each element, the first column represents the values of the first moderator specified in the \code{valProbe1} argument. The second column represents the 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. The sixth column is the \emph{p}-value testing whether the simple intercepts or slopes are different from 0. -} -\references{ -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. \emph{Psychological Methods, 9}, 275-300. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. - \item \code{\link{probe2WayMC}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe2WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{probe3WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the latent interaction. - } -} -\examples{ -library(lavaan) - -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, meanstructure=TRUE, std.lv=FALSE) -summary(fitMC3way) - -result3wayMC <- probe3WayMC(fitMC3way, c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), - "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) -result3wayMC -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/probeInteraction.R +\name{probe3WayMC} +\alias{probe3WayMC} +\title{Probing two-way interaction on the no-centered or mean-centered latent +interaction} +\usage{ +probe3WayMC(fit, nameX, nameY, modVar, valProbe1, valProbe2) +} +\arguments{ +\item{fit}{The lavaan model object used to evaluate model fit} + +\item{nameX}{The vector of the factor names used as the predictors. The +three first-order factors will be listed first. Then the second-order +factors will be listeed. The last element of the name will represent the +three-way interaction. Note that the fourth element must be the interaction +between the first and the second variables. The fifth element must be the +interaction between the first and the third variables. The sixth element +must be the interaction between the second and the third variables.} + +\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.} +} +\value{ +A list with two elements: +\enumerate{ + \item \code{SimpleIntercept}: The intercepts given each value of the moderator. + This element will be shown only if the factor intercept is estimated + (e.g., not fixed as 0). + \item \code{SimpleSlope}: The slopes given each value of the moderator. +} +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. The sixth column is the \emph{p} +value testing whether the simple intercepts or slopes are different from 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}} +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 varaible (\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. + +For probing 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 varaible 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) + 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) + 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 statistic is used for test statistic. +} +\examples{ + +library(lavaan) + +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) +summary(fitMC3way) + +result3wayMC <- probe3WayMC(fitMC3way, + c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), + "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) +result3wayMC + +} +\references{ +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}} For creating the indicator products with no + centering, mean centering, double-mean centering, or residual centering. + \item \code{\link{probe2WayMC}} For probing the two-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe2WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{probe3WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the + latent interaction. +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/probe3WayRC.Rd r-cran-semtools-0.5.0/man/probe3WayRC.Rd --- r-cran-semtools-0.4.14/man/probe3WayRC.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/probe3WayRC.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,108 +1,173 @@ -\name{probe3WayRC} -\alias{probe3WayRC} -\title{ -Probing three-way interaction on the residual-centered latent interaction -} -\description{ -Probing interaction for simple intercept and simple slope for the residual-centered latent three-way interaction (Pornprasertmanit, Schoemann, Geldhof, & Little, submitted) -} -\usage{ -probe3WayRC(fit, nameX, nameY, modVar, valProbe1, valProbe2) -} -\arguments{ - \item{fit}{The lavaan model object used to evaluate model fit} - \item{nameX}{The vector of the factor names used as the predictors. The three first-order factors will be listed first. Then the second-order factors will be listeed. The last element of the name will represent the three-way interaction. Note that the fourth element must be the interaction between the first and the second variables. The fifth element must be the interaction between the first and the third variables. The sixth element must be the interaction between the second and the third variables.} - \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.} -} -\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}} 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, Pornprasertmanit, Schoemann, & Little, in press). 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 Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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}} for further details. -} -\value{ -A list with two elements: -\enumerate{ - \item{SimpleIntercept} The intercepts given each value of the moderator. This element will be shown only if the factor intercept is estimated (e.g., not fixed as 0). - \item{SimpleSlope} The slopes given each value of the moderator. -} -In each element, the first column represents the values of the first moderator specified in the \code{valProbe1} argument. The second column represents the 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. The sixth column is the \emph{p}-value testing whether the simple intercepts or slopes are different from 0. -} -\references{ -Geldhof, G. J., Pornprasertmanit, S., Schoemann, A., & Little, T. D. (in press). Orthogonalizing through residual centering: Applications and caveats. \emph{Educational and Psychological Measurement.} - -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}, 163-175. - -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}, 497-519. - -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}, 275-300. - -Pornprasertmanit, S., Schoemann, A. M., Geldhof, G. J., & Little, T. D. (submitted). \emph{Probing latent interaction estimated with a residual centering approach.} - -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \itemize{ - \item \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. - \item \code{\link{probe2WayMC}} For probing the two-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe3WayMC}} For probing the three-way latent interaction when the results are obtained from mean-centering, or double-mean centering. - \item \code{\link{probe2WayRC}} For probing the two-way latent interaction when the results are obtained from residual-centering approach. - \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the latent interaction. - } -} -\examples{ -library(lavaan) - -dat3wayRC <- orthogonalize(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 -" - -fitRC3way <- sem(model3, data=dat3wayRC, meanstructure=TRUE, std.lv=FALSE) -summary(fitRC3way) - -result3wayRC <- probe3WayRC(fitRC3way, c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), - "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) -result3wayRC -} +% 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) +} +\arguments{ +\item{fit}{The lavaan model object used to evaluate model fit} + +\item{nameX}{The vector of the factor names used as the predictors. The +three first-order factors will be listed first. Then the second-order +factors will be listeed. The last element of the name will represent the +three-way interaction. Note that the fourth element must be the interaction +between the first and the second variables. The fifth element must be the +interaction between the first and the third variables. The sixth element +must be the interaction between the second and the third variables.} + +\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.} +} +\value{ +A list with two elements: +\enumerate{ + \item \code{SimpleIntercept}: The intercepts given each value of the moderator. + This element will be shown only if the factor intercept is estimated + (e.g., not fixed as 0). + \item \code{SimpleSlope}: The slopes given each value of the moderator. +} +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. The sixth column is the \emph{p} value +testing whether the simple intercepts or slopes are different from 0. +} +\description{ +Probing interaction for simple intercept and simple slope for the +residual-centered latent three-way interaction (Pornprasertmanit, Schoemann, +Geldhof, & Little, submitted) +} +\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}} 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, Pornprasertmanit, Schoemann, & +Little, in press). 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 +Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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}} for further details. +} +\examples{ + +library(lavaan) + +dat3wayRC <- orthogonalize(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 +" + +fitRC3way <- sem(model3, data = dat3wayRC, std.lv = FALSE, + meanstructure = TRUE) +summary(fitRC3way) + +result3wayRC <- probe3WayRC(fitRC3way, + c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), + "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) +result3wayRC + +} +\references{ +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}} For creating the indicator products with no + centering, mean centering, double-mean centering, or residual centering. + \item \code{\link{probe2WayMC}} For probing the two-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe3WayMC}} For probing the three-way latent interaction + when the results are obtained from mean-centering, or double-mean centering + \item \code{\link{probe2WayRC}} For probing the two-way latent interaction + when the results are obtained from residual-centering approach. + \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the + latent interaction. +} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/quark.Rd r-cran-semtools-0.5.0/man/quark.Rd --- r-cran-semtools-0.4.14/man/quark.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/quark.Rd 2018-06-26 12:19:09.000000000 +0000 @@ -1,61 +1,116 @@ -\name{quark} -\alias{quark} -\title{ -Quark -} -\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. -} -\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. Be acknowledging the 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 fails. 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, incorporate the argument order=2 into the quark function in order to reorder the imputation method procedure. Otherwise, the order is defaulted to 1. Example to rerun quark after imputation failure, quark.list <- quark(data=yourdataframe,id=vectorofIDs,order=2). - } - \item{silent}{ - If \code{FALSE}, the details of the \code{quark} process are printed. - } -} -\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}} 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. -} -\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.} -} -\references{ -Howard, W. J., Little, T. D., & Rhemtulla, M. (in press). Using principal component analysis (PCA) to obtain auxiliary variables for missing data estimation in large data sets. \emph{Multivariate Behavioral Research}. -} -\author{ -Steven R. Chesnut (University of Southern Mississippi; \email{Steven.Chesnut@usm.edu}), Danny Squire (Texas Tech University). The PCA code is copied and modified from the \code{FactoMineR} package. The function to print correlation matrix is copied from the \code{psych} package. -} -\seealso{ -\code{\link{combinequark}} -} -\examples{ -set.seed(123321) -library(lavaan) - -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) -} \ No newline at end of file +% 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}}.} +} +\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}} 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) +\dontrun{ +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}} +} +\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. +} diff -Nru r-cran-semtools-0.4.14/man/reliabilityL2.Rd r-cran-semtools-0.5.0/man/reliabilityL2.Rd --- r-cran-semtools-0.4.14/man/reliabilityL2.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/reliabilityL2.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,61 +1,99 @@ -\name{reliabilityL2} -\alias{reliabilityL2} -\title{ -Calculate the reliability values of a second-order factor -} -\description{ -Calculate the reliability values (coefficient omega) of a second-order factor -} -\usage{ -reliabilityL2(object, secondFactor) -} -\arguments{ - \item{object}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions that has a second-order factor} - \item{secondFactor}{The name of the second-order factor} -} -\details{ -The first formula of the coefficient omega (in the \code{\link{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 factor, the uniqueness of the first-order factor, and the measurement error of 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} is the first-order factor loading, \eqn{\bold{B}} is the second-order factor loading, \eqn{\Phi_2} is the covariance matrix of the second-order factors, \eqn{\Psi_{u}} is the covariance matrix of the unique scores from first-order factors, and \eqn{\Theta} is the covariance matrix of the measurement errors from indicators. Thus, the proportion of the second-order factor explaining the total score, or the coefficient omega at Level 1, can be calculated: - -\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. When model-implied covariance matrix among first-order factors (\eqn{\Phi_1}) can be calculated: - -\deqn{ \Phi_1 = \bold{B} \Phi_2 \bold{B}^{\prime} + \Psi_{u}, } - -Thus, the proportion of the second-order factor explaining the varaince at first-order factor level, or the coefficient omega at Level 2, can be calculated: - -\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. - -The partial coefficient omega at Level 1, or the proportion of observed variance explained by the second-order factor after partialling the uniqueness from the first-order factor, can be calculated: - -\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. -} -\value{ - 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}) -} -\seealso{ - \code{\link{reliability}} for the reliability of the first-order factors. -} -\examples{ -library(lavaan) - -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 variable -reliabilityL2(fit6, "higher") -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/reliability.R +\name{reliabilityL2} +\alias{reliabilityL2} +\title{Calculate the reliability values of a second-order factor} +\usage{ +reliabilityL2(object, secondFactor) +} +\arguments{ +\item{object}{The lavaan model object provided after running the \code{cfa}, +\code{sem}, \code{growth}, or \code{lavaan} functions that has a +second-order factor} + +\item{secondFactor}{The name of the second-order factor} +} +\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}}) 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 factor, the uniqueness of the +first-order factor, and the measurement error of 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} is the first-order factor loading, \eqn{\bold{B}} is the +second-order factor loading, \eqn{\Phi_2} is the covariance matrix of the +second-order factors, \eqn{\Psi_{u}} is the covariance matrix of the unique +scores from first-order factors, and \eqn{\Theta} is the covariance matrix +of the measurement errors from indicators. Thus, the proportion of the +second-order factor explaining the total score, or the coefficient omega at +Level 1, can be calculated: + +\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. When model-implied covariance matrix among +first-order factors (\eqn{\Phi_1}) can be calculated: + +\deqn{ \Phi_1 = \bold{B} \Phi_2 \bold{B}^{\prime} + \Psi_{u}, } + +Thus, the proportion of the second-order factor explaining the varaince at +first-order factor level, or the coefficient omega at Level 2, can be +calculated: + +\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. + +The partial coefficient omega at Level 1, or the proportion of observed +variance explained by the second-order factor after partialling the +uniqueness from the first-order factor, can be calculated: + +\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. +} +\examples{ + +library(lavaan) + +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{reliability}} for the reliability of the first-order +factors. +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/reliability.Rd r-cran-semtools-0.5.0/man/reliability.Rd --- r-cran-semtools-0.4.14/man/reliability.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/reliability.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,85 +1,166 @@ -\name{reliability} -\alias{reliability} -\title{ -Calculate reliability values of factors -} -\description{ -Calculate reliability values of factors by coefficient omega -} -\usage{ -reliability(object) -} -\arguments{ - \item{object}{The lavaan model object provided after running the \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions.} -} -\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}. - -The coefficient omega (Raykov, 2001) can be calculated by - -\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}. - -The second coefficient omega (Bentler, 1972, 2009) can be 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 different values if there are dual loadings (or the existence of method factors). The first coefficient omega can be viewed as the reliability controlling for the other factors (like partial eta-squared in ANOVA). The second coefficient omega can be viewed as the unconditional reliability (like eta-squared in ANOVA). - -The third coefficient omega (McDonald, 1999), which is sometimes referred to 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, the third coefficient omega will be similar to the \eqn{\omega_2}. Note that if there is a directional effect in the model, all coefficients omega will use the total factor variances, which is calculated by \code{\link[lavaan]{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 is accounted 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. - -Regarding to categorical items, coefficient alpha and AVE are calculated based on polychoric correlations. The coefficient alpha from this function may be not the same as the standard alpha calculation for categorical items. Researchers may check the \code{alpha} function in the \code{psych} package for the standard coefficient alpha calculation. - -Item thresholds are not accounted for. Coefficient omega for categorical items, however, is calculated by accounting for both item covariances and item thresholds 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. -} -\value{ - Reliability values (coefficient alpha, coefficients omega, average variance extracted) of each factor in each group -} -\references{ -Bentler, P. M. (1972). A lower-bound method for the dimension-free measurement of internal consistency. \emph{Social Science Research, 1}, 343-357. - -Bentler, P. M. (2009). Alpha, dimension-free, and model-based internal consistency reliability. \emph{Psychometrika, 74}, 137-143. - -Cronbach, L. J. (1951). Coefficient alpha and the internal structure of tests. \emph{Psychometrika, 16}, 297-334. - -Fornell, C., & Larcker, D. F. (1981). Evaluating structural equation models with unobservable variables and measurement errors. \emph{Journal of Marketing Research, 18}, 39-50. - -Green, S. B., & Yang, Y. (2009). Reliability of summed item scores using structural equation modeling: An alternative to coefficient alpha. \emph{Psychometrika, 74}, 155-167. - -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 \emph{British Journal of Mathematical and Statistical Psychology, 54}, 315-323. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}); Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) -} -\seealso{ - \code{\link{reliabilityL2}} for reliability value of a desired second-order factor, \code{\link{maximalRelia}} for the maximal reliability of weighted composite -} -\examples{ -library(lavaan) - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -fit <- cfa(HS.model, data=HolzingerSwineford1939) -reliability(fit) -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/reliability.R +\name{reliability} +\alias{reliability} +\title{Calculate reliability values of factors} +\usage{ +reliability(object) +} +\arguments{ +\item{object}{The lavaan model object provided after running the \code{cfa}, +\code{sem}, \code{growth}, or \code{lavaan} functions.} +} +\value{ +Reliability values (coefficient alpha, coefficients omega, average +variance extracted) of each factor in each group +} +\description{ +Calculate reliability values of factors by coefficient omega +} +\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}. + +The coefficient omega (Bollen, 1980; see also Raykov, 2001) can be +calculated by + +\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}. + +The second coefficient omega (Bentler, 1972, 2009) can be 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 when the model has simple +structure, but different values when there are (for example) 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 third coefficient omega (McDonald, 1999), which is sometimes referred to +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, the third coefficient omega will be similar to the +\eqn{\omega_2}. Note that if there is a directional effect in the model, all +coefficients omega will use the total factor variances, which is calculated +by \code{\link[lavaan]{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. + +Regarding categorical indicators, coefficient alpha and AVE are calculated +based on polychoric correlations. The coefficient alpha from this function +may be not the same as the standard alpha calculation for categorical items. +Researchers may check the \code{alpha} function in the \code{psych} package +for the standard coefficient alpha calculation. + +Item thresholds are not accounted for. Coefficient omega for categorical +items, however, is calculated by accounting for both item covariances and +item thresholds 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 in the model, an error is returned. If the categorical indicators +load on a different factor(s) than continuous indicators, then reliability +can be calculated separately for those scales by fitting separate models and +submitting each to the \code{reliability} function. +} +\examples{ + +library(lavaan) + +HS.model <- ' visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + speed =~ x7 + x8 + x9 ' + +fit <- cfa(HS.model, data = HolzingerSwineford1939) +reliability(fit) + +} +\references{ +Bollen, K. A. (1980). Issues in the comparative measurement of +political democracy. \emph{American Sociological Review, 45}(3), 370--390. +Retrieved from \url{http://www.jstor.org/stable/2095172} + +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 + +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 +} +\seealso{ +\code{\link{reliabilityL2}} for reliability value of a desired +second-order factor, \code{\link{maximalRelia}} for the maximal reliability +of weighted composite +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) + +Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) +} diff -Nru r-cran-semtools-0.4.14/man/residualCovariate.Rd r-cran-semtools-0.5.0/man/residualCovariate.Rd --- r-cran-semtools-0.4.14/man/residualCovariate.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/residualCovariate.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,37 +1,44 @@ -\name{residualCovariate} -\alias{residualCovariate} -\title{ - Residual centered all target indicators by covariates -} -\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, in press). -} -\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 -} -\references{ -Geldhof, G. J., Pornprasertmanit, S., Schoemann, A. M., & Little, T. D. (2013). Orthogonalizing through residual centering: Applications and caveats. \emph{Educational and Psychological Measurement, 73}, 27-46. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\seealso{ - \code{\link{indProd}} For creating the indicator products with no centering, mean centering, double-mean centering, or residual centering. -} -\examples{ -dat <- residualCovariate(attitude, 2:7, 1) -} +% 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}} For creating the indicator products with no +centering, mean centering, double-mean centering, or residual centering. +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/rotate.Rd r-cran-semtools-0.5.0/man/rotate.Rd --- r-cran-semtools-0.4.14/man/rotate.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/rotate.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,68 +1,85 @@ -\name{rotate} -\alias{orthRotate} -\alias{oblqRotate} -\alias{funRotate} -\title{ - Implement orthogonal or oblique rotation -} -\description{ -These functions will implement orthogonal or oblique rotation on standardized factor loadings from a lavaan output. -} -\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. -} -} -\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{lavJacobianD} function in the \code{lavaan} package. -} -\value{ - An \code{linkS4class{EFA}} object that saves the rotated EFA solution. -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -library(lavaan) - -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") - -\dontrun{ -# 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) -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/efa.R +\name{orthRotate} +\alias{orthRotate} +\alias{oblqRotate} +\alias{funRotate} +\alias{oblqRotate} +\alias{funRotate} +\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{\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.} + +\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}}.} +} +\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{ + +\dontrun{ + +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) +} + +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/runMI.Rd r-cran-semtools-0.5.0/man/runMI.Rd --- r-cran-semtools-0.4.14/man/runMI.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/runMI.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -1,161 +1,177 @@ -\name{runMI} -\alias{runMI} -\alias{cfa.mi} -\alias{sem.mi} -\alias{growth.mi} -\alias{lavaan.mi} -\title{ -Multiply impute and analyze data using lavaan -} -\description{ -This function takes data with missing observations, multiple imputes the data, runs a SEM using lavaan and combines the results using Rubin's rules. Note that parameter estimates and standard errors are pooled by the Rubin's (1987) rule. The chi-square statistics and the related fit indices are pooled by the method described in \code{"chi"} argument. SRMR is calculated based on the average model-implied means and covariance matrices across imputations. -} -\usage{ -runMI(model, data, m, miArgs=list(), chi="all", miPackage="Amelia", - seed=12345, fun, nullModel = NULL, includeImproper = FALSE, ...) -cfa.mi(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", - seed=12345, nullModel = NULL, includeImproper = FALSE, ...) -sem.mi(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", - seed=12345, nullModel = NULL, includeImproper = FALSE, ...) -growth.mi(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", - seed=12345, nullModel = NULL, includeImproper = FALSE, ...) -lavaan.mi(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", - seed=12345, nullModel = NULL, includeImproper = FALSE, ...) -} -\arguments{ - \item{model}{ -lavaan syntax for the model to be analyzed. -} - \item{data}{ -Data frame with missing observations or a list of data frames where each data frame is one imputed data set (for imputed data generated outside of the function). If a list of data frames is supplied, then other options can be left at the default. -} - \item{m}{ -Number of imputations wanted. -} - \item{miArgs}{ -Addition arguments for the multiple-imputation function. The arguments should be put in a list (see example below). -} - \item{miPackage}{ -Package to be used for imputation. Currently these functions only support \code{"Amelia"} or \code{"mice"} for imputation. -} - \item{chi}{ -The method to combine the chi-square. Can be one of the following: \code{"mr"} for the method proposed for Meng & Rubin (1992), \code{"mplus"} for the method used in Mplus (Asparouhov & Muthen, 2010), \code{"lmrr"} for the method proposed by Li, Meng, Raghunathan, & Rubin (1991), \code{"all"} to show the three methods in the output, and \code{"none"} to not pool any chi-square values. The default is \code{"all"}. -} - \item{seed}{ - Random number seed to be used in imputations. -} - \item{nullModel}{ -lavaan syntax for the null model. If not specified, the default null model from lavaan is used. -} - \item{includeImproper}{ -If \code{TRUE}, the function will combine the results with improper solutions to get the combined solution. -} - \item{fun}{ - The character of the function name used in running lavaan model (\code{"cfa"}, \code{"sem"}, \code{"growth"}, \code{"lavaan"}). -} - \item{...}{ - Other arguments to be passed to the specified lavaan function (\code{"cfa"}, \code{"sem"}, \code{"growth"}, \code{"lavaan"}). -} -} -\value{ - The \code{\linkS4class{lavaanStar}} object which contains the original \code{lavaan} object (where the appropriate parameter estimates, appropriate standard errors, and chi-squares are filled), the additional fit-index values of the null model, which need to be adjusted to multiple datasets, and the information from pooling multiple results. -} -\references{ -Asparouhov T. & Muthen B. (2010).\emph{Chi-Square Statistics with Multiple Imputation}. Technical Report. www.statmodel.com. - -Li, K.H., Meng, X.-L., Raghunathan, T.E. and Rubin, D.B. (1991). Significance Levels From Repeated p-values with Multiply-Imputed Data. \emph{Statistica Sinica, 1}, 65-92. - -Meng, X.L. & Rubin, D.B. (1992). Performing likelihood ratio tests with multiply-imputed data sets. \emph{Biometrika, 79}, 103 - 111. - -Rubin, D.B. (1987) \emph{Multiple Imputation for Nonresponse in Surveys.} J. Wiley & Sons, New York. -} -\author{Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) -Patrick Miller (University of Notre Dame; \email{pmille13@nd.edu}) -Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -Mijke Rhemtulla (University of Amsterdam; \email{M.T.Rhemtulla@uva.nl}) -Alexander Robitzsch (Federal Institute for Education Research, Innovation, and Development of the Austrian School System, Salzburg, Austria; \email{a.robitzsch@bifie.at}) -Craig Enders (Arizona State University; \email{Craig.Enders@asu.edu}) -Mauricio Garnier Villarreal (University of Kansas; \email{mgv@ku.edu}) -Yves Rosseel (Ghent University; \email{Yves.Rosseel@UGent.be}) -} -\examples{ -\dontrun{ -library(lavaan) - -HS.model <- ' visual =~ x1 + x2 + x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + x8 + x9 ' - -HSMiss <- HolzingerSwineford1939[,paste("x", 1:9, sep="")] -randomMiss <- rbinom(prod(dim(HSMiss)), 1, 0.1) -randomMiss <- matrix(as.logical(randomMiss), nrow=nrow(HSMiss)) -HSMiss[randomMiss] <- NA - -out <- cfa.mi(HS.model, data=HSMiss, m = 3, chi="all") -summary(out) -inspect(out, "fit") -inspect(out, "impute") - -##Multiple group example -HSMiss2 <- cbind(HSMiss, school = HolzingerSwineford1939[,"school"]) -out2 <- cfa.mi(HS.model, data=HSMiss2, m = 3, miArgs=list(noms="school"), chi="MR", group="school") -summary(out2) -inspect(out2, "fit") -inspect(out2, "impute") - -##Example using previously imputed data with runMI -library(Amelia) - -modsim <- ' -f1 =~ 0.7*y1+0.7*y2+0.7*y3 -f2 =~ 0.7*y4+0.7*y5+0.7*y6 -f3 =~ 0.7*y7+0.7*y8+0.7*y9' - -mod <- ' -f1 =~ y1+y2+y3 -f2 =~ y4+y5+y6 -f3 =~ y7+y8+y9' - -datsim <- simulateData(modsim,model.type="cfa", meanstructure=TRUE, - std.lv=TRUE, sample.nobs=c(200,200)) -randomMiss2 <- rbinom(prod(dim(datsim)), 1, 0.1) -randomMiss2 <- matrix(as.logical(randomMiss2), nrow=nrow(datsim)) -datsim[randomMiss2] <- NA -datsimMI <- amelia(datsim,m=3, noms="group") - -out3 <- runMI(mod, data=datsimMI$imputations, chi="LMRR", group="group", fun="cfa") -summary(out3) -inspect(out3, "fit") -inspect(out3, "impute") - -# Categorical variables -popModel <- " -f1 =~ 0.6*y1 + 0.6*y2 + 0.6*y3 + 0.6*y4 -y1 ~*~ 1*y1 -y2 ~*~ 1*y2 -y3 ~*~ 1*y3 -y4 ~*~ 1*y4 -f1 ~~ 1*f1 -y1 | 0.5*t1 -y2 | 0.25*t1 -y3 | 0*t1 -y4 | -0.5*t1 -" -analyzeModel <- " -f1 =~ y1 + y2 + y3 + y4 -y1 ~*~ 1*y1 -y2 ~*~ 1*y2 -y3 ~*~ 1*y3 -y4 ~*~ 1*y4 -" -dat <- simulateData(popModel, sample.nobs = 200L) -miss.pat <- matrix(as.logical(rbinom(prod(dim(dat)), 1, 0.2)), nrow(dat), ncol(dat)) -dat[miss.pat] <- NA -out5 <- cfa.mi(analyzeModel, data=dat, ordered=paste0("y", 1:4), m = 3, - miArgs=list(ords = c("y1", "y2", "y3", "y4"))) -summary(out5) -inspect(out5, "fit") -inspect(out5, "impute") - -} -} +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/runMI.R +\name{runMI} +\alias{runMI} +\alias{lavaan.mi} +\alias{cfa.mi} +\alias{sem.mi} +\alias{growth.mi} +\alias{lavaan.mi} +\alias{cfa.mi} +\alias{sem.mi} +\alias{growth.mi} +\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 lavaan +\code{\link[lavaan]{model.syntax}} or a parameter table (as returned by +\code{\link[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 +\code{@DataList} slot, so \code{data} can also be a \code{lavaan.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 +\code{model} to \code{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}} or +\code{\link[lavaan]{lavaanList}}. See also \code{\link[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 +\code{data} is already a \code{list} of imputed data sets or a +\code{lavaan.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 \code{data} is already a \code{list} of imputed data sets +or a \code{lavaan.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 a +\code{lavaan.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 a \code{lavaan.mi} object.} +} +\value{ +A \code{\linkS4class{lavaan.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{ + \dontrun{ +## 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 +' + +## impute data within runMI... +out1 <- cfa.mi(HS.model, data = HSMiss, m = 20, seed = 12345, + miArgs = list(noms = "school")) + +## ... or impute missing data first +library(Amelia) +set.seed(12345) +HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +imps <- HS.amelia$imputations +out2 <- cfa.mi(HS.model, data = imps) + +## same results (using the same seed results in the same imputations) +cbind(impute.within = coef(out1), impute.first = coef(out2)) + +summary(out1) +summary(out1, ci = FALSE, fmi = TRUE, add.attributes = FALSE) +summary(out1, ci = FALSE, stand = TRUE, rsq = TRUE) + +## model fit. D3 includes information criteria +anova(out1) +anova(out1, test = "D2", indices = TRUE) # request D2 and fit indices + + + +## fit multigroup model without invariance constraints +mgfit1 <- cfa.mi(HS.model, data = imps, estimator = "mlm", group = "school") +## add invariance constraints, and use previous fit as "data" +mgfit0 <- cfa.mi(HS.model, data = mgfit1, estimator = "mlm", group = "school", + group.equal = c("loadings","intercepts")) + +## compare fit (scaled likelihood ratio test) +anova(mgfit0, h1 = mgfit1) + +## correlation residuals +resid(mgfit0, type = "cor.bentler") + + +## use D1 to test a parametrically nested model (whether latent means are ==) +anova(mgfit0, test = "D1", constraints = ' + .p70. == 0 + .p71. == 0 + .p72. == 0') + + + +## ordered-categorical data +data(datCat) +lapply(datCat, class) +## impose missing values +set.seed(123) +for (i in 1:8) datCat[sample(1:nrow(datCat), size = .1*nrow(datCat)), i] <- NA + +catout <- cfa.mi(' f =~ u1 + u2 + u3 + u4 ', data = datCat, + m = 3, seed = 456, + miArgs = list(ords = paste0("u", 1:8), noms = "g"), + FUN = function(fit) { + list(wrmr = lavaan::fitMeasures(fit, "wrmr"), + zeroCells = lavaan::lavInspect(fit, "zero.cell.tables")) + }) +summary(catout) +anova(catout, indices = "all") # note the scaled versions of indices, too + +## extract custom output +sapply(catout@funList, function(x) x$wrmr) # WRMR for each imputation +catout@funList[[1]]$zeroCells # zero-cell tables for first imputation +catout@funList[[2]]$zeroCells # zero-cell tables for second imputation ... + +} + +} +\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. +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/saturateMx.Rd r-cran-semtools-0.5.0/man/saturateMx.Rd --- r-cran-semtools-0.4.14/man/saturateMx.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/saturateMx.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -\name{saturateMx} -\alias{saturateMx} -\title{ - Analyzing data using a saturate model -} -\description{ - Analyzing data using a saturate model by full-information maximum likelihood. In the saturate model, all means and covariances are free if items are continuous. For ordinal variables, their means are fixed as 0 and their variances are fixed as 1--their covariances and thresholds are estimated. In multiple-group model, all means are variances are separately estimated. -} -\usage{ -saturateMx(data, groupLab = NULL) -} -\arguments{ - \item{data}{ - The target data frame -} - \item{groupLab}{ - The name of grouping variable - } -} -\value{ - The \code{MxModel} object which contains the analysis result of the saturate model. -} -\seealso{ - \code{\link{nullMx}}, \code{\link{fitMeasuresMx}}, \code{\link{standardizeMx}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -\dontrun{ -library(OpenMx) -data(demoOneFactor) -satModel <- saturateMx(demoOneFactor) -} -} diff -Nru r-cran-semtools-0.4.14/man/semTools-deprecated.Rd r-cran-semtools-0.5.0/man/semTools-deprecated.Rd --- r-cran-semtools-0.4.14/man/semTools-deprecated.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/semTools-deprecated.Rd 2018-06-27 12:30:54.000000000 +0000 @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/lisrel2lavaan.R, R/semTools-deprecated.R, +% R/standardizeMx.R +\name{lisrel2lavaan} +\alias{lisrel2lavaan} +\alias{semTools-deprecated} +\alias{standardizeMx} +\title{Deprecated functions in package \pkg{semTools}.} +\usage{ +lisrel2lavaan(filename = NULL, analyze = TRUE, silent = FALSE, ...) + +standardizeMx(object, free = TRUE) +} +\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{\code{lisrel2lavaan}}{ + +The \code{lisrel2lavaan} function will no longer be supported, nor will +there be a replacement function. +} + +\section{\code{standardizeMx}}{ + +The \code{standardizeMx} and \code{fitMeasuresMx} functions will no longer +be supported, nor will there be replacement functions. Their functionality +is now available in the \pkg{OpenMx} package, making these functions +obsolete. The utility functions \code{nullMx} and \code{saturateMx} will +also no longer be supported. These have already been removed from +\pkg{semTools}, except that \code{standardizeMx} remains deprecated due to +the temporary depndency on it of the \pkg{semPlot} package. The exception +is that \code{\link[OpenMx]{mxStandardizeRAMpaths}} currently only provides +standardized estimates of covariance-structure parameters, whereas +\code{standardizeMx} also provides standardized means. +} + +\keyword{internal} diff -Nru r-cran-semtools-0.4.14/man/semTools.Rd r-cran-semtools-0.5.0/man/semTools.Rd --- r-cran-semtools-0.4.14/man/semTools.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/semTools.Rd 2018-06-26 12:13:58.000000000 +0000 @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/semTools.R +\docType{package} +\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}}, + \code{\link{nullRMSEA}}, + \code{\link{singleParamTest}}, + \code{\link{miPowerFit}}, and + \code{\link{chisqSmallN}}} +\item{Measurement Invariance: + \code{\link{measurementInvariance}}, + \code{\link{measurementInvarianceCat}}, + \code{\link{longInvariance}}, + \code{\link{partialInvariance}}, + \code{\link{partialInvarianceCat}}, and + \code{\link{permuteMeasEq}}} +\item{Power Analysis: + \code{\link{SSpower}}, + \code{\link{findRMSEApower}}, + \code{\link{plotRMSEApower}}, + \code{\link{plotRMSEAdist}}, + \code{\link{findRMSEAsamplesize}}, + \code{\link{findRMSEApowernested}}, + \code{\link{plotRMSEApowernested}}, and + \code{\link{findRMSEAsamplesizenested}}} +\item{Missing Data Analysis: + \code{\link{auxiliary}}, + \code{\link{runMI}}, + \code{\link{twostage}}, + \code{\link{fmi}}, + \code{\link{bsBootMiss}}, + \code{\link{quark}}, and + \code{\link{combinequark}}} +\item{Latent Interactions: + \code{\link{indProd}}, + \code{\link{orthogonalize}}, + \code{\link{probe2WayMC}}, + \code{\link{probe3WayMC}}, + \code{\link{probe2WayRC}}, + \code{\link{probe3WayRC}}, and + \code{\link{plotProbe}}} +\item{Exploratory Factor Analysis (EFA): + \code{\link{efa.ekc}}, + \code{\link{efaUnrotate}}, + \code{\link{orthRotate}}, + \code{\link{oblqRotate}}, and + \code{\link{funRotate}}} +\item{Reliability Estimation: + \code{\link{reliability}}, + \code{\link{reliabilityL2}}, and + \code{\link{maximalRelia}}} +\item{Parceling: + \code{\link{parcelAllocation}}, + \code{\link{PAVranking}}, and + \code{\link{poolMAlloc}}} +\item{Non-Normality: + \code{\link{skew}}, + \code{\link{kurtosis}}, + \code{\link{mardiaSkew}}, + \code{\link{mardiaKurtosis}}, and + \code{\link{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")} +} diff -Nru r-cran-semtools-0.4.14/man/simParcel.Rd r-cran-semtools-0.5.0/man/simParcel.Rd --- r-cran-semtools-0.4.14/man/simParcel.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/simParcel.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,40 +1,40 @@ -\name{simParcel} -\alias{simParcel} -\title{ -Simulated Data set to Demonstrate Random Allocations of Parcels -} -\description{ -A simulated data set with 2 factors with 9 indicators for each factor -} -\usage{ -data(simParcel) -} -\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 was generated using the \code{simsem} package. -} -\examples{ -head(simParcel) -} \ No newline at end of file +% 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} diff -Nru r-cran-semtools-0.4.14/man/singleParamTest.Rd r-cran-semtools-0.5.0/man/singleParamTest.Rd --- r-cran-semtools-0.4.14/man/singleParamTest.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/singleParamTest.Rd 2018-06-25 21:57:01.000000000 +0000 @@ -1,70 +1,100 @@ -\name{singleParamTest} -\alias{singleParamTest} -\title{ - Single Parameter Test Divided from Nested Model Comparison -} -\description{ - In comparing two nested models, chi-square 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. -} -\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}} for available options} -} -\details{ -This function first identify the differences between these two models. The model with more free parameters is referred to as parent model and the model with less free parameters is referred to as nested model. Three 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 free. 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, two parameters are equally 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. -} -\value{ - If \code{return.fit = FALSE}, the result tables are provided. Chi-square and p-value are provided for all methods. Note that the chi-square is all based on 1 degree of freedom. 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. -} -\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(HW.model, data=HolzingerSwineford1939, group="school") -singleParamTest(models[[1]], models[[2]]) - -# Note that the comparison between weak (Model 2) and scalar invariance (Model 3) cannot be done -# by this function # because the weak invariance model fixes factor means as 0 in Group 2 but -# the strong invariance model frees the factor means in Group 2. Users may try to compare -# strong (Model 3) and means invariance models by this function. -} +% 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}} 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 identify the differences between these two models. The +model with more free parameters is referred to as parent model and the model +with less free parameters is referred to as nested model. Three 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 free. 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 weak (Model 2) and scalar invariance +## (Model 3) cannot be done by this function # because the weak invariance +## model fixes factor means as 0 in Group 2 but the strong invariance model +## frees the factor means in Group 2. Users may try to compare +## strong (Model 3) and means invariance models by this function. + +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/skew.Rd r-cran-semtools-0.5.0/man/skew.Rd --- r-cran-semtools-0.4.14/man/skew.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/skew.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,57 +1,64 @@ -\name{skew} -\alias{skew} -\title{ - Finding skewness -} -\description{ - Finding skewness (g1) of an object -} -\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} -} -\details{ - The skewness computed is g1. The parameter skewness \eqn{\gamma_{2}} formula is - - \deqn{\gamma_{2} = \frac{\mu_{3}}{\mu^{3/2}_{2}},} - - 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_{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}_2) = \frac{6}{N}} - - where \eqn{N} is the sample size. -} -\references{ -Weisstein, Eric W. (n.d.). \emph{Skewness.} Retrived from MathWorld--A Wolfram Web Resource \url{http://mathworld.wolfram.com/Skewness.html} -} -\seealso{ - \itemize{ - \item \code{\link{kurtosis}} Find the univariate excessive kurtosis of a variable - \item \code{\link{mardiaSkew}} Find the Mardia's multivariate skewness of a set of variables - \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate kurtosis of a set of variables - } -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -skew(1:5) -} +% 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 is \eqn{g_{1}}. The parameter skewness \eqn{\gamma_{2}} +formula is + +\deqn{\gamma_{2} = \frac{\mu_{3}}{\mu^{3/2}_{2}},} + +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_{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}_2) = \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}} Find the univariate excessive kurtosis + of a variable + \item \code{\link{mardiaSkew}} Find Mardia's multivariate skewness + of a set of variables + \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate + kurtosis of a set of variables + } +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/splitSample.rd r-cran-semtools-0.5.0/man/splitSample.rd --- r-cran-semtools-0.4.14/man/splitSample.rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/splitSample.rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -\name{splitSample} -\alias{splitSample} -\title{ -Randomly Split a Data Set into Halves -} -\description{ -This function randomly splits a data set into two halves, and saves the resulting data sets to the same folder as the original. -} -\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 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".)} -} -\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 .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. -} -\value{ -\item{dataL}{List of output data sets. ONLY IF dataset is an R object and path is default. Otherwise, output will saved to hard drive with the same formatting 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" -} diff -Nru r-cran-semtools-0.4.14/man/splitSample.Rd r-cran-semtools-0.5.0/man/splitSample.Rd --- r-cran-semtools-0.4.14/man/splitSample.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/splitSample.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -0,0 +1,78 @@ +% 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 *.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}) +} diff -Nru r-cran-semtools-0.4.14/man/SSpower.Rd r-cran-semtools-0.5.0/man/SSpower.Rd --- r-cran-semtools-0.4.14/man/SSpower.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/SSpower.Rd 2018-05-03 15:15:37.000000000 +0000 @@ -1,87 +1,131 @@ -\name{SSpower} -\alias{SSpower} -\title{ - Power for model parameters -} -\description{ -Determines power for model parameters using the Satorra & Sarris (1985) method -} -\usage{ -SSpower(popModel, n, powerModel, fun = "cfa", nparam = 1, alpha = .05, ...) -} -\arguments{ -\item{popModel}{ - lavaan syntax for the population model. This model should specify population values for all paramters in the model. -} -\item{n}{ - Sample size used in power calculation -} -\item{powerModel}{ - lavaan syntax for the model to be analyzed. This syntax should have the parameter(s) of interest fixed to 0 (or some other number). -} - \item{fun}{ - The character of the function name used in running lavaan model (\code{"cfa"}, \code{"sem"}, \code{"growth"}, \code{"lavaan"}). -} -\item{nparam}{ - The number of parameters one is constrained in \code{powerModel}. -} -\item{alpha}{ - The Type I error rate used to assess power -} - \item{...}{ - Other arguments to be passed to the specified lavaan function (\code{"cfa"}, \code{"sem"}, \code{"growth"}, \code{"lavaan"}). -} -} - -\author{ - Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) -} -\references{ -Satorra, A., & Saris, W. E. (1985). Power of the likelihood ratio test in covariance structure analysis. \emph{Psychometrika, 50}, 83-90.} - -\examples{ -library(lavaan) - -#Specify population values. Note every paramter 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 model to be analyzed. Note parameter of interest f1~~f2 is fixed to 0. -modelA <- ' - f1 =~ V1 + V2 + V3 + V4 - f2 =~ V5 + V6 + V7 + V8 - - f1 ~~ 0*f2 - - - ' - - -SSpower(modelP, 150, modelA, std.lv=TRUE) - -##Get power for a range of values - -Ns <- seq(100, 500, 40) -powVals <- rep(NA, length(Ns)) -for(i in 1:length(Ns)){ -powVals[i] <- SSpower(modelP, Ns[i], modelA) -} -plot(Ns, powVals, type = 'l') - -} - +% 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 = "cfa", + alpha = 0.05, ...) +} +\arguments{ +\item{powerModel}{lavaan \code{\link[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.} + +\item{nparam}{\code{integer}. Number of invalid constraints in \code{powerModel}.} + +\item{popModel}{lavaan \code{\link[lavaan]{model.syntax}} specifying the +data-generating model. This syntax should specify values for all nonzero +paramters in the model. If \code{length(n) > 1}, the same population +values will be used for each group. Different population values per group +can only be specified by utilizing \code{Sigma} (and \code{mu}).} + +\item{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 +\code{mu} and \code{popModel} are missing, mean structure will be excluded +from the analysis.} + +\item{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.} + +\item{fun}{character. Name of 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}}.} +} +\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 constrains at least +one nonzero parameter to an incorrect value. Note the number in the +\code{nparam} argument. +} +\examples{ +## Specify population values. Note every paramter 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") + +## Specify second population to calculate power for multigroup model + +popMoments1 <- fitted(cfa(modelP)) +modelP2 <- ' + f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 + f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 + f1 ~~ .5*f2 ## higher correlation in Group 2 + 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 +' +popMoments2 <- fitted(cfa(modelP2)) +modelA2 <- ' + f1 =~ V1 + V2 + V3 + V4 + f2 =~ V5 + V6 + V7 + V8 + f1 ~~ c(0, 0)*f2 +' +mu <- list(popMoments1$mean, popMoments2$mean) +Sigma <- list(popMoments1$cov, popMoments2$cov) +SSpower(powerModel = modelA2, mu = mu, Sigma = Sigma, + n = c(60, 65), nparam = 2) + +} +\references{ +Satorra, A., & Saris, W. E. (1985). Power of the likelihood ratio + test in covariance structure analysis. \emph{Psychometrika, 50}, 83--90. + doi:10.1007/BF02294150 +} +\author{ +Alexander M. Schoemann (East Carolina University; \email{schoemanna@ecu.edu}) + +Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/standardizeMx-deprecated.Rd r-cran-semtools-0.5.0/man/standardizeMx-deprecated.Rd --- r-cran-semtools-0.4.14/man/standardizeMx-deprecated.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/standardizeMx-deprecated.Rd 2018-06-27 12:03:35.000000000 +0000 @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/standardizeMx.R +\name{standardizeMx-deprecated} +\alias{standardizeMx-deprecated} +\title{Find standardized estimates for OpenMx output} +\usage{ +standardizeMx(object, free = TRUE) +} +\arguments{ +\item{object}{Target OpenMx output using \code{MxRAMObjective}} + +\item{free}{If \code{TRUE}, the function will show only standardized values +of free parameters. If \code{FALSE}, the function will show the results for +fixed and free parameters.} +} +\value{ +A vector of standardized estimates +} +\description{ +Find standardized estimates for OpenMx output. This function is applicable +for the \code{MxRAMObjective} only. +} +\examples{ + +\dontrun{ +library(OpenMx) +data(myFADataRaw) +myFADataRaw <- myFADataRaw[,c("x1","x2","x3","x4","x5","x6")] +oneFactorModel <- mxModel("Common Factor Model Path Specification", + type="RAM", + mxData( + observed=myFADataRaw, + type="raw" + ), + manifestVars=c("x1","x2","x3","x4","x5","x6"), + latentVars="F1", + mxPath(from=c("x1","x2","x3","x4","x5","x6"), + arrows=2, + free=TRUE, + values=c(1,1,1,1,1,1), + labels=c("e1","e2","e3","e4","e5","e6") + ), + # residual variances + # ------------------------------------- + mxPath(from="F1", + arrows=2, + free=TRUE, + values=1, + labels ="varF1" + ), + # latent variance + # ------------------------------------- + mxPath(from="F1", + to=c("x1","x2","x3","x4","x5","x6"), + arrows=1, + free=c(FALSE,TRUE,TRUE,TRUE,TRUE,TRUE), + values=c(1,1,1,1,1,1), + labels =c("l1","l2","l3","l4","l5","l6") + ), + # factor loadings + # ------------------------------------- + mxPath(from="one", + to=c("x1","x2","x3","x4","x5","x6","F1"), + arrows=1, + free=c(TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,FALSE), + values=c(1,1,1,1,1,1,0), + labels =c("meanx1","meanx2","meanx3","meanx4","meanx5","meanx6",NA) + ) + # means + # ------------------------------------- +) # close model +# Create an MxModel object +# ----------------------------------------------------------------------------- +oneFactorFit <- mxRun(oneFactorModel) +standardizeMx(oneFactorFit) + +# Compare with lavaan +library(lavaan) +script <- "f1 =~ x1 + x2 + x3 + x4 + x5 + x6" +fit <- cfa(script, data=myFADataRaw, meanstructure=TRUE) +standardizedSolution(fit) +} + +} +\seealso{ +\code{\link{semTools-deprecated}} +} +\author{ +Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) +} +\keyword{internal} diff -Nru r-cran-semtools-0.4.14/man/standardizeMx.Rd r-cran-semtools-0.5.0/man/standardizeMx.Rd --- r-cran-semtools-0.4.14/man/standardizeMx.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/standardizeMx.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -\name{standardizeMx} -\alias{standardizeMx} -\title{ - Find standardized estimates for OpenMx output -} -\description{ - Find standardized estimates for OpenMx output. This function is applicable for the \code{MxRAMObjective} only. -} -\usage{ -standardizeMx(object, free = TRUE) -} -\arguments{ - \item{object}{ - Target OpenMx output using \code{MxRAMObjective} -} - \item{free}{ - If \code{TRUE}, the function will show only standardized values of free parameters. If \code{FALSE}, the function will show the results for fixed and free parameters. - } -} -\value{ - A vector of standardized estimates -} -\seealso{ - \code{\link{saturateMx}}, \code{\link{nullMx}}, \code{\link{fitMeasuresMx}} -} -\author{ - Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -\dontrun{ -library(OpenMx) -data(myFADataRaw) -myFADataRaw <- myFADataRaw[,c("x1","x2","x3","x4","x5","x6")] -oneFactorModel <- mxModel("Common Factor Model Path Specification", - type="RAM", - mxData( - observed=myFADataRaw, - type="raw" - ), - manifestVars=c("x1","x2","x3","x4","x5","x6"), - latentVars="F1", - mxPath(from=c("x1","x2","x3","x4","x5","x6"), - arrows=2, - free=TRUE, - values=c(1,1,1,1,1,1), - labels=c("e1","e2","e3","e4","e5","e6") - ), - # residual variances - # ------------------------------------- - mxPath(from="F1", - arrows=2, - free=TRUE, - values=1, - labels ="varF1" - ), - # latent variance - # ------------------------------------- - mxPath(from="F1", - to=c("x1","x2","x3","x4","x5","x6"), - arrows=1, - free=c(FALSE,TRUE,TRUE,TRUE,TRUE,TRUE), - values=c(1,1,1,1,1,1), - labels =c("l1","l2","l3","l4","l5","l6") - ), - # factor loadings - # ------------------------------------- - mxPath(from="one", - to=c("x1","x2","x3","x4","x5","x6","F1"), - arrows=1, - free=c(TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,FALSE), - values=c(1,1,1,1,1,1,0), - labels =c("meanx1","meanx2","meanx3","meanx4","meanx5","meanx6",NA) - ) - # means - # ------------------------------------- -) # close model -# Create an MxModel object -# ----------------------------------------------------------------------------- -oneFactorFit <- mxRun(oneFactorModel) -standardizeMx(oneFactorFit) - -# Compare with lavaan -library(lavaan) -script <- "f1 =~ x1 + x2 + x3 + x4 + x5 + x6" -fit <- cfa(script, data=myFADataRaw, meanstructure=TRUE) -standardizedSolution(fit) -} -} diff -Nru r-cran-semtools-0.4.14/man/tukeySEM.rd r-cran-semtools-0.5.0/man/tukeySEM.rd --- r-cran-semtools-0.4.14/man/tukeySEM.rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/tukeySEM.rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -\name{tukeySEM} -\alias{tukeySEM} -\title{ -Tukey's WSD post-hoc test of means for unequal variance and sample size -} -\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. -} -\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).} -} -\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. -} -\value{ -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, degrees of freedom and the total number of groups to be compared - } -} -\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}) -} - -\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) -} diff -Nru r-cran-semtools-0.4.14/man/tukeySEM.Rd r-cran-semtools-0.5.0/man/tukeySEM.Rd --- r-cran-semtools-0.4.14/man/tukeySEM.Rd 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/man/tukeySEM.Rd 2018-05-03 15:15:38.000000000 +0000 @@ -0,0 +1,72 @@ +% 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}) +} diff -Nru r-cran-semtools-0.4.14/man/twostage-class.Rd r-cran-semtools-0.5.0/man/twostage-class.Rd --- r-cran-semtools-0.4.14/man/twostage-class.Rd 2016-10-17 15:36:14.000000000 +0000 +++ r-cran-semtools-0.5.0/man/twostage-class.Rd 2018-06-26 12:19:09.000000000 +0000 @@ -1,53 +1,165 @@ -\name{twostage-class} -\docType{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 -} -\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 \code{\linkS4class{lavaan}} methods. -} -\section{Objects from the Class}{ - Objects can be created via the \code{\link{twostage}} function. -} -\section{Slots}{ - \describe{ - \item{\code{saturated}:}{A fitted \code{\linkS4class{lavaan}} object containing the saturated model results.} - \item{\code{target}:}{A fitted \code{\linkS4class{lavaan}} object containing the target/hypothesized model results.} - \item{\code{baseline}:}{A fitted \code{\linkS4class{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{methods}{ - \describe{ - \item{anova}{\code{signature(object = "twostage", h1 = NULL, baseline = FALSE:} The \code{anova} function returns the residual-based chi-squared test statistic result, as well as the scaled chi-squared 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 chi-squared difference test results, under the assumption that the models are nested. The models will be automatically sorted according their degrees of freedom.} - \item{show}{\code{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}{\code{signature(object = "twostage", ...):} The summary function prints the same information from the \code{show} method, but also provides (and returns) the output of \code{\link[lavaan]{parameterEstimates}(object@target, ...)} with corrected \emph{SE}s, test statistics, and confidence intervals. Additional arguments can be passed to \code{\link[lavaan]{parameterEstimates}}, including \code{fmi = TRUE} to provide an estimate of the fraction of missing information.} - \item{vcov}{\code{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{nobs}{\code{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}{\code{signature(object = "twostage", type = c("free", "user"):} This is simply a wrapper around the corresponding \code{\linkS4class{lavaan}} method, providing point estimates from the \code{target} slot.} - \item{fitted.values}{\code{signature(object = "twostage", model = c("target", "saturated", "baseline"):} This is simply a wrapper around the corresponding \code{\linkS4class{lavaan}} method, providing model-implied sample moments from the slot specified in the \code{model} argument.} - \item{fitted}{\code{signature(object = "twostage", model = c("target", "saturated", "baseline"):} an alias for \code{fitted.values}.} - \item{residuals}{\code{signature(object = "twostage", type = c("raw", "cor", "normalized", "standardized"):} This is simply a wrapper around the corresponding \code{\linkS4class{lavaan}} method, providing residuals of the specified \code{type} from the \code{target} slot.} - \item{resid}{\code{signature(object = "twostage", model = c("raw", "cor", "normalized", "standardized"):} an alias for \code{residuals}.} - } -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\seealso{ -\code{\link{twostage}} -} -\examples{ -# See the example from the twostage function -} +% 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} +\alias{show,twostage-method} +\alias{summary,twostage-method} +\alias{anova,twostage-method} +\alias{nobs,twostage-method} +\alias{coef,twostage-method} +\alias{vcov,twostage-method} +\alias{fitted.values,twostage-method} +\alias{fitted,twostage-method} +\alias{residuals,twostage-method} +\alias{resid,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}}.} + +\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 \bold{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 \bold{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}{\code{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}{\code{signature(object = "twostage", ...):} The summary + function prints the same information from the \code{show} method, but also + provides (and returns) the output of + \code{\link[lavaan]{parameterEstimates}(object@target, ...)} with corrected + \emph{SE}s, test statistics, and confidence intervals. Additional + arguments can be passed to \code{\link[lavaan]{parameterEstimates}}, + including \code{fmi = TRUE} to provide an estimate of the fraction of + missing information.} + \item{anova}{\code{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}{\code{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}{\code{signature(object = "twostage", type = c("free", "user")):} + This is simply a wrapper around the corresponding + \code{\linkS4class{lavaan}} method, providing point estimates from the + \code{target} slot.} + \item{vcov}{\code{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}{\code{signature(object = "twostage", + model = c("target", "saturated", "baseline")):} This is simply a wrapper + around the corresponding \code{\linkS4class{lavaan}} method, providing + model-implied sample moments from the slot specified in the \code{model} + argument.} + \item{residuals, resid}{\code{signature(object = "twostage", type = c("raw", + "cor", "normalized", "standardized")):} This is simply a wrapper around the + corresponding \code{\linkS4class{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 \code{\linkS4class{lavaan}} +methods. +} +\section{Slots}{ + +\describe{ +\item{\code{saturated}}{A fitted \code{\linkS4class{lavaan}} object containing the +saturated model results} + +\item{\code{target}}{A fitted \code{\linkS4class{lavaan}} object containing the +target/hypothesized model results} + +\item{\code{baseline}}{A fitted \code{\linkS4class{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}} function. +} + +\examples{ + +# See the example from the twostage function + +} +\seealso{ +\code{\link{twostage}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/twostage.Rd r-cran-semtools-0.5.0/man/twostage.Rd --- r-cran-semtools-0.4.14/man/twostage.Rd 2016-10-17 12:36:59.000000000 +0000 +++ r-cran-semtools-0.5.0/man/twostage.Rd 2018-05-03 15:15:36.000000000 +0000 @@ -1,92 +1,146 @@ -\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. -} -\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). - - 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}}, this function will automatically set \code{meanstructure = TRUE}, \code{estimator = "ML"}, \code{missing = "fiml"}, and \code{test = "standard"}. \code{\link[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. -} -\usage{ -twostage(..., aux, fun, baseline.model = NULL) -cfa.2stage(..., aux = NULL, baseline.model = NULL) -sem.2stage(..., aux = NULL, baseline.model = NULL) -growth.2stage(..., aux = NULL, baseline.model = NULL) -lavaan.2stage(..., aux = NULL, baseline.model = NULL) -} -\arguments{ - \item{\dots}{ - Arguments passed to the \code{\link[lavaan]{lavaan}} function specified in the \code{fun} argument. At a minimum, the user must supply the first two named arguments to \code{\link[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}} 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 \code{\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 \code{\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 \code{\linkS4class{twostage}} to extract corrected \emph{SE}s and test statistics. -} -\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{ - \code{\linkS4class{twostage}} -} -\author{ - Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) -} -\examples{ - -## set some example data missing at random -dat1 <- HolzingerSwineford1939 -dat1$x5 <- ifelse(dat1$x1 <= quantile(dat1$x1, .3), NA, dat1$x5) -dat1$age <- dat1$ageyr + dat1$agemo/12 -dat1$x9 <- ifelse(dat1$age <= quantile(dat1$age, .3), NA, dat1$x9) - -## fit CFA model from lavaan's ?cfa help page -model <- ' -visual =~ x1 + x2 + x3 -textual =~ x4 + x5 + x6 -speed =~ x7 + x8 + x9 -' -## use ageyr and agemo as auxiliary variables -out <- cfa.2stage(model = model, data = dat1, 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 = dat1, 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 - -} +% 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} +\alias{lavaan.2stage} +\alias{cfa.2stage} +\alias{sem.2stage} +\alias{growth.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}} function +specified in the \code{fun} argument. See also +\code{\link[lavaan]{lavOptions}}. At a minimum, the user must supply the +first two named arguments to \code{\link[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}} 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 \code{\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 \code{\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 \code{\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}}, +this function will automatically set \code{meanstructure = TRUE}, +\code{estimator = "ML"}, \code{missing = "fiml"}, and \code{test = +"standard"}. \code{\link[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{ +\code{\linkS4class{twostage}} +} +\author{ +Terrence D. Jorgensen (University of Amsterdam; +\email{TJorgensen314@gmail.com}) +} diff -Nru r-cran-semtools-0.4.14/man/wald.Rd r-cran-semtools-0.5.0/man/wald.Rd --- r-cran-semtools-0.4.14/man/wald.Rd 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/man/wald.Rd 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -\name{wald} -\alias{wald} -\title{ -Calculate multivariate Wald statistics -} -\description{ -Calculate multivariate Wald statistics based on linear combinations of model parameters -} -\usage{ -wald(object, syntax) -} -\arguments{ - \item{object}{An output from \code{lavaan}} - \item{syntax}{Syntax that each line represents one linear constraint. A plus or minus sign is used to separate between each coefficient. An asterisk is used to separate between coefficients and parameters. The coefficient can have a forward slash to represent a division. The parameter names must be matched with the names of lavaan parameters investigated by running the \code{coef} function on a lavaan output. Lines can be separated by semi-colon. A pound sign is allowed for comments. Note that the defined parameters (created by ":=") do not work with this function.} -} -\details{ -The formula for multivariate Wald test is - -\deqn{ \chi^2 = \left(C\hat{b}\right)^\prime\left[C\hat{V}C^\prime\right]^{-1}\left(C\hat{b}\right),} - -where \eqn{C} is the contrast matrix, \eqn{\hat{b}} is the estimated fixed effect, \eqn{\hat{V}} is the asymptotic covariance matrix among fixed effects. -} -\value{ -Chi-square value with \emph{p} value. -} -\author{ -Sunthud Pornprasertmanit (\email{psunthud@gmail.com}) -} -\examples{ -# Test the difference in factor loadings -library(lavaan) -HS.model <- ' visual =~ x1 + con1*x2 + con1*x3 - textual =~ x4 + x5 + x6 - speed =~ x7 + con2*x8 + con2*x9 ' - -fit <- cfa(HS.model, data=HolzingerSwineford1939) -wald(fit, "con2 - con1") - -# Simultaneously test the difference in the influences -# of x1 and x2 on intercept and slope -model.syntax <- ' - i =~ 1*t1 + 1*t2 + 1*t3 + 1*t4 - s =~ 0*t1 + 1*t2 + 2*t3 + 3*t4 - i ~ x1 + x2 - s ~ x1 + x2 - t1 ~ c1 - t2 ~ c2 - t3 ~ c3 - t4 ~ c4 -' - -fit2 <- growth(model.syntax, data=Demo.growth) -wald.syntax <- ' - i~x1 - i~x2 - 1/2*s~x1 - 1/2*s~x2 -' -wald(fit2, wald.syntax) - -# Mplus example of MODEL TEST -model3 <- ' f1 =~ x1 + p2*x2 + p3*x3 + p4*x4 + p5*x5 + p6*x6 - p4 == 2*p2' - -fit3 <- cfa(model3, data=HolzingerSwineford1939) -wald(fit3, "p3; p6 - 0.5*p5") -} diff -Nru r-cran-semtools-0.4.14/MD5 r-cran-semtools-0.5.0/MD5 --- r-cran-semtools-0.4.14/MD5 2016-10-22 17:06:27.000000000 +0000 +++ r-cran-semtools-0.5.0/MD5 2018-06-27 13:13:01.000000000 +0000 @@ -1,129 +1,135 @@ -875a3b26b1fe2b929b518453651c1444 *DESCRIPTION -6e8b868ee425d966510d021978baa8f4 *NAMESPACE -310920ad14c1132389790abb4990fce5 *R/NET.R -1de19b1c4637cda48fc16f9c9e685f82 *R/PAVranking.R -cbe816c8b97f2beec6e6723c6c59f122 *R/TSML.R -e956d6438ded241574448335de494eb6 *R/auxiliary.R -3f9c1fed2999e61a63e4e4d73d0c1913 *R/clipboard.R -1954f2fad1064b1c8b2f5932c557ff40 *R/compareFit.R -e902924f1c086d73e84c00476c2d4f52 *R/dataDiagnosis.R -93f4e9e1ee476d5710fa0c1b250cd1aa *R/efa.R -cd6f7b2fd8463a822d7910dbfb10ab72 *R/fitIndices.R -f8c84afdf152962238167427f0786ad2 *R/fitOpenMx.R -f04d1166e8c2f052cfe07b546b59518f *R/fmi.R -4316dbce195eb595a780b0e23e5c5a44 *R/htmt.R -05080e921acdfef731616afc936f955f *R/imposeStart.R -d2c267f412605b21c602689ac70c3b7a *R/indProd.R -0b3cb217de78ec40e0257184821c2980 *R/kd.R -0115c95b54d0d4d6df27e9fd9d194da6 *R/lisrel2lavaan.R -0c3a853ef650edde439661ba9a198af3 *R/loadingFromAlpha.R -d9610fd2f7a2d093c6add24d138540b4 *R/longInvariance.R -f78a87f068644a4f98c6cf5b5c86a873 *R/measurementInvariance.R -01e8377cc0ed4e42e5b95fd9468998f6 *R/measurementInvarianceCat.R -db826a05fcdc27b1d802d877334f9997 *R/miPowerFit.R -af20e44ed7512b1df96caac698727355 *R/missingBootstrap.R -6e6aa020023ba9c41ec493dc65bf5736 *R/monteCarloMed.R -bdfe2a592ba3e4095583a2f2f436f7ef *R/mvrnonnorm.R -07e6f5965634fb8c70fdfd5980df43f8 *R/parcelAllocation.R -9402a55a88552d635f0a84e15780ffe1 *R/partialInvariance.R -d9c1c95d9210b6e731ad5168e5cae11d *R/partialInvarianceCat.R -ada7d2fed73343a3e17eb66871de36e4 *R/permuteMeasEq.R -e8feb00445a9a27e21319d84b0632bfe *R/poolMAlloc.R -fed7a1e44769dbeb3e0dbdf111d75e65 *R/powerAnalysis.R -ee97b4a367f247d1a62c23d534320b77 *R/powerAnalysisNested.R -3b676e747ea08e121a123244e8eede3e *R/powerAnalysisSS.R -ed0ac285eb7c00dc5b60cd9db8f89794 *R/probeInteraction.R -0176a1b59771cad73def3e1e9934dafe *R/quark.R -3a9f6041660959fe18a21bfec482f0c5 *R/reliability.R -66fbcd194d75454c4e4e5ed47bd5c445 *R/residualCovariate.R -af8506899739e987bd9705a5b385fe9b *R/runMI.R -cca98371f1e860d10b0821e4bd549a4b *R/singleParamTest.R -e197f2d14cf82ba70a2de639c46ac921 *R/splitSample.R -5ebe2b6b09164210d8e7db37504a0597 *R/tukeySEM.R -55e1c48f9753406ad8ab3f5c086f0c04 *R/wald.R +a452af2c3ab4835bc8033c29ecf1979a *DESCRIPTION +56f1145dbd948fce4b1e59f4c39f1fd1 *NAMESPACE +a315fd6941777e1a222190f9ec1eb639 *R/EmpKaiser.R +2195fafb9d5821f050724aef19cff4cc *R/NET.R +7b8076b3de5750dc86ea9d1eedbe8de4 *R/PAVranking.R +5cd8d409cb1f56400a10cf53e1989603 *R/TSML.R +23bcd1d1ea969aba04480cf9b2c510eb *R/auxiliary.R +eb88cca001294e650191ee37666c84b3 *R/clipboard.R +840b30ddb664f0d5b1a5c53e6857faf9 *R/compareFit.R +4b16bdfc99f24e1ba4acb62d47d65c6e *R/data.R +783eb720e415c5043dbb054d815ccdb1 *R/dataDiagnosis.R +cb920fddcbb0b7022b059e6c8d6f80a5 *R/efa.R +7019040f405fc123b6244d084fcc7ee3 *R/fitIndices.R +fb6ceb7e9f60818e134cfe2137be7b95 *R/fmi.R +267dfc857c8c62f224064b834674dd0a *R/htmt.R +207208a2958321ac21b56cd53642c9b9 *R/imposeStart.R +17b39abad2c98349deb3dff49dfddd2f *R/indProd.R +84d5b351d498d611743c4f022275882d *R/kd.R +bd966e6dfeb5b1bc4da8e7aecc5fdd55 *R/lisrel2lavaan.R +664b1dee784db1f51dfc2b82984d21c4 *R/loadingFromAlpha.R +f8e1c30a5134617673fafa57ea1ac96f *R/longInvariance.R +c64e4ad7eea5075804958f61c032c3a7 *R/measurementInvariance.R +8caa9fb1ae46f8f785d6c85998ca3b71 *R/measurementInvarianceCat.R +4fe4d473ca94e2e72dc2fb480c699e1e *R/miPowerFit.R +88976f155732ba8b41745497b8288c47 *R/missingBootstrap.R +e197e63abd849ee2e9b53b7d1223ef81 *R/monteCarloMed.R +59765ff3d583e18fb6bd963b8a7ba5db *R/mvrnonnorm.R +ee62e0af4b39f6df3645a81aca747c16 *R/parcelAllocation.R +66e8aa7d44aa30690ef4da720fcf1a05 *R/partialInvariance.R +2eb38f3ebd1b230a12235c4229bdaf93 *R/permuteMeasEq.R +619d56d4811dd921700fbcd78d2dd7f7 *R/poolMAlloc.R +84466d80ede70183ed41a56b594fa86e *R/powerAnalysisNested.R +1726a14e353015b338ba1b1d4df21bf5 *R/powerAnalysisRMSEA.R +4aa17b4ce956271d2279ea9bd74ed4ea *R/powerAnalysisSS.R +7bf40542695805b8ff3f5dc7bda9117f *R/probeInteraction.R +679e7fb03e32ca52fd71ebac8d990111 *R/quark.R +c2875b0f6c3a28dd2429f0a09059d75f *R/reliability.R +2134c41427ab07a2bcd7db18ae4169a4 *R/residualCovariate.R +fd3af7ee1cbd62680ae13def527bb8ab *R/runMI-methods.R +14ce3a186860945c9d341102c24db907 *R/runMI-modification.R +0f8feb89dad94f8630cd3da9dda0f074 *R/runMI-score.R +e49a2987208cfecfbe46b31f72f5b03d *R/runMI.R +c0c9a902cab07c1c2646bc6866b3d763 *R/semTools-deprecated.R +97e8ea81fb2e2bc1fbee8ad62b20bfc4 *R/semTools.R +14a2f8556006017c12f77eff791224dc *R/singleParamTest.R +419f5f28bf8c448d5bf912d83af9576c *R/splitSample.R +d261a70e659957bd339699bcd99ac1d3 *R/standardizeMx.R +0d3de3b59b265e9321f823924cab79fa *R/tukeySEM.R 601d9cc4e9066fdc9f64dea1a68fa9c1 *R/zzz.R -356b4f195cdab4ad90aa68c9e36149ee *build/vignette.rds +0c88189a31f84f2c1c73bdc0d00143ba *build/vignette.rds 4d1090db8b160303f235075ebbda16d7 *data/dat2way.rda c56c2358c6e4d82c4cd7855e4df37282 *data/dat3way.rda d3f489a4fefd07ccfcd3875bc71e0b83 *data/datCat.rda ba21a4b5113fd7515fbf26fccfe0fe17 *data/exLong.rda 35cb60d186fd440645d81b56e22a3fa2 *data/simParcel.rda -24e62650eb20ada41123144a32d0f7c7 *inst/CITATION +6007534495c1aa447123794e3aa4541a *inst/CITATION 81dc319ba4e3739b20cbcd3196f00e1e *inst/doc/partialInvariance.Rnw 4f5891dc46f7212c1ce6189c4467adba *inst/doc/partialInvariance.bib -423b2dcd312ca2190fb90c21d50a0f02 *inst/doc/partialInvariance.pdf -051afce8bfe1f5850c9a928a4c211113 *man/BootMiss-class.Rd -789bb57cd701e69fa76d75664f42760a *man/EFA-class.Rd -3088e7c0e7b22cbdc83038b4c9d2eb93 *man/FitDiff-class.Rd -cf8ebe0461f358886c862819ff92e84d *man/Net-class.Rd -758acdd5f9e6d28060f1dc5b924f5aed *man/PAVranking.Rd -400d6c3328e9f845b4967b48e464aa3f *man/SSpower.Rd -2d64d6a37f591ecfd9002c639a968c10 *man/auxiliary.Rd -fb9a663d9c663742a32c1561ba09fe39 *man/bsBootMiss.Rd -8a2cf1cd89b514bb2238b6ac96b7727b *man/chisqSmallN.Rd -4b1bd4d6a3251465a1cf68b8246c0da5 *man/clipboard.Rd -a5ec84228b781300dfcde1d7c65f055f *man/combinequark.Rd -89e6fc45067caf0cc9af0db0e6b9d956 *man/compareFit.Rd -0652ec1f468f7d5b7fbaab93bbdb686b *man/dat2way.Rd -34151a790c2733b1a767c45bb53f69ce *man/dat3way.Rd -aa3fc3f7d78f11789afb3a9090565e63 *man/datCat.Rd -3d653edc46c76f7945bed07f1cd40306 *man/efaUnrotate.Rd -9f4002301d9bde6a1b7e0b34894a3585 *man/exLong.Rd -835661a7f893987d0eaa128aea9b9c35 *man/findRMSEApower.Rd -0c615412362d8657d03743351d22af52 *man/findRMSEApowernested.Rd -3a777bcdbcb0b0cf6a7cffee92af94e4 *man/findRMSEAsamplesize.Rd -ec1669651a06b492cc61f45386789ec9 *man/findRMSEAsamplesizenested.Rd -3a2a6e96669f9b9fb6a828953b4db536 *man/fitMeasuresMx.Rd -b6a3e2b6dfe6fe01a6b640dcf5c874f6 *man/fmi.Rd -8f6b842409cdfaa16c5768084b43c8e4 *man/htmt.Rd -5610302699505c139b905b4123f5835d *man/imposeStart.Rd -6c0258e5b0ad4b40bcdbfd92a1971fe3 *man/indProd.Rd -bc9f4f1a34a71effb92d3affac95e07d *man/kd.Rd -289810e0631423fdfa7e5b26e396e035 *man/kurtosis.Rd -2f9ee2abda674a63efde872967f77fe3 *man/lavaanStar-class.Rd -66e84e27e37a6bc50e413bb50d713fca *man/lisrel2lavaan.Rd -e2f1d5c0754e87cdf87032661828f259 *man/loadingFromAlpha.Rd -55942878a11ab359609e65862677ecad *man/longInvariance.Rd -df58577077bf9680e8decd1efbc64c19 *man/mardiaKurtosis.Rd -86d6177745e4b46ece1af0f9d36ac7a1 *man/mardiaSkew.Rd -58f35fbfb69dec2a8ab366f6c07a59bc *man/maximalRelia.Rd -fb1c235e431a1bfec644031e76019d1c *man/measurementInvariance.Rd -2c86eae80ea6061a3e982c01139130a7 *man/measurementInvarianceCat.Rd -5d7f84717c177eccc631a20eb04934b5 *man/miPowerFit.Rd -958cefe2370f406ff8d7f2be0b734bc5 *man/monteCarloMed.Rd -4c2bd94d158a06ede3ba4851ea76c9de *man/moreFitIndices.Rd -d4299fa9a1ddcf8375457f2a5034243d *man/mvrnonnorm.Rd -7dc60009699fac33154c94b5140d3b5c *man/net.Rd -1e338d43ce014a1c4056dd455cfa8c0e *man/nullMx.Rd -84dcdab468b85fb0c30d284deab74d93 *man/nullRmsea.Rd -7e0d75f2c92e277030a75e0c288910e7 *man/parcelAllocation.Rd -c791d5d02532bc40d11d1467f095b630 *man/partialInvariance.Rd -36a3a983da75072e64121559fca4bb97 *man/permuteMeasEq-class.Rd -5a5919d5715199454303c56a53bedc0e *man/permuteMeasEq.Rd -2a845d7afb0981de4a1af72dc0813008 *man/plotProbe.Rd -e553cfaa865d0843e9d9118632cbc9d6 *man/plotRMSEAdist.Rd -319bf923b4db20b7c468046d2b2f16bd *man/plotRMSEApower.Rd -dc2a73fdb1aa348f23ea0c8a5ca1d594 *man/plotRMSEApowernested.Rd -42f3e747345ab5eedb5fe1cadd83f10b *man/poolMAlloc.Rd -31d19c926b85f7911dc0228945ef85f9 *man/probe2WayMC.Rd -327ca9e06ece593ced47e82eb21b76d0 *man/probe2WayRC.Rd -9d8edeb8cd70c19d6a90b123216116ac *man/probe3WayMC.Rd -a26f32fde33328cdfb3591de3e59d17c *man/probe3WayRC.Rd -abbd314af9b687274821d2a76b0138bd *man/quark.Rd -1e3835c9587a78a1af4ce86a497e342f *man/reliability.Rd -b9d6698b2d7e616acbe47e7f2b9e12c7 *man/reliabilityL2.Rd -a6839cb39fadbc13478e12b19ee880fb *man/residualCovariate.Rd -ebec2c18f86b00ae485563c3a797145d *man/rotate.Rd -69dbae753e1b9dcc1787b98c7b24577d *man/runMI.Rd -a736a81c47c188ac312024124d48bc1b *man/saturateMx.Rd -629e0a71164edf949d2a4bad4a641381 *man/simParcel.Rd -830da4c698bf219103e106267a56203f *man/singleParamTest.Rd -a4ef14fd6ab8ee46694d51f527c4fb70 *man/skew.Rd -8aded169014b5c23c16759de4cbb685c *man/splitSample.rd -1de20b1661876f07945cf473c0b00777 *man/standardizeMx.Rd -48fbef830fc4370886705ea4f4f11d28 *man/tukeySEM.rd -76a1a8228891e906ce393d2e3aad7b46 *man/twostage-class.Rd -c06f7f5e182fdcfdb4fe8b080c6e6059 *man/twostage.Rd -b600ba526ceb1b7d6075fa3f16bb2db9 *man/wald.Rd +518ece4421edfda637f4a4cfe5c7c6d4 *inst/doc/partialInvariance.pdf +fd76b111692a41d00af44c48ce9dee44 *man/BootMiss-class.Rd +7611248df3a2ec4433b08ce10a0ac979 *man/EFA-class.Rd +2fa38a931d3ada4418a25077a2775175 *man/FitDiff-class.Rd +f55e1f896ab8999567ae07030c7535e2 *man/Net-class.Rd +7a9451d3808ac9860038ee118c441f83 *man/PAVranking.Rd +53b05d66d15f907d76ae55cf4caabb67 *man/SSpower.Rd +be848b48b50a4e52d2d367be432b3ad6 *man/auxiliary.Rd +87bd7afbdde890f0261847debe2b3a33 *man/bsBootMiss.Rd +9c3bc6b701dabe88dcf246df1cfc9bd0 *man/chisqSmallN.Rd +45326a4e0c0622502b5e86bd96fc5294 *man/clipboard.Rd +1a22a9680bcaa9e067c8b87897ccd599 *man/combinequark.Rd +21be804249f64aefc6936de261c31915 *man/compareFit.Rd +87d8dfd16001958f9bad5173ab7849e5 *man/dat2way.Rd +8baf94be188331f24d8a1b9a755099d9 *man/dat3way.Rd +7caebac3fb75bd814a66739edac00ab2 *man/datCat.Rd +933cdf0ea7295368b3bffff4fb3f335f *man/efa.ekc.Rd +92f17f362f2f61c17ac8da2d6a58c1ae *man/efaUnrotate.Rd +23e7e5897885b302aeb073a96c07f6b0 *man/exLong.Rd +3af65108f13aadd3a08d17115fc49181 *man/findRMSEApower.Rd +5a0089471644b62ac580de6051dfa24c *man/findRMSEApowernested.Rd +9d2abe8525ec494910aa3d604023ea3f *man/findRMSEAsamplesize.Rd +47d76341032d2417030f7b418d442333 *man/findRMSEAsamplesizenested.Rd +12fc749a8f7156bfb6d3b1ef965df8f3 *man/fmi.Rd +86882bdd901567cd6c89a736b909d6e1 *man/htmt.Rd +2148c4f4b424ba00c60ca1a5a4bd31aa *man/imposeStart.Rd +fdbfb6891510c3df70c888d9f24b15c3 *man/indProd.Rd +67247cf485048f89df95ce7d9f48ed41 *man/kd.Rd +ca41d4ff693ff79c09354a82f9e69690 *man/kurtosis.Rd +41677bf45f6da1c4fcf9ee9d1404a173 *man/lavTestScore.mi.Rd +2f7763c1befa566c191252f7bb67b97b *man/lavaan.mi-class.Rd +2a9660410575efe7a64a8a2c34320211 *man/lisrel2lavaan-deprecated.Rd +1832df1e479737c1bec483b4af43bd27 *man/loadingFromAlpha.Rd +2c0fff1aa95bad631adf97a3cbab03aa *man/longInvariance.Rd +e885c8b837b15b255824fa37fdd7bb9c *man/mardiaKurtosis.Rd +c03bd0924d4b7a4d8e6b8b8041a6b291 *man/mardiaSkew.Rd +8457d50e4adea91c1a3a201992942564 *man/maximalRelia.Rd +e16f5ef545a6078c5d050cd122dce810 *man/measurementInvariance.Rd +2b3adfb969be87f1a4e2e1b6ca39317f *man/measurementInvarianceCat.Rd +2e87d94b651e7cb2c9898aff1e3ae272 *man/miPowerFit.Rd +f62b7f3d2641e240df486b099c76dee7 *man/modindices.mi.Rd +3b078c258024a8d2003a87f44074551e *man/monteCarloMed.Rd +0b21a2ede16f90ec1da1a7289567880f *man/moreFitIndices.Rd +02b69fad977cb25c675f1c08e767d715 *man/mvrnonnorm.Rd +0fd2cb9f781aefe3c1add5328c318754 *man/net.Rd +e5db8d1a9dc4924df36249e34f804643 *man/nullRMSEA.Rd +e3bcd4f35fe5bea1c8b0b49b3ab9b3dd *man/parcelAllocation.Rd +80b1b4a567e403722af7df99df6303b3 *man/partialInvariance.Rd +939a0613b1d2b8f52c9c77369d1fa5ff *man/permuteMeasEq-class.Rd +b984729a669994b94be465b8ee916033 *man/permuteMeasEq.Rd +1a216ea45fcef1076248da76d2de66fb *man/plotProbe.Rd +453b86374d39983d84b8f0366de81fe1 *man/plotRMSEAdist.Rd +396287d1c03f2878a6ba4cce76a22e53 *man/plotRMSEApower.Rd +48655628c3bad90b1b91b7739b88a7a0 *man/plotRMSEApowernested.Rd +2fe80551d2976a53e521e163e84d3c81 *man/poolMAlloc.Rd +2374e28363f6c9e0a76231240179f674 *man/probe2WayMC.Rd +9daf3b8d1c426ced81848781018578d3 *man/probe2WayRC.Rd +da172577278ac0ca1a557c3efe840d6e *man/probe3WayMC.Rd +6c10be88b271f7d9ee8d07ee06201595 *man/probe3WayRC.Rd +233e67a12c4e4a3ac388278d991caf1d *man/quark.Rd +e2cd08fcc602f7c567cbd878733ee767 *man/reliability.Rd +ae73ed04166328914ab85b41e7f38971 *man/reliabilityL2.Rd +671f4f17bca124a483d84897b6d5e713 *man/residualCovariate.Rd +13664d492e59b9d63ab2a1be1d3a8721 *man/rotate.Rd +943c408a2ad56a83e51ce452e14b57d2 *man/runMI.Rd +c59c79e7268eaabe11c9537e6a215149 *man/semTools-deprecated.Rd +94ef8d4159bdb2d83cfa6a5091db4aad *man/semTools.Rd +0ee1628a0b6559bcad4e1e34b3971ef9 *man/simParcel.Rd +6ecf2a9789198bfd8cbd849b68418047 *man/singleParamTest.Rd +f2347a4e8b65c957bdadbefae4b60ce7 *man/skew.Rd +bbb7e8a2602313352c10d0fda1f14227 *man/splitSample.Rd +2a7065503d7173d1948eaf0e022924ae *man/standardizeMx-deprecated.Rd +39dd9a0e3fb089bf19f5d57e87dc858b *man/tukeySEM.Rd +305fa3489a58f94218fafd3eb022a97d *man/twostage-class.Rd +e813e6ecb7d216a865a5b75fa5647813 *man/twostage.Rd 81dc319ba4e3739b20cbcd3196f00e1e *vignettes/partialInvariance.Rnw 4f5891dc46f7212c1ce6189c4467adba *vignettes/partialInvariance.bib diff -Nru r-cran-semtools-0.4.14/NAMESPACE r-cran-semtools-0.5.0/NAMESPACE --- r-cran-semtools-0.4.14/NAMESPACE 2016-10-20 09:28:29.000000000 +0000 +++ r-cran-semtools-0.5.0/NAMESPACE 2018-06-27 12:12:29.000000000 +0000 @@ -1,64 +1,148 @@ -## Last updated: 20 October 2016 - -importFrom("methods", show, is, new, slot, as, hasArg, getMethod) -importFrom("lavaan", inspect) -importFrom("stats", - cov, nlminb, rnorm, runif, cov2cor, qnorm, sd, quantile, qchisq, fitted, cor, pchisq, factanal, coef, uniroot, lm, pnorm, pf, var, fitted.values, nobs, residuals, resid, dist, ptukey, dchisq, na.omit, qf, pt, qt, anova, vcov) -importFrom("utils", - capture.output, write.table, combn, read.table, read.csv, setTxtProgressBar, txtProgressBar) -importFrom("graphics", hist, plot, par, abline, lines, legend) - -exportClasses(lavaanStar, FitDiff, EFA, Net, BootMiss, permuteMeasEq, twostage) -exportMethods(show, summary, hist, anova, vcov, coef, fitted, fitted.values, resid, residuals, nobs) - -## ORGANIZE BY AUTHOR(S) OF EACH FUNCTION -export( - ## Sunthud - auxiliary, cfa.auxiliary, sem.auxiliary, growth.auxiliary, lavaan.auxiliary, - clipboard, saveFile, compareFit, - efaUnrotate, orthRotate, oblqRotate, funRotate, - imposeStart, loadingFromAlpha, - skew, kurtosis, mardiaSkew, mardiaKurtosis, - residualCovariate, - singleParamTest, wald, - miPowerFit, - plotRMSEAdist, findRMSEApower, findRMSEAsamplesize, - plotProbe, - probe2WayMC, probe2WayRC, probe3WayMC, probe3WayRC, - reliabilityL2, maximalRelia, - partialInvariance, partialInvarianceCat, - ## Sunthud with Bell Clinton and Pavel Panko - findRMSEApowernested, findRMSEAsamplesizenested, plotRMSEApowernested, - ## Sunthud with Alex - indProd, orthogonalize, - ## Sunthud with Yves Rosseel - measurementInvariance, longInvariance, measurementInvarianceCat, - reliability, mvrnonnorm, - ## Alex - plotRMSEApower, SSpower, tukeySEM, - ## Alex with Corbin (and James Selig) - monteCarloMed, parcelAllocation, - ## Jason D. Rights - PAVranking, poolMAlloc, - ## Terrence - bsBootMiss, net, chisqSmallN, permuteMeasEq, - twostage, cfa.2stage, sem.2stage, growth.2stage, lavaan.2stage, - ## Mauricio - fmi, - ## Ed Merkle - kd, - ## Corbin Quick - lisrel2lavaan, splitSample, - ## Steven R. Chesnut - quark, combinequark, - ## Ylenio Longo - htmt, - ## Ruben Arslan - nullRMSEA, - ## Alex, Patrick, Sunthud, Mijke, Alexander Robitzsch, Craig Enders, Mauricio, Yves - runMI, cfa.mi, sem.mi, growth.mi, lavaan.mi, - ## Sunthud, Terrence, Aaron, Ruben Arslan, Yves - moreFitIndices, - - nullMx, saturateMx, fitMeasuresMx, standardizeMx -) +# Generated by roxygen2: do not edit by hand + +export(PAVranking) +export(SSpower) +export(auxiliary) +export(bsBootMiss) +export(cfa.2stage) +export(cfa.auxiliary) +export(cfa.mi) +export(chisqSmallN) +export(clipboard) +export(combinequark) +export(compareFit) +export(efa.ekc) +export(efaUnrotate) +export(findRMSEApower) +export(findRMSEApowernested) +export(findRMSEAsamplesize) +export(findRMSEAsamplesizenested) +export(fmi) +export(funRotate) +export(growth.2stage) +export(growth.auxiliary) +export(growth.mi) +export(htmt) +export(imposeStart) +export(indProd) +export(kd) +export(kurtosis) +export(lavTestScore.mi) +export(lavaan.2stage) +export(lavaan.auxiliary) +export(lavaan.mi) +export(lisrel2lavaan) +export(loadingFromAlpha) +export(longInvariance) +export(mardiaKurtosis) +export(mardiaSkew) +export(maximalRelia) +export(measurementInvariance) +export(measurementInvarianceCat) +export(miPowerFit) +export(modindices.mi) +export(monteCarloMed) +export(moreFitIndices) +export(mvrnonnorm) +export(net) +export(nullRMSEA) +export(oblqRotate) +export(orthRotate) +export(orthogonalize) +export(parcelAllocation) +export(partialInvariance) +export(partialInvarianceCat) +export(permuteMeasEq) +export(plotProbe) +export(plotRMSEAdist) +export(plotRMSEApower) +export(plotRMSEApowernested) +export(poolMAlloc) +export(probe2WayMC) +export(probe2WayRC) +export(probe3WayMC) +export(probe3WayRC) +export(quark) +export(reliability) +export(reliabilityL2) +export(residualCovariate) +export(runMI) +export(saveFile) +export(sem.2stage) +export(sem.auxiliary) +export(sem.mi) +export(singleParamTest) +export(skew) +export(splitSample) +export(standardizeMx) +export(tukeySEM) +export(twostage) +exportMethods(anova) +exportMethods(coef) +exportMethods(fitMeasures) +exportMethods(fitmeasures) +exportMethods(fitted) +exportMethods(fitted.values) +exportMethods(hist) +exportMethods(nobs) +exportMethods(resid) +exportMethods(residuals) +exportMethods(show) +exportMethods(summary) +exportMethods(vcov) +importClassesFrom(lavaan,lavaanList) +importFrom(graphics,abline) +importFrom(graphics,hist) +importFrom(graphics,legend) +importFrom(graphics,lines) +importFrom(graphics,par) +importFrom(graphics,plot) +importFrom(lavaan,fitMeasures) +importFrom(lavaan,fitmeasures) +importFrom(lavaan,lavInspect) +importFrom(lavaan,lavListInspect) +importFrom(lavaan,lavNames) +importFrom(lavaan,lavaan) +importFrom(lavaan,lavaanList) +importFrom(lavaan,lavaanify) +importFrom(lavaan,parTable) +importFrom(methods,as) +importFrom(methods,getMethod) +importFrom(methods,hasArg) +importFrom(methods,is) +importFrom(methods,new) +importFrom(methods,setClass) +importFrom(methods,setMethod) +importFrom(methods,show) +importFrom(methods,slot) +importFrom(stats,anova) +importFrom(stats,coef) +importFrom(stats,cor) +importFrom(stats,cov) +importFrom(stats,cov2cor) +importFrom(stats,dchisq) +importFrom(stats,factanal) +importFrom(stats,fitted) +importFrom(stats,fitted.values) +importFrom(stats,lm) +importFrom(stats,nlminb) +importFrom(stats,nobs) +importFrom(stats,pchisq) +importFrom(stats,pf) +importFrom(stats,pnorm) +importFrom(stats,pt) +importFrom(stats,ptukey) +importFrom(stats,qchisq) +importFrom(stats,qnorm) +importFrom(stats,qt) +importFrom(stats,quantile) +importFrom(stats,resid) +importFrom(stats,residuals) +importFrom(stats,rnorm) +importFrom(stats,runif) +importFrom(stats,sd) +importFrom(stats,uniroot) +importFrom(stats,var) +importFrom(stats,vcov) +importFrom(utils,read.csv) +importFrom(utils,read.table) diff -Nru r-cran-semtools-0.4.14/R/auxiliary.R r-cran-semtools-0.5.0/R/auxiliary.R --- r-cran-semtools-0.4.14/R/auxiliary.R 2016-10-17 15:29:56.000000000 +0000 +++ r-cran-semtools-0.5.0/R/auxiliary.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,524 +1,242 @@ -### Title: Automatically accounts for auxiliary variable in full information maximum likelihood -### Author: Sunthud Pornprasertmanit -### Last updated: 17 October 2016 -### Description: Automatically accounts for auxiliary variable in full information maximum likelihood - -setClass("lavaanStar", contains = "lavaan", representation(nullfit = "vector", imputed="list", imputedResults="list", auxNames="vector"), prototype(nullfit=c(chi=0,df=0), imputed=list(), imputedResults=list(), auxNames = "")) - -setMethod("inspect", "lavaanStar", ## FIXME: get rid of lavaanStar object -function(object, what="free") { - what <- tolower(what) - if(what == "fit" || - what == "fitmeasures" || - what == "fit.measures" || - what == "fit.indices") { - fitMeasuresLavaanStar(object) - } else if(what == "imputed" || - what == "impute") { - result <- object@imputed - if(length(result) > 0) { - return(result) - } else { - stop("This method did not made by multiple imputation.") - } - } else if(what == "aux" || - what == "auxiliary") { - print(object@auxNames) - } else { - getMethod("inspect", "lavaan")(object, what=what) ## FIXME: don't set a new inspect method - } -}) - -setMethod("summary", "lavaanStar", -function(object, fit.measures=FALSE, ...) { - getMethod("summary", "lavaan")(object, fit.measures=FALSE, ...) - if(fit.measures) { - cat("Because the original method to find the baseline model does not work, \nplease do not use any fit measures relying on baseline model, including CFI and TLI. \nTo find the correct one, please use the function: lavInspect(object, what='fit').\n") - } -}) - -setMethod("anova", signature(object = "lavaanStar"), -function(object, ...) { - imputed <- object@imputed - if(length(imputed) > 0) { - dots <- list(...) - if(length(dots) > 1) stop("Multiple Imputed Results: Cannot compare more than two objects") - object2 <- dots[[1]] - imputed2 <- object2@imputed - if(length(imputed) == 0) stop("The second object must come from multiple imputation.") - listlogl1 <- imputed[["indivlogl"]] - listlogl2 <- imputed2[["indivlogl"]] - df1 <- lavaan::lavInspect(object, "fit")["df"] - df2 <- lavaan::lavInspect(object2, "fit")["df"] - if(df2 < df1) { - templogl <- listlogl1 - listlogl1 <- listlogl2 - listlogl2 <- templogl - } - dfdiff <- df2 - df1 - anovaout <- mapply(lavaan::anova, object@imputedResults, object2@imputedResults, SIMPLIFY = FALSE) - chidiff <- sapply(anovaout, function(u) u[2, "Chisq diff"]) - dfdiff2 <- mean(sapply(anovaout, function(u) u[2, "Df diff"])) - fit.altcc <- mean(chidiff) - naive <- c(fit.altcc, dfdiff2, 1 - pchisq(fit.altcc, dfdiff2)) - names(naive) <- c("chisq", "df", "pvalue") - lmrr <- lmrrPooledChi(chidiff, dfdiff2) - mr <- NULL - mplus <- NULL - if(!is.null(listlogl1[["loglmod"]]) | !is.null(listlogl2[["loglmod"]])) { - logl1 <- listlogl1[["loglmod"]] - logl2 <- listlogl2[["loglmod"]] - chimean <- mean((logl1 - logl2)*2) - m <- length(logl1) - ariv <- ((m+1)/((m-1)*dfdiff))*(fit.altcc-chimean) - - mplus <- mplusPooledChi(chimean, dfdiff, ariv) - mr <- mrPooledChi(chimean, m, dfdiff, ariv) - } - result <- list(naive = naive, lmrr = lmrr, mr = mr, mplus = mplus) - return(result) - } else { - return(getMethod("anova", "lavaan")(object, ...)) - } -}) - -setMethod("vcov", "lavaanStar", -function(object, ...) { - result <- object@imputed - if(length(result) == 0) { - return(getMethod("vcov", "lavaan")(object, ...)) - } else { - out <- object@vcov$vcov - rownames(out) <- colnames(out) <- lavaan::lav_partable_labels(lavaan::partable(object), type="free") - return(out) - } -}) - -# auxiliary: Automatically accounts for auxiliary variable in full information maximum likelihood - -cfa.auxiliary <- function(model, aux, ...) { - auxiliary(model = model, aux = aux, fun = "cfa", ...) -} - -sem.auxiliary <- function(model, aux, ...) { - auxiliary(model = model, aux = aux, fun = "sem", ...) -} - -growth.auxiliary <- function(model, aux, ...) { - auxiliary(model = model, aux = aux, fun = "growth", ...) -} - -lavaan.auxiliary <- function(model, aux, ...) { - auxiliary(model = model, aux = aux, fun = "lavaan", ...) -} - -auxiliary <- function(model, aux, fun, ...) { - args <- list(...) - args$fixed.x <- FALSE - args$missing <- "fiml" - - if(is(model, "lavaan")) { - if(!lavaan::lavInspect(model, "options")$meanstructure) stop("The lavaan fitted model must evaluate the meanstructure. Please re-fit the lavaan object again with 'meanstructure=TRUE'") - model <- lavaan::parTable(model) - } else if(!(is.list(model) && ("lhs" %in% names(model)))) { - fit <- do.call(fun, c(list(model=model, do.fit=FALSE), args)) - model <- lavaan::parTable(fit) - } - model <- model[setdiff(1:length(model), which(names(model) == "start"))] - - if(any(model$exo == 1)) { - stop("All exogenous variables (covariates) must be treated as endogenous variables by the 'auxiliary' function (fixed.x = FALSE).") - } - - auxResult <- craftAuxParTable(model = model, aux = aux, ...) - if(checkOrdered(args$data, auxResult$indName, ...)) { - 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.") - } - - args$model <- auxResult$model - result <- do.call(fun, args) - - codeNull <- nullAuxiliary(aux, auxResult$indName, NULL, any(model$op == "~1"), max(model$group)) - resultNull <- lavaan::lavaan(codeNull, ...) - result <- as(result, "lavaanStar") - fit <- lavaan::fitMeasures(resultNull) - name <- names(fit) - fit <- as.vector(fit) - names(fit) <- name - result@nullfit <- fit - result@auxNames <- aux - return(result) -} - -checkOrdered <- function(dat, varnames, ...) { - 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)) - } - any(c(ord, orderedVar)) -} - -craftAuxParTable <- function(model, aux, ...) { - constraintLine <- model$op %in% c("==", ":=", ">", "<") - modelConstraint <- lapply(model, "[", constraintLine) - model <- lapply(model, "[", !constraintLine) - facName <- NULL - indName <- NULL - singleIndicator <- NULL - facName <- unique(model$lhs[model$op == "=~"]) - indName <- setdiff(unique(model$rhs[model$op == "=~"]), facName) - singleIndicator <- setdiff(unique(c(model$lhs, model$rhs)), c(facName, indName, "")) - facSingleIndicator <- paste0("f", singleIndicator) - for(i in seq_along(singleIndicator)) { - model$lhs <- gsub(singleIndicator[i], facSingleIndicator[i], model$lhs) - model$rhs <- gsub(singleIndicator[i], facSingleIndicator[i], model$rhs) - } - ngroups <- max(model$group) - if(!is.null(singleIndicator) && length(singleIndicator) != 0) model <- attachPT(model, facSingleIndicator, "=~", singleIndicator, ngroups, fixed = TRUE, ustart = 1, expand = FALSE) - if(!is.null(singleIndicator) && length(singleIndicator) != 0) model <- attachPT(model, singleIndicator, "~~", singleIndicator, ngroups, fixed = TRUE, ustart = 0, expand = FALSE) - if(!is.null(singleIndicator) && length(singleIndicator) != 0) model <- attachPT(model, singleIndicator, "~1", "", ngroups, fixed = TRUE, ustart = 0, expand = FALSE) - if(is.null(indName) || length(indName) == 0) { - faux <- paste0("f", aux) - model <- attachPT(model, faux, "=~", aux, ngroups, fixed = TRUE, ustart = 1, expand = FALSE) - model <- attachPT(model, aux, "~~", aux, ngroups, fixed = TRUE, ustart = 0, expand = FALSE) - model <- attachPT(model, facSingleIndicator, "~~", faux, ngroups) - model <- attachPT(model, faux, "~~", faux, ngroups, symmetric=TRUE) - if(any(model$op == "~1")) { - model <- attachPT(model, faux, "~1", "", ngroups) - model <- attachPT(model, aux, "~1", "", ngroups, fixed = TRUE, ustart = 0, expand = FALSE) - } - } else { - if(!is.null(indName) && length(indName) != 0) model <- attachPT(model, indName, "~~", aux, ngroups) - model <- attachPT(model, aux, "~~", aux, ngroups, symmetric=TRUE, useUpper=TRUE) - if(!is.null(singleIndicator) && length(singleIndicator) != 0) model <- attachPT(model, facSingleIndicator, "=~", aux, ngroups) - if(any(model$op == "~1")) model <- attachPT(model, aux, "~1", "", ngroups) - } - model <- attachConstraint(model, modelConstraint) - - list(model = model, indName = union(indName, singleIndicator)) -} - -attachConstraint <- function(pt, con) { - len <- length(con$id) - if(len > 0) { - pt$id <- c(pt$id, (max(pt$id)+1):(max(pt$id)+len)) - pt$lhs <- c(pt$lhs, con$lhs) - pt$op <- c(pt$op, con$op) - pt$rhs <- c(pt$rhs, con$rhs) - pt$user <- c(pt$user, con$user) - pt$group <- c(pt$group, con$group) - pt$free <- c(pt$free, con$free) - pt$ustart <- c(pt$ustart, con$ustart) - pt$exo <- c(pt$exo, con$exo) - pt$label <- c(pt$label, con$label) - pt$plabel <- c(pt$plabel, con$plabel) - pt$start <- c(pt$start, con$start) - pt$est <- c(pt$est, con$est) - pt$se <- c(pt$se, con$se) - } - pt -} - -attachPT <- function(pt, lhs, op, rhs, ngroups, symmetric=FALSE, exo=FALSE, fixed=FALSE, useUpper=FALSE, ustart = NA, expand = TRUE, diag = TRUE) { - pt$start <- pt$est <- pt$se <- NULL - if(expand) { - element <- expand.grid(lhs, rhs, stringsAsFactors = FALSE) - } else { - element <- cbind(lhs, rhs) - } - if(symmetric) { - if(useUpper) { - element <- element[as.vector(upper.tri(diag(length(lhs)), diag=diag)),] - } else { - element <- element[as.vector(lower.tri(diag(length(lhs)), diag=diag)),] - } - } - num <- nrow(element) * ngroups - pt$id <- c(pt$id, (max(pt$id)+1):(max(pt$id)+num)) - pt$lhs <- c(pt$lhs, rep(element[,1], ngroups)) - pt$op <- c(pt$op, rep(op, num)) - pt$rhs <- c(pt$rhs, rep(element[,2], ngroups)) - pt$user <- c(pt$user, rep(1, num)) - pt$group <- c(pt$group, rep(1:ngroups, each=nrow(element))) - free <- (max(pt$free)+1):(max(pt$free)+num) - if(fixed) free <- rep(0L, num) - pt$free <- c(pt$free, free) - pt$ustart <- c(pt$ustart, rep(ustart, num)) - pt$exo <- c(pt$exo, rep(as.numeric(exo), num)) - pt$label <- c(pt$label, rep("", num)) - pt$plabel <- c(pt$plabel, rep("", num)) - return(pt) -} - -nullAuxiliary <- function(aux, indName, covName=NULL, meanstructure, ngroups) { - covName <- rev(covName) - pt <- list() - num <- length(indName) * ngroups - if(meanstructure) num <- num*2 - pt$id <- 1:num - pt$lhs <- rep(indName, ngroups) - pt$op <- rep("~~", num) - pt$rhs <- rep(indName, ngroups) - pt$user <- rep(1, num) - pt$group <- rep(1:ngroups, each=length(indName)) - pt$free <- 1:num - pt$ustart <- rep(NA, num) - pt$exo <- rep(0, num) - pt$label <- rep("", num) - pt$plabel <- rep("", num) - if(meanstructure) { - pt$lhs <- rep(rep(indName, ngroups), 2) - pt$op <- rep(c("~~", "~1"), each=num/2) - pt$rhs <- c(rep(indName, ngroups), rep("", num/2)) - pt$group <- rep(rep(1:ngroups, each=length(indName)), 2) - } - pt <- attachPT(pt, aux, "~~", aux, ngroups, symmetric=TRUE) - pt <- attachPT(pt, indName, "~~", aux, ngroups) - if(meanstructure) pt <- attachPT(pt, aux, "~1", "", ngroups) - if(!is.null(covName) && length(covName) != 0) { - pt <- attachPT(pt, aux, "~~", covName, ngroups) - pt <- attachPT(pt, covName, "~~", covName, ngroups, symmetric=TRUE, useUpper=TRUE) - if(meanstructure) pt <- attachPT(pt, covName, "~1", "", ngroups) - } - return(pt) -} - - -fitMeasuresLavaanStar <- function(object) { - notused <- capture.output(result <- suppressWarnings(getMethod("inspect", "lavaan")(object, what="fit"))) ## FIXME: don't set a new inspect method - result[c("baseline.chisq", "baseline.df", "baseline.pvalue")] <- object@nullfit[c("chisq", "df", "pvalue")] - - if(lavaan::lavInspect(object, "options")$test %in% c("satorra.bentler", "yuan.bentler", - "mean.var.adjusted", "scaled.shifted")) { - scaled <- TRUE - } else { - scaled <- FALSE - } - - if(scaled) { - result[c("baseline.chisq.scaled", "baseline.df.scaled", "baseline.pvalue.scaled", "baseline.chisq.scaling.factor")] <- object@nullfit[c("chisq.scaled", "df.scaled", "pvalue.scaled", "chisq.scaling.factor")] - } - - X2.null <- object@nullfit["chisq"] - df.null <- object@nullfit["df"] - X2 <- result["chisq"] - df <- result["df"] - - if(df.null == 0) { - result["cfi"] <- NA - result["tli"] <- NA - result["nnfi"] <- NA - result["rfi"] <- NA - result["nfi"] <- NA - result["pnfi"] <- NA - result["ifi"] <- NA - result["rni"] <- NA - } else { - # CFI - if("cfi" %in% names(result)) { - t1 <- max( c(X2 - df, 0) ) - t2 <- max( c(X2 - df, X2.null - df.null, 0) ) - if(t1 == 0 && t2 == 0) { - result["cfi"] <- 1 - } else { - result["cfi"] <- 1 - t1/t2 - } - } - - # TLI - if("tli" %in% names(result)) { - if(df > 0) { - t1 <- X2.null/df.null - X2/df - t2 <- X2.null/df.null - 1 - # note: TLI original formula was in terms of fx/df, not X2/df - # then, t1 <- fx_0/df.null - fx/df - # t2 <- fx_0/df.null - 1/N (or N-1 for wishart) - if(t1 < 0 && t2 < 0) { - TLI <- 1 - } else { - TLI <- t1/t2 - } - } else { - TLI <- 1 - } - result["tli"] <- result["nnfi"] <- TLI - } - - # RFI - if("rfi" %in% names(result)) { - if(df > 0) { - t1 <- X2.null/df.null - X2/df - t2 <- X2.null/df.null - if(t1 < 0 || t2 < 0) { - RLI <- 1 - } else { - RLI <- t1/t2 - } - } else { - RLI <- 1 - } - result["rfi"] <- RLI - } - - # NFI - if("nfi" %in% names(result)) { - t1 <- X2.null - X2 - t2 <- X2.null - NFI <- t1/t2 - result["nfi"] <- NFI - } - - # PNFI - if("pnfi" %in% names(result)) { - t1 <- X2.null - X2 - t2 <- X2.null - PNFI <- (df/df.null) * t1/t2 - result["pnfi"] <- PNFI - } - - # IFI - if("ifi" %in% names(result)) { - t1 <- X2.null - X2 - t2 <- X2.null - df - if(t2 < 0) { - IFI <- 1 - } else { - IFI <- t1/t2 - } - result["ifi"] <- IFI - } - - # RNI - if("rni" %in% names(result)) { - t1 <- X2 - df - t2 <- X2.null - df.null - if(df.null == 0) { - RNI <- NA - } else if(t1 < 0 || t2 < 0) { - RNI <- 1 - } else { - RNI <- 1 - t1/t2 - } - result["rni"] <- RNI - } - } - - if(scaled) { - X2.scaled <- result["chisq.scaled"] - df.scaled <- result["df.scaled"] - X2.null.scaled <- object@nullfit["chisq.scaled"] - df.null.scaled <- object@nullfit["df.scaled"] - - if(df.null.scaled == 0) { - result["cfi.scaled"] <- NA - result["tli.scaled"] <- result["nnfi.scaled"] <- NA - result["rfi.scaled"] <- NA - result["nfi.scaled"] <- NA - result["pnfi.scaled"] <- NA - result["ifi.scaled"] <- NA - result["rni.scaled"] <- NA - } else { - if("cfi.scaled" %in% names(result)) { - t1 <- max( c(X2.scaled - df.scaled, 0) ) - t2 <- max( c(X2.scaled - df.scaled, - X2.null.scaled - df.null.scaled, 0) ) - if(t1 == 0 && t2 == 0) { - result["cfi.scaled"] <- 1 - } else { - result["cfi.scaled"] <- 1 - t1/t2 - } - } - - if("tli.scaled" %in% names(result)) { - if(df > 0) { - t1 <- X2.null.scaled/df.null.scaled - X2.scaled/df.scaled - t2 <- X2.null.scaled/df.null.scaled - 1 - if(t1 < 0 && t2 < 0) { - TLI <- 1 - } else { - TLI <- t1/t2 - } - } else { - TLI <- 1 - } - result["tli.scaled"] <- result["nnfi.scaled"] <- TLI - } - - if("rfi.scaled" %in% names(result)) { - if(df > 0) { - t1 <- X2.null.scaled/df.null.scaled - X2.scaled/df.scaled - t2 <- X2.null.scaled/df.null.scaled - if(t1 < 0 || t2 < 0) { - RLI <- 1 - } else { - RLI <- t1/t2 - } - } else { - RLI <- 1 - } - result["rfi.scaled"] <- RLI - } - - if("nfi.scaled" %in% names(result)) { - t1 <- X2.null.scaled - X2.scaled - t2 <- X2.null.scaled - NFI <- t1/t2 - result["nfi.scaled"] <- NFI - } - - if("pnfi.scaled" %in% names(result)) { - t1 <- X2.null.scaled - X2.scaled - t2 <- X2.null.scaled - PNFI <- (df/df.null) * t1/t2 - result["pnfi.scaled"] <- PNFI - } - - if("ifi.scaled" %in% names(result)) { - t1 <- X2.null.scaled - X2.scaled - t2 <- X2.null.scaled - if(t2 < 0) { - IFI <- 1 - } else { - IFI <- t1/t2 - } - result["ifi.scaled"] <- IFI - } - - if("rni.scaled" %in% names(result)) { - t1 <- X2.scaled - df.scaled - t2 <- X2.null.scaled - df.null.scaled - t2 <- X2.null - df.null - if(t1 < 0 || t2 < 0) { - RNI <- 1 - } else { - RNI <- 1 - t1/t2 - } - result["rni.scaled"] <- RNI - } - } - } - - #logl - imputed <- object@imputed - if(length(imputed) > 0) { - loglikval <- unlist(imputed[["logl"]]) - npar <- result["npar"] - result["unrestricted.logl"] <- loglikval["unrestricted.logl"] - result["logl"] <- loglikval["logl"] - result["aic"] <- -2*loglikval["logl"] + 2*npar - result["bic"] <- -2*loglikval["logl"] + npar*log(result["ntotal"]) - N.star <- (result["ntotal"] + 2) / 24 - result["bic2"] <- -2*loglikval["logl"] + npar*log(N.star) - result <- result[-which("fmin" == names(result))] - } - result +### Terrence D. Jorgensen +### Last updated: 8 March 2018 +### new auxiliary function does NOT create a lavaanStar-class instance + +#' 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 \code{\link[lavaan]{lavaan}}, but you +#' \emph{must} pass your full \code{data.frame} to the \code{data} argument. +#' Because the saturated-correlates approaches (Enders, 2008) treates 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}. +#' +#' @aliases auxiliary lavaan.auxiliary cfa.auxiliary sem.auxiliary growth.auxiliary +#' @importFrom lavaan lavInspect parTable +#' @importFrom stats cov quantile +#' +#' @param model The analysis model can be specified with 1 of 2 objects: +#' \enumerate{ +#' \item lavaan \code{\link[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}}, +#' 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")} +#' } +#' @param data \code{data.frame} that includes auxiliary variables as well as +#' any observed variables in the \code{model} +#' @param aux \code{character}. Names of auxiliary variables to add to \code{model} +#' @param 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}. +#' @param ... additional arguments to pass to \code{\link[lavaan]{lavaan}}. +#' +#' @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. \emph{Structural Equation Modeling, 15}(3), 434--448. +#' doi:10.1080/10705510802154307 +#' +#' @return a fitted \code{\linkS4class{lavaan}} object. Additional +#' information is stored as a \code{list} in the \code{\@external} slot: +#' \itemize{ +#' \item \code{baseline.model}. a fitted \code{\linkS4class{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}}. +#' \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. +#' } +#' +#' @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, ...) { + lavArgs <- list(...) + lavArgs$data <- data + lavArgs$fixed.x <- FALSE + 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 (!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") + ## 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))$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 + PT <- parTable(do.call(fun, ptArgs))[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 <- lavaan::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 + 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) + ##FIXME: 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)) + result <- do.call(fun, lavArgs) + + ## 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$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::lavaan, baseArgs) + result@external$aux <- aux + result@external$baseline.syntax <- satMod + result +} + +#' @rdname auxiliary +#' @aliases lavaan.auxiliary +#' @export +lavaan.auxiliary <- function(model, data, aux, ...) { + auxiliary(model = model, data = data, aux = aux, fun = "lavaan", ...) +} + +#' @rdname auxiliary +#' @aliases cfa.auxiliary +#' @export +cfa.auxiliary <- function(model, data, aux, ...) { + auxiliary(model = model, data = data, aux = aux, fun = "cfa", ...) +} + +#' @rdname auxiliary +#' @aliases sem.auxiliary +#' @export +sem.auxiliary <- function(model, data, aux, ...) { + auxiliary(model = model, data = data, aux = aux, fun = "sem", ...) +} + +#' @rdname auxiliary +#' @aliases growth.auxiliary +#' @export +growth.auxiliary <- function(model, data, aux, ...) { + auxiliary(model = model, data = data, aux = aux, fun = "growth", ...) } diff -Nru r-cran-semtools-0.4.14/R/clipboard.R r-cran-semtools-0.5.0/R/clipboard.R --- r-cran-semtools-0.4.14/R/clipboard.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/clipboard.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,15 +1,99 @@ -### Title: Copy or save each aspect of the lavaan object into a clipboard or a file -### Author: Sunthud Pornprasertmanit -### Last updated: 14 October 2016 -### Description: Copy or print each aspect of the lavaan object into a clipboard or a file - -# Clipboard: copy each aspect of the lavaan object into a clipboard; this function will be compatible with lavaan::lavInspect -clipboard <- function(object, what="summary", ...) { - if(.Platform$OS.type == "windows") { +### Sunthud Pornprasertmanit & Terrence D. Jorgensen +### Last updated: 11 April 2017 +### Copy or save each aspect of the lavaan object into a clipboard or a file + + +#' Copy or save the result of \code{lavaan} or \code{FitDiff} objects into a +#' clipboard or a file +#' +#' Copy or save the result of \code{lavaan} or \code{\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. +#' +#' +#' @aliases clipboard saveFile +#' @param object The \code{lavaan} or \code{\linkS4class{FitDiff}} object +#' @param 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}} function. Other attributes listed in the +#' \code{inspect} method in the \link[lavaan]{lavaan-class} could also be used, +#' such as \code{"coef"}, \code{"se"}, \code{"fit"}, \code{"samp"}, and so on. +#' For the The \code{\linkS4class{FitDiff}} object, this argument is not active +#' yet. +#' @param file A file name used for saving the result +#' @param tableFormat If \code{TRUE}, save the result in the table format using +#' tabs for seperation. Otherwise, save the result as the output screen +#' printed in the R console. +#' @param fit.measures \code{character} vector specifying names of fit measures +#' returned by \code{\link[lavaan]{fitMeasures}} to be copied/saved. Only +#' relevant if \code{object} is class \code{\linkS4class{FitDiff}}. +#' @param writeArgs \code{list} of additional arguments to be passed to +#' \code{\link[utils]{write.table}} +#' @param \dots Additional argument listed in the \code{\link{miPowerFit}} +#' function (for \code{lavaan} object only). +#' @return 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. +#' @author +#' Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' +#' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@gmail.com}) +#' @examples +#' +#' \dontrun{ +#' 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", meanstructure=TRUE) +#' +#' # Copy the summary of the lavaan object +#' clipboard(fit) +#' +#' # Copy the modification indices and the model fit 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 the modification indices and the model fit 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 { - if(system("pbcopy", ignore.stderr = TRUE) == 0) { + if (system("pbcopy", ignore.stderr = TRUE) == 0) { saveFile(object, file=pipe("pbcopy", "w"), 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) { @@ -21,71 +105,100 @@ } } -# saveFile: save each aspect of the lavaan object into a file; this function will be compatible with lavaan::lavInspect -saveFile <- function(object, file, what="summary", tableFormat=FALSE, ...) { +#' @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, ...) - } else if(is(object, "FitDiff")) { - saveFileFitDiff(object, file, what=what, tableFormat=tableFormat) + 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 in the `lavaan' output or the output from the compareFit function.") + stop("The object must be in the `lavaan' output or the", + " output from the compareFit function.") } } -saveFileLavaan <- function(object, file, what="summary", tableFormat=FALSE, ...) { - if(length(what) > 1) { - stop("`what' arguments contains multiple arguments; only one is allowed") - } - # be case insensitive - what <- tolower(what) - - if(what == "summary") { - if(tableFormat) { - copySummary(object, file=file) + + +## ---------------- +## 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) { + copySummary(object, file = file, writeArgs = writeArgs) } else { - write(paste(capture.output(summary(object, rsquare=TRUE, standardize=TRUE, fit.measure=TRUE)), collapse="\n"), file=file) + write(paste(utils::capture.output(summary(object, rsquare = TRUE, fit = TRUE, + standardize = TRUE)), + collapse = "\n"), file = file) } } else if (what == "mifit") { - if(tableFormat) { - write.table(miPowerFit(object, ...), file=file, sep="\t", row.names=FALSE, col.names=TRUE) + 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 { - write(paste(capture.output(miPowerFit(object, ...)), collapse="\n"), file=file) + write(paste(utils::capture.output(miPowerFit(object, ...)), + collapse = "\n"), file = file) } } else { - target <- lavaan::lavInspect(object, what=what) - if(tableFormat) { - if(is(target, "lavaan.data.frame") || is(target, "data.frame")) { - utils::write.table(target, file=file, sep="\t", row.names=FALSE, col.names=TRUE) + 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")) { + 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) - target <- do.call(rbind, target) - utils::write.table(target[-1,], file=file, sep="\t", row.names=FALSE, col.names=FALSE) + 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 { - target <- listToDataFrame(target) - utils::write.table(target, file=file, sep="\t", row.names=FALSE, col.names=FALSE) + 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 { - utils::write.table(target, file=file, sep="\t", row.names=TRUE, col.names=TRUE) + writeArgs$x <- target + if (is.null(writeArgs$row.names)) writeArgs$row.names <- TRUE + if (is.null(writeArgs$col.names)) writeArgs$col.names <- TRUE } } else { - write(paste(utils::capture.output(target), collapse="\n"), file=file) + write(paste(utils::capture.output(target), collapse = "\n"), file = file) } } + 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 +# 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) { +copySummary <- function(object, file, writeArgs = list()) { # Capture the output of the lavaan class outputText <- utils::capture.output(lavaan::summary(object, rsquare=TRUE, standardize=TRUE, fit.measure=TRUE)) # 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) @@ -101,16 +214,16 @@ # 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 + 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) { + if (length(x) == 0) { return(rep("", numcol)) - } else if(length(x) == 1) { + } else if (length(x) == 1) { return(c(x, rep("", numcol - 1))) - } else if((length(x) >= 2) & (length(x) <= numcol)) { + } 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") @@ -120,26 +233,26 @@ # 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) { + 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])))) { + 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) { + if (length(group2) == 1) { group2 <- c(group2, rep("", 6 - length(group2))) - } else if(length(group2) == 4) { + } 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)) } } @@ -147,16 +260,22 @@ # A function to parse the r-squared output set3Parse <- function(x, numcol) { - if(length(x) == 0) { + 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 - utils::write.table(rbind(set1, set2, set3), file=file, sep="\t", row.names=FALSE, col.names=FALSE) + 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) } # trim function from the R.oo package @@ -169,16 +288,16 @@ # 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,] @@ -187,10 +306,10 @@ # 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")) { + 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)) { + 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")) { @@ -203,15 +322,15 @@ } 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) diff -Nru r-cran-semtools-0.4.14/R/compareFit.R r-cran-semtools-0.5.0/R/compareFit.R --- r-cran-semtools-0.4.14/R/compareFit.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/compareFit.R 2018-06-25 21:25:42.000000000 +0000 @@ -1,32 +1,80 @@ ### Sunthud Pornprasertmanit -### Last updated: 14 October 2016 +### Last updated: 25 June 2018 +### source code for compareFit() function and FitDiff class -setClass("FitDiff", representation(name = "vector", nested = "data.frame", ordernested = "vector", fit="data.frame")) - -isNested <- function(object) length(object@ordernested) > 1 || !is.na(object@ordernested) - -noLeadingZero <- function(vec, fmt) { - out <- sprintf(fmt, vec) - used <- vec < 1 & vec >= 0 - used[is.na(used)] <- FALSE - out[used] <- substring(out[used], 2) - out -} +## ----------------- +## 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 The name of each model +#' @slot nested Model fit comparisons between adjacent nested models that are +#' ordered based on their degrees of freedom (\emph{df}) +#' @slot ordernested The order of nested models regarding to their \emph{df} +#' @slot fit Fit measures of all models specified in the \code{name} slot +#' @section Objects from the Class: Objects can be created via the +#' \code{\link{compareFit}} function. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \code{\link{compareFit}}; \code{\link{clipboard}} +#' @examples +#' +#' HW.model <- ' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 ' +#' +#' out <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, +#' group = "school", quiet = TRUE) +#' modelDiff <- compareFit(out) +#' summary(modelDiff) +#' summary(modelDiff, fit.measures = "all") +#' summary(modelDiff, fit.measures = c("aic", "bic")) +#' +#' \dontrun{ +#' ## Save results to a file +#' saveFile(modelDiff, file = "modelDiff.txt") +#' +#' ## Copy to a clipboard +#' clipboard(modelDiff) +#' } +#' +setClass("FitDiff", representation(name = "vector", + nested = "data.frame", + ordernested = "vector", + fit = "data.frame")) +#' @rdname FitDiff-class +#' @export setMethod("show", signature(object = "FitDiff"), function(object) { summary(object) -}) +}) -setMethod("summary", signature(object = "FitDiff"), function(object, fit.measures = "default") { - if(isNested(object)) { +#' @rdname FitDiff-class +#' @param object object of class \code{FitDiff} +#' @param fit.measures \code{character} vector naming fit indices the user can +#' request from \code{\link[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. +#' @export +setMethod("summary", signature(object = "FitDiff"), + function(object, fit.measures = "default") { + if (isNested(object)) { cat("################### Nested Model Comparison #########################\n") print(getNestedTable(object)) cat("\n") } cat("#################### Fit Indices Summaries ##########################\n") print(getFitSummary(object, fit.measures)) -}) +}) getNestedTable <- function(object) { ord <- object@ordernested @@ -43,9 +91,9 @@ } getFitSummary <- function(object, fit.measures = "default") { - if(is.null(fit.measures)) fit.measures <- "all" - if(length(fit.measures) == 1) { - if(fit.measures == "default") { + if (is.null(fit.measures)) fit.measures <- "all" + if (length(fit.measures) == 1) { + if (fit.measures == "default") { fit.measures <- c("chisq", "df", "pvalue", "cfi", "tli", "rmsea", "srmr", "aic", "bic") } else if (fit.measures == "all") { fit.measures <- colnames(object@fit) @@ -53,57 +101,92 @@ } fitTab <- object@fit orderThing <- rep(NA, ncol(fitTab)) - orderThing[colnames(fitTab) %in% c("rmsea", "aic", "bic", "bic2", "srmr", "srmr_nomean", "rmr", "rmr_nomean", "ecvi")] <- TRUE - orderThing[colnames(fitTab) %in% c("pvalue", "cfi", "tli", "nnfi", "rfi", "nfi", "pnfi", "ifi", "rni", "cn_05", "cn_01", "gfi", "agfi", "pgfi", "mfi")] <- FALSE + orderThing[colnames(fitTab) %in% c("rmsea","aic","bic","bic2","srmr","rmr", + "srmr_nomean","rmr_nomean","ecvi")] <- TRUE + orderThing[colnames(fitTab) %in% c("pvalue","cfi","tli","nnfi","rfi","nfi", + "pnfi","ifi","rni","cn_05","cn_01","gfi", + "agfi","pgfi","mfi")] <- FALSE isDF <- rep(FALSE, ncol(fitTab)) isDF[grep("df", colnames(fitTab))] <- TRUE - suppressWarnings(fitTab <- as.data.frame(mapply(tagDagger, fitTab, orderThing, is.df=isDF))) + suppressWarnings(fitTab <- as.data.frame(mapply(tagDagger, fitTab, orderThing, is.df = isDF))) rownames(fitTab) <- object@name - fitTab[,colnames(fitTab) %in% fit.measures] + fitTab[ , colnames(fitTab) %in% fit.measures] } -saveFileFitDiff <- function(object, filewrite, what="summary", tableFormat=FALSE, fit.measures = "default") { - if(tableFormat) { - filetemplate <- file(filewrite, 'w') - if(isNested(object)) { - cat("Nested Model Comparison\n\n", file=filetemplate) +## "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 (isNested(object)) { + cat("Nested Model Comparison\n\n", file = file, append = TRUE) out <- getNestedTable(object) out <- data.frame(model.diff = rownames(out), out) - write.table(out, file=filetemplate, sep="\t", quote=FALSE, row.names=FALSE) - cat("\n\n", file=filetemplate) + 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=filetemplate) - write.table(out2, file=filetemplate, sep="\t", quote=FALSE, row.names=FALSE) - close(filetemplate) + cat("Fit Indices Summaries\n\n", file = file, append = TRUE) + writeArgs$x <- out2 + do.call("write.table", writeArgs) } else { - write(paste(capture.output(lavaan::summary(object)), collapse="\n"), file=filewrite) + write(paste(utils::capture.output(lavaan::summary(object)), + collapse = "\n"), file = file) } } -tagDagger <- function(vec, minvalue = NA, is.df = FALSE) { - if(is.na(minvalue)) { - if(is.df) { - vec <- noLeadingZero(vec, fmt="%.0f") - } else { - vec <- noLeadingZero(vec, fmt="%.3f") - } - } else { - target <- max(vec, na.rm=TRUE) - if (minvalue) { - target <- min(vec, na.rm=TRUE) - } - tag <- rep(" ", length(vec)) - tag[vec == target] <- "\u2020" - vec <- noLeadingZero(vec, fmt="%.3f") - vec <- paste0(vec, tag) - } - vec -} - - - +## -------------------- +## 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. +#' +#' +#' @param ... fitted \code{lavaan} models or list(s) of \code{lavaan} objects +#' @param nested \code{logical} indicating whether the models in \code{...} are +#' nested. See the \code{\link{net}} function for an empirical test of nesting. +#' @return A \code{\linkS4class{FitDiff}} object that saves model fit +#' comparisons across multiple models. If the output is not assigned as an +#' object, the output is printed in two parts: (1) nested model comparison (if +#' models are nested) and (2) summary of fit indices. In the fit indices +#' summaries, daggers are tagged to the model with the best fit according to +#' each fit index. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \code{\linkS4class{FitDiff}}, \code{\link{clipboard}} +#' @examples +#' +#' m1 <- ' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 ' +#' +#' fit1 <- cfa(m1, data = HolzingerSwineford1939) +#' +#' m2 <- ' f1 =~ x1 + x2 + x3 + x4 +#' f2 =~ x5 + x6 + x7 + x8 + x9 ' +#' fit2 <- cfa(m2, data = HolzingerSwineford1939) +#' compareFit(fit1, fit2, nested = FALSE) +#' +#' HW.model <- ' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 ' +#' +#' out <- measurementInvariance(model = HW.model, data = HolzingerSwineford1939, +#' group = "school", quiet = TRUE) +#' compareFit(out) +#' +#' @export compareFit <- function(..., nested = TRUE) { arg <- match.call() mods <- input <- list(...) @@ -124,13 +207,13 @@ if(length(tempname[[i]]) == 1) { temp2 <- paste0(tempname[[i]], "[[", seq_along(input[[i]]), "]]") if(!is.null(names(input[[i]]))) temp2 <- names(input[[i]]) - nameMods <- c(nameMods, temp2) + nameMods <- c(nameMods, temp2) } else { temp2 <- tempname[[i]][tempname[[i]] != "list"] - nameMods <- c(nameMods, temp2) + nameMods <- c(nameMods, temp2) } - } else { - nameMods <- c(nameMods, tempname[[i]]) + } else { + nameMods <- c(nameMods, tempname[[i]]) } } nestedout <- data.frame() @@ -161,3 +244,40 @@ new("FitDiff", name = nameMods, nested = nestedout, ordernested = ord, fit = fit) } + + +## ---------------- +## Hidden Functions +## ---------------- + +isNested <- function(object) length(object@ordernested) > 1 || !is.na(object@ordernested) + +noLeadingZero <- function(vec, fmt) { + out <- sprintf(fmt, vec) + used <- vec < 1 & vec >= 0 + used[is.na(used)] <- FALSE + out[used] <- substring(out[used], 2) + out +} + +tagDagger <- function(vec, minvalue = NA, is.df = FALSE) { + if(is.na(minvalue)) { + if(is.df) { + vec <- noLeadingZero(vec, fmt="%.0f") + } else { + vec <- noLeadingZero(vec, fmt="%.3f") + } + } else { + target <- max(vec, na.rm=TRUE) + if (minvalue) { + target <- min(vec, na.rm=TRUE) + } + tag <- rep(" ", length(vec)) + tag[vec == target] <- "\u2020" + vec <- noLeadingZero(vec, fmt="%.3f") + vec <- paste0(vec, tag) + } + vec +} + + diff -Nru r-cran-semtools-0.4.14/R/dataDiagnosis.R r-cran-semtools-0.5.0/R/dataDiagnosis.R --- r-cran-semtools-0.4.14/R/dataDiagnosis.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/dataDiagnosis.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,58 +1,58 @@ -## Title: Data Diagnosis -## Author: Sunthud Pornprasertmanit -# Description: Diagnose data for its distribution -# Remark: initial version from the simsem package - -# centralMoment -# Calculate central moments of a variable -# Argument: -# x: vector of a variable -# ord: order of the moment -# weight: weight variable +### Sunthud Pornprasertmanit +### Last updated: 2 April 2017 +### Higher-order moments. Initial version from the simsem package. -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 -# Argument: -# 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) - -# skew -# Calculate the skewness of a vector -# Argument: -# object: The target vector -# population: The vector represents population values or sample values -skew <- function(object, population=FALSE) { +#' Finding skewness +#' +#' Finding skewness (\eqn{g_{1}}) of an object +#' +#' The skewness computed is \eqn{g_{1}}. The parameter skewness \eqn{\gamma_{2}} +#' formula is +#' +#' \deqn{\gamma_{2} = \frac{\mu_{3}}{\mu^{3/2}_{2}},} +#' +#' 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_{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}_2) = \frac{6}{N}} +#' +#' where \eqn{N} is the sample size. +#' +#' +#' @importFrom stats pnorm +#' +#' @param object A vector used to find a skewness +#' @param population \code{TRUE} to compute the parameter formula. \code{FALSE} +#' to compute the sample statistic formula. +#' @return A value of a skewness with a test statistic if the population is +#' specified as \code{FALSE} +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{kurtosis}} Find the univariate excessive kurtosis +#' of a variable +#' \item \code{\link{mardiaSkew}} Find Mardia's multivariate skewness +#' of a set of variables +#' \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate +#' kurtosis of a set of variables +#' } +#' @references Weisstein, Eric W. (n.d.). \emph{Skewness}. Retrived from +#' \emph{MathWorld}--A Wolfram Web Resource: +#' \url{http://mathworld.wolfram.com/Skewness.html} +#' @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.") @@ -68,16 +68,60 @@ } } -# kurtosis -# Calculate the (excessive) kurtosis of a vector -# Argument: -# object: The target vector -# population: The vector represents population values or sample values -kurtosis <- function(object, population=FALSE) { + + +#' Finding excessive kurtosis +#' +#' Finding excessive kurtosis (\eqn{g_{2}}) of an object +#' +#' The excessive kurtosis computed is \eqn{g_{2}}. The 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}},} +#' +#' 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. +#' +#' +#' @importFrom stats pnorm +#' +#' @param object A vector used to find a excessive kurtosis +#' @param population \code{TRUE} to compute the parameter formula. \code{FALSE} +#' to compute the sample statistic formula. +#' @return A value of an excessive kurtosis with a test statistic if the +#' population is specified as \code{FALSE} +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{skew}} Find the univariate skewness of a variable +#' \item \code{\link{mardiaSkew}} Find the Mardia's multivariate +#' skewness of a set of variables +#' \item \code{\link{mardiaKurtosis}} Find the Mardia's multivariate kurtosis +#' of a set of variables +#' } +#' @references Weisstein, Eric W. (n.d.). \emph{Kurtosis.} Retrived from +#' \emph{MathWorld}--A Wolfram Web Resource: +#' \url{http://mathworld.wolfram.com/Kurtosis.html} +#' @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) { return((centralMoment(object, 4)/(centralMoment(object, 2)^2)) - 3) } else { @@ -89,10 +133,48 @@ } } -# mardiaSkew -# Calculate the Mardia's skewness -# Argument: -# dat: Datasets with multiple variables + + +#' 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 \code{\link[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 \code{\link{skew}} Find the univariate skewness of a variable +#' \item \code{\link{kurtosis}} Find the univariate excessive +#' kurtosis of a variable +#' \item \code{\link{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. \emph{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)) @@ -111,10 +193,48 @@ return(c(b1d = b1d, chi = chi, df=df, p=p)) } -# mardiaKurtosis -# Calculate the Mardia's Kurtosis -# Argument: -# dat: Datasets with multiple variables + + +#' 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 \code{\link[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 \code{\link{skew}} Find the univariate skewness of a variable +#' \item \code{\link{kurtosis}} Find the univariate excessive kurtosis +#' of a variable +#' \item \code{\link{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. \emph{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)) @@ -130,3 +250,52 @@ p <- pnorm(-abs(z)) * 2 return(c(b2d = b2d, z = z, p=p)) } + + + +## ---------------- +## 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) + diff -Nru r-cran-semtools-0.4.14/R/data.R r-cran-semtools-0.5.0/R/data.R --- r-cran-semtools-0.4.14/R/data.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/data.R 2018-05-01 13:33:39.000000000 +0000 @@ -0,0 +1,137 @@ +### 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 \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}} function in +#' the \code{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 \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}} function in +#' the \code{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 \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. +#' @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 \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. +#' @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 \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. +#' @examples head(simParcel) +"simParcel" + + + diff -Nru r-cran-semtools-0.4.14/R/efa.R r-cran-semtools-0.5.0/R/efa.R --- r-cran-semtools-0.4.14/R/efa.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/efa.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,157 +1,290 @@ -### Sunthud Pornprasertmanit -### Last updated: 14 October 2016 -### run EFA model in lavaan - -setClass("EFA", representation(loading = "matrix", rotate="matrix", gradRotate="matrix", convergence="logical", phi="matrix", se = "matrix", method = "character", call="call")) - -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) +### Sunthud Pornprasertmanit & Terrence D. Jorgensen +### Last updated: 27 August 2017 +### 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 +#' in addition to the \code{\link{factanal}} function is that users can enjoy +#' some advanced features from the \code{lavaan} package such as scaled +#' \eqn{\chi^2}, diagonal weighted least squares for ordinal indicators, or +#' full-information maximum likelihood (FIML). +#' +#' @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. +#' @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}, or +#' \code{estimator} +#' @return A \code{lavaan} output of unrotated exploratory factor analysis +#' solution. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @examples +#' +#' 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") +#' +#' @export +efaUnrotate <- function(data, nf, varList = NULL, + start = TRUE, aux = NULL, ...) { + if (is.null(varList)) varList <- colnames(data) + isOrdered <- checkOrdered(data, varList, ...) + args <- list(...) + if (!is.null(args$group)) stop("Multi-group EFA is not currently supported.") + args$data <- data + if (!is.null(aux)) { + if (isOrdered) { + 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.") + } + args$fixed.x <- FALSE + args$missing <- "fiml" + args$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") + + if (!isOrdered) { + syntax <- paste(syntax, paste(paste0(varList, " ~ 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' ") + } + args$model <- syntax + do.call(lavaancfa, args) } -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) - warnings("The standard error is currently invalid because it does not account for the variance of rotation function. It is simply based on 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 -} -setMethod("show", signature(object = "EFA"), function(object) { + +## ----------------- +## 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 +#' +#' 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") - print("The standard errors are close but do not match with other packages. Be mindful when using it.") -}) - -setMethod("summary", signature(object = "EFA"), function(object, suppress = 0.1, sort = TRUE) { + 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) + print(object@phi) cat("\nMethod of rotation:\t") cat(object@method, "\n") cat("\nTest Statistics for Standardized Rotated Factor Loadings\n") print(testLoadings(object)) -}) +}) -efaUnrotate <- function(data, nf, varList=NULL, start=TRUE, aux=NULL, ...) { - if(is.null(varList)) varList <- colnames(data) - 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") - - isOrdered <- checkOrdered(data, varList, ...) - if(!isOrdered) { - syntax <- paste(syntax, paste(paste0(varList, " ~ 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) { - List <- c(list(model=syntax, data=data), list(...)) - List$do.fit <- FALSE - outtemp <- do.call(lavaancfa, List) - covtemp <- lavaan::lavInspect(outtemp, "sampstat")$cov - partemp <- lavaan::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 <- partemp$start <- NULL - syntax <- partemp - } - args <- list(...) - args$model <- syntax - args$data <- data - if(!is.null(aux)) { - if(isOrdered) { - 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.") - } - auxResult <- craftAuxParTable(syntax, aux = aux) - args$model <- auxResult$model - args$fixed.x <- FALSE - args$missing <- "fiml" - result <- do.call(lavaancfa, args) - codeNull <- nullAuxiliary(aux, auxResult$indName, NULL, any(syntax$op == "~1"), max(syntax$group)) - resultNull <- lavaan::lavaan(codeNull, data=data, ...) - result <- as(result, "lavaanStar") - fit <- lavaan::fitMeasures(resultNull) - name <- names(fit) - fit <- as.vector(fit) - names(fit) <- name - result@nullfit <- fit - result@auxNames <- aux - return(result) - } else { - return(do.call(lavaancfa, args)) - } -} -getLoad <- function(object, std = TRUE) { - out <- lavaan::inspect(object, "coef")$lambda - 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(object, "lavaanStar")) { - out <- out[!(rownames(out) %in% object@auxNames),] - } - class(out) <- c("loadings", out) - out -} -orthRotate <- function(object, method="varimax", ...) { +## ------------------------------ +## 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 +#' +#' \dontrun{ +#' +#' 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) +#' } +#' +#' @export +orthRotate <- function(object, method = "varimax", ...) { requireNamespace("GPArotation") - if(!("package:GPArotation" %in% search())) attachNamespace("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)) - LIST <- seStdLoadings(rotated, object, fun = GPArotation::GPForth, MoreArgs = c(method = method, list(...))) - orthogonal <- rotated$orthogonal + # 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 @@ -160,18 +293,24 @@ 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) + new("EFA", loading = loading, rotate = rotate, gradRotate = gradRotate, + convergence = convergence, phi = phi, se = LIST, method = method, call = mc) } -oblqRotate <- function(object, method="quartimin", ...) { + + +#' @rdname rotate +#' @export +oblqRotate <- function(object, method = "quartimin", ...) { requireNamespace("GPArotation") - if(!("package:GPArotation" %in% search())) attachNamespace("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)) - LIST <- seStdLoadings(rotated, object, fun = GPArotation::GPFoblq, MoreArgs = c(method = method, list(...))) - orthogonal <- rotated$orthogonal + 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 @@ -180,29 +319,97 @@ 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) + new("EFA", loading=loading, rotate = rotate, gradRotate = gradRotate, + convergence = convergence, phi = phi, se = LIST, method = method, call = mc) } + + +#' @rdname rotate +#' @export funRotate <- function(object, fun, ...) { stopifnot(is.character(fun)) requireNamespace("GPArotation") - if(!("package:GPArotation" %in% search())) attachNamespace("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)) + # rotateMat <- t(solve(rotated$Th)) # defined but never used gradRotate <- rotated$Gq LIST <- seStdLoadings(rotated, object, fun = fun, MoreArgs = list(...)) - orthogonal <- rotated$orthogonal + # 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)) + 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) + 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) { @@ -214,38 +421,39 @@ result[1:nrow(X), 1:ncol(Y)] } -stdRotatedLoadings <- function(est, object, fun, aux=NULL, rotate=NULL, MoreArgs = NULL) { +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) + 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 <- matrix(est[load.idx], ncol = length(lv.names)) loading <- rbind(loading, matrix(0, length(aux), ncol(loading))) # Nu 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, length(ov.names), length(ov.names), dimnames = list(ov.names, ov.names)) - for(i in th.idx) { + 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") + if (!("package:GPArotation" %in% search())) attachNamespace("GPArotation") # Compute standardized results - loading <- invsd %*% loading - + loading <- invsd %*% loading + obj <- do.call(fun, c(list(loading), MoreArgs)) - - # GPArotation::GPFoblq(loading, method="geomin") + + # GPArotation::GPFoblq(loading, method = "geomin") loading <- obj$loadings rotMat <- t(solve(obj$Th)) @@ -255,10 +463,8 @@ est[int.idx] <- as.vector(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]] - } - + 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) @@ -266,39 +472,41 @@ # rotate2 <- t(solve(rotate)) # phi <- t(rotate2) %*% rotate2 phi <- obj$Phi - if(!is.null(phi)) { - for(i in seq_along(templhs)) { + 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)) + if (is.null(phi)) phi <- diag(ncol(loading)) est <- lavaan::parameterEstimates(object)$est - aux <- NULL - if(is(object, "lavaanStar")) { - aux <- object@auxNames - } + 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 <- lavaan::lavInspect(object, "list") + 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)) + VCOV <- as.matrix(lavaan::vcov(object, labels = FALSE)) if(object@Model@eq.constraints) { JAC1 <- JAC1 %*% object@Model@eq.constraints.K } @@ -307,8 +515,8 @@ # 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) @@ -333,7 +541,7 @@ # runrow <- runrow + 1 # } # } - + # dconphi <- matrix(0, m^2 - m, m*(m-1)/2) # runrow <- 1 # descript2 <- NULL @@ -361,14 +569,31 @@ # 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 <- lavaan::parTable(object) + 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)) + matrix(LIST$se[idx], ncol = length(lv.names)) } + +checkOrdered <- function(dat, varnames, ...) { + 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)) + } + any(c(ord, orderedVar)) +} + + diff -Nru r-cran-semtools-0.4.14/R/EmpKaiser.R r-cran-semtools-0.5.0/R/EmpKaiser.R --- r-cran-semtools-0.4.14/R/EmpKaiser.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/EmpKaiser.R 2018-05-01 13:33:39.000000000 +0000 @@ -0,0 +1,134 @@ +### Ylenio Longo +### Last updated: 9 March 2018 + +#' Empirical Kaiser criterion +#' +#' 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. +#' +#' +#' @importFrom stats cov cov2cor +#' +#' @param data A \code{data.frame} or data \code{matrix} containing columns of +#' variables to be factor-analyzed. +#' @param sample.cov A covariance or correlation matrix can be used, instead of +#' \code{data}, to estimate the eigenvalues. +#' @param sample.nobs Number of observations (i.e. sample size) if +#' \code{is.null(data)} and \code{sample.cov} is used. +#' @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 \link[lavaan]{lavCor}). +#' @param 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 == TRUE} in +#' \code{data}). (see also \link[lavaan]{lavCor}) +#' @param plot logical. Whether to print a scree plot comparing the sample +#' eigenvalues with the reference eigenvalues. +#' @return 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 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} +#' @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. (in press). An empirical Kaiser +#' criterion. \emph{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) +} + diff -Nru r-cran-semtools-0.4.14/R/fitIndices.R r-cran-semtools-0.5.0/R/fitIndices.R --- r-cran-semtools-0.4.14/R/fitIndices.R 2016-10-20 09:07:12.000000000 +0000 +++ r-cran-semtools-0.5.0/R/fitIndices.R 2018-06-25 19:58:59.000000000 +0000 @@ -3,10 +3,142 @@ ## Sunthud Pornprasertmanit , ## Aaron Boulton , ## Ruben Arslan -## Last updated: 17 October 2016 +## Last updated: 2 June 2018 ## Description: Calculations for promising alternative fit indices ##---------------------------------------------------------------------------- + + +#' Calculate more fit indices +#' +#' Calculate more fit indices that are not already provided in lavaan. +#' +#' Gamma Hat (gammaHat; West, Taylor, & Wu, 2012) is a global fit index which +#' can be computed (assuming equal number of indicators across groups) by +#' +#' \deqn{ gammaHat =\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 (adjGammaHat; West, Taylor, & Wu, 2012) is a global fit +#' index which can be computed by +#' +#' \deqn{ adjGammaHat = \left(1 - \frac{K \times p \times (p + 1)}{2 \times +#' df_{k}} \right) \times \left( 1 - gammaHat \right) ,} +#' +#' where \eqn{K} is the number of groups (please refer to Dudgeon, 2004 for the +#' multiple-group adjustment for agfi*). +#' +#' Corrected Akaike Information Criterion (aic.smallN; Burnham & Anderson, +#' 2003) is a corrected version of AIC for small sample size, often abbreviated +#' AICc: +#' +#' \deqn{ aic.smallN = AIC + \frac{2k(k + 1)}{N - k - 1},} +#' +#' where \eqn{AIC} is the original AIC: \eqn{-2 \times LL + 2k} (where \eqn{k} +#' = 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 (bic.priorN; Kuha, 2004) is similar +#' to BIC but explicitly specifying the sample size on which the prior is based +#' (\eqn{N_{prior}}). +#' +#' \deqn{ bic.priorN = f + k\log{(1 + N/N_{prior})},} +#' +#' Stochastic information criterion (SIC; Preacher, 2006) is similar to AIC or +#' BIC. This index will account for model complexity in the model's function +#' form, in addition to the number of free parameters. This index will be +#' provided only when the \eqn{\chi^2} value is not scaled. The SIC can be +#' computed by +#' +#' \deqn{ sic = \frac{1}{2}\left(f - \log{\det{I(\hat{\theta})}}\right),} +#' +#' where \eqn{I(\hat{\theta})} is the information matrix of the parameters. +#' +#' Hannan-Quinn Information Criterion (hqc; Hannan & Quinn, 1979) is used for +#' model selection similar to AIC or BIC. +#' +#' \deqn{ hqc = f + 2k\log{(\log{N})},} +#' +#' Note that if Satorra--Bentler or Yuan--Bentler's method is used, the fit +#' indices using the scaled \eqn{\chi^2} values are also provided. +#' +#' See \code{\link{nullRMSEA}} for the further details of the computation of +#' RMSEA of the null model. +#' +#' +#' @importFrom lavaan lavInspect +#' +#' @param object The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{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*. +#' @return \enumerate{ +#' \item \code{gammaHat}: Gamma Hat +#' \item \code{adjGammaHat}: Adjusted Gamma Hat +#' \item \code{baseline.rmsea}: RMSEA of the Baseline (Null) Model +#' \item \code{aic.smallN}: Corrected (for small sample size) Akaike Information Criterion +#' \item \code{bic.priorN}: Bayesian Information Criterion with specified prior sample size +#' \item \code{sic}: Stochastic Information Criterion +#' \item \code{hqc}: Hannan-Quinn Information Criterion +#' \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 Baseline (Null) Model using scaled \eqn{\chi^2} +#' } +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' +#' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) +#' +#' Aaron Boulton (University of North Carolina, Chapel Hill; \email{aboulton@@email.unc.edu}) +#' +#' Ruben Arslan (Humboldt-University of Berlin, \email{rubenarslan@@gmail.com}) +#' +#' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) +#' +#' @seealso \itemize{ \item \code{\link{miPowerFit}} For the modification +#' indices and their power approach for model fit evaluation \item +#' \code{\link{nullRMSEA}} For RMSEA of the null model } +#' +#' @references 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 +#' +#' 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. +#' @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", @@ -17,19 +149,20 @@ 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 + if ("all" %in% fit.measures) fit.measures <- fit.choices # Extract fit indices information from lavaan object - fit <- lavaan::lavInspect(object, "fit") + 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"] - # Get number of observations - n <- lavaan::lavInspect(object, "ntotal") # Find the number of groups - ngroup <- lavaan::lavInspect(object, "ngroups") + 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"] @@ -37,90 +170,133 @@ # Compute fit indices result <- list() if (length(grep("gamma", fit.measures, ignore.case = TRUE))) { - gammaHatValue <- p / (p + 2 * ((fit["chisq"] - fit["df"]) / (n - 1))) - adjGammaHatValue <- 1 - (((ngroup * p * (p + 1)) / 2) / fit["df"]) * (1 - gammaHatValue) - result["gammaHat"] <- gammaHatValue - result["adjGammaHat"] <- adjGammaHatValue - if(lavaan::lavInspect(object, "options")$test %in% c("satorra.bentler", "yuan.bentler")) { - gammaHatScaledValue <- p / (p + 2 * ((fit["chisq.scaled"] - fit["df.scaled"]) / (n - 1))) - adjGammaHatScaledValue <- 1 - (((ngroup * p * (p + 1)) / 2) / fit["df.scaled"]) * (1 - gammaHatScaledValue) - result["gammaHat.scaled"] <- gammaHatScaledValue - result["adjGammaHat.scaled"] <- adjGammaHatScaledValue + 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 (!lavInspect(object, "options")$test %in% c("standard","bollen.stine")) { + 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(lavaan::lavInspect(object, "options")$test %in% c("satorra.bentler", "yuan.bentler")) { + if (!lavInspect(object, "options")$test %in% c("standard","bollen.stine")) { result["baseline.rmsea.scaled"] <- nullRMSEA(object, scaled = TRUE, silent = TRUE) } } - if(!is.na(f)) { - if("aic.smallN" %in% fit.measures) result["aic.smallN"] <- f + (2 * nParam * (nParam + 1)) / (n - nParam - 1) - if("bic.priorN" %in% fit.measures) result["bic.priorN"] <- f + log(1 + n/nPrior) * nParam - if("hqc" %in% fit.measures) result["hqc"] <- f + 2 * log(log(n)) * nParam - if("sic" %in% fit.measures) result["sic"] <- sic(f, object) + 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 ("hqc" %in% fit.measures) result["hqc"] <- f + 2 * log(log(N)) * nParam + if ("sic" %in% fit.measures) result["sic"] <- sic(f, object) } + class(result) <- c("lavaan.vector","numeric") unlist(result[fit.measures]) } -nullRMSEA <- function (object, scaled = FALSE, silent = FALSE) { - # return RMSEA of the null model, warn if it is lower than 0.158, because it makes the TLI/CLI hard to interpret - test <- lavaan::lavInspect(object, "options")$test - - fits <- lavaan::fitMeasures(object) - N <- lavaan::lavInspect(object, "ntotal") # sample size - - X2 <- as.numeric ( fits['baseline.chisq'] ) # get baseline chisq - df <- as.numeric ( fits['baseline.df'] ) # get baseline df - G <- lavaan::lavInspect(object, "ngroups") # number of groups - - ### a simple rip from fit.measures.R in lavaan's codebase. - N.RMSEA <- max(N, X2*4) # Check with lavaan - # RMSEA - if(df > 0) { - if(scaled) { - d <- sum(diag(lavaan::lavInspect(object, "UGamma"))) - } - if(lavaan::lavInspect(object, "options")$mimic %in% c("Mplus", "lavaan")) { - GG <- 0 - RMSEA <- sqrt( max( c((X2/N)/df - 1/(N-GG), 0) ) ) * sqrt(G) - if(scaled && test != "scaled.shifted") { - RMSEA.scaled <- - sqrt( max( c((X2/N)/d - 1/(N-GG), 0) ) ) * sqrt(G) - } else if(test == "scaled.shifted") { - RMSEA.scaled <- - sqrt( max(c((as.numeric(fits["baseline.chisq.scaled"])/N)/df - 1/(N-GG), 0))) * sqrt(G) - } - } else { - RMSEA <- sqrt( max( c((X2/N)/df - 1/N, 0) ) ) - if(scaled) { - RMSEA.scaled <- sqrt( max( c((X2/N)/d - 1/N, 0) ) ) - } - } - } else { - RMSEA <- RMSEA.scaled <- 0 - } - if(scaled) { - RMSEA <- RMSEA.scaled - } - if(!silent) { - if(RMSEA < 0.158 ) { - cat(paste0("TLI and other incremental fit indices may not be that informative, because the RMSEA of the baseline model is lower than 0.158 (Kenny, Kaniskan, & McCoach, 2011). The baseline RMSEA is ",round(RMSEA,3), "\n")) - } else { - cat(paste0("Baseline RMSEA: ",round(RMSEA,3), "\n")) + + +#' 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 +#' \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} +#' +#' +#' @importFrom lavaan lavInspect +#' +#' @param object The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{lavaan} functions. +#' @param scaled If \code{TRUE}, the scaled (or robust, if available) RMSEA +#' is returned. Ignored if a robust test statistic was not requested. +#' @param silent If \code{TRUE}, do not print anything on the screen. +#' +#' @return A value of RMSEA of the null model (a \code{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 \code{\link{miPowerFit}} For the modification indices and their +#' power approach for model fit evaluation +#' \item \code{\link{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. +#' \emph{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, 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 - sic <- function(f, lresults = NULL) { E.inv <- lavaan::lavTech(lresults, "inverted.information") - if(inherits(E.inv, "try-error")) { + if (inherits(E.inv, "try-error")) { return(as.numeric(NA)) } E <- MASS::ginv(E.inv) * lavaan::nobs(lresults) @@ -138,7 +314,60 @@ f + log(DET) } -## small-sample adjustment for (delta) chi-squared test statistic + + +#' \emph{k}-factor correction for \eqn{chi^2} test statistic +#' +#' Calculate \emph{k}-factor correction for \eqn{chi^2} model-fit test +#' statistic to adjust for small sample size. +#' +#' The \emph{k}-factor correction (Nevitt & Hancock, 2004) is a global fit +#' index which can be computed by: +#' +#' \deqn{ kc = 1 - \frac{2 \times P + 4 \times K + 5}{6 \times N}} +#' +#' where \eqn{N} is the sample size when using normal likelihood, or \eqn{N - +#' 1} when using \code{likelihood = 'wishart'}. +#' +#' +#' @importFrom lavaan lavInspect +#' @importFrom stats pchisq +#' +#' @param fit0 The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{lavaan} functions. +#' @param fit1 Optional additional \linkS4class{lavaan} model, in which +#' \code{fit0} is nested. If \code{fit0} has fewer \emph{df} than \code{fit1}, +#' the models will be swapped, still on the assumption that they are nested. +#' @param \dots Additional arguments to the \code{\link[lavaan]{lavTestLRT}} +#' function. +#' @return A numeric vector including the unadjusted (naive) chi-squared test +#' statistic, the \emph{k}-factor correction, the corrected test statistic, the +#' \emph{df} for the test, 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). +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @references Nevitt, J., & Hancock, G. R. (2004). Evaluating small sample +#' approaches for model test statistics in structural equation modeling. +#' \emph{Multivariate Behavioral Research, 39}(3), 439--478. +#' doi:10.1207/S15327906MBR3903_3 +#' @examples +#' +#' HS.model <- ' +#' visual =~ x1 + b1*x2 + x3 +#' textual =~ x4 + b2*x5 + x6 +#' speed =~ x7 + b3*x8 + x9 +#' ' +#' fit1 <- cfa(HS.model, data = HolzingerSwineford1939) +#' ## test a single model (implicitly compared to a saturated model) +#' chisqSmallN(fit1) +#' +#' ## fit a more constrained model +#' fit0 <- cfa(HS.model, data = HolzingerSwineford1939, orthogonal = TRUE) +#' ## compare 2 models +#' chisqSmallN(fit1, fit0) +#' +#' @export chisqSmallN <- function(fit0, fit1 = NULL, ...) { ## if there are 2 models, order them by DF if (!is.null(fit1)) { @@ -154,20 +383,22 @@ #if (min(c(DF0, DF1)) == 0L) fit1 <- NULL } ## calculate k-factor correction - N <- lavaan::lavInspect(fit0, "ntotal") - if (!lavaan::lavInspect(fit0, "options")$sample.cov.rescale) N <- N - 1 + N <- lavInspect(fit0, "ntotal") + Ng <- lavInspect(fit0, "ngroups") + if (!lavInspect(fit0, "options")$sample.cov.rescale) N <- N - Ng P <- length(lavaan::lavNames(fit0)) K <- length(lavaan::lavNames(fit0, type = "lv")) # count latent factors if (!is.null(fit1)) { - N1 <- lavaan::lavInspect(fit1, "ntotal") - if (!lavaan::lavInspect(fit1, "options")$sample.cov.rescale) N1 <- N1 - 1 + 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(lavaan::lavNames(fit1))) stop("Unequal number of variables") K <- max(K, length(lavaan::lavNames(fit1, type = "lv"))) } kc <- 1 - ((2*P + 4*K + 5) / (6*N)) if (is.null(fit1)) { - scaled <- lavaan::lavInspect(fit0, "options")$test %in% + scaled <- lavInspect(fit0, "options")$test %in% c("satorra.bentler","yuan.bentler","mean.var.adjusted","scaled.shifted") chi <- lavaan::fitMeasures(fit0)[[if (scaled) "chisq.scaled" else "chisq"]] DF <- lavaan::fitMeasures(fit0)[["df"]] diff -Nru r-cran-semtools-0.4.14/R/fitOpenMx.R r-cran-semtools-0.5.0/R/fitOpenMx.R --- r-cran-semtools-0.4.14/R/fitOpenMx.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/fitOpenMx.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,1157 +0,0 @@ - -saturateMx <- function(data, groupLab = NULL) { - multipleGroup <- FALSE - if(is.data.frame(data) && !is.null(groupLab) && groupLab %in% colnames(data)) multipleGroup <- TRUE - if(is.list(data) && !is.data.frame(data)) multipleGroup <- TRUE - if(multipleGroup) { - if(is.data.frame(data)) { - data.l <- split(data, data[,groupLab]) - data.l <- lapply(data.l, function(x) x[-ncol(x)]) - ngroups <- length(data.l) - } else if(is.list(data)) { - data.l <- data - ngroups <- length(data.l) - } else { - stop("The data argument must be a data frame or a list of MxData objects") - } - temp <- mapply(saturateMxSingleGroup, data = data.l, title = paste0("group", 1:ngroups), groupnum = 1:ngroups, SIMPLIFY=FALSE) - title <- "Multiple group Saturate Model" - asdf <- NULL - algebra <- OpenMx::mxAlgebra(asdf, name="allobjective") - groupnames <- paste0("group", 1:ngroups) - groupnames <- paste0(groupnames, ".objective") - groupnames <- lapply(groupnames, as.name) - algebra@formula <- as.call(c(list(as.name("sum")), groupnames)) - objective <- OpenMx::mxFitFunctionAlgebra("allobjective") - Saturate <- OpenMx::mxModel(title, unlist(temp), algebra, objective) - } else { - Saturate <- saturateMxSingleGroup(data, title = "Saturate Model") - } - capture.output(fit <- OpenMx::mxRun(Saturate, suppressWarnings = FALSE, silent = TRUE)) - fit -} - -saturateMxSingleGroup <- function(data, title = "Saturate Model", groupnum = NULL) { - if(!is(data, "MxData")) { - data <- OpenMx::mxData( - observed=data, - type="raw") - } - p <- ncol(data@observed) - if(data@type == "raw") { - categorical <- rep(FALSE, p) - for(i in seq_len(p)) { - categorical[i] <- "ordered" %in% class(data@observed[,i]) - } - startMeans <- apply(data@observed, 2, function(x) mean(as.numeric(x), na.rm=TRUE)) - startVar <- apply(data@observed, 2, var, na.rm=TRUE) - } else { - categorical <- rep(FALSE, p) - if(!all(is.na(data@means))) { - startMeans <- data@means - } else { - startMeans <- rep(0, p) - } - startVar <- diag(data@observed) - } - startCor <- diag(p) - - startVar[categorical] <- 1 - startMeans[categorical] <- 0 - startCov <- lavaan::cor2cov(startCor, sqrt(startVar)) - lab <- outer(1:p, 1:p, function(x, y) paste0("cov", x, y, "_", groupnum)) - lab2 <- outer(1:p, 1:p, function(x, y) paste0("cov", y, x, "_", groupnum)) - lab[upper.tri(lab)] <- lab2[upper.tri(lab2)] - freeMean <- !categorical - freeCov <- matrix(TRUE, p, p) - diag(freeCov) <- !categorical - if(any(categorical)) { - labCategorical <- colnames(data@observed)[categorical] - datCategorical <- data@observed[,categorical, drop=FALSE] - numCat <- apply(datCategorical, 2, function(x) length(unique(x))) - maxCat <- max(numCat) - FUN <- function(x, tot) c(rep(TRUE, x), rep(FALSE, tot-x)) - freeThreshold <- sapply(numCat - 1, FUN, maxCat - 1) - FUN2 <- function(x, tot) { - x <- x[!is.na(x)] - f <- table(x)/length(x) - f <- cumsum(f)[-length(f)] - f <- qnorm(f) - c(f, rep(NA, tot - length(f))) - } - valueThreshold <- sapply(datCategorical, FUN2, maxCat - 1) - T <- OpenMx::mxMatrix( - type="Full", - nrow=maxCat - 1, - ncol=length(labCategorical), - free=freeThreshold, - values=valueThreshold, - dimnames=list(c(), labCategorical), - byrow=TRUE, - name="thresh" - ) - Saturate <- OpenMx::mxModel(title, - data, - # means - OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ), - # symmetric paths - OpenMx::mxMatrix( - type="Symm", - nrow=p, - ncol=p, - values=startCov, - free=freeCov, - labels=lab, - byrow=TRUE, - name="S" - ), - T, - OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed), - thresholds = "thresh" - ), - OpenMx::mxFitFunctionML() - ) - } else { - if(data@type == "raw") { - obj <- OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed) - ) - modelMean <- OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ) - } else { - if(!all(is.na(data@means))) { - modelMean <- OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ) - obj <- OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed) - ) - } else { - modelMean <- NULL - obj <- OpenMx::mxExpectationNormal( - covariance="S", - dimnames=colnames(data@observed) - ) - } - - } - Saturate <- OpenMx::mxModel(title, - data, - # means - modelMean, - # symmetric paths - OpenMx::mxMatrix( - type="Symm", - nrow=p, - ncol=p, - values=startCov, - free=freeCov, - labels=lab, - byrow=TRUE, - name="S" - ), - obj, - OpenMx::mxFitFunctionML() - ) - } - Saturate -} - -nullMx <- function(data, groupLab = NULL) { - multipleGroup <- FALSE - if(is.data.frame(data) && !is.null(groupLab) && groupLab %in% colnames(data)) multipleGroup <- TRUE - if(is.list(data) && !is.data.frame(data)) multipleGroup <- TRUE - if(multipleGroup) { - if(is.data.frame(data)) { - data.l <- split(data, data[,groupLab]) - data.l <- lapply(data.l, function(x) x[-ncol(x)]) - ngroups <- length(data.l) - } else if(is.list(data)) { - data.l <- data - ngroups <- length(data.l) - } else { - stop("The data argument must be a data frame or a list of MxData objects") - } - temp <- mapply(nullMxSingleGroup, data = data.l, title = paste0("group", 1:ngroups), groupnum = 1:ngroups, SIMPLIFY=FALSE) - title <- "Multiple group Null Model" - asdf <- NULL - algebra <- OpenMx::mxAlgebra(asdf, name="allobjective") - groupnames <- paste0("group", 1:ngroups) - groupnames <- paste0(groupnames, ".objective") - groupnames <- lapply(groupnames, as.name) - algebra@formula <- as.call(c(list(as.name("sum")), groupnames)) - objective <- OpenMx::mxFitFunctionAlgebra("allobjective") - Null <- OpenMx::mxModel(title, unlist(temp), algebra, objective) - } else { - Null <- nullMxSingleGroup(data, title = "Null Model") - } - capture.output(fit <- OpenMx::mxRun(Null, suppressWarnings = FALSE, silent = TRUE)) - fit -} - -nullMxSingleGroup <- function(data, title = "Null Model", groupnum = NULL) { - if(!is(data, "MxData")) { - data <- OpenMx::mxData( - observed=data, - type="raw") - } - p <- ncol(data@observed) - if(data@type == "raw") { - categorical <- rep(FALSE, p) - for(i in seq_len(p)) { - categorical[i] <- "ordered" %in% class(data@observed[,i]) - } - startMeans <- apply(data@observed, 2, function(x) mean(as.numeric(x), na.rm=TRUE)) - startVar <- apply(data@observed, 2, var, na.rm=TRUE) - } else { - categorical <- rep(FALSE, p) - if(!all(is.na(data@means))) { - startMeans <- data@means - } else { - startMeans <- rep(0, p) - } - startVar <- diag(data@observed) - } - startVar[categorical] <- 1 - startMeans[categorical] <- 0 - lab <- paste0("var", 1:p, "_", groupnum) - freeMean <- !categorical - - if(any(categorical)) { - labCategorical <- colnames(data@observed)[categorical] - datCategorical <- data@observed[,categorical, drop=FALSE] - numCat <- apply(datCategorical, 2, function(x) length(unique(x))) - maxCat <- max(numCat) - FUN <- function(x, tot) c(rep(TRUE, x), rep(FALSE, tot-x)) - freeThreshold <- sapply(numCat - 1, FUN, maxCat - 1) - FUN2 <- function(x, tot) { - f <- table(x)/length(x) - f <- cumsum(f)[-length(f)] - f <- qnorm(f) - c(f, rep(NA, tot - length(f))) - } - valueThreshold <- sapply(datCategorical, FUN2, maxCat - 1) - T <- OpenMx::mxMatrix( - type="Full", - nrow=maxCat - 1, - ncol=length(labCategorical), - free=freeThreshold, - values=valueThreshold, - dimnames=list(c(), labCategorical), - byrow=TRUE, - name="thresh" - ) - NullModel <- OpenMx::mxModel(title, - data, - # means - OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ), - # symmetric paths - OpenMx::mxMatrix( - type="Diag", - nrow=p, - ncol=p, - values=startVar, - free=freeMean, - labels=lab, - byrow=TRUE, - name="S" - ), - T, - OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed), - thresholds = "thresh" - ), - OpenMx::mxFitFunctionML() - ) - } else { - if(data@type == "raw") { - obj <- OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed) - ) - modelMean <- OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ) - } else { - if(!all(is.na(data@means))) { - modelMean <- OpenMx::mxMatrix( - type="Full", - nrow=1, - ncol=p, - values=startMeans, - free=freeMean, - labels=paste0("mean", 1:p, "_", groupnum), - name="M" - ) - obj <- OpenMx::mxExpectationNormal( - covariance="S", - means="M", - dimnames=colnames(data@observed) - ) - } else { - modelMean <- NULL - obj <- OpenMx::mxExpectationNormal( - covariance="S", - dimnames=colnames(data@observed) - ) - } - - } - NullModel <- OpenMx::mxModel(title, - data, - # means - modelMean, - # symmetric paths - OpenMx::mxMatrix( - type="Diag", - nrow=p, - ncol=p, - values=startVar, - free=freeMean, - labels=lab, - byrow=TRUE, - name="S" - ), - obj, - OpenMx::mxFitFunctionML() - ) - } - NullModel -} - -checkConvergence <- function(object) { - (object@output$status[[1]] %in% c(0,1)) & (object@output$status[[2]] == 0) -} - -fitMeasuresMx <- function(object, fit.measures="all") { - mxMixture <- FALSE - if(length(object@submodels) > 1) { - if(is.null(object@submodels[[1]]@data)) mxMixture <- TRUE - } - - if(length(object@submodels) > 1 & !mxMixture) { - varnames <- lapply(object@submodels, function(x) { - out <- x@expectation@dims - if(any(is.na(out))) out <- x@manifestVars - out - }) - dat <- lapply(object@submodels, slot, "data") - FUN <- function(x, var) { - if(x@type == "raw") { - x@observed <- x@observed[,intersect(var, colnames(x@observed))] - } - x - } - dat <- mapply(FUN, x=dat, var=varnames) - } else { - dat <- object@data - if(!mxMixture) { - varnames <- object@expectation@dims - if(any(is.na(varnames))) varnames <- object@manifestVars - dat@observed <- dat@observed[,intersect(varnames, colnames(dat@observed)), drop=FALSE] - } - } - - if(length(object@output) == 0) { - stop("The target model has not been estimated yet.") - } - - if(!checkConvergence(object)) { - warning("The target model may be not convergent.") - } - - if("all" %in% fit.measures) { - class.flag <- TRUE - } else { - class.flag <- FALSE - } - - # reference: Muthen technical Appendix 5 - - # collect info from the lavaan slots - if(length(object@submodels) > 1 & !mxMixture) { - N <- sum(sapply(dat, slot, "numObs")) - } else { - N <- dat@numObs - } - - # Does not account for equality constraints imposed in MxAlgebra - npar <- length(object@output$estimate) - - - multigroup <- length(object@submodels) > 1 - G <- length(object@submodels) # number of groups - if(G == 0) G <- 1 # Correct when there is no submodel - - if(multigroup) { - if(is(object@submodels[[1]]@expectation, "MxExpectationRAM")) { - meanstructure <- !all(is.na(object@submodels[[1]]@expectation@M)) # Only ML objective - categorical <- !all(is.na(object@submodels[[1]]@expectation@thresholds)) # Only ML objective - } else { - meanstructure <- !all(is.na(object@submodels[[1]]@expectation@means)) # Only ML objective - categorical <- !all(is.na(object@submodels[[1]]@expectation@thresholds)) # Only ML objective - } - } else { - if(is(object@expectation, "MxExpectationRAM")) { - meanstructure <- !all(is.na(object@expectation@M)) # Only ML objective - categorical <- !all(is.na(object@expectation@thresholds)) # Only ML objective - } else { - meanstructure <- !all(is.na(object@expectation@means)) # Only ML objective - categorical <- !all(is.na(object@expectation@thresholds)) # Only ML objective - } - } - # define 'sets' of fit measures: - - # basic chi-square test - fit.chisq <- c("chisq", "df", "pvalue") - - # basline model - fit.baseline <- c("baseline.chisq", "baseline.df", "baseline.pvalue") - - # cfi/tli - fit.cfi.tli <- c("cfi", "tli") - - # more incremental fit indices - fit.incremental <- c("cfi", "tli", "nnfi", "rfi", "nfi", "pnfi", - "ifi", "rni") - - # likelihood based measures - fit.logl <- c("logl", "npar", "aic", "bic", - "ntotal", "bic2") - - # rmsea - fit.rmsea <- c("rmsea", "rmsea.ci.lower", "rmsea.ci.upper", "rmsea.pvalue") - - # srmr - if(categorical) { - fit.srmr <- c("wrmr") - fit.srmr2 <- c("wrmr") - } else { - fit.srmr <- c("srmr") - fit.srmr2 <- c("rmr", "rmr_nomean", - "srmr", # the default - "srmr_bentler", "srmr_bentler_nomean", - "srmr_bollen", "srmr_bollen_nomean", - "srmr_mplus", "srmr_mplus_nomean") - } - - # various - fit.other <- c("cn_05","cn_01","mfi") - if(!categorical && G == 1) { - fit.other <- c(fit.other, "ecvi") - } - - # lower case - fit.measures <- tolower(fit.measures) - - # select 'default' fit measures - - # Check ML Categorical in OpenMx - if(length(fit.measures) == 1L) { - if(fit.measures == "default") { - fit.measures <- c(fit.chisq, fit.baseline, - fit.cfi.tli, fit.logl, - fit.rmsea, fit.srmr, "saturate.status", "null.status") - } else if(fit.measures == "all") { - fit.measures <- c(fit.chisq, fit.baseline, fit.incremental, - fit.logl, fit.rmsea, fit.srmr2, fit.other, "saturate.status", "null.status") - } - } - - objectSat <- saturateMx(dat) - objectNull <- nullMx(dat) - - # main container - indices <- list() - - # Number of free parameters - if("npar" %in% fit.measures) { - indices["npar"] <- npar - } - - if("logl" %in% fit.measures || - "aic" %in% fit.measures || - "bic" %in% fit.measures) { - - # Use the definition in OpenMx - logl.H0 <- (-1/2) * (object@output$Minus2LogLikelihood - objectSat@output$Minus2LogLikelihood ) - - if("logl" %in% fit.measures) { - indices["logl"] <- logl.H0 - } - - # AIC - AIC <- -2*logl.H0 + 2*npar - if("aic" %in% fit.measures) { - indices["aic"] <- AIC - } - - # BIC - if("bic" %in% fit.measures) { - BIC <- -2*logl.H0 + npar*log(N) - indices["bic"] <- BIC - - # add sample-size adjusted bic - N.star <- (N + 2) / 24 - BIC2 <- -2*logl.H0 + npar*log(N.star) - indices["bic2"] <- BIC2 - } - } - - if(!mxMixture) { - if(multigroup) { - defVars <- lapply(object@submodels, findDefVars) - defVars <- do.call(c, defVars) - } else { - defVars <- findDefVars(object) - } - } - if(mxMixture || length(defVars) > 0) { - out <- unlist(indices[intersect(fit.measures, names(indices))]) - return(out) - } - - if(length(objectSat@output) == 0) { - stop("The saturated model has not been estimated yet.") - } - - if(length(objectNull@output) == 0) { - stop("The null model has not been estimated yet.") - } - - if(length(objectNull@output) == 0) { - stop("The null model has not been estimated yet.") - } - - if(length(object@output) == 0) { - stop("The model has not been estimated yet.") - } - - # has the model converged? - - if(!checkConvergence(objectSat)) { - warning("The saturated model may be not convergent.") - } - - if(!checkConvergence(objectNull)) { - warning("The null model may be not convergent.") - } - X2 <- object@output$Minus2LogLikelihood - objectSat@output$Minus2LogLikelihood - df <- length(objectSat@output$estimate) - length(object@output$estimate) - - indices["saturate.status"] <- objectSat@output$status[[1]] - indices["null.status"] <- objectNull@output$status[[1]] - - if(objectSat@output$status[[2]] != 0) indices["saturate.status"] <- -1 - if(objectNull@output$status[[2]] != 0) indices["null.status"] <- -1 - - # Chi-square value estimated model (H0) - if(any("chisq" %in% fit.measures)) { - indices["chisq"] <- X2 - } - if(any("df" %in% fit.measures)) { - indices["df"] <- df - } - - if(any(c("pvalue") %in% fit.measures)) { - indices["pvalue"] <- pchisq(X2, df, lower.tail = FALSE) - } - - - if(any(c("cfi", "tli", - "nnfi", "pnfi", - "rfi", "nfi", - "ifi", "rni", - "baseline.chisq", - "baseline.pvalue") %in% fit.measures)) { - - X2.null <- objectNull@output$Minus2LogLikelihood - objectSat@output$Minus2LogLikelihood - df.null <- length(objectSat@output$estimate) - length(objectNull@output$estimate) - - # check for NAs - if(is.na(X2) || is.na(df) || is.na(X2.null) || is.na(df.null)) { - indices[fit.incremental] <- as.numeric(NA) - } else { - if("baseline.chisq" %in% fit.measures) { - indices["baseline.chisq"] <- X2.null - } - if("baseline.df" %in% fit.measures) { - indices["baseline.df"] <- df.null - } - if("baseline.pvalue" %in% fit.measures) { - indices["baseline.pvalue"] <- pchisq(X2.null, df.null, lower.tail = FALSE) - } - - # CFI - comparative fit index (Bentler, 1990) - if("cfi" %in% fit.measures) { - t1 <- max( c(X2 - df, 0) ) - t2 <- max( c(X2 - df, X2.null - df.null, 0) ) - if(t1 == 0 && t2 == 0) { - indices["cfi"] <- 1 - } else { - indices["cfi"] <- 1 - t1/t2 - } - } - - # TLI - Tucker-Lewis index (Tucker & Lewis, 1973) - # same as - # NNFI - nonnormed fit index (NNFI, Bentler & Bonett, 1980) - if("tli" %in% fit.measures || "nnfi" %in% fit.measures) { - if(df > 0) { - t1 <- X2.null/df.null - X2/df - t2 <- X2.null/df.null - 1 - # note: TLI original formula was in terms of fx/df, not X2/df - # then, t1 <- fx_0/df.null - fx/df - # t2 <- fx_0/df.null - 1/N (or N-1 for wishart) - if(t1 < 0 && t2 < 0) { - TLI <- 1 - } else { - TLI <- t1/t2 - } - } else { - TLI <- 1 - } - indices["tli"] <- indices["nnfi"] <- TLI - } - - # RFI - relative fit index (Bollen, 1986; Joreskog & Sorbom 1993) - if("rfi" %in% fit.measures) { - if(df > 0) { - t1 <- X2.null/df.null - X2/df - t2 <- X2.null/df.null - if(t1 < 0 || t2 < 0) { - RLI <- 1 - } else { - RLI <- t1/t2 - } - } else { - RLI <- 1 - } - indices["rfi"] <- RLI - } - - # NFI - normed fit index (Bentler & Bonett, 1980) - if("nfi" %in% fit.measures) { - t1 <- X2.null - X2 - t2 <- X2.null - NFI <- t1/t2 - indices["nfi"] <- NFI - } - - # PNFI - Parsimony normed fit index (James, Mulaik & Brett, 1982) - if("pnfi" %in% fit.measures) { - t1 <- X2.null - X2 - t2 <- X2.null - PNFI <- (df/df.null) * t1/t2 - indices["pnfi"] <- PNFI - } - - # IFI - incremental fit index (Bollen, 1989; Joreskog & Sorbom, 1993) - if("ifi" %in% fit.measures) { - t1 <- X2.null - X2 - t2 <- X2.null - df - if(t2 < 0) { - IFI <- 1 - } else { - IFI <- t1/t2 - } - indices["ifi"] <- IFI - } - - # RNI - relative noncentrality index (McDonald & Marsh, 1990) - if("rni" %in% fit.measures) { - t1 <- X2 - df - t2 <- X2.null - df.null - if(t1 < 0 || t2 < 0) { - RNI <- 1 - } else { - RNI <- 1 - t1/t2 - } - indices["rni"] <- RNI - } - } - } - - N.RMSEA <- max(N, X2*4) # FIXME: good strategy?? - if(any("rmsea" %in% fit.measures)) { - # RMSEA - if(is.na(X2) || is.na(df)) { - RMSEA <- as.numeric(NA) - } else if(df > 0) { - GG <- 0 - RMSEA <- sqrt( max( c((X2/N)/df - 1/(N-GG), 0) ) ) * sqrt(G) - } else { - RMSEA <- 0 - } - indices["rmsea"] <- RMSEA - } - - if("rmsea.ci.lower" %in% fit.measures) { - lower.lambda <- function(lambda) { - (pchisq(X2, df=df, ncp=lambda) - 0.95) - } - if(is.na(X2) || is.na(df)) { - indices["rmsea.ci.lower"] <- NA - } else if(df < 1 || lower.lambda(0) < 0.0) { - indices["rmsea.ci.lower"] <- 0 - } else { - lambda.l <- try(uniroot(f=lower.lambda, lower=0, upper=X2)$root) - if(inherits(lambda.l, "try-error")) { lambda.l <- NA } - GG <- 0 - indices["rmsea.ci.lower"] <- - sqrt( lambda.l/((N-GG)*df) ) * sqrt(G) - } - } - - if("rmsea.ci.upper" %in% fit.measures) { - upper.lambda <- function(lambda) { - (pchisq(X2, df=df, ncp=lambda) - 0.05) - } - if(is.na(X2) || is.na(df)) { - indices["rmsea.ci.upper"] <- NA - } else if(df < 1 || upper.lambda(N.RMSEA) > 0 || upper.lambda(0) < 0) { - indices["rmsea.ci.upper"] <- 0 - } else { - lambda.u <- try(uniroot(f=upper.lambda, lower=0, upper=N.RMSEA)$root) - if(inherits(lambda.u, "try-error")) { lambda.u <- NA } - GG <- 0 - indices["rmsea.ci.upper"] <- - sqrt( lambda.u/((N-GG)*df) ) * sqrt(G) - } - } - - if("rmsea.pvalue" %in% fit.measures) { - if(is.na(X2) || is.na(df)) { - indices["rmsea.pvalue"] <- as.numeric(NA) - } else if(df > 0) { - GG <- 0 - ncp <- (N-GG)*df*0.05^2/G - indices["rmsea.pvalue"] <- - 1 - pchisq(X2, df=df, ncp=ncp) - } else { - indices["rmsea.pvalue"] <- 1 - } - } - - if(any(c("rmr","srmr") %in% fit.measures)) { - # RMR and SRMR - rmr.group <- numeric(G) - rmr_nomean.group <- numeric(G) - # srmr.group <- numeric(G) - # srmr_nomean.group <- numeric(G) - srmr_bentler.group <- numeric(G) - srmr_bentler_nomean.group <- numeric(G) - srmr_bollen.group <- numeric(G) - srmr_bollen_nomean.group <- numeric(G) - srmr_mplus.group <- numeric(G) - srmr_mplus_nomean.group <- numeric(G) - upperLevelMatrices <- NULL - if(G > 1) { - upperLevelMatrices <- getInnerObjects(object) - if(length(upperLevelMatrices) > 0) { - names(upperLevelMatrices) <- paste0(object@name, ".", names(upperLevelMatrices)) - } - } - for(g in 1:G) { - if(G > 1) { - if(is(objectSat@submodels[[g]]@expectation, "MxExpectationRAM")) { - impliedSat <- getImpliedStatRAM(objectSat@submodels[[g]]) - } else { - impliedSat <- getImpliedStatML(objectSat@submodels[[g]]) - } - } else { - if(is(objectSat@expectation, "MxExpectationRAM")) { - impliedSat <- getImpliedStatRAM(objectSat) - } else { - impliedSat <- getImpliedStatML(objectSat) - } - } - S <- impliedSat[[2]] - M <- matrix(impliedSat[[1]], ncol=1) - - nvar <- ncol(S) - - # estimated - if(G > 1) { - if(is(object@submodels[[g]]@expectation, "MxExpectationRAM")) { - implied <- getImpliedStatRAM(object@submodels[[g]]) - } else { - implied <- getImpliedStatML(object@submodels[[g]], xxxextraxxx = upperLevelMatrices) - } - } else { - if(is(object@expectation, "MxExpectationRAM")) { - implied <- getImpliedStatRAM(object) - } else { - implied <- getImpliedStatML(object) - } - } - Sigma.hat <- implied[[2]] - Mu.hat <- matrix(implied[[1]], ncol=1) - - # unstandardized residuals - RR <- (S - Sigma.hat) # not standardized - - # standardized residual covariance matrix - # this is the Hu and Bentler definition, not the Bollen one! - sqrt.d <- 1/sqrt(diag(S)) - D <- diag(sqrt.d, ncol=length(sqrt.d)) - R <- D %*% (S - Sigma.hat) %*% D - - # Bollen approach: simply using cov2cor ('residual correlations') - S.cor <- cov2cor(S) - Sigma.cor <- cov2cor(Sigma.hat) - R.cor <- (S.cor - Sigma.cor) - - if(meanstructure) { - # standardized residual mean vector - R.mean <- D %*% (M - Mu.hat) # EQS approach! - RR.mean <- (M - Mu.hat) # not standardized - R.cor.mean <- M/sqrt(diag(S)) - Mu.hat/sqrt(diag(Sigma.hat)) - - e <- nvar*(nvar+1)/2 + nvar - srmr_bentler.group[g] <- - sqrt( (sum(R[lower.tri(R, diag=TRUE)]^2) + - sum(R.mean^2))/ e ) - rmr.group[g] <- sqrt( (sum(RR[lower.tri(RR, diag=TRUE)]^2) + - sum(RR.mean^2))/ e ) - srmr_bollen.group[g] <- - sqrt( (sum(R.cor[lower.tri(R.cor, diag=TRUE)]^2) + - sum(R.cor.mean^2)) / e ) - # see http://www.statmodel.com/download/SRMR.pdf - srmr_mplus.group[g] <- - sqrt( (sum(R.cor[lower.tri(R.cor, diag=FALSE)]^2) + - sum(R.cor.mean^2) + - sum(((diag(S) - diag(Sigma.hat))/diag(S))^2)) / e ) - - e <- nvar*(nvar+1)/2 - srmr_bentler_nomean.group[g] <- - sqrt( sum( R[lower.tri( R, diag=TRUE)]^2) / e ) - rmr_nomean.group[g] <- - sqrt( sum(RR[lower.tri(RR, diag=TRUE)]^2) / e ) - srmr_bollen_nomean.group[g] <- - sqrt( sum(R.cor[lower.tri(R.cor, diag=TRUE)]^2) / e ) - srmr_mplus_nomean.group[g] <- - sqrt( (sum(R.cor[lower.tri(R.cor, diag=FALSE)]^2) + - sum(((diag(S) - diag(Sigma.hat))/diag(S))^2)) / e ) - } else { - e <- nvar*(nvar+1)/2 - srmr_bentler_nomean.group[g] <- srmr_bentler.group[g] <- - sqrt( sum(R[lower.tri(R, diag=TRUE)]^2) / e ) - rmr_nomean.group[g] <- rmr.group[g] <- - sqrt( sum(RR[lower.tri(RR, diag=TRUE)]^2) / e ) - srmr_bollen_nomean.group[g] <- srmr_bollen.group[g] <- - sqrt( sum(R.cor[lower.tri(R.cor, diag=TRUE)]^2) / e ) - srmr_mplus_nomean.group[g] <- srmr_mplus.group[g] <- - sqrt( (sum(R.cor[lower.tri(R.cor, diag=FALSE)]^2) + - sum(((diag(S) - diag(Sigma.hat))/diag(S))^2)) / e ) - } - } - - if(G > 1) { - ## FIXME: get the scaling right - ngroups <- sapply(dat, slot, "numObs") - SRMR_BENTLER <- as.numeric( (ngroups %*% srmr_bentler.group) / N ) - SRMR_BENTLER_NOMEAN <- as.numeric( (ngroups %*% srmr_bentler_nomean.group) / N ) - SRMR_BOLLEN <- as.numeric( (ngroups %*% srmr_bollen.group) / N ) - SRMR_BOLLEN_NOMEAN <- as.numeric( (ngroups %*% srmr_bollen_nomean.group) / N ) - SRMR_MPLUS <- as.numeric( (ngroups %*% srmr_mplus.group) / N ) - SRMR_MPLUS_NOMEAN <- as.numeric( (ngroups %*% srmr_mplus_nomean.group) / N ) - RMR <- as.numeric( (ngroups %*% rmr.group) / N ) - RMR_NOMEAN <- as.numeric( (ngroups %*% rmr_nomean.group) / N ) - } else { - SRMR_BENTLER <- srmr_bentler.group[1] - SRMR_BENTLER_NOMEAN <- srmr_bentler_nomean.group[1] - SRMR_BOLLEN <- srmr_bollen.group[1] - SRMR_BOLLEN_NOMEAN <- srmr_bollen_nomean.group[1] - SRMR_MPLUS <- srmr_mplus.group[1] - SRMR_MPLUS_NOMEAN <- srmr_mplus_nomean.group[1] - RMR <- rmr.group[1] - RMR_NOMEAN <- rmr_nomean.group[1] - } - - indices["srmr"] <- SRMR_BENTLER - indices["srmr_nomean"] <- SRMR_BENTLER_NOMEAN - indices["srmr_bentler"] <- SRMR_BENTLER - indices["srmr_bentler_nomean"] <- SRMR_BENTLER_NOMEAN - indices["srmr_bollen"] <- SRMR_BOLLEN - indices["srmr_bollen_nomean"] <- SRMR_BOLLEN_NOMEAN - indices["srmr_mplus"] <- SRMR_MPLUS - indices["srmr_mplus_nomean"] <- SRMR_MPLUS_NOMEAN - indices["rmr"] <- RMR - indices["rmr_nomean"] <- RMR_NOMEAN - } - - if(any(c("cn_05", "cn_01") %in% fit.measures)) { - CN_05 <- qchisq(p=0.95, df=df)/(X2/N) + 1 - CN_01 <- qchisq(p=0.99, df=df)/(X2/N) + 1 - indices["cn_05"] <- CN_05 - indices["cn_01"] <- CN_01 - } - - if("wrmr" %in% fit.measures) { - # we use the definition: wrmr = sqrt ( 2*N*F / e ) - e <- npar + df # Modified from lavaan - WRMR <- sqrt( X2 / e ) - indices["wrmr"] <- WRMR - } - - # Intentionally not report GFI, AGFI, and PGFI because it requires the weight matrix - - # MFI - McDonald Fit Index (McDonald, 1989) - if("mfi" %in% fit.measures) { - #MFI <- exp(-0.5 * (X2 - df)/(N-1)) # Hu & Bentler 1998 Table 1 - MFI <- exp(-0.5 * (X2 - df)/N) - indices["mfi"] <- MFI - } - - # ECVI - cross-validation index (Brown & Cudeck, 1989) - # not defined for multiple groups and/or models with meanstructures - if("ecvi" %in% fit.measures) { - if(G > 1 || meanstructure) { - ECVI <- as.numeric(NA) - } else { - ECVI <- X2/N + (2*npar)/N - } - indices["ecvi"] <- ECVI - } - - if("ntotal" %in% fit.measures) { - indices["ntotal"] <- N - } - - # do we have everything that we requested? - idx.missing <- which(is.na(match(fit.measures, names(indices)))) - if(length(idx.missing) > 0L) { - cat("lavaan WARNING: some requested fit measure(s) are not available for this model:\n") - print( fit.measures[ idx.missing ] ) - cat("\n") - } - - out <- unlist(indices[fit.measures]) - - if(length(out) > 0L) { - return(out) - } else { - return( invisible(numeric(0)) ) - } -} - -findDefVars <- function(object) { - mat <- lapply(object@matrices, slot, "labels") - defvars <- sapply(mat, function(x) x[apply(x, c(1,2), OpenMx::imxIsDefinitionVariable)]) - Reduce("c", defvars) -} - -getImpliedStatML <- function(xxxobjectxxx, xxxcovdatatxxx = NULL, xxxextraxxx = NULL) { - if(!is.null(xxxextraxxx)) { - xxxmatnamexxx2 <- names(xxxextraxxx) - for(i in seq_along(xxxmatnamexxx2)) { - assign(xxxmatnamexxx2[i], xxxextraxxx[[i]]) - } - } - xxxmatxxx <- xxxobjectxxx@matrices - xxxmatnamexxx <- names(xxxmatxxx) - xxxmatvalxxx <- lapply(xxxmatxxx, slot, "values") - for(i in seq_along(xxxmatnamexxx)) { - assign(xxxmatnamexxx[i], xxxmatvalxxx[[i]]) - } - if(!is.null(xxxcovdatatxxx)) { - xxxmatlabxxx <- lapply(xxxmatxxx, slot, "labels") - xxxdefvarsxxx <- lapply(xxxmatlabxxx, function(x) apply(x, c(1,2), OpenMx::imxIsDefinitionVariable)) - for(i in seq_along(xxxmatnamexxx)) { - if(any(xxxdefvarsxxx[[i]])) { - xxxtempxxx <- get(xxxmatnamexxx[i]) - for(j in seq_len(length(xxxdefvarsxxx[[i]]))) { - if(xxxdefvarsxxx[[i]][j]) { - xxxtempnamexxx <- gsub("data.", "", xxxmatlabxxx[[i]][j]) - xxxtempxxx[j] <- xxxcovdatatxxx[xxxtempnamexxx] - } - } - assign(xxxmatnamexxx[i], xxxtempxxx) - } - } - } - xxxalgebraxxx <- xxxobjectxxx@algebras - xxxalgebranamexxx <- names(xxxalgebraxxx) - xxxalgebraformulaxxx <- lapply(xxxalgebraxxx, slot, "formula") - for(i in seq_along(xxxalgebranamexxx)) { - assign(xxxalgebranamexxx[i], eval(xxxalgebraformulaxxx[[i]])) - } - - xxximpliedCovxxx <- get(xxxobjectxxx@expectation@covariance) - - if(is.na(xxxobjectxxx@expectation@means)) { - xxximpliedMeanxxx <- rep(0, nrow(xxximpliedCovxxx)) - } else { - xxximpliedMeanxxx <- get(xxxobjectxxx@expectation@means) - } - - if(is.na(xxxobjectxxx@expectation@thresholds)) { - xxximpliedThresholdxxx <- NA - } else { - xxximpliedThresholdxxx <- get(xxxobjectxxx@expectation@thresholds) - } - list(xxximpliedMeanxxx, xxximpliedCovxxx, xxximpliedThresholdxxx) -} - -getImpliedStatRAM <- function(object) { - A <- object@matrices$A@values - I <- diag(nrow(A)) - S <- object@matrices$S@values - F <- object@matrices$F@values - Z <- solve(I - A) - impliedCov <- F %*% Z %*% S %*% t(Z) %*% t(F) - if(!is.null(object@matrices$M)) { - M <- object@matrices$M@values - impliedMean <- t(F %*% Z %*% t(M)) - } else { - impliedMean <- rep(0, nrow(impliedCov)) - } - list(impliedMean, impliedCov) -} - -standardizeMx <- function(object, free = TRUE) { - objectOrig <- object - multigroup <- length(object@submodels) > 0 - if(multigroup) { - defVars <- lapply(object@submodels, findDefVars) - defVars <- do.call(c, defVars) - } else { - defVars <- findDefVars(object) - } - if(length(defVars) > 0) stop("The standardizeMx is not available for the model with definition variable.") - if(multigroup) { - object@submodels <- lapply(object@submodels, standardizeMxSingleGroup) - } else { - object <- standardizeMxSingleGroup(object) - } - vectorizeMx(object, free=free) -} - -standardizeMxSingleGroup <- function(object) { - if(!is(object@expectation, "MxExpectationRAM")) stop("The standardizeMx function is available for the MxExpectationRAM only.") - A <- object@matrices$A@values - I <- diag(nrow(A)) - S <- object@matrices$S@values - F <- object@matrices$F@values - Z <- solve(I - A) - impliedCov <- Z %*% S %*% t(Z) - temp <- sqrt(diag(impliedCov)) - if(length(temp) == 1) { - ImpliedSd <- as.matrix(temp) - } else { - ImpliedSd <- diag(temp) - } - ImpliedInvSd <- solve(ImpliedSd) - object@matrices$S@values <- ImpliedInvSd %*% S %*% ImpliedInvSd - object@matrices$A@values <- ImpliedInvSd %*% A %*% ImpliedSd - if(!is.null(object@matrices$M)) { - M <- object@matrices$M@values - object@matrices$M@values <- M %*% ImpliedInvSd - } - return(object) -} - - -vectorizeMx <- function(object, free = TRUE) { - multigroup <- length(object@submodels) > 0 - if(multigroup) { - object <- object@submodels - } else { - object <- list(object) - } - result <- NULL - for(i in seq_along(object)) { - name <- "" - if(multigroup) name <- paste0(object[[i]]@name, ".") - mat <- object[[i]]@matrices - for(j in seq_along(mat)) { - tempname <- paste0(name, mat[[j]]@name) - lab <- mat[[j]]@labels - tempfree <- as.vector(mat[[j]]@free) - madeLab <- paste0(tempname, "[", row(lab), ",", col(lab), "]") - lab <- as.vector(lab) - madeLab[!is.na(lab)] <- lab[!is.na(lab)] - if(!free) tempfree <- rep(TRUE, length(tempfree)) - temp <- mat[[j]]@values[tempfree] - names(temp) <- madeLab[tempfree] - result <- c(result, temp) - } - } - - result[!duplicated(names(result))] -} - - -getInnerObjects <- function(xxxobjectxxx) { - xxxmatxxx <- xxxobjectxxx@matrices - xxxmatnamexxx <- names(xxxmatxxx) - xxxmatvalxxx <- lapply(xxxmatxxx, slot, "values") - for(i in seq_along(xxxmatnamexxx)) { - assign(xxxmatnamexxx[i], xxxmatvalxxx[[i]]) - } - xxxalgebraxxx <- xxxobjectxxx@algebras - xxxalgebranamexxx <- names(xxxalgebraxxx) - xxxalgebraformulaxxx <- lapply(xxxalgebraxxx, slot, "formula") - xxxalgebraassignedxxx <- NULL - for(i in seq_along(xxxalgebranamexxx)) { - temp <- NULL - try(temp <- eval(xxxalgebraformulaxxx[[i]]), silent = TRUE) - if(!is.null(temp)) { - assign(xxxalgebranamexxx[i], temp) - xxxalgebraassignedxxx <- c(xxxalgebraassignedxxx, xxxalgebranamexxx[i]) - } - } - xxxusednamexxx <- c(xxxmatnamexxx, xxxalgebraassignedxxx) - xxxresultxxx <- list() - for(i in seq_along(xxxusednamexxx)) { - xxxresultxxx[[i]] <- get(xxxusednamexxx[i]) - } - names(xxxresultxxx) <- xxxusednamexxx - xxxresultxxx -} diff -Nru r-cran-semtools-0.4.14/R/fmi.R r-cran-semtools-0.5.0/R/fmi.R --- r-cran-semtools-0.4.14/R/fmi.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/fmi.R 2018-06-25 21:43:19.000000000 +0000 @@ -1,144 +1,235 @@ -########### Mauricio Garnier Villarreal (mgv@ku.edu) -### Last updated: 14 October 2016 -######This function estimates the Fraction of Missing Information for the variance and mean of each variable in a list of multiple imputed data sets -#### dat.imp is a list of the imputed data sets -#### method is the model used for the estimation -#### varnames is used to select a subset of variables -#### digits is the number of decimals -#### group is the grouping variable, in case you want to get the fmi for each group -#### exclude are the variables that you wnat to exclude from the analysis - -fmi <- function(dat.imp, method="saturated", varnames=NULL, group=NULL, exclude=NULL, digits=3){ - - if(is.character(varnames)){ - vars <- varnames - } else { - vars <- colnames(dat.imp[[1]]) - } - - if(!is.null(group)){ - vars <- vars[vars!=group] - } - - if(!is.null(exclude)){ - vars <- vars[vars!=exclude] - } - - if(method == "saturated" | method == "sat"){ - par.tab <- satParFMI(dat.imp, var.names=vars, groups=group) - } - if(method == "null"){ - par.tab <- nullParFMI(dat.imp, var.names=vars, groups=group) +### Mauricio Garnier Villarreal & Terrence D. Jorgensen +### Last updated: 25 June 2018 +### 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 \code{\link[lavaan]{lavaan}} +#' for a single incomplete data set using FIML, or with \code{\link{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. +#' +#' +#' @importFrom lavaan lavListInspect lavInspect +#' +#' @param data Either a single \code{data.frame} with incomplete observations, +#' or a \code{list} of imputed data sets. +#' @param 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 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 character. Optional vector of names of ordered-categorical +#' variables, which are not already stored as class \code{ordered} in +#' \code{data}. +#' @param varnames character. Optional vector of variable names, to calculate +#' FMI for a subset of variables in \code{data}. By default, all numeric and +#' ordered variables will be included, unless \code{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. +#' @param exclude character. Optional vector of variable names to exclude from +#' the analysis. +#' @param fewImps logical. If \code{TRUE}, use the estimate of FMI that applies +#' a correction to the estimated between-imputation variance. Recommended when +#' there are few imputations; makes little difference when there are many +#' imputations. Ignored when \code{data} is not a list of imputed data sets. +#' @return \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"}.} \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.} \item{message}{A message indicating caution +#' when the null model is used.} +#' @author Mauricio Garnier Villarreal (University of Kansas; +#' \email{mauricio.garniervillarreal@@marquette.edu}) Terrence Jorgensen +#' (University of Amsterdam; \email{TJorgensen314@@gmail.com}) +#' @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 +#' @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, group = "school")) +#' +#' \dontrun{ +#' ## ordered-categorical data +#' data(datCat) +#' lapply(datCat, class) +#' ## impose missing values +#' set.seed(123) +#' for (i in 1:8) datCat[sample(1:nrow(datCat), size = .1*nrow(datCat)), i] <- NA +#' ## impute data m = 3 times +#' library(Amelia) +#' set.seed(456) +#' impout <- amelia(datCat, m = 3, noms = "g", ords = paste0("u", 1:8), p2s = FALSE) +#' imps <- impout$imputations +#' ## calculate FMI, using list of imputed data sets +#' fmi(imps, group = "g") +#' } +#' +#' @export +fmi <- function(data, method = "saturated", group = NULL, ords = NULL, + varnames = NULL, exclude = NULL, fewImps = 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) { + 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 } - - comb.results1 <- cfa.mi(par.tab, dat.imp, chi="none", meanstructure = TRUE, group = group) - - comb.results <- inspect(comb.results1, "impute")[[2]] ## FIXME: can't just be lavInspect because it is a lavaanStar - - comb.results <- data.frame(comb.results[,c("lhs","op","rhs","group")], - round(lavaan::parameterEstimates(comb.results1)[,"est"], digits), - round(comb.results[,c("fmi1","fmi2")], digits)) - - colnames(comb.results) <- c('lhs', 'op', 'rhs', 'group', 'coef', 'fmi.1', 'fmi.2') - - variances <- comb.results[comb.results$lhs==comb.results$rhs,] - - variances <- data.frame(variances[,"lhs"], variances[,"group"], variances[,"coef"], - variances[,"fmi.1"], variances[,"fmi.2"]) - - colnames(variances) <- c('var', 'group', 'coef', 'fmi.1', 'fmi.2') - - var.means <- comb.results[comb.results$op=="~1",] - - var.means <- data.frame(var.means[,"lhs"], var.means[,"group"], var.means[,"coef"], - var.means[,"fmi.1"], var.means[,"fmi.2"]) - - colnames(var.means) <- c('var', 'group', 'coef', 'fmi.1', 'fmi.2') - - if(method == "null"){ - mes <- "These estimates used the null model, they may not be as precise as the saturated model estimates" - results<-list(Variances=variances, Means=var.means, Message=mes) + + ## construct model + covstruc <- outer(vars, vars, function(x, y) paste(x, "~~", y)) + if (method == "saturated" | method == "sat") { + diag(covstruc)[which(ordvars %in% vars)] <- "" + model <- covstruc[lower.tri(covstruc, diag = TRUE)] + } else if (method == "null") model <- diag(covstruc) + if (length(numvars)) model <- c(model, paste(numvars, "~1")) + + ## fit model + if (fiml) { + fit <- lavaan::lavaan(model, data = data, missing = "fiml", group = group) + 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 { - results<-list(Variances=variances, Means=var.means) + fit <- lavaan.mi(model, data, group = group, ordered = ordvars, auto.th = TRUE) + comb.results <- getMethod("summary","lavaan.mi")(fit, fmi = TRUE, ci = FALSE, + add.attributes = FALSE) + nG <- lavListInspect(fit, "ngroups") + if (nG == 1L) comb.results$group <- 1L + group.label <- lavListInspect(fit, "group.label") + if (fewImps) { + comb.results["fmi1"] <- NULL + names(comb.results)[names(comb.results) == "fmi2"] <- "fmi" + } else { + comb.results["fmi2"] <- NULL + names(comb.results)[names(comb.results) == "fmi1"] <- "fmi" + } + for (i in c("t","df","pvalue","riv")) comb.results[i] <- NULL } - - return(results) -} -#### function to produce a parameter table for the saturated model -satParFMI <- function(dat.imp, var.names=NULL, groups=NULL){ - - if(!is.null(groups)){ - ngroups <- length(table(dat.imp[[1]][,groups])) + ## 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") + ## start list of results + results <- list(Variances = Variances) + } else results <- list() } else { - ngroups <- 1 + ## covariances from saturated model, including polychorics (if applicable) + if (fiml) { + covmat <- lavInspect(fit, "theta") + if (nG == 1L) covmat <- list(covmat) + } else { + useImps <- sapply(fit@convergence, "[[", "converged") + m <- sum(useImps) + if (nG == 1L) { + ThetaList <- lapply(fit@coefList[useImps], function(x) x$theta) + covmat <- list(Reduce("+", ThetaList) / m) + } else { + covmat <- list() + for (i in group.label) { + groupList <- lapply(fit@coefList[useImps],"[[", i) + ThetaList <- lapply(groupList, function(x) x$theta) + covmat[[i]] <- Reduce("+", ThetaList) / m + } + } + } + + fmimat <- covmat + covars <- comb.results[comb.results$op == "~~", c("lhs","rhs","group","est","fmi")] + for (i in 1:nG) { + fmimat[[i]][as.matrix(covars[covars$group == i, 1:2])] <- covars$fmi[covars$group == i] + fmimat[[i]][as.matrix(covars[covars$group == i, 2:1])] <- covars$fmi[covars$group == i] + } + if (nG == 1L) { + Covariances <- list(coef = covmat[[1]], fmi = fmimat[[1]]) + } else Covariances <- list(coef = covmat, fmi = fmimat) + ## start list of results + results <- list(Covariances = Covariances) } - - # gets the parameter table from the null model - par.null <- nullParFMI(dat.imp, var.names, groups=groups) - lhs.diag <- par.null$lhs - op.diag <- par.null$op - rhs.diag <- par.null$rhs - gnull <- par.null$group - #combine the variable names to set al the covariances - combs <- t(combn(var.names, 2)) - lhs.up <- rep(combs[, 1],times=ngroups) - op.up <- rep("~~", length(lhs.up)) - rhs.up <- rep(combs[, 2],times=ngroups) - galt <- sort(rep(1:ngroups,times=length(lhs.up)/ngroups)) - #put together the null table and the covariances - lhs.all <- c(lhs.up, lhs.diag) - id <- seq(1:length(lhs.all)) - op.all <- c(op.up, op.diag) - rhs.all <- c(rhs.up, rhs.diag) - user <- rep(1,length(lhs.all)) - group <- as.integer(c(galt,gnull)) - free <- as.integer(id) - ustart <- rep(NA, length(lhs.all)) - exo <- rep(0, length(lhs.all)) - label <- rep("", length(lhs.all)) - plabel <- rep("", length(lhs.all)) - par.sat <- list(id, lhs.all, op.all, rhs.all, user, group, - free, ustart, exo, label, plabel) - names(par.sat) <- c("id", "lhs", "op", "rhs", "user", "group", "free", "ustart", "exo", "label", "plabel") - return(par.sat) -} -#### function to produce a parameter table for the null model -nullParFMI <- function(dat.imp, var.names=NULL, groups=NULL){ - - if(!is.null(groups)){ - ngroups <- length(table(dat.imp[[1]][,groups])) - } else { - ngroups <- 1 + ## 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") } - - lhs.diag1 <- rep(c(var.names),times=ngroups) - op.diag1 <- rep("~~",ngroups*(length(var.names))) - rhs.diag1 <- rep(var.names,times=ngroups) - group1 <- sort(rep(1:ngroups,times=length(lhs.diag1)/ngroups)) - - lhs.diag2 <- rep(c(var.names),times=ngroups) - op.diag2 <- rep("~1",ngroups*(length(var.names))) - rhs.diag2 <- rep("",ngroups*length(var.names)) - group2 <- sort(rep(1:ngroups,times=length(lhs.diag2)/ngroups)) - - lhs.diag <- c(lhs.diag1, lhs.diag2) - op.diag <- c(op.diag1, op.diag2) - rhs.diag <- c(rhs.diag1, rhs.diag2) - group <- c(group1, group2) - first <- data.frame(lhs.diag,op.diag,rhs.diag,group) - first <- first[order(first$group),] - id <- seq(1:length(lhs.diag)) - user <- rep(1,length(lhs.diag)) - free <- as.integer(id) - ustart <- rep(NA, length(lhs.diag)) - exo <- rep(0, length(lhs.diag)) - label <- rep("", length(lhs.diag)) - plabel <- rep("", length(lhs.diag)) - null.sat.fmi <- list(id, as.character(first$lhs.diag), as.character(first$op.diag), - as.character(first$rhs.diag), user, first$group, - free, ustart, exo, label, plabel) - names(null.sat.fmi) <- c("id","lhs","op","rhs","user","group","free","ustart","exo","label","plabel") - return(null.sat.fmi) + + ## return results, with message if using null model + if (method == "null") + results$message <- paste("Null-model estimates may not be as", + "precise as saturated-model estimates.") + results } + + diff -Nru r-cran-semtools-0.4.14/R/htmt.R r-cran-semtools-0.5.0/R/htmt.R --- r-cran-semtools-0.4.14/R/htmt.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/htmt.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,55 +1,119 @@ -### HTMT function -#Written by Ylenio Longo +### Ylenio Longo +### Last updated: 9 March 2018 -htmt <- function(data, model, ...){ - R <- lavaan::lavCor(object = data, ...) - R <- abs(R) #this helps avoid errors - diag(R) <- NA - m <- lavaan::lavaanify(model) - m <- m[m$op%in% "=~",] - - ##variable names for each scale / factor - factors <- unique(m$lhs) - var <- list() - for(i in 1:length(factors)){ - var[[i]] <- m$rhs[which(m$lhs %in% factors[i])] +#' 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 average correlation among +#' indicators across constructs (i.e. heterotrait-heteromethod correlations), +#' relative to the average correlation among indicators within the same +#' construct (i.e. monotrait-heteromethod correlations). The resulting HTMT +#' values are interpreted as estimates of inter-construct correlations. +#' Absolute values of the correlations are recommended to calculate the HTMT +#' matrix. Correlations are estimated using the lavCor function in the lavaan +#' package. +#' +#' +#' @importFrom stats cov2cor +#' +#' @param model lavaan \link[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 \code{data.frame} or data \code{matrix} +#' @param sample.cov A covariance or correlation matrix can be used, instead of +#' \code{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 \link[lavaan]{lavCor}). +#' @param 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 == TRUE} in +#' \code{data}). (see also \link[lavaan]{lavCor}) +#' @param absolute logical. Whether HTMT values should be estimated based on +#' absolute correlations (recommended and default is \code{TRUE}) +#' @return A matrix showing HTMT 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. \emph{Journal of the Academy of Marketing Science, 43}(1), +#' 115--135. doi:10.1007/s11747-014-0403-8 +#' @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) +#' +#' @export +htmt <- function (model, data = NULL, sample.cov = NULL, missing = "listwise", + ordered = NULL, absolute = 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 = " ")) } - var - - ##mean correlation within scales - m.cor.w <- list() - for(i in 1:length(factors)){ - m.cor.w[[i]] <- mean(R[var[[i]],var[[i]]], na.rm=TRUE) + 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 = " ")) } - m.cor.w <- as.numeric(m.cor.w) - m.cor.w - - ##geometric mean correlations within scale pairs - #all possible correlation combinations - comb <- expand.grid(1:length(factors), 1:length(factors)) - g <- list() - for(i in 1:nrow(comb)){ - g[[i]] <- sqrt(m.cor.w[comb[i,2]]*m.cor.w[comb[i,1]]) + 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] } - g <- as.numeric(g) - g #geometric mean results - - paste(comb[,2], comb[,1]) - - ##mean correlations among items across scales - m.cor.a <- list() - for(i in 1:nrow(comb)){ - 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) - m.cor.a - - ##htmt values - outhtmt <- m.cor.a / g - - ##results - res <- matrix(outhtmt, nrow=length(factors), ncol=length(factors), dimnames=list(factors)) - colnames(res) <- factors - class(res) <- c("lavaan.matrix.symmetric", "matrix") - res + } + if (absolute) { + R <- abs(R) + } + diag(R) <- NA + m.cor.w <- list() + for (i in 1:nf) { + 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)) { + 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 } diff -Nru r-cran-semtools-0.4.14/R/imposeStart.R r-cran-semtools-0.5.0/R/imposeStart.R --- r-cran-semtools-0.4.14/R/imposeStart.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/imposeStart.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,9 +1,148 @@ +### 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 \code{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 <- lavaan::parTable(model) + ptmodel <- parTable(model) coefmodel <- lavaan::coef(model) coefout <- lavaan::coef(out) start <- coefout[match(names(coefmodel), names(coefout))] diff -Nru r-cran-semtools-0.4.14/R/indProd.R r-cran-semtools-0.5.0/R/indProd.R --- r-cran-semtools-0.4.14/R/indProd.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/indProd.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,167 +1,265 @@ -## Title: Orthogonalize data for 2-way and 3-way interaction in SEM -## Author: Sunthud Pornprasertmanit and Alexander M. Schoemann -## Description: Orthogonalize data for 2-way and 3-way interaction in SEM -##----------------------------------------------------------------------------## - -# indProd: Make a product of indicators using mean centering, double-mean centering, or residual centering - -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) +### Sunthud Pornprasertmanit and Alexander M. Schoemann +### Last updated: 9 March 2018 +### 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 \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. +#' +#' +#' @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 \code{TRUE} to use match-paired approach (Marsh, Wen, & +#' Hau, 2004). If \code{FALSE}, the resulting products are all possible +#' products. +#' @param meanC Specify \code{TRUE} for mean centering the main effect +#' indicator before making the products +#' @param residualC Specify \code{TRUE} for residual centering the products by +#' the main effect indicators (Little, Bovaird, & Widaman, 2006). +#' @param doubleMC Specify \code{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 \code{\link{probe2WayMC}} For probing the two-way +#' latent interaction when the results are obtained from mean-centering, or +#' double-mean centering. \item \code{\link{probe3WayMC}} For probing the +#' three-way latent interaction when the results are obtained from +#' mean-centering, or double-mean centering. \item \code{\link{probe2WayRC}} +#' For probing the two-way latent interaction when the results are obtained +#' from residual-centering approach. \item \code{\link{probe3WayRC}} For +#' probing the two-way latent interaction when the results are obtained from +#' residual-centering approach. \item \code{\link{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. \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 +#' @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) +#' +#' @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) } - 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 - } + ## 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 { - 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 + 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 <- data.frame(data, datProd) - return(data) -} - -# orthogonalize: the shortcut for residual centering -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) + } + ## 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) +} + + diff -Nru r-cran-semtools-0.4.14/R/kd.R r-cran-semtools-0.5.0/R/kd.R --- r-cran-semtools-0.4.14/R/kd.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/kd.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,30 +1,87 @@ -"kd" <- function(covmat, n, type=c("exact","sample")) -{ - ## Kaiser-Dickman (1962) algorithm for generating sample data - ## based on the input covmat, which is a covariance matrix. - ## - ## n is desired sample size - ## type="exact" returns data matrix that yields the exact covmat; - ## type="sample" returns sample data, treating covmat as population matrix - ## - ## Returns the sample data matrix, dat - - ## Code written by Edgar Merkle, University of Missouri - +### Edgar Merkle +### Last updated: 9 March 2018 +### 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 \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. +#' +#' +#' @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. \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}. +#' @return \code{kd} returns a data matrix of dimension \code{n} by +#' \code{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. \emph{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") + 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") - + 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)) @@ -32,7 +89,7 @@ ## Generate standard normal data and mean center each variable Xscore <- matrix(rnorm(p*n), p, n) - Xsub0 <- t(apply(Xscore, 1, scale, scale=FALSE)) + Xsub0 <- t(apply(Xscore, 1, scale, scale = FALSE)) ## Correlation matrix factored via Cholesky decomposition: Fcomp <- t(chol(cormat)) @@ -45,18 +102,24 @@ ## 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) + 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) + Z <- Z * sqrt(n) dat <- Z - if (type=="sample"){dat <- Zhat} + 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 } + + diff -Nru r-cran-semtools-0.4.14/R/lisrel2lavaan.R r-cran-semtools-0.5.0/R/lisrel2lavaan.R --- r-cran-semtools-0.4.14/R/lisrel2lavaan.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/lisrel2lavaan.R 2018-06-27 11:20:44.000000000 +0000 @@ -1,13 +1,136 @@ -##lisrel2lavaan -##Corbin Quick -##02/12/13 -##file path/name of LS8 LISREL syntax file - -lisrel2lavaan <- function(filename=NULL, analyze=TRUE, silent=FALSE, ...){ - -## if filename == null, prompt user with file browser - - if(is.null(filename)){ +### Corbin Quick +### Last updated: 9 March 2018 +### deprecated because it is based on an old template for lavaan's parTable + + +#' Translate LISREL syntax to lavaan \code{\link[lavaan]{model.syntax}} +#' +#' \bold{This function is deprecated} because it is based on an old template +#' for lavaan's parameter table, which is expected to differ more as +#' development continues. +#' +#' This function can be used to estimate a structural equation model in +#' \code{\linkS4class{lavaan}} using LISREL syntax. Data are automatically +#' imported from the LISREL syntax file, or, if data files names are provided +#' within LISREL syntax, from the same directory as the syntax itself, as per +#' standard LISREL data importation. +#' +#' +#' @importFrom utils read.table read.csv +#' @param filename Filename of the LISREL syntax file. If the \code{filename} +#' arguement is not specified, the user will be prompted with a file browser +#' with which LISREL syntax file can be selected (recommended). +#' @param analyze Logical. If \code{analyze==TRUE} (default), data will be +#' automatically imported and analyzed; \code{\linkS4class{lavaan}} summary +#' output displayed and fit object will be returned silently. If +#' \code{analyze==FALSE}, data will not be imported or analyzed; instead, a +#' \code{\linkS4class{lavaan}} parameter table containing the model +#' specifications will be returned. +#' @param silent Logical. If false (default) the data will be analyzed and +#' output displayed. If true, a fit object will be returned and summary output +#' will not be displayed. +#' @param \dots Additional arguments to be passed to +#' \code{\link[lavaan]{lavaan}}. See also \code{\link[lavaan]{lavOptions}} +#' @return Output summary is printed to screen and \code{\linkS4class{lavaan}} +#' fit object is returned. +#' @note \code{lisrel2lavaan} is still in development, and not all LISREL +#' commands are currently functional. A number of known limitations are +#' outlined below. If an error is encountered that is not listed, please +#' contact \email{corbinq@ku.edu}. +#' +#' \enumerate{ +#' \item data importation: \code{lisrel2lavaan} currently supports .csv, +#' .dat, and most other delimited data formats. However, formats that are +#' specific to LISREL or PRELIS (e.g., the .PSF file format) cannot be +#' imported. \code{lisrel2lavaan} supports raw data, covariance matrices, +#' and correlation matrices (accompanied by a variance vector). Symmetric +#' matrices can either contain lower triangle or full matrix. For MACS +#' structure models, either raw data or summary statistics (that include a +#' mean vector) are supported. +#' +#' \item variable labels: Certain variable labels that are permitted in LISREL +#' cannot be supported in \code{lisrel2lavaan}. +#' +#' \item duplicate labels: Most importantly, no two variables of any kind +#' (including phantom variables) should be given the same label when using +#' \code{lisrel2lavaan}. If multiple variables are given the same label, +#' \code{\link[lavaan]{lavaan}} will estimate an incorrect model. +#' +#' \item numeric character labels: All variable labels are recommended to include +#' non-numeric characters. In addition, the first character in each variable +#' label is recommended to be non-numeric. +#' +#' \item labels not specified: If variable labels are not provided by the user, +#' names will be generated reflecting variable assignment (e.g. 'eta1', +#' 'ksi1'); manifest variables will be in lower case and latent variables in +#' upper case. +#' +#' \item OU paragraph Not all commands in the OU paragraph are presently +#' supported in \code{lisrel2lavaan}. The ME command can be used to specify +#' estimation method; however, not all estimations available in LISREL are +#' currently supported by \code{\link[lavaan]{lavaan}}. If the specified ME is +#' unsupported, \code{lisrel2lavaan} will revert to default estimation. The AD, +#' EP, IT, ND and NP keywords will be ignored. Requests for text files +#' containing starting values (e.g., \code{OU BE}) will also be ignored. +#' +#' \item starting values: Certain functionalities related to starting values in +#' LISREL are not yet operational in \code{lisrel2lavaan}. Note that due to +#' differences in estimation, starting values are not as important in +#' \code{\link[lavaan]{lavaan}} model estimation as in LISREL. +#' +#' \item text file output: Requests for text files containing starting +#' values for individual matrices in the in the \code{OU} command (e.g., +#' \code{OU BE}) are not currently supported. These requests will be ignored. +#' +#' \item MA paragraph: Specification of matrix starting values using the MA +#' command is permitted by providing starting values within syntax directly. +#' However, \code{lisrel2lavaan} has sometimes encountered problems with +#' importation when files are specified following the MA paragraph. +#' +#' } +#' @author Corbin Quick (University of Michigan; \email{corbinq@@umich.edu}) +#' @examples +#' +#' \dontrun{ +#' ## calling lisrel2lavaan without specifying the filename argument will +#' ## open a file browser window with which LISREL syntax can be selected. +#' +#' ## any additional arguments to be passed to lavaan for data analysis can +#' ## be specified normally. +#' +#' lisrel2lavaan(se = "standard") +#' ## lavaan output summary printed to screen +#' ## lavaan fit object returned silently +#' +#' ## manual file specification +#' +#' lisrel2lavaan(filename = "myFile.LS8", se = "standard") +#' ## lavaan output summary printed to screen +#' ## lavaan fit object returned silently +#' } +#' +#' @name lisrel2lavaan-deprecated +#' @usage lisrel2lavaan(filename = NULL, analyze = TRUE, silent = FALSE, ...) +#' @seealso \code{\link{semTools-deprecated}} +#' @keywords internal +NULL + + + +#' @rdname semTools-deprecated +#' @section \code{lisrel2lavaan}: +#' The \code{lisrel2lavaan} function will no longer be supported, nor will +#' there be a replacement function. +#' +#' @export +lisrel2lavaan <- function(filename = NULL, analyze = TRUE, silent = FALSE, ...) { + .Deprecated(msg = c("The lisrel2lavaan function is deprecated, and it will", + " cease to be included in future versions of semTools.", + " There is no guarantee lisrel2lavaan will work with", + " the current version of lavaan.")) + ## if filename == null, prompt user with file browser + + if (is.null(filename)) { reverseSlash <- function (x, pat = "\\", rep = "/") { x <- gsub(pat, rep, x, fixed = T) x <- gsub("'", "", x, fixed = T) @@ -16,270 +139,270 @@ } filename <- reverseSlash(file.choose()) } - -## if a file path is included in 'filename', set the working directory -## to that path so that data files will be searched for in the same -## directory as the syntax file regardless of the current directory. -## working directory is restored at the end of the function. + + ## if a file path is included in 'filename', set the working directory + ## to that path so that data files will be searched for in the same + ## directory as the syntax file regardless of the current directory. + ## working directory is restored at the end of the function. temp <- unlist(strsplit(filename,'/',fixed=T)) restore.wd <- getwd() - if(length(temp)>1){ + if (length(temp) > 1) { path <- paste(temp[1:(length(temp)-1)],"/",sep='',collapse="") filename <- temp[length(temp)] setwd(path) } - -lisrel<-function(filename, analyze, ...){ - -## "find" function for manipulating syntax - - find <- function(pat = 0, sou, n = 1) { - flag <- function(vec, pat){ - vec <- unlist(vec) - if(is.null(vec[1])){ + + lisrel<-function(filename, analyze, ...){ + + ## "find" function for manipulating syntax + + find <- function(pat = 0, sou, n = 1) { + flag <- function(vec, pat){ + vec <- unlist(vec) + if(is.null(vec[1])){ FALSE }else{ - if(is.na(vec[1])){ - FALSE + if(is.na(vec[1])){ + FALSE + } else { + if(vec[1]==pat){TRUE}else{FALSE} + } + } + } + if (is.data.frame(sou) | is.matrix(sou)) { + out <- 1:nrow(sou) + out <- out[unlist(apply(sou, 1, flag, pat = pat))] + out <- out[length(out)] + } else if (is.list(sou) | is.vector(sou)) { + if(is.vector(sou)){ + sou <- as.list(sou) + } + out <- 1:length(sou) + out <- out[unlist(lapply(sou, flag, pat = pat))] + if(n!=0) { + out <- out[n] } else { - if(vec[1]==pat){TRUE}else{FALSE} + out <- out[length(out)] } + } else { + out <- NULL } - } - if (is.data.frame(sou) | is.matrix(sou)) { - out <- 1:nrow(sou) - out <- out[unlist(apply(sou, 1, flag, pat = pat))] - out <- out[length(out)] - } else if (is.list(sou) | is.vector(sou)) { - if(is.vector(sou)){ - sou <- as.list(sou) - } - out <- 1:length(sou) - out <- out[unlist(lapply(sou, flag, pat = pat))] - if(n!=0) { - out <- out[n] - } else { - out <- out[length(out)] - } - } else { - out <- NULL - } - if(!is.null(out)){ - out <- out[!is.na(out)] - if(length(out)<1){ - out <- NULL - } else if(is.na(out)){ - out <- NULL - } - } - out - } + if(!is.null(out)){ + out <- out[!is.na(out)] + if(length(out)<1){ + out <- NULL + } else if(is.na(out)){ + out <- NULL + } + } + out + } -as.numeric.s <- function(x){ - suppressWarnings(as.numeric(x)) -} + as.numeric.s <- function(x){ + suppressWarnings(as.numeric(x)) + } -## function to evaluate MO matrix commands; creates pseudo-class for matrices + ## function to evaluate MO matrix commands; creates pseudo-class for matrices -modMat <- function(name, line) { - ## obtain row/col numbers using ref table (external) - row <- eval(parse(text=paste(ref[find(name,ref),2]))) - col <- eval(parse(text=paste(ref[find(name,ref),3]))) - ## constraint and misc are blank by default - constraint <- matrix(0, row, col) - misc <- matrix("", row, col) - ## if mode specified then obtain mode, else mode='de' (default) - if(length(unlist(strsplit(line,",")))>1){ - form <- unlist(strsplit(line,","))[1] - mode <- unlist(strsplit(line,","))[2] - } else { - if(any(line==c("fi","fr"))){ - mode <- line - if(any(name==c("lx","ly","ga"))){ - form <- "fu" - }else if(any(name==c("ps","te","td"))){ - form <- "di" - }else if(any(name==c("be","th"))){ - form <- "ze" - }else if(any(name==c("ph"))){ - form <- "sy" - }else { - form <- "fu" + modMat <- function(name, line) { + ## obtain row/col numbers using ref table (external) + row <- eval(parse(text=paste(ref[find(name,ref),2]))) + col <- eval(parse(text=paste(ref[find(name,ref),3]))) + ## constraint and misc are blank by default + constraint <- matrix(0, row, col) + misc <- matrix("", row, col) + ## if mode specified then obtain mode, else mode='de' (default) + if(length(unlist(strsplit(line,",")))>1){ + form <- unlist(strsplit(line,","))[1] + mode <- unlist(strsplit(line,","))[2] + } else { + if(any(line==c("fi","fr"))){ + mode <- line + if(any(name==c("lx","ly","ga"))){ + form <- "fu" + }else if(any(name==c("ps","te","td"))){ + form <- "di" + }else if(any(name==c("be","th"))){ + form <- "ze" + }else if(any(name==c("ph"))){ + form <- "sy" + }else { + form <- "fu" + } + }else{ + form <- line + mode <- "de" } - }else{ - form <- line - mode <- "de" } - } - ## determine matrix type (properties differ) - if(any(name== c("lx","ly") )){ - if(any(form==c("fu","ze"))){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else{ - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(any(form==c("sd","sy","st","iz","zi"))){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else{ - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(form=="di"){ - if(name=="ly"){ - if(ny==ne){ - if(mode=="fr"){ - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - }else{ - start <- as.matrix(diag(1, row)) - free <- as.matrix(diag(0, row)) - } - }else { - stop("syntax error: LY matrix cannot be form DI when NY is not equal to NE") - } - } - if(name=="lx"){ - if(nx==nk){ - if(mode=="fr"){ - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - }else { - start <- as.matrix(diag(1, row)) - free <- as.matrix(diag(0, row)) - } - }else { - stop("syntax error: LX matrix cannot be form DI when NX is not equal to NK") - } - } - }else if(any(form==c("id"))){ - start <- matrix(0, row, col) - diag(start) <- 1 - free <- matrix(0, row, col) - } - }else if(name=="ga") { - if(form=="fu"){ - if(mode=="fr" | mode=="de"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - } else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(form=="ze"){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - } else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(any(form==c("sd","sy","st","iz","zi"))){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - } else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - } - if(form=="di"){ - if(ny==nx){ - if(mode=="fr"){ - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - } else { - start <- as.matrix(diag(1, row)) - free <- as.matrix(diag(0, row)) - } - } else { - stop("syntax error: GA matrix cannot be form DI when NY is not equal to NX") - } - } - if(form=="id"){ - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(name=="be") { - if(any(form==c("fu","ze"))){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - } else if(form=="sy"){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else if(mode=="de") { - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - }else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(any(form==c("sd","st","iz","zi","id", "di"))){ - if(mode=="fi"){ - start <- as.matrix(diag(1, row)) - free <- as.matrix(diag(0, row)) - }else { - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - } - } - }else if(any(name==c("td", "te", "th", "ph", "ps"))) { - if(any(form==c("fu","ze"))){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(form=="sy"){ - if(mode=="fr"){ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - }else if(mode=="de") { - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - }else { - start <- matrix(0, row, col) - free <- matrix(0, row, col) - } - }else if(any(form==c("sd","st","iz","zi","id","di"))){ - if(mode=="fi"){ - start <- as.matrix(diag(1, row)) - free <- as.matrix(diag(0, row)) - }else { - start <- as.matrix(diag(NA, row)) - free <- as.matrix(diag(1, row)) - } - } - }else if(any(name==c("ty","tx","ka","kl","al"))){ - if(any(mode==c("fi","ze")) | any(form==c("fi","ze"))){ - start <- matrix(0, row, col) - free <- matrix(0, row, col) - }else{ - start <- matrix(NA, row, col) - free <- matrix(1, row, col) - } - } - list(start=start,free=free,constraint=constraint,misc=misc) -} + ## determine matrix type (properties differ) + if(any(name== c("lx","ly") )){ + if(any(form==c("fu","ze"))){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else{ + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(any(form==c("sd","sy","st","iz","zi"))){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else{ + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(form=="di"){ + if(name=="ly"){ + if(ny==ne){ + if(mode=="fr"){ + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + }else{ + start <- as.matrix(diag(1, row)) + free <- as.matrix(diag(0, row)) + } + }else { + stop("syntax error: LY matrix cannot be form DI when NY is not equal to NE") + } + } + if(name=="lx"){ + if(nx==nk){ + if(mode=="fr"){ + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + }else { + start <- as.matrix(diag(1, row)) + free <- as.matrix(diag(0, row)) + } + }else { + stop("syntax error: LX matrix cannot be form DI when NX is not equal to NK") + } + } + }else if(any(form==c("id"))){ + start <- matrix(0, row, col) + diag(start) <- 1 + free <- matrix(0, row, col) + } + }else if(name=="ga") { + if(form=="fu"){ + if(mode=="fr" | mode=="de"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + } else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(form=="ze"){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + } else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(any(form==c("sd","sy","st","iz","zi"))){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + } else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + } + if(form=="di"){ + if(ny==nx){ + if(mode=="fr"){ + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + } else { + start <- as.matrix(diag(1, row)) + free <- as.matrix(diag(0, row)) + } + } else { + stop("syntax error: GA matrix cannot be form DI when NY is not equal to NX") + } + } + if(form=="id"){ + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(name=="be") { + if(any(form==c("fu","ze"))){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + } else if(form=="sy"){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else if(mode=="de") { + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + }else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(any(form==c("sd","st","iz","zi","id", "di"))){ + if(mode=="fi"){ + start <- as.matrix(diag(1, row)) + free <- as.matrix(diag(0, row)) + }else { + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + } + } + }else if(any(name==c("td", "te", "th", "ph", "ps"))) { + if(any(form==c("fu","ze"))){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(form=="sy"){ + if(mode=="fr"){ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + }else if(mode=="de") { + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + }else { + start <- matrix(0, row, col) + free <- matrix(0, row, col) + } + }else if(any(form==c("sd","st","iz","zi","id","di"))){ + if(mode=="fi"){ + start <- as.matrix(diag(1, row)) + free <- as.matrix(diag(0, row)) + }else { + start <- as.matrix(diag(NA, row)) + free <- as.matrix(diag(1, row)) + } + } + }else if(any(name==c("ty","tx","ka","kl","al"))){ + if(any(mode==c("fi","ze")) | any(form==c("fi","ze"))){ + start <- matrix(0, row, col) + free <- matrix(0, row, col) + }else{ + start <- matrix(NA, row, col) + free <- matrix(1, row, col) + } + } + list(start=start,free=free,constraint=constraint,misc=misc) + } + + ## function to format LISREL syntax -## function to format LISREL syntax - - doc <- scan(filename, "", sep="\n") + doc <- scan(filename, "", sep="\n") - format <- function(doc) { + format <- function(doc) { doc <- gsub("\t"," ",doc) doc <- gsub("(^ +)|( +$)", "", doc) doc <- gsub("\\(","[",doc) @@ -306,362 +429,362 @@ doc<-lapply(doc,function(x){x[x!=""]}) doc<-doc[!unlist(lapply(doc,is.null))] doc<-doc[unlist(lapply(doc,function(x){if(length(x)==0){FALSE}else{TRUE}}))] - - doc - } - - doc0 <- format(doc) - doc <- format(tolower(doc)) - -## OU output commands ... - if(!is.null(find("ou",doc))){ - ou <- unlist(doc[[find("ou",doc)]]) - ou <- ou[ou!="ou"] - }else{ - ou <- NULL - } - if(length(grep("me",ou))>0){ - estimator <- unlist(strsplit(ou[grep("me",ou)],"="))[2] - if(estimator=="gl"){ - estimator <- "GLS" - }else if(estimator=="wl"){ - estimator <- "WLS" - }else if(estimator=="ul"){ - estimator <- "ULS" - }else if(estimator=="dw"){ - estimator <- "DWLS" - } - }else{ - estimator <- "default" - } -# if(length(grep("se",ou))>0){ -# me <- -# }else{ -# me <- "default" -# } - -## Multiple-Group Models - - groupN <- 1 - da <- doc[[find("da",doc,1)]] - da <- t(as.data.frame(strsplit(da[2:length(da)],"="))) - if(!is.null(find("ng",da))){ - ng <- as.numeric.s(da[find("ng",(da)),2]) - if(ng>1){ - for(i in 2:ng){ - if(i==ng){ - tx <- ")):length(doc)]" - }else{ - tx <- paste(")):(find('da',doc,",(i+1),")-1)]",sep="") - } - eval(parse(text=paste("doc",i,"<-doc[(find('da',doc,",i,tx,sep=""))) - eval(parse(text=paste("doc0",i,"<-doc0[(find('da',doc,",i,tx,sep=""))) - } - doc0 <- doc0[1:(find("da",doc,2)-1)] - doc <- doc[1:(find("da",doc,2)-1)] + + doc } - }else{ - ng <- 1 - } - -## FUNCTION TO EXTRACT DATA - ## get # variables - ## must be global environment - ni <- doc[[find("da",doc)]][[grep("ni",doc[[find("da",doc)]])]] - ni <- as.numeric.s(gsub("ni=","",ni)) - - ## the 'makeSym' function is primarily used in 'getData'; - ## however, it has uses elsewhere (e.g. PA commands), and - ## therefore must be left out of 'getData' itself. - makeSym <- function(dat, ni){ - dat <- unlist(dat) - lapply(1:ni,function(x,dat){ - if(x==1){ - return(dat[1]) - }else{ - dat[(sum(1:(x-1))+1):sum(1:x)] + doc0 <- format(doc) + doc <- format(tolower(doc)) + + ## OU output commands ... + if(!is.null(find("ou",doc))){ + ou <- unlist(doc[[find("ou",doc)]]) + ou <- ou[ou!="ou"] + }else{ + ou <- NULL + } + if(length(grep("me",ou))>0){ + estimator <- unlist(strsplit(ou[grep("me",ou)],"="))[2] + if(estimator=="gl"){ + estimator <- "GLS" + }else if(estimator=="wl"){ + estimator <- "WLS" + }else if(estimator=="ul"){ + estimator <- "ULS" + }else if(estimator=="dw"){ + estimator <- "DWLS" } - },dat=dat) - } - -getData <- function(doc, doc0, ngroup = 1) { - -## below is an unfortunate work-around .. - if(length(grep("cm=", doc))>0){ - doc[[grep("cm=", doc)]] <- unlist(strsplit(unlist(doc[grep("cm=", doc)]),"=")) - doc0[[grep("cm=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("cm=", doc0, ignore.case=T)]),"=")) - } - if(length(grep("km=", doc))>0){ - doc[[grep("km=", doc)]] <- unlist(strsplit(unlist(doc[grep("km=", doc)]),"=")) - doc0[[grep("km=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("km=", doc0, ignore.case=T)]),"=")) - } - if(length(grep("me=", doc))>0){ - doc[[grep("me=", doc)]] <- unlist(strsplit(unlist(doc[grep("me=", doc)]),"=")) - doc0[[grep("me=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("me=", doc0, ignore.case=T)]),"=")) - } - if(length(grep("pm=", doc))>0){ - doc[[grep("pm=", doc)]] <- unlist(strsplit(unlist(doc[grep("pm=", doc)]),"=")) - doc0[[grep("pm=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("pm=", doc0, ignore.case=T)]),"=")) - } - if(length(grep("sd=", doc))>0){ - doc[[grep("sd=", doc)]] <- unlist(strsplit(unlist(doc[grep("sd=", doc)]),"=")) - doc0[[grep("sd=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("sd=", doc0, ignore.case=T)]),"=")) - } - if(length(grep("ra=", doc))>0){ - doc[[grep("ra=", doc)]] <- unlist(strsplit(unlist(doc[grep("ra=", doc)]),"=")) - doc0[[grep("ra=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("ra=", doc0, ignore.case=T)]),"=")) - } - -##paragraphs of interest ... - paragraphs <- c("cm","km","me","pm","sd","ra") - pValues <- 1:length(paragraphs) - - cm <- NULL - km <- NULL - me <- NULL - pm <- NULL - sd <- NULL - ra <- NULL - - fLength <- c(((ni^2+ni)/2), ((ni^2+ni)/2), ni, ni, ni, NA) - fExist <- rep(FALSE, length(paragraphs)) - fLocate <- rep(0, length(paragraphs)) - fNames <- rep(NA, length(paragraphs)) - fData <- list() - - dataList <- list() - dN <- 1 - existList <- list() - orderList <- list() - - charTest <-function(line){ - line <- unlist(line) - if(is.na(as.numeric.s(line[1]))) - {TRUE} else {FALSE} - } - - ## read in data for individual paragraphs - for(i in seq_along(paragraphs)){ - p <- paragraphs[[i]] - if(!is.null(find(p,doc))){ - line1a <- length(unlist(doc[find(p,doc)]))>1 - line1b <- if(line1a){charTest(doc[[find(p,doc)]][2])}else{FALSE} - line2 <- charTest(unlist(doc[find(p,doc)+1])) - if(line1a && line1b && line2){ - fExist[i] <- TRUE - if(length(grep("=",doc0[[find(p,doc)]][2]))>0){ - if(doc0[[find(p,doc)]][2]=="="){ - fname <- doc0[[find(p,doc)]][3] + }else{ + estimator <- "default" + } + # if(length(grep("se",ou))>0){ + # me <- + # }else{ + # me <- "default" + # } + + ## Multiple-Group Models + + groupN <- 1 + da <- doc[[find("da",doc,1)]] + da <- t(as.data.frame(strsplit(da[2:length(da)],"="))) + if(!is.null(find("ng",da))){ + ng <- as.numeric.s(da[find("ng",(da)),2]) + if(ng>1){ + for(i in 2:ng){ + if(i==ng){ + tx <- ")):length(doc)]" }else{ - fname <- unlist(strsplit(doc0[[find(p,doc)]][2],"="))[2] + tx <- paste(")):(find('da',doc,",(i+1),")-1)]",sep="") } + eval(parse(text=paste("doc",i,"<-doc[(find('da',doc,",i,tx,sep=""))) + eval(parse(text=paste("doc0",i,"<-doc0[(find('da',doc,",i,tx,sep=""))) + } + doc0 <- doc0[1:(find("da",doc,2)-1)] + doc <- doc[1:(find("da",doc,2)-1)] + } + }else{ + ng <- 1 + } + + ## FUNCTION TO EXTRACT DATA + + ## get # variables + ## must be global environment + ni <- doc[[find("da",doc)]][[grep("ni",doc[[find("da",doc)]])]] + ni <- as.numeric.s(gsub("ni=","",ni)) + + ## the 'makeSym' function is primarily used in 'getData'; + ## however, it has uses elsewhere (e.g. PA commands), and + ## therefore must be left out of 'getData' itself. + makeSym <- function(dat, ni){ + dat <- unlist(dat) + lapply(1:ni,function(x,dat){ + if(x==1){ + return(dat[1]) }else{ - fname <- doc0[[find(p,doc)]][2] + dat[(sum(1:(x-1))+1):sum(1:x)] } - if(length(find(fname, fNames))==0){ - if(paragraphs[i]=="ra"){ - type <- tolower(substr(fname, (nchar(fname)-2), nchar(fname))) - if(type=='dat'){ - if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ - dataList[[dN]] <- as.matrix(read.table(fname,header=TRUE)) - } - else{dataList[[dN]] <- as.matrix(read.table(fname))} - } else if(type=='csv'){ - if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ - dataList[[dN]] <- as.matrix(read.csv(fname,header=TRUE)) - }else{dataList[[dN]] <- as.matrix(read.csv(fname))} - } else if (type=='psf'){ - stop("Please use a different data format: .PSF files are compatible only with PRELIS.") - } else { - if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ - dataList[[dN]] <- as.matrix(read.table(fname,header=TRUE)) + },dat=dat) + } + + getData <- function(doc, doc0, ngroup = 1) { + + ## below is an unfortunate work-around .. + if(length(grep("cm=", doc))>0){ + doc[[grep("cm=", doc)]] <- unlist(strsplit(unlist(doc[grep("cm=", doc)]),"=")) + doc0[[grep("cm=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("cm=", doc0, ignore.case=T)]),"=")) + } + if(length(grep("km=", doc))>0){ + doc[[grep("km=", doc)]] <- unlist(strsplit(unlist(doc[grep("km=", doc)]),"=")) + doc0[[grep("km=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("km=", doc0, ignore.case=T)]),"=")) + } + if(length(grep("me=", doc))>0){ + doc[[grep("me=", doc)]] <- unlist(strsplit(unlist(doc[grep("me=", doc)]),"=")) + doc0[[grep("me=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("me=", doc0, ignore.case=T)]),"=")) + } + if(length(grep("pm=", doc))>0){ + doc[[grep("pm=", doc)]] <- unlist(strsplit(unlist(doc[grep("pm=", doc)]),"=")) + doc0[[grep("pm=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("pm=", doc0, ignore.case=T)]),"=")) + } + if(length(grep("sd=", doc))>0){ + doc[[grep("sd=", doc)]] <- unlist(strsplit(unlist(doc[grep("sd=", doc)]),"=")) + doc0[[grep("sd=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("sd=", doc0, ignore.case=T)]),"=")) + } + if(length(grep("ra=", doc))>0){ + doc[[grep("ra=", doc)]] <- unlist(strsplit(unlist(doc[grep("ra=", doc)]),"=")) + doc0[[grep("ra=", doc0, ignore.case=T)]] <- unlist(strsplit(unlist(doc0[grep("ra=", doc0, ignore.case=T)]),"=")) + } + + ##paragraphs of interest ... + paragraphs <- c("cm","km","me","pm","sd","ra") + pValues <- 1:length(paragraphs) + + cm <- NULL + km <- NULL + me <- NULL + pm <- NULL + sd <- NULL + ra <- NULL + + fLength <- c(((ni^2+ni)/2), ((ni^2+ni)/2), ni, ni, ni, NA) + fExist <- rep(FALSE, length(paragraphs)) + fLocate <- rep(0, length(paragraphs)) + fNames <- rep(NA, length(paragraphs)) + fData <- list() + + dataList <- list() + dN <- 1 + existList <- list() + orderList <- list() + + charTest <-function(line){ + line <- unlist(line) + if(is.na(as.numeric.s(line[1]))) + {TRUE} else {FALSE} + } + + ## read in data for individual paragraphs + for(i in seq_along(paragraphs)){ + p <- paragraphs[[i]] + if(!is.null(find(p,doc))){ + line1a <- length(unlist(doc[find(p,doc)]))>1 + line1b <- if(line1a){charTest(doc[[find(p,doc)]][2])}else{FALSE} + line2 <- charTest(unlist(doc[find(p,doc)+1])) + if(line1a && line1b && line2){ + fExist[i] <- TRUE + if(length(grep("=",doc0[[find(p,doc)]][2]))>0){ + if(doc0[[find(p,doc)]][2]=="="){ + fname <- doc0[[find(p,doc)]][3] + }else{ + fname <- unlist(strsplit(doc0[[find(p,doc)]][2],"="))[2] + } + }else{ + fname <- doc0[[find(p,doc)]][2] + } + if(length(find(fname, fNames))==0){ + if(paragraphs[i]=="ra"){ + type <- tolower(substr(fname, (nchar(fname)-2), nchar(fname))) + if(type=='dat'){ + if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ + dataList[[dN]] <- as.matrix(read.table(fname,header=TRUE)) + } + else{dataList[[dN]] <- as.matrix(read.table(fname))} + } else if(type=='csv'){ + if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ + dataList[[dN]] <- as.matrix(read.csv(fname,header=TRUE)) + }else{dataList[[dN]] <- as.matrix(read.csv(fname))} + } else if (type=='psf'){ + stop("Please use a different data format: .PSF files are compatible only with PRELIS.") + } else { + if(is.numeric(as.matrix(read.table(fname, nrows=1)))==FALSE){ + dataList[[dN]] <- as.matrix(read.table(fname,header=TRUE)) + } + else{dataList[[dN]] <- as.matrix(read.table(fname))} } - else{dataList[[dN]] <- as.matrix(read.table(fname))} + + }else{ + dataList[[dN]] <- unlist(format(scan(fname,"",sep="\n"))) } - - }else{ - dataList[[dN]] <- unlist(format(scan(fname,"",sep="\n"))) + fLocate[i] <- dN + existList[[dN]] <- rep(FALSE, length(paragraphs)) + existList[[dN]][i] <- TRUE + dN <- dN + 1 + } else { + existList[[(dN-1)]][i] <- TRUE + fLocate[i] <- fLocate[find(fname, fNames)] + } + fNames[[i]] <- fname } - fLocate[i] <- dN - existList[[dN]] <- rep(FALSE, length(paragraphs)) - existList[[dN]][i] <- TRUE - dN <- dN + 1 - } else { - existList[[(dN-1)]][i] <- TRUE - fLocate[i] <- fLocate[find(fname, fNames)] } - fNames[[i]] <- fname } - } - } - ## determine order: which paragraphs are found in data files first? - if(length(dataList)>0){ - for(x in 1:length(dataList)){ - tempFrame <- matrix(NA,2,length(pValues[existList[[x]]])) - tempFrame[1,] <- pValues[existList[[x]]] - for(i in pValues[existList[[x]]]){ - tempFrame[2,tempFrame[1,]==i] <- find(paragraphs[i], doc) - } - orderList[[x]] <- tempFrame[1,order(tempFrame[2,])] - } - ## assign appropriate data to paragraph list - for(x in 1:length(dataList)){ - for(i in orderList[[x]]){ + ## determine order: which paragraphs are found in data files first? + if(length(dataList)>0){ + for(x in 1:length(dataList)){ + tempFrame <- matrix(NA,2,length(pValues[existList[[x]]])) + tempFrame[1,] <- pValues[existList[[x]]] + for(i in pValues[existList[[x]]]){ + tempFrame[2,tempFrame[1,]==i] <- find(paragraphs[i], doc) + } + orderList[[x]] <- tempFrame[1,order(tempFrame[2,])] + } + ## assign appropriate data to paragraph list + for(x in 1:length(dataList)){ + for(i in orderList[[x]]){ ## TEST: IS FULL (NON-SYMMETRIC) MATRIX?? - if(paragraphs[[i]]=="ra"){ - fData[[i]] <- dataList[[x]] - }else{ - if(fLength[i]==((ni^2+ni)/2)){ - if(dataList[[x]][2]==dataList[[x]][(ni+1)] && dataList[[x]][3]==dataList[[x]][(2*ni+1)]){ - fLength[i] <- ni^2 + if(paragraphs[[i]]=="ra"){ + fData[[i]] <- dataList[[x]] + }else{ + if(fLength[i]==((ni^2+ni)/2)){ + if(dataList[[x]][2]==dataList[[x]][(ni+1)] && dataList[[x]][3]==dataList[[x]][(2*ni+1)]){ + fLength[i] <- ni^2 + fData[[i]] <- dataList[[x]][1:fLength[i]] + }else{ + fData[[i]] <- makeSym(dataList[[x]][1:fLength[i]], ni=ni) + } + } else { fData[[i]] <- dataList[[x]][1:fLength[i]] - }else{ - fData[[i]] <- makeSym(dataList[[x]][1:fLength[i]], ni=ni) } - } else { - fData[[i]] <- dataList[[x]][1:fLength[i]] + + dataList[[x]] <- dataList[[x]][(fLength[i]+1):length(dataList[[x]])] } - - dataList[[x]] <- dataList[[x]][(fLength[i]+1):length(dataList[[x]])] } + } } - } - } - - excerpt <- function(para, doc){ - ## determine whether or not paragraph is specified - if(!is.null(find(para, doc))){ - if(fExist[[grep(para, paragraphs)]]){ - fData[[grep(para, paragraphs)]] - } else { - out <- find(para, doc):length(doc) - out <- out[unlist(lapply(doc0[find(para, doc):length(doc)], charTest))] - doc[(find(para, doc)+1):(out[2]-1)] + + excerpt <- function(para, doc){ + ## determine whether or not paragraph is specified + if(!is.null(find(para, doc))){ + if(fExist[[grep(para, paragraphs)]]){ + fData[[grep(para, paragraphs)]] + } else { + out <- find(para, doc):length(doc) + out <- out[unlist(lapply(doc0[find(para, doc):length(doc)], charTest))] + doc[(find(para, doc)+1):(out[2]-1)] + } + } else { + return(NULL) + } } - } else { - return(NULL) - } - } - makeMatrix <- function(x) { - if(is.null(x)){ - NULL - } else { - if(length(x)>1 && length(x[[1]])!=length(x[[2]])){ - for(i in 1:(length(x)-1)){ - d <- unlist(lapply(x[(i+1):length(x)],function(z,i){z[i]}, i=i)) - x[[i]] <- c(x[[i]],d) - } - do.call(rbind,lapply(x, as.numeric.s)) - } else { - if(!is.matrix(x) && !is.data.frame(x)){ - sapply(x, as.numeric.s,simplify="vector") - } else{ - apply(x, 2, as.numeric.s) - } + makeMatrix <- function(x) { + if(is.null(x)){ + NULL + } else { + if(length(x)>1 && length(x[[1]])!=length(x[[2]])){ + for(i in 1:(length(x)-1)){ + d <- unlist(lapply(x[(i+1):length(x)],function(z,i){z[i]}, i=i)) + x[[i]] <- c(x[[i]],d) + } + do.call(rbind,lapply(x, as.numeric.s)) + } else { + if(!is.matrix(x) && !is.data.frame(x)){ + sapply(x, as.numeric.s,simplify="vector") + } else{ + apply(x, 2, as.numeric.s) + } + } + } } - } - } - for(i in paragraphs){ - if(i=="me"|i=="sd"){ - assign(i,makeMatrix(unlist(excerpt(i, doc)))) - }else{ - assign(i,makeMatrix(excerpt(i, doc))) - } - } - if(!is.null(cm)){ - if(length(var)>ncol(cm)){ - var <- var[1:ncol(cm)] - } - } - if(!is.null(km)){ - if(length(var)>ncol(km)){ - var <- var[1:ncol(km)] - } - } - output <- list(cm=cm,km=km,me=me,pm=pm,sd=sd,ra=ra) - rows <- list(var,var,NULL,var,NULL,NULL) - for(i in paragraphs[!sapply(output,is.null)]){ - if(i=="ra"){ - if(length(var)ncol(cm)){ + var <- var[1:ncol(cm)] + } + } + if(!is.null(km)){ + if(length(var)>ncol(km)){ + var <- var[1:ncol(km)] + } + } + output <- list(cm=cm,km=km,me=me,pm=pm,sd=sd,ra=ra) + rows <- list(var,var,NULL,var,NULL,NULL) + for(i in paragraphs[!sapply(output,is.null)]){ + if(i=="ra"){ + if(length(var)0){ w <- grep("-",x) @@ -693,8 +816,8 @@ x } } - - ##pullNames function to simplify obtaining names + + ##pullNames function to simplify obtaining names pullNames <- function(x){ y <- find(x, doc) if(is.null(y)){ @@ -708,14 +831,14 @@ extrapNames(names[names!=""]) } } - + use <- pullNames("se") var <- pullNames("la") - + if(is.null(use)){use <- var} - + use.t <- use - + if(!is.null(var)){ name.def <- FALSE } else { @@ -732,892 +855,894 @@ }else{ NX <- NULL } - + if(name.def){ ## names not specified if(is.numeric(nx)){ - NX <- paste("ksi",1:nx,sep="") + NX <- paste("ksi",1:nx,sep="") if(is.null(ny)){ NY <- NX var <- NX } } if(is.numeric(ny)){ - NY <- paste("eta",1:ny,sep="") + NY <- paste("eta",1:ny,sep="") if(is.null(nx)){ NX <- NY var <- NY } - } + } use <- var } - + NK <- pullNames("lk") NE <- pullNames("le") - - ## for path analysis models... - - if(!is.null(nx)){ - if(nx>length(NX)){ - NX <- paste("ksi", 1:nx, sep="") - } - } - if(!is.null(ny)){ - if(ny>length(NY)){ - NY <- paste("eta", 1:ny, sep="") - } - } - if(is.null(NK)){ - NK<-NX - } - if(!is.null(nk)){ - if(nk>length(NK)){ - NK <- paste("KSI", 1:nk, sep="") - } - } - if(is.null(NE)){ - NE<-NY - } - if(!is.null(ne)){ - if(ne>length(NE)){ - NE <- paste("ETA", 1:ne, sep="") - } - } - if(is.null(nk)){nk<-nx} - if(is.null(ne)){ne<-ny} - -## generate model matrices - - for(i in 1:nrow(mo)){ - assign(mo[i,1],modMat(mo[i,1], mo[i,2])) - } - - if((!is.null(ph) && !is.null(td))|(length(grep("lx",doc))>0)){ - if(is.null(find("lx",mo))){ - mo <- rbind(mo,c("lx","fu,fi")) - lx <- modMat("lx", "fu,fi") + ## for path analysis models... + + if(!is.null(nx)){ + if(nx>length(NX)){ + NX <- paste("ksi", 1:nx, sep="") + } } - } - if((!is.null(ps) && !is.null(te))|(length(grep("ly",doc))>0)){ - if(is.null(find("ly",mo))){ - mo <- rbind(mo,c("ly","fu,fi")) - lx <- modMat("ly", "fu,fi") + if(!is.null(ny)){ + if(ny>length(NY)){ + NY <- paste("eta", 1:ny, sep="") + } } - } - -## PA paragraph commands - -while(!is.null(find("pa",doc))){ - if(!is.null(find("pa",doc))){ - loc.n <- find("pa",doc) - nam.n <- unlist(doc[[loc.n]])[2] - row.n <- (eval(parse(text=paste(ref[find(nam.n,ref),2])))) - lis.n <- doc[(loc.n+1):(loc.n+row.n)] - if(length(lis.n[[1]])!=length(lis.n[[length(lis.n)]])){ - lis.n <- lavaan::lower2full(lavaan::char2num(paste(lapply(lis.n,paste,collapse=", "),collapse="\n"))) - }else{ - lis.n <- do.call(rbind,lapply(lis.n,as.numeric.s)) + if(is.null(NK)){ + NK<-NX + } + if(!is.null(nk)){ + if(nk>length(NK)){ + NK <- paste("KSI", 1:nk, sep="") + } + } + if(is.null(NE)){ + NE<-NY + } + if(!is.null(ne)){ + if(ne>length(NE)){ + NE <- paste("ETA", 1:ne, sep="") + } } - eval(parse(text=paste(nam.n,"$free<-lis.n"))) - tex.n<-paste(nam.n,"$start[(is.na(",nam.n,"$start)|",nam.n,"$start=='NA')&(",nam.n,"$free==0)]<-0") - eval(parse(text=tex.n)) - doc[(loc.n):(loc.n+row.n)] <- NULL - doc <- doc[!is.null(doc)] - } -} -## MA paragraph commands - -while(!is.null(find("ma",doc))){ - if(!is.null(find("ma",doc))){ - if(length(grep("fi",doc[[find("ma",doc)]]))>0){ - loc.n <- find("ma",doc) - nam.n <- unlist(doc[[loc.n]])[2] - file <- unlist(strsplit(doc[[find("ma",doc)]],'=')) - file <- file[length(file)] - lis.n <- read.table(file) - if(length(grep('D',unlist(lis.n)))>0){ - s2n <- function(x){ - s2n.i <- function(x){ - x <- as.numeric(unlist(strsplit(x,'D'))) - x[1]*10^(x[2]) - } - sapply(x, s2n.i) - } - lis.n <- apply(lis.n, 2, s2n) + if(is.null(nk)){nk<-nx} + if(is.null(ne)){ne<-ny} + + ## generate model matrices + + for(i in 1:nrow(mo)){ + assign(mo[i,1],modMat(mo[i,1], mo[i,2])) + } + + if((!is.null(ph) && !is.null(td))|(length(grep("lx",doc))>0)){ + if(is.null(find("lx",mo))){ + mo <- rbind(mo,c("lx","fu,fi")) + lx <- modMat("lx", "fu,fi") } - if(is.list(lis.n)){ + } + if((!is.null(ps) && !is.null(te))|(length(grep("ly",doc))>0)){ + if(is.null(find("ly",mo))){ + mo <- rbind(mo,c("ly","fu,fi")) + lx <- modMat("ly", "fu,fi") + } + } + + ## PA paragraph commands + + while(!is.null(find("pa",doc))){ + if(!is.null(find("pa",doc))){ + loc.n <- find("pa",doc) + nam.n <- unlist(doc[[loc.n]])[2] + row.n <- (eval(parse(text=paste(ref[find(nam.n,ref),2])))) + lis.n <- doc[(loc.n+1):(loc.n+row.n)] if(length(lis.n[[1]])!=length(lis.n[[length(lis.n)]])){ lis.n <- lavaan::lower2full(lavaan::char2num(paste(lapply(lis.n,paste,collapse=", "),collapse="\n"))) }else{ lis.n <- do.call(rbind,lapply(lis.n,as.numeric.s)) } + eval(parse(text=paste(nam.n,"$free<-lis.n"))) + tex.n<-paste(nam.n,"$start[(is.na(",nam.n,"$start)|",nam.n,"$start=='NA')&(",nam.n,"$free==0)]<-0") + eval(parse(text=tex.n)) + doc[(loc.n):(loc.n+row.n)] <- NULL + doc <- doc[!is.null(doc)] } - eval(parse(text=paste(nam.n,"$start<-lis.n"))) - doc[(loc.n)] <- NULL - doc <- doc[!is.null(doc)] - }else{ - loc.n <- find("ma",doc) - nam.n <- unlist(doc[[loc.n]])[2] - row.n <- (eval(parse(text=paste(ref[find(nam.n,ref),2])))) - lis.n <- doc[(loc.n+1):(loc.n+row.n)] - if(length(lis.n[[1]])!=length(lis.n[[length(lis.n)]])){ - lis.n <- lavaan::lower2full(lavaan::char2num(paste(lapply(lis.n,paste,collapse=", "),collapse="\n"))) - }else{ - lis.n <- do.call(rbind,lapply(lis.n,as.numeric.s)) - } - eval(parse(text=paste(nam.n,"$start<-lis.n"))) - doc[(loc.n):(loc.n+row.n)] <- NULL - doc <- doc[!is.null(doc)] } - } -} - -## ensure that command lines have brackets - -fixLazilyWrittenSyntax <- function(line){ - commands <- c("fr", "fi", "eq", "co", "va", "st", "pa") - line <- unlist(line) - if(any(line[1]==commands) && length(grep("\\[",line))==0){ - if(!is.na(as.numeric.s(line[2]))){ - l <- 2 } else {l <- 1} - line[(l+1):length(line)]<-sapply(line[(l+1):length(line)], - function(x){if(!is.na(as.numeric.s(x))){paste('[',x,']',sep='')}else{x}}) - temp <- paste(line[(l+1):length(line)],collapse="") - temp <- strsplit(gsub("\\]","\\]:",gsub("\\]\\[",",",temp)),":") - unlist(c(line[1:l],gsub(",,",",",unlist(temp)))) - } else { line } -} -doc<-lapply(doc,fixLazilyWrittenSyntax) + ## MA paragraph commands + + while(!is.null(find("ma",doc))){ + if(!is.null(find("ma",doc))){ + if(length(grep("fi",doc[[find("ma",doc)]]))>0){ + loc.n <- find("ma",doc) + nam.n <- unlist(doc[[loc.n]])[2] + file <- unlist(strsplit(doc[[find("ma",doc)]],'=')) + file <- file[length(file)] + lis.n <- read.table(file) + if(length(grep('D',unlist(lis.n)))>0){ + s2n <- function(x){ + s2n.i <- function(x){ + x <- as.numeric(unlist(strsplit(x,'D'))) + x[1]*10^(x[2]) + } + sapply(x, s2n.i) + } + lis.n <- apply(lis.n, 2, s2n) + } + if(is.list(lis.n)){ + if(length(lis.n[[1]])!=length(lis.n[[length(lis.n)]])){ + lis.n <- lavaan::lower2full(lavaan::char2num(paste(lapply(lis.n,paste,collapse=", "),collapse="\n"))) + }else{ + lis.n <- do.call(rbind,lapply(lis.n,as.numeric.s)) + } + } + eval(parse(text=paste(nam.n,"$start<-lis.n"))) + doc[(loc.n)] <- NULL + doc <- doc[!is.null(doc)] + }else{ + loc.n <- find("ma",doc) + nam.n <- unlist(doc[[loc.n]])[2] + row.n <- (eval(parse(text=paste(ref[find(nam.n,ref),2])))) + lis.n <- doc[(loc.n+1):(loc.n+row.n)] + if(length(lis.n[[1]])!=length(lis.n[[length(lis.n)]])){ + lis.n <- lavaan::lower2full(lavaan::char2num(paste(lapply(lis.n,paste,collapse=", "),collapse="\n"))) + }else{ + lis.n <- do.call(rbind,lapply(lis.n,as.numeric.s)) + } + eval(parse(text=paste(nam.n,"$start<-lis.n"))) + doc[(loc.n):(loc.n+row.n)] <- NULL + doc <- doc[!is.null(doc)] + } + } + } + ## ensure that command lines have brackets -## function: process model commands - - eqN <- 1 - - processCommands <- function(doc){ - - fr1 <- doc[(find("mo",doc)+1):length(doc)] - - is.pertinent <- function(doc.l){ + fixLazilyWrittenSyntax <- function(line){ commands <- c("fr", "fi", "eq", "co", "va", "st", "pa") - if(any(doc.l[[1]][1]==commands)){ - return(TRUE) + line <- unlist(line) + if(any(line[1]==commands) && length(grep("\\[",line))==0){ + if(!is.na(as.numeric.s(line[2]))){ + l <- 2 } else {l <- 1} + line[(l+1):length(line)]<-sapply(line[(l+1):length(line)], + function(x){if(!is.na(as.numeric.s(x))){paste('[',x,']',sep='')}else{x}}) + temp <- paste(line[(l+1):length(line)],collapse="") + temp <- strsplit(gsub("\\]","\\]:",gsub("\\]\\[",",",temp)),":") + unlist(c(line[1:l],gsub(",,",",",unlist(temp)))) + } else { line } + } + + doc<-lapply(doc,fixLazilyWrittenSyntax) + + + ## function: process model commands + + eqN <- 1 + + processCommands <- function(doc){ + + fr1 <- doc[(find("mo",doc)+1):length(doc)] + + is.pertinent <- function(doc.l){ + commands <- c("fr", "fi", "eq", "co", "va", "st", "pa") + if(any(doc.l[[1]][1]==commands)){ + return(TRUE) + } else { + return(FALSE) + } + } + + fr1 <- fr1[unlist(lapply(fr1,is.pertinent))] + + if(length(fr1)>0){ + + comm <- c() + commN <- 1 + eq <- list() + co <- c() + coN <- 1 + + for(i in 1:length(fr1)){ + fr1[[i]] <- fr1[[i]][fr1[[i]] != ""] + if(length(fr1[[i]])>1){ + for(z in 2:length(fr1[[i]])){ + if(length(unlist(strsplit(fr1[[i]][z],",")))>2){ + temp <- unlist(strsplit(fr1[[i]][z],",")) + fr1[[i]][z] <- paste(substr(temp[1],1,3),temp[2],",",temp[3],sep="") + } + } + } + if(fr1[[i]][1]=="fr"){ + comm[[commN]] <- c(1,NA,fr1[[i]][2:length(fr1[[i]])]) + commN <- commN+1 + } + if(any(fr1[[i]][1]==c("va","st"))){ + comm[[commN]] <- c("X",fr1[[i]][2:length(fr1[[i]])]) + commN <- commN+1 + } + if(fr1[[i]][1]=="fi"){ + comm[[commN]] <- c(0,0,fr1[[i]][2:length(fr1[[i]])]) + commN <- commN+1 + } + if(fr1[[i]][1]=="eq"){ + eq[[eqN]] <- fr1[[i]][2:length(fr1[[i]])] + eqN <- eqN+1 + } + if(fr1[[i]][1]=="co"){ + tempc <- fr1[[i]][2:length(fr1[[i]])] + if(length(tempc>1)){ + tempc <- paste(tempc,sep="",collapse="") + tempc <- strsplit(tempc,"=") + } + co[[coN]] <- tempc[[1]] + coN <- coN+1 + } + if(fr1[[i]][1]=="pa"){ + a <- (i+1) + b <- eval(parse(text=paste(ref[find(fr1[[i]][2],ref),2]))) + a - 1 + c <- 1 + matr <- list() + for(d in a:b){ + matr[[c]] <- fr1[[d]] + c <- c + 1 + } + matr <- lapply(matr, as.numeric.s) + matr <- do.call(rbind,matr) + eval(parse(text=paste(fr1[[i]][2],"<-matr"))) + } + + } + simpl <- function(x) { + x <- lapply(x,unlist) + x <- x[unlist(lapply(x, length) != 0)] + x <- x[x != ""] + } + comm <- simpl(comm) + eq <- simpl(eq) + co <- simpl(co) + + outp <- list(comm,eq,co) + + return(list(outp,eqN)) + } else { - return(FALSE) + return(list(list(NULL,NULL,NULL,NULL,NULL),eqN)) } } - - fr1 <- fr1[unlist(lapply(fr1,is.pertinent))] - - if(length(fr1)>0){ - - comm <- c() - commN <- 1 - eq <- list() - co <- c() - coN <- 1 - - for(i in 1:length(fr1)){ - fr1[[i]] <- fr1[[i]][fr1[[i]] != ""] - if(length(fr1[[i]])>1){ - for(z in 2:length(fr1[[i]])){ - if(length(unlist(strsplit(fr1[[i]][z],",")))>2){ - temp <- unlist(strsplit(fr1[[i]][z],",")) - fr1[[i]][z] <- paste(substr(temp[1],1,3),temp[2],",",temp[3],sep="") - } - } - } - if(fr1[[i]][1]=="fr"){ - comm[[commN]] <- c(1,NA,fr1[[i]][2:length(fr1[[i]])]) - commN <- commN+1 - } - if(any(fr1[[i]][1]==c("va","st"))){ - comm[[commN]] <- c("X",fr1[[i]][2:length(fr1[[i]])]) - commN <- commN+1 - } - if(fr1[[i]][1]=="fi"){ - comm[[commN]] <- c(0,0,fr1[[i]][2:length(fr1[[i]])]) - commN <- commN+1 - } - if(fr1[[i]][1]=="eq"){ - eq[[eqN]] <- fr1[[i]][2:length(fr1[[i]])] - eqN <- eqN+1 - } - if(fr1[[i]][1]=="co"){ - tempc <- fr1[[i]][2:length(fr1[[i]])] - if(length(tempc>1)){ - tempc <- paste(tempc,sep="",collapse="") - tempc <- strsplit(tempc,"=") - } - co[[coN]] <- tempc[[1]] - coN <- coN+1 - } - if(fr1[[i]][1]=="pa"){ - a <- (i+1) - b <- eval(parse(text=paste(ref[find(fr1[[i]][2],ref),2]))) + a - 1 - c <- 1 - matr <- list() - for(d in a:b){ - matr[[c]] <- fr1[[d]] - c <- c + 1 - } - matr <- lapply(matr, as.numeric.s) - matr <- do.call(rbind,matr) - eval(parse(text=paste(fr1[[i]][2],"<-matr"))) - } - - } - simpl <- function(x) { - x <- lapply(x,unlist) - x <- x[unlist(lapply(x, length) != 0)] - x <- x[x != ""] - } - comm <- simpl(comm) - eq <- simpl(eq) - co <- simpl(co) - - outp <- list(comm,eq,co) - - return(list(outp,eqN)) - - } else { - return(list(list(NULL,NULL,NULL,NULL,NULL),eqN)) - } - } - - ## function: apply model commands to matrices - - eqID <- 1 - - applyCommands <- function(commList){ - - comm <- commList[[1]] - eq <- commList[[2]] - co <- commList[[3]] - - outList <- list() - t0 <- 1 - - ## apply fixed parameter values - - if(length(comm)>0){ - for(i in 1:length(comm)){ - for(z in 3:length(comm[[i]])){ - if(comm[[i]][1]=="X"){ - outList[[t0]] <- paste(gsub("\\[","$start[",comm[[i]][z]),"<-",comm[[i]][2],sep="") - t0 <- t0 + 1 - }else{ - outList[[t0]] <- paste(gsub("\\[","$free[",comm[[i]][z]),"<-",comm[[i]][1],sep="") - outList[[t0+1]] <- paste(gsub("\\[","$start[",comm[[i]][z]),"<-",comm[[i]][2],sep="") - t0 <- t0 + 2 + + ## function: apply model commands to matrices + + eqID <- 1 + + applyCommands <- function(commList){ + + comm <- commList[[1]] + eq <- commList[[2]] + co <- commList[[3]] + + outList <- list() + t0 <- 1 + + ## apply fixed parameter values + + if(length(comm)>0){ + for(i in 1:length(comm)){ + for(z in 3:length(comm[[i]])){ + if(comm[[i]][1]=="X"){ + outList[[t0]] <- paste(gsub("\\[","$start[",comm[[i]][z]),"<-",comm[[i]][2],sep="") + t0 <- t0 + 1 + }else{ + outList[[t0]] <- paste(gsub("\\[","$free[",comm[[i]][z]),"<-",comm[[i]][1],sep="") + outList[[t0+1]] <- paste(gsub("\\[","$start[",comm[[i]][z]),"<-",comm[[i]][2],sep="") + t0 <- t0 + 2 + } } } } + + ## apply equality constraints to matrices + + if(length(eq)>0){ + for(i in 1:length(eq)){ + for(z in 1:length(eq[[i]])){ + qtest <- nrow(eval(parse(text=gsub("\\[","$start[",eq[[i]][z])))) + if(is.null(qtest)){ + qtest <- 1 + } + if(qtest > 1){ + subN <- gsub("\\D", "", eq[[i]][z]) + eq[[i]][z] <- gsub(subN, paste(subN,",",subN), eq[[i]][z]) + } + if(z==1){ + outList[[t0]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + outList[[(t0+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") + t0 <- t0 + 2 + }else{ + outList[[t0]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + t0 <- t0 + 1 + } + } + eqID <- eqID + 1 + } + } + + ## apply CO parameter constraints to matrices + + if(length(co)>0){ + for(i in 1:length(co)){ + temp <- gsub('\\+','?',co[[i]][2]) + temp <- gsub('\\-','?',temp) + temp <- gsub('\\*','?',temp) + temp <- gsub('/','?',temp) + temp <- strsplit(temp,'\\?') + temp <- unlist(c(co[[i]][1],temp)) + is.mat <- function(input){ + if(nchar(input)<4){ + return(FALSE) + } else{ + return(TRUE) + } + } + temp <- temp[unlist(lapply(temp,is.mat))] + } + } + + outList + + } + + ## execute processCommands, applyCommands + + commList1 <- processCommands(doc) + eqN<-commList1[[2]] + commList1<-commList1[[1]] + + commands1 <- applyCommands(commList1) + + if(length(commands1)>0){ + for(i in 1:length(commands1)){ + eval(parse(text=commands1[[i]])) + } } - - ## apply equality constraints to matrices - - if(length(eq)>0){ - for(i in 1:length(eq)){ - for(z in 1:length(eq[[i]])){ - qtest <- nrow(eval(parse(text=gsub("\\[","$start[",eq[[i]][z])))) - if(is.null(qtest)){ - qtest <- 1 - } - if(qtest > 1){ - subN <- gsub("\\D", "", eq[[i]][z]) - eq[[i]][z] <- gsub(subN, paste(subN,",",subN), eq[[i]][z]) - } - if(z==1){ - outList[[t0]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - outList[[(t0+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") - t0 <- t0 + 2 + + ## matrix-to-parameter-table function + + toPara <- function(name) + { + ob <- eval(parse(text=name)) + + if(nrow(ob$free)!=0 && ncol(ob$free)!=0){ + ID <- find(name, ref) + + ROW <- eval(parse(text=toupper(ref[ID,2]))) + COL <- eval(parse(text=toupper(ref[ID,3]))) + if(length(ROW)==1){ + if(ROW==1){ + ROW <- rep("",length(COL)) + } + } + + if(paste(ref[ID,2])==paste(ref[ID,3]) && name!="be"){ + ob$start[upper.tri(ob$start)] <- 0 + } + + if(name=="ps"){ + if(is.null(be) && all(ob$free==diag(1,nrow(ob$free),ncol(ob$free)))){ + diag(ob$start) <- diag(ob$start) + 99 + ob$start[is.na(ob$start)] <- "NA" + ob$start[ob$start[lower.tri(ob$start)]!="0"]<-(as.numeric.s(ob$start[ob$start[lower.tri(ob$start)]!="0"])+99) + } else { + ob$start[lower.tri(ob$start,diag=T)] <- ob$start[lower.tri(ob$start,diag=T)]+99 + if(!is.null(be)){ + test <- (be$free+be$start+t(be$free)+t(be$start))[lower.tri(ob$start,diag=T)] + test[is.na(test)] <- 100 + tmpPS <- ob$start[lower.tri(ob$start,diag=T)] + tmpPS[test!=0] <- tmpPS[test!=0] - 99 + ob$start[lower.tri(ob$start,diag=T)] <- tmpPS + } + } + } + + if(name=="al" | name=="ka" | name=="ty"){ + ob$start <- ob$start + 99 + ob$start[is.na(ob$start)]<-"NA" + ob$start <- t(as.matrix(as.character(ob$start))) + }else { + ob$start <- apply(ob$start,2,function(x){ + x[is.na(x)]<-"NA" + as.matrix(as.character(x)) + }) + } + + OP <- paste(ref[ID,4]) + + lhs <- c() + op <- c() + rhs <- c() + user <- c() + group <- c() + free <- c() + ustart <- c() + exo <- c() + label <- c() + eq.id <- c() + unco <- c() + + ob <- lapply(ob, as.matrix) + + correctPosition <- function(x){ + if(length(ROW)!=nrow(x) && length(ROW)==ncol(x)){ + t(x) }else{ - outList[[t0]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - t0 <- t0 + 1 + x } } - eqID <- eqID + 1 + + + + ob <- lapply(ob, correctPosition) + + if(any(name==c("al","ka","tx","ty"))){ + ROW <- COL + COL <- rep("", length(ROW)) + } + + for(i in 1:ncol(ob$start)){ + non <- 1:nrow(ob$start) + non <- non[unlist(ob$start[,i]!=0)] + if(length(non)!=0){ + for(z in non){ + lhs <- c(lhs, COL[i]) + op <- c(op, OP) + rhs <- c(rhs, paste(ROW[z])) + user <- c(user, 1) + group <- c(group, groupN) + free <- c(free, ob$free[z,i]) + ustart <- c(ustart, ob$start[z,i]) + exo <- c(exo, 0) + label <- c(label, paste(name,"_",z,"_",i,sep="")) + eq.id <- c(eq.id, ob$constraint[z,i]) + unco <- c(unco, ob$free[z,i]) + } + } + } + if(name=="al" | name=="ka" | name=="ty"){ + ustart<-as.character(as.numeric.s(ustart)-99) + ustart[is.na(ustart)]<-"NA" + } + if(name=="ps"){ + ustart<-as.character(as.numeric.s(ustart)-99) + ustart[is.na(ustart)]<-"NA" + } + if(any(name==c("al","ka","tx","ty"))){ + lhs <- rhs + rhs <- rep("", length(lhs)) + } + data.frame(lhs,op,rhs,user,group,free,ustart,exo,label,eq.id,unco) + + }else{ + NULL } + } - - ## apply CO parameter constraints to matrices - - if(length(co)>0){ - for(i in 1:length(co)){ - temp <- gsub('\\+','?',co[[i]][2]) - temp <- gsub('\\-','?',temp) - temp <- gsub('\\*','?',temp) - temp <- gsub('/','?',temp) - temp <- strsplit(temp,'\\?') - temp <- unlist(c(co[[i]][1],temp)) - is.mat <- function(input){ - if(nchar(input)<4){ - return(FALSE) - } else{ - return(TRUE) + + ## CHECK FOR EQUALITY CONSTRAINTS BEFORE GROUP 1 PARAMETER TABLE + + if(ng>1){ + + moEQ <- mo + moEQ[,2] <- 0 + + for(gN in 2:ng){ + + eval(parse(text=paste("docN<-doc",gN,sep=""))) + eval(parse(text=paste("docN0<-doc0",gN,sep=""))) + + moN <- docN[[find("mo",docN,1)]] + moN <- t(as.data.frame(strsplit(moN[2:length(moN)],"="))) + + ## check each matrix for constraints + for(i in 1:nrow(moEQ)){ + if(!is.null(find(moEQ[i,1],moN))){ + if(moN[find(moEQ[i,1],moN),2]=="in"){ + moEQ[i,2]<-1 + } } } - temp <- temp[unlist(lapply(temp,is.mat))] } - } - - outList - - } -## execute processCommands, applyCommands - - commList1 <- processCommands(doc) - eqN<-commList1[[2]] - commList1<-commList1[[1]] - - commands1 <- applyCommands(commList1) - - if(length(commands1)>0){ - for(i in 1:length(commands1)){ - eval(parse(text=commands1[[i]])) - } - } - -## matrix-to-parameter-table function + multi.grp.eq <- function(x){ + if(x[1]=="eq"){ + if(any(sapply(x,function(y) + {if(length(unlist(strsplit(y,",")))>1){TRUE}else{FALSE}} + ))){ + TRUE + }else{ + FALSE + } + } else { + FALSE + } + } + + eq <- docN[sapply(docN,multi.grp.eq)] - toPara <- function(name) - { - ob <- eval(parse(text=name)) - - if(nrow(ob$free)!=0 && ncol(ob$free)!=0){ - ID <- find(name, ref) - - ROW <- eval(parse(text=toupper(ref[ID,2]))) - COL <- eval(parse(text=toupper(ref[ID,3]))) - if(length(ROW)==1){ - if(ROW==1){ - ROW <- rep("",length(COL)) - } - } - - if(paste(ref[ID,2])==paste(ref[ID,3]) && name!="be"){ - ob$start[upper.tri(ob$start)] <- 0 - } - - if(name=="ps"){ - if(is.null(be) && all(ob$free==diag(1,nrow(ob$free),ncol(ob$free)))){ - diag(ob$start) <- diag(ob$start) + 99 - ob$start[is.na(ob$start)] <- "NA" - ob$start[ob$start[lower.tri(ob$start)]!="0"]<-(as.numeric.s(ob$start[ob$start[lower.tri(ob$start)]!="0"])+99) - } else { - ob$start[lower.tri(ob$start,diag=T)] <- ob$start[lower.tri(ob$start,diag=T)]+99 - if(!is.null(be)){ - test <- (be$free+be$start+t(be$free)+t(be$start))[lower.tri(ob$start,diag=T)] - test[is.na(test)] <- 100 - tmpPS <- ob$start[lower.tri(ob$start,diag=T)] - tmpPS[test!=0] <- tmpPS[test!=0] - 99 - ob$start[lower.tri(ob$start,diag=T)] <- tmpPS - } - } - } - - if(name=="al" | name=="ka" | name=="ty"){ - ob$start <- ob$start + 99 - ob$start[is.na(ob$start)]<-"NA" - ob$start <- t(as.matrix(as.character(ob$start))) - }else { - ob$start <- apply(ob$start,2,function(x){ - x[is.na(x)]<-"NA" - as.matrix(as.character(x)) - }) - } - - OP <- paste(ref[ID,4]) - - lhs <- c() - op <- c() - rhs <- c() - user <- c() - group <- c() - free <- c() - ustart <- c() - exo <- c() - label <- c() - eq.id <- c() - unco <- c() - - ob <- lapply(ob, as.matrix) - - correctPosition <- function(x){ - if(length(ROW)!=nrow(x) && length(ROW)==ncol(x)){ - t(x) + if(length(eq)>0){ + t0G1 <- 1 + t0GN <- 1 + listG1 <- list() + listGN <- list() + if(is.list(eq)){ + eq <- lapply(eq, function(x){x[2:length(x)]}) }else{ - x + eq <- list(eq[2:length(eq)]) } + for(i in seq_along(eq)){ + for(z in 1:length(eq[[i]])){ + if(length(unlist(strsplit(eq[[i]][[z]],",")))>1){ + tmp <- unlist(strsplit(eq[[i]][[z]],",")) + wh.gr <- as.numeric(strsplit(tmp[1],'\\[')[[1]][2]) + eq[[i]][[z]] <- paste(strsplit(tmp,"\\[")[[1]][1],"[",tmp[2],",",tmp[3]) + }else{ + wh.gr <- 2 + } + qtest <- nrow(eval(parse(text=gsub("\\[","$start[",eq[[i]][z])))) + if(is.null(qtest)){ + qtest <- 1 + } + if(qtest > 1){ + subN <- gsub("\\D", "", eq[[i]][z]) + eq[[i]][z] <- gsub(subN, paste(subN,",",subN), eq[[i]][z]) + } + if(z==1){ + if(wh.gr==1){ + listG1[[t0G1]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + listG1[[(t0G1+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") + t0G1 <- t0G1 + 2 + } else { + listGN[[t0GN]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + listG1[[(t0GN+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") + t0GN <- t0GN + 2 + } + }else{ + if(wh.gr==1){ + listG1[[t0G1]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + t0G1 <- t0G1 + 1 + } else { + listGN[[t0GN]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") + t0GN <- t0GN + 1 + } + } + } + eqID <- eqID + 1 + } + listG1<-unlist(listG1) + listGN<-unlist(listGN) + ## apply these constraints to group 1 + if(length(listG1)>0){ + for(i in listG1){eval(parse(text=i))} + } + }else{ + listGN <- NULL } - - - ob <- lapply(ob, correctPosition) - - if(any(name==c("al","ka","tx","ty"))){ - ROW <- COL - COL <- rep("", length(ROW)) - } - - for(i in 1:ncol(ob$start)){ - non <- 1:nrow(ob$start) - non <- non[unlist(ob$start[,i]!=0)] - if(length(non)!=0){ - for(z in non){ - lhs <- c(lhs, COL[i]) - op <- c(op, OP) - rhs <- c(rhs, paste(ROW[z])) - user <- c(user, 1) - group <- c(group, groupN) - free <- c(free, ob$free[z,i]) - ustart <- c(ustart, ob$start[z,i]) - exo <- c(exo, 0) - label <- c(label, paste(name,"_",z,"_",i,sep="")) - eq.id <- c(eq.id, ob$constraint[z,i]) - unco <- c(unco, ob$free[z,i]) + ## enter constraint requests into group 1 matrices + + if(sum(as.numeric.s(moEQ[,2]))>0){ + + g1.eq <- list() + gn.eq <- list() + + moEQ <- unlist(moEQ[moEQ[,2]!=0,1]) + liEQ <- list() + t0 <- 1 + + for(i in seq_along(moEQ)){ + # matN is the current matrix for which multiple group + # invariance constraints are being processed + + matN <- eval(parse(text=moEQ[i]))$start + matV <- 1:nrow(matN) + for(z in 1:ncol(matN)){ + for(y in matV[is.na(matN[,z]) | matN[,z]!="0"]){ + g1.eq[[t0]] <- list(paste(moEQ[i],"$constraint[",y,",",z,"]<-",eqID,sep="")) + g1.eq[[t0]][[2]] <- paste(moEQ[i],"$misc[", y, ",", z, "]<-", 1, sep="") + gn.eq[[t0]] <- paste(moEQ[i],"$constraint[",y,",",z,"]<-",eqID,sep="") + t0 <- t0 + 1 + eqID <- eqID + 1 + } } } + g1.eq <- unlist(g1.eq) + } else { + + g1.eq <- NULL + gn.eq <- NULL + } - if(name=="al" | name=="ka" | name=="ty"){ - ustart<-as.character(as.numeric.s(ustart)-99) - ustart[is.na(ustart)]<-"NA" - } - if(name=="ps"){ - ustart<-as.character(as.numeric.s(ustart)-99) - ustart[is.na(ustart)]<-"NA" - } - if(any(name==c("al","ka","tx","ty"))){ - lhs <- rhs - rhs <- rep("", length(lhs)) + + ## APPLY CONSTRAINTS TO GROUP 1 MATRICES + ## create global matrices so that constraints + ## are not carried to other groups + for(i in 1:nrow(mo)){ + eval(parse(text=paste(mo[i,1],"G<-",mo[i,1],sep=""))) } - data.frame(lhs,op,rhs,user,group,free,ustart,exo,label,eq.id,unco) - - }else{ - NULL - } - - } - -## CHECK FOR EQUALITY CONSTRAINTS BEFORE GROUP 1 PARAMETER TABLE - -if(ng>1){ - - moEQ <- mo - moEQ[,2] <- 0 - - for(gN in 2:ng){ - - eval(parse(text=paste("docN<-doc",gN,sep=""))) - eval(parse(text=paste("docN0<-doc0",gN,sep=""))) - - moN <- docN[[find("mo",docN,1)]] - moN <- t(as.data.frame(strsplit(moN[2:length(moN)],"="))) - - ## check each matrix for constraints - for(i in 1:nrow(moEQ)){ - if(!is.null(find(moEQ[i,1],moN))){ - if(moN[find(moEQ[i,1],moN),2]=="in"){ - moEQ[i,2]<-1 - } - } - } - } - - multi.grp.eq <- function(x){ - if(x[1]=="eq"){ - if(any(sapply(x,function(y) - {if(length(unlist(strsplit(y,",")))>1){TRUE}else{FALSE}} - ))){ - TRUE - }else{ - FALSE + if(!is.null(g1.eq) && length(g1.eq)>1){ + for(i in 1:length(g1.eq)){ + eval(parse(text=g1.eq[i])) } - } else { - FALSE + } } - } - - eq <- docN[sapply(docN,multi.grp.eq)] - - if(length(eq)>0){ - t0G1 <- 1 - t0GN <- 1 - listG1 <- list() - listGN <- list() - if(is.list(eq)){ - eq <- lapply(eq, function(x){x[2:length(x)]}) - }else{ - eq <- list(eq[2:length(eq)]) - } - for(i in seq_along(eq)){ - for(z in 1:length(eq[[i]])){ - if(length(unlist(strsplit(eq[[i]][[z]],",")))>1){ - tmp <- unlist(strsplit(eq[[i]][[z]],",")) - wh.gr <- as.numeric(strsplit(tmp[1],'\\[')[[1]][2]) - eq[[i]][[z]] <- paste(strsplit(tmp,"\\[")[[1]][1],"[",tmp[2],",",tmp[3]) - }else{ - wh.gr <- 2 - } - qtest <- nrow(eval(parse(text=gsub("\\[","$start[",eq[[i]][z])))) - if(is.null(qtest)){ - qtest <- 1 - } - if(qtest > 1){ - subN <- gsub("\\D", "", eq[[i]][z]) - eq[[i]][z] <- gsub(subN, paste(subN,",",subN), eq[[i]][z]) - } - if(z==1){ - if(wh.gr==1){ - listG1[[t0G1]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - listG1[[(t0G1+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") - t0G1 <- t0G1 + 2 - } else { - listGN[[t0GN]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - listG1[[(t0GN+1)]] <- paste(gsub("\\[","$misc[",eq[[i]][z]),"<-",1,sep="") - t0GN <- t0GN + 2 - } - }else{ - if(wh.gr==1){ - listG1[[t0G1]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - t0G1 <- t0G1 + 1 - } else { - listGN[[t0GN]] <- paste(gsub("\\[","$constraint[",eq[[i]][z]),"<-",eqID,sep="") - t0GN <- t0GN + 1 - } - } - } - eqID <- eqID + 1 - } - listG1<-unlist(listG1) - listGN<-unlist(listGN) - ## apply these constraints to group 1 - if(length(listG1)>0){ - for(i in listG1){eval(parse(text=i))} + + ## PROCESS MATRICES TO PARAMETER TABLE, GROUP 1 + + endL <- c() + allL <- c("lx","ly","td","te","al","ka","tx","ty","be","ps","ph","th","ga") + for(i in 1:13){ + if(is.null(find(allL[i],mo))==FALSE){ + endL <- c(endL, allL[i]) + } } - }else{ - listGN <- NULL - } - ## enter constraint requests into group 1 matrices - - if(sum(as.numeric.s(moEQ[,2]))>0){ - - g1.eq <- list() - gn.eq <- list() - - moEQ <- unlist(moEQ[moEQ[,2]!=0,1]) - liEQ <- list() - t0 <- 1 - - for(i in seq_along(moEQ)){ - # matN is the current matrix for which multiple group - # invariance constraints are being processed - - matN <- eval(parse(text=moEQ[i]))$start - matV <- 1:nrow(matN) - for(z in 1:ncol(matN)){ - for(y in matV[is.na(matN[,z]) | matN[,z]!="0"]){ - g1.eq[[t0]] <- list(paste(moEQ[i],"$constraint[",y,",",z,"]<-",eqID,sep="")) - g1.eq[[t0]][[2]] <- paste(moEQ[i],"$misc[", y, ",", z, "]<-", 1, sep="") - gn.eq[[t0]] <- paste(moEQ[i],"$constraint[",y,",",z,"]<-",eqID,sep="") - t0 <- t0 + 1 - eqID <- eqID + 1 - } - } - } - g1.eq <- unlist(g1.eq) - } else { - - g1.eq <- NULL - gn.eq <- NULL - - } - - ## APPLY CONSTRAINTS TO GROUP 1 MATRICES - ## create global matrices so that constraints - ## are not carried to other groups - for(i in 1:nrow(mo)){ - eval(parse(text=paste(mo[i,1],"G<-",mo[i,1],sep=""))) - } - if(!is.null(g1.eq) && length(g1.eq)>1){ - for(i in 1:length(g1.eq)){ - eval(parse(text=g1.eq[i])) - } - } -} + tableList <- lapply(endL, toPara) + parTable <- do.call(rbind,tableList) -## PROCESS MATRICES TO PARAMETER TABLE, GROUP 1 + ## multiple group models, parameter table - endL <- c() - allL <- c("lx","ly","td","te","al","ka","tx","ty","be","ps","ph","th","ga") - for(i in 1:13){ - if(is.null(find(allL[i],mo))==FALSE){ - endL <- c(endL, allL[i]) - } - } - - tableList <- lapply(endL, toPara) - parTable <- do.call(rbind,tableList) - -## multiple group models, parameter table - - if(ng>1){ - - for(groupN in 2:ng){ - - eval(parse(text=paste("docN<-doc",groupN,sep=""))) - eval(parse(text=paste("docN0<-doc0",groupN,sep=""))) - - docN <- docN[!sapply(docN,multi.grp.eq)] - - mo <- docN[[find("mo",docN,1)]] - mo <- t(as.data.frame(strsplit(mo[2:length(mo)],"="))) - - if(macs==TRUE){ - if(length(find("ty",mo))==0){ - mo <- rbind(mo,c("ty","fr")) - } - if(length(find("al",mo))==0){ - mo <- rbind(mo,c("al","fi")) - } - } - - for(i in 1:nrow(mo)){ - m.typ <- unlist(strsplit(mo[i,2],",")) - if(length(m.typ)>1){ - m.form <- m.typ[2] - m.typ <- m.typ[1] - }else{ - m.form <- "de" - } - if(m.typ=="fi"){ - ## fixed - eval(parse(text=(paste(mo[i,1],"$start[]","<- 0")))) - eval(parse(text=(paste(mo[i,1],"$free[]","<- 0")))) - eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - } - if(m.typ=="fr"){ - ## free - eval(parse(text=(paste(mo[i,1],"$start[]","<-NA")))) - eval(parse(text=(paste(mo[i,1],"$free[]","<-1")))) - eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - } - if(m.typ=="ps"){ - ## same pattern & starting values - eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - } - if(m.typ=="sp"){ - ## same pattern - eval(parse(text=(paste(mo[i,1],"$start[",mo[i,1],"$start!=0]","<-NA")))) - eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - } - if(m.typ=="ss"){ - ## same starting values ... ? - eval(parse(text=(paste(mo[i,1],"$free[]","<- 0")))) - eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - } - if(m.typ=="in"){ - eval(parse(text=(paste(mo[i,1],"<-",mo[i,1],"G",sep="")))) + if(ng>1){ + + for(groupN in 2:ng){ + + eval(parse(text=paste("docN<-doc",groupN,sep=""))) + eval(parse(text=paste("docN0<-doc0",groupN,sep=""))) + + docN <- docN[!sapply(docN,multi.grp.eq)] + + mo <- docN[[find("mo",docN,1)]] + mo <- t(as.data.frame(strsplit(mo[2:length(mo)],"="))) + + if(macs==TRUE){ + if(length(find("ty",mo))==0){ + mo <- rbind(mo,c("ty","fr")) + } + if(length(find("al",mo))==0){ + mo <- rbind(mo,c("al","fi")) + } } - if(any(m.typ==c("fu","sy","ze"))){ - if(any(m.form==c("fi","de"))){ + + for(i in 1:nrow(mo)){ + m.typ <- unlist(strsplit(mo[i,2],",")) + if(length(m.typ)>1){ + m.form <- m.typ[2] + m.typ <- m.typ[1] + }else{ + m.form <- "de" + } + if(m.typ=="fi"){ + ## fixed eval(parse(text=(paste(mo[i,1],"$start[]","<- 0")))) eval(parse(text=(paste(mo[i,1],"$free[]","<- 0")))) eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) - }else{ + } + if(m.typ=="fr"){ + ## free eval(parse(text=(paste(mo[i,1],"$start[]","<-NA")))) eval(parse(text=(paste(mo[i,1],"$free[]","<-1")))) eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) } + if(m.typ=="ps"){ + ## same pattern & starting values + eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) + } + if(m.typ=="sp"){ + ## same pattern + eval(parse(text=(paste(mo[i,1],"$start[",mo[i,1],"$start!=0]","<-NA")))) + eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) + } + if(m.typ=="ss"){ + ## same starting values ... ? + eval(parse(text=(paste(mo[i,1],"$free[]","<- 0")))) + eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) + } + if(m.typ=="in"){ + eval(parse(text=(paste(mo[i,1],"<-",mo[i,1],"G",sep="")))) + } + if(any(m.typ==c("fu","sy","ze"))){ + if(any(m.form==c("fi","de"))){ + eval(parse(text=(paste(mo[i,1],"$start[]","<- 0")))) + eval(parse(text=(paste(mo[i,1],"$free[]","<- 0")))) + eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) + }else{ + eval(parse(text=(paste(mo[i,1],"$start[]","<-NA")))) + eval(parse(text=(paste(mo[i,1],"$free[]","<-1")))) + eval(parse(text=(paste(mo[i,1],"$misc[]","<- '' ")))) + } + } + + } + + if(!is.null(gn.eq) && length(gn.eq)>1){ + for(i in unlist(gn.eq)){ + eval(parse(text=i)) + } + } + + if(length(listGN)>0){ + for(i in listGN){eval(parse(text=i))} + } + + commListN <- processCommands(docN) + + commandsN <- applyCommands(commListN[[1]]) + + if(length(commandsN>0)){ + for(i in 1:length(commandsN)){ + eval(parse(text=commandsN[[i]])) + } } - + + ## PROCESS MATRICES TO PARAMETER TABLE, MULTIPLE GROUPS + + tableListN <- lapply(as.vector(mo[,1]), toPara) + parTableN <- do.call(rbind,tableListN) + + colnames(parTableN) <- colnames(parTable) + + row.names(parTableN) <- NULL + + parTable <- rbind(parTable, parTableN) + } - - if(!is.null(gn.eq) && length(gn.eq)>1){ - for(i in unlist(gn.eq)){ - eval(parse(text=i)) - } - } - - if(length(listGN)>0){ - for(i in listGN){eval(parse(text=i))} - } - - commListN <- processCommands(docN) - - commandsN <- applyCommands(commListN[[1]]) - - if(length(commandsN>0)){ - for(i in 1:length(commandsN)){ - eval(parse(text=commandsN[[i]])) - } - } - - ## PROCESS MATRICES TO PARAMETER TABLE, MULTIPLE GROUPS - - tableListN <- lapply(as.vector(mo[,1]), toPara) - parTableN <- do.call(rbind,tableListN) - - colnames(parTableN) <- colnames(parTable) - - row.names(parTableN) <- NULL - - parTable <- rbind(parTable, parTableN) - + } - - } - ## CO command constraints + ## CO command constraints - if(length(commList1[[3]])>1){ - for(i in 1:length(commList1[[3]])){ + if(length(commList1[[3]])>1){ + for(i in 1:length(commList1[[3]])){ exp <- gsub("\\[","_",commList1[[3]][[i]]) exp <- gsub(",","_",exp) exp <- gsub("\\]","",exp) exp <- data.frame(exp[1], "==",exp[2],1,0,0,"NA",0,"",0,0) colnames(exp) <- colnames(parTable) parTable <- rbind(parTable,exp) + } } - } -## format final parameter table - - if(sum(parTable[,6])!=0){ - if(sum(parTable$eq.id!=0)>0){ - j <- 1 - for(i in unique(parTable$eq.id[parTable$eq.id!=0])){ - test <- parTable$free[((parTable$eq.id==i)+(parTable$free!=0))==2] - if(length(test)>0){ - parTable$free[((parTable$eq.id==i)+(parTable$free!=0))==2] <- j - j <- j + 1 + ## format final parameter table + + if(sum(parTable[,6])!=0){ + if(sum(parTable$eq.id!=0)>0){ + j <- 1 + for(i in unique(parTable$eq.id[parTable$eq.id!=0])){ + test <- parTable$free[((parTable$eq.id==i)+(parTable$free!=0))==2] + if(length(test)>0){ + parTable$free[((parTable$eq.id==i)+(parTable$free!=0))==2] <- j + j <- j + 1 + } } + }else{ + j <- 1 } - }else{ - j <- 1 + parTable[(((parTable$free==1)+(parTable$eq.id==0))==2),6] <- + j:(j-1+sum(((parTable$free==1)+(parTable$eq.id==0))==2)) } - parTable[(((parTable$free==1)+(parTable$eq.id==0))==2),6] <- - j:(j-1+sum(((parTable$free==1)+(parTable$eq.id==0))==2)) - } - parTable$unco[parTable$unco!=0] <- 1:length(parTable$unco[parTable$unco!=0]) + parTable$unco[parTable$unco!=0] <- 1:length(parTable$unco[parTable$unco!=0]) - id <- 1:nrow(parTable) - parTable <- data.frame(id,parTable) + id <- 1:nrow(parTable) + parTable <- data.frame(id,parTable) - row.names(parTable) <- NULL - - parTable$id <- as.integer(as.numeric.s(parTable$id)) - parTable$lhs <- as.character(parTable$lhs) - parTable$op <- as.character(parTable$op) - parTable$rhs <- as.character(parTable$rhs) - parTable$user <- as.integer(as.numeric.s(parTable$user)) - parTable$group <- as.integer(as.numeric.s(parTable$group)) - parTable$free <- as.integer(as.numeric.s(parTable$free)) - parTable$ustart <- as.numeric.s(as.character(parTable$ustart)) - parTable$exo <- as.integer(as.numeric.s(parTable$exo)) - parTable$label <- as.character(parTable$label) - parTable$eq.id <- as.integer(as.numeric.s(as.character(parTable$eq.id))) - parTable$unco <- as.integer(as.numeric.s(parTable$unco)) - - if(analyze){ - for(i in 1:ng){ - if(i==1){ - data <- getData(doc, doc0) - }else{ - data <- mapply("list",data,getData( - doc=eval(parse(text=paste("doc",i,sep=""))), - doc0=eval(parse(text=paste("doc0",i,sep=""))) - ),SIMPLIFY=FALSE) + row.names(parTable) <- NULL + + parTable$id <- as.integer(as.numeric.s(parTable$id)) + parTable$lhs <- as.character(parTable$lhs) + parTable$op <- as.character(parTable$op) + parTable$rhs <- as.character(parTable$rhs) + parTable$user <- as.integer(as.numeric.s(parTable$user)) + parTable$group <- as.integer(as.numeric.s(parTable$group)) + parTable$free <- as.integer(as.numeric.s(parTable$free)) + parTable$ustart <- as.numeric.s(as.character(parTable$ustart)) + parTable$exo <- as.integer(as.numeric.s(parTable$exo)) + parTable$label <- as.character(parTable$label) + parTable$eq.id <- as.integer(as.numeric.s(as.character(parTable$eq.id))) + parTable$unco <- as.integer(as.numeric.s(parTable$unco)) + + if(analyze){ + for(i in 1:ng){ + if(i==1){ + data <- getData(doc, doc0) + }else{ + data <- mapply("list",data,getData( + doc=eval(parse(text=paste("doc",i,sep=""))), + doc0=eval(parse(text=paste("doc0",i,sep=""))) + ),SIMPLIFY=FALSE) + } } - } - if(ng>1){ - for(i in names(data)){ - if(is.null(data[[i]][[1]])){ - data[[i]] <- NULL + if(ng>1){ + for(i in names(data)){ + if(is.null(data[[i]][[1]])){ + data[[i]] <- NULL + } } } - } - if(is.null(data$ra) | is.null(data$ra[[1]])){ - for(i in 1:ng){ - if(i==1){ - if(ng==1){ - n <- doc[[find("da",doc)]][[grep("no",doc[[find("da",doc)]])]] - n <- as.numeric.s(gsub("no=","",n)) - } else { - n2 <- doc[[find("da",doc)]][[grep("no",doc[[find("da",doc)]])]] - n <- list() + if(is.null(data$ra) | is.null(data$ra[[1]])){ + for(i in 1:ng){ + if(i==1){ + if(ng==1){ + n <- doc[[find("da",doc)]][[grep("no",doc[[find("da",doc)]])]] + n <- as.numeric.s(gsub("no=","",n)) + } else { + n2 <- doc[[find("da",doc)]][[grep("no",doc[[find("da",doc)]])]] + n <- list() + n[[i]] <- as.numeric.s(gsub("no=","",n2)) + } + }else{ + n2 <- eval(parse(text=paste("doc",i,"[[find('da',doc",i,")]][[grep('no',doc",i,"[[find('da',doc",i,")]])]]",sep=""))) n[[i]] <- as.numeric.s(gsub("no=","",n2)) } - }else{ - n2 <- eval(parse(text=paste("doc",i,"[[find('da',doc",i,")]][[grep('no',doc",i,"[[find('da',doc",i,")]])]]",sep=""))) - n[[i]] <- as.numeric.s(gsub("no=","",n2)) } + } else{ + n <- NULL } - } else{ - n <- NULL - } - if(!is.null(data$sd) && is.null(data$ra)){ - cr2cv <- function(x,sd){ - na <- colnames(x) - sd <- diag(as.vector(sd)) - ou <- sd%*%x%*%t(sd) - colnames(ou) <- na - rownames(ou) <- na - ou - } - for(i in 1:ng){ - if(i==1){ - if(ng==1){ - data$cm <- cr2cv(data$km, data$sd) + if(!is.null(data$sd) && is.null(data$ra)){ + cr2cv <- function(x,sd){ + na <- colnames(x) + sd <- diag(as.vector(sd)) + ou <- sd%*%x%*%t(sd) + colnames(ou) <- na + rownames(ou) <- na + ou + } + for(i in 1:ng){ + if(i==1){ + if(ng==1){ + data$cm <- cr2cv(data$km, data$sd) + }else{ + data$cm <- list() + data$cm[[i]] <- cr2cv(data$km[[i]], data$sd[[i]]) + } }else{ - data$cm <- list() data$cm[[i]] <- cr2cv(data$km[[i]], data$sd[[i]]) } - }else{ - data$cm[[i]] <- cr2cv(data$km[[i]], data$sd[[i]]) } } - } - if(!is.null(data$ra)){ - if(ng==1){ - data$ra <- as.data.frame(data$ra) - }else{ - data$ra <- lapply(data$ra, as.data.frame) + if(!is.null(data$ra)){ + if(ng==1){ + data$ra <- as.data.frame(data$ra) + }else{ + data$ra <- lapply(data$ra, as.data.frame) + } } - } - if(is.null(data$cm) && is.null(data$ra)){ - invisible(suppressWarnings(lavaan::lavaan(model=parTable))) - stop("lisrel2lavaan requires either 1) raw data (specified in the RA paragraph in LISREL syntax), 2) a variance-covariance matrix (the CM paragraph in LISREL syntax), or 3) a correlation matrix AND standard deviation vector (the KM and SD paragraphs respectively) in order to fit models.") - } else { - if(!is.null(data$me)){ - macs <- T + if(is.null(data$cm) && is.null(data$ra)){ + invisible(suppressWarnings(lavaan::lavaan(model=parTable))) + stop("lisrel2lavaan requires either 1) raw data (specified in the RA paragraph in LISREL syntax), 2) a variance-covariance matrix (the CM paragraph in LISREL syntax), or 3) a correlation matrix AND standard deviation vector (the KM and SD paragraphs respectively) in order to fit models.") } else { - macs <- F + if(!is.null(data$me)){ + macs <- T + } else { + macs <- F + } + # return(parTable) + fit <- lavaan::lavaan(model=parTable,data=data$ra,sample.cov=data$cm,sample.mean=data$me,estimator=estimator,sample.nobs=n,...) + if(silent==F){ + lavaan::summary(fit, standardized=TRUE, fit.measures=TRUE) + invisible(fit) + }else{ + return(fit) + } } -# return(parTable) - fit <- lavaan::lavaan(model=parTable,data=data$ra,sample.cov=data$cm,sample.mean=data$me,estimator=estimator,sample.nobs=n,...) - if(silent==F){ - lavaan::summary(fit, standardized=TRUE, fit.measures=TRUE) - invisible(fit) - }else{ - return(fit) - } + }else{ + invisible(parTable) } - }else{ - invisible(parTable) + } - -} -return(suppressWarnings(lisrel(filename=filename, analyze=analyze, ...=...))) + return(suppressWarnings(lisrel(filename=filename, analyze=analyze, ...=...))) -setwd(restore.wd) + setwd(restore.wd) } + + diff -Nru r-cran-semtools-0.4.14/R/loadingFromAlpha.R r-cran-semtools-0.5.0/R/loadingFromAlpha.R --- r-cran-semtools-0.4.14/R/loadingFromAlpha.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/loadingFromAlpha.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,8 +1,26 @@ -# loadingFromAlpha: Find a standardized factor loading that provide a specified -# alpha value +### 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) -} +} + + diff -Nru r-cran-semtools-0.4.14/R/longInvariance.R r-cran-semtools-0.5.0/R/longInvariance.R --- r-cran-semtools-0.4.14/R/longInvariance.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/longInvariance.R 2018-05-13 15:21:29.000000000 +0000 @@ -1,16 +1,134 @@ -## Title: Longitudinal (or within-group, such as dyadic data) measurement invariance -## Author: Sunthud Pornprasertmanit -## Description: Test measurement invariance and save the fitted objects -##----------------------------------------------------------------------------## - -longInvariance <- function(model, varList, auto = "all", constrainAuto = FALSE, fixed.x = TRUE, std.lv = FALSE, group=NULL, group.equal="", group.partial="", warn=TRUE, debug=FALSE, strict = FALSE, quiet = FALSE, fit.measures = "default", method = "satorra.bentler.2001", ...) { +### Sunthud Pornprasertmanit & Yves Rosseel +### Last updated: 13 May 2018 +#' 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. +#' +#' 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} +#' +#' @aliases longInvariance longInvariance +#' @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 +#' \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. +#' @param 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. +#' @param fixed.x See \code{\link[lavaan]{lavaan}.} +#' @param std.lv See \code{\link[lavaan]{lavaan}.} +#' @param group See \code{\link[lavaan]{lavaan}.} +#' @param group.equal See \code{\link[lavaan]{lavaan}.} +#' @param group.partial See \code{\link[lavaan]{lavaan}.} +#' @param strict If \code{TRUE}, the sequence requires strict invariance. See +#' @param warn See \code{\link[lavaan]{lavaan}.} +#' @param debug See \code{\link[lavaan]{lavaan}.} +#' details for more information. +#' @param 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. +#' @param fit.measures Fit measures used to calculate the differences between +#' nested models. +#' @param baseline.model custom baseline model passed to +#' \code{\link[lavaan]{fitMeasures}} +#' @param method The method used to calculate likelihood ratio test. See +#' \code{\link[lavaan]{lavTestLRT}} for available options +#' @param ... Additional arguments in the \code{\link[lavaan]{lavaan}} +#' function. See also \code{\link[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}) +#' @seealso \code{\link{measurementinvariance}} For the measurement invariance +#' test between groups +#' @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 +#' @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")) +#' +#' @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", ...) { List <- list(...) # Find the number of groups ngroups <- 1 - if(!is.null(group)) { - if(!is.null(List$data)) { + 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) @@ -18,140 +136,164 @@ 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?") - } + 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") + 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 <- 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]])) { + 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) { + 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) + if (constrainAuto & (length(vec) > 1)) + lavaanParTable <- constrainParTable(lavaanParTable, name[vec], "~~", name[vec + j], k) } } } } - + # Fit configural invariance - fitConfigural <- lavaan::lavaan(lavaanParTable, ..., group=group, group.equal=group.equal, group.partial=group.partial, warn=TRUE, debug=FALSE) - + 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) { + 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]])) { + 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) { + for (k in 1:ngroups) { # Constrain factor loadings but keep marker variables - for(i in 2:length(varList[[1]])) { + for (i in 2:length(varList[[1]])) { ptMetric <- constrainParTable(ptMetric, facName, "=~", sapply(varList, function(x, element) x[element], element = i), k) } } } - fitMetric <- lavaan::lavaan(ptMetric, ..., group=group, group.equal=group.equal, group.partial=group.partial, warn=TRUE, debug=FALSE) - + 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) { + 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]])) { + 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 <- lavaan::lavaan(ptScalar, ..., group=group, group.equal=group.equal, group.partial=group.partial, warn=TRUE, debug=FALSE) - + 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) { + if (strict) { ptStrict <- ptScalar - for(k in 1:ngroups) { + for (k in 1:ngroups) { # Constrain measurement error variances - for(i in 1:length(varList[[1]])) { + for (i in 1:length(varList[[1]])) { name <- sapply(varList, function(x, element) x[element], element = i) ptStrict <- constrainParTable(ptStrict, name, "~~", name, k) } } - fitStrict <- lavaan::lavaan(ptStrict, ..., group=group, group.equal=group.equal, group.partial=group.partial, warn=TRUE, debug=FALSE) + 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) { + for (k in 1:ngroups) { ptMeans <- fixParTable(ptMeans, facName[-1], "~1", "", k, ustart = 0) } - fitMeans <- lavaan::lavaan(ptMeans, ..., group=group, group.equal=group.equal, group.partial=group.partial, warn=TRUE, debug=FALSE) - - FIT <- invisible(list(fit.configural = fitConfigural, fit.loadings = fitMetric, fit.thresholds = fitScalar, fit.residuals = fitStrict, fit.means = fitMeans)) + 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, method) - } + if (!quiet) printInvarianceResult(FIT, fit.measures, baseline.model, method) - invisible(FIT) - # Modify these functions from measurementInvariance function # if(!quiet) { # cat("\n#################### Measurement invariance tests ####################\n") @@ -180,7 +322,7 @@ # 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") @@ -203,37 +345,46 @@ # } # } # return(invisible(list(fit.configural = fitConfigural, fit.loadings = fitMetric, fit.intercepts = fitScalar, fit.residuals = fitStrict, fit.means = fitMeans))) + invisible(FIT) } + + +## ---------------- +## Hidden Functions +## ---------------- + # freeParTable: Free elements in parameter table 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)) { + for (i in 1:nrow(target)) { targetElem <- matchElement(parTable = parTable, vec = target[i,]) ptargetElem <- parTable$plabel[targetElem] - if((length(targetElem) == 0) || is.na(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)) + 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) { + 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) + rmelem <- intersect(union(match(ptargetElem, parTable$lhs), + match(ptargetElem, parTable$rhs)), + equalelement) + if (length(rmelem) > 0) parTable <- removeEqCon(parTable, rmelem) } } - parTable <- rearrangept(parTable) - return(parTable) + parTable <- rearrangept(parTable) + parTable } # removeEqCon: Remove equality constraints @@ -250,22 +401,25 @@ 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)) { - if(parTable$free[element[i]] == 0) warnings(paste("The", lhs, op, rhs, group, "is fixed already.")) - + 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 - return(parTable) + parTable } # constrainParTable: Impose equality constraints in any set of elements in the parameter table @@ -275,28 +429,28 @@ 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)) { + # 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) + 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) } - return(parTable) + parTable } # matchElement: Find the number of row that have the specification in vec (lhs, op, rhs, group) matchElement <- function(parTable, vec) { - if(is.null(parTable$group)) { + 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]))) } } -# rearrangeFreeElement: Rearrange the number listed in 'free' in parameter tables +# rearrangeFreeElement: Rearrange the number listed in 'free' in parameter tables rearrangeFreeElement <- function(vec) { vec2 <- vec @@ -305,7 +459,7 @@ newvec <- 1:length(unique(vec)) vec2[vec2 != 0] <- newvec[match(vec, uvec)] class(vec2) <- "integer" - return(vec2) + vec2 } createplabel <- function(num) { @@ -323,7 +477,7 @@ newplabel <- createplabel(seq_along(pt$op)) eqpos <- which(pt$op == "==") newplabel[eqpos] <- "" - if(length(eqpos) > 0) { + if (length(eqpos) > 0) { eqlhs <- pt$lhs[eqpos] eqrhs <- pt$rhs[eqpos] matchlhs <- match(eqlhs, oldplabel) @@ -342,111 +496,112 @@ getValue <- function(parTable, est, lhs, op, rhs, group) { target <- cbind(lhs, op, rhs, group) - element <- apply(target, 1, matchElement, parTable=parTable) + element <- apply(target, 1, matchElement, parTable = parTable) free <- parTable$free[element] out <- parTable$ustart[element] out[free != 0] <- est[free[free != 0]] out } -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 +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 } + + diff -Nru r-cran-semtools-0.4.14/R/measurementInvarianceCat.R r-cran-semtools-0.5.0/R/measurementInvarianceCat.R --- r-cran-semtools-0.4.14/R/measurementInvarianceCat.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/measurementInvarianceCat.R 2018-06-21 08:10:32.000000000 +0000 @@ -1,31 +1,115 @@ -measurementInvarianceCat <- function(..., std.lv = FALSE, strict=FALSE, quiet=FALSE, - fit.measures = "default", - method = "satorra.bentler.2001") { +### Sunthud Pornprasertmanit, Yves Rosseel, & Terrence D. Jorgensen +### Last updated: 14 May 2018 +### 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 \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). +#' +#' @importFrom lavaan lavInspect parTable +#' +#' @param ... The same arguments as for any lavaan model. See +#' \code{\link{cfa}} for more information. +#' @param 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. +#' @param strict If \code{TRUE}, the sequence requires `strict' invariance. +#' See details for more information. +#' @param 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. +#' @param fit.measures Fit measures used to calculate the differences between +#' nested models. +#' @param baseline.model custom baseline model passed to +#' \code{\link[lavaan]{fitMeasures}} +#' @param method The method used to calculate likelihood ratio test. See +#' \code{\link[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}) +#' @seealso \code{\link{measurementInvariance}} for measurement invariance for +#' continuous variables; \code{\link{longInvariance}} For the measurement +#' invariance test within person with continuous variables; +#' \code{partialInvariance} for the automated function for finding partial +#' invariance models +#' @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 +#' @examples +#' +#' \dontrun{ +#' syntax <- ' f1 =~ u1 + u2 + u3 + u4' +#' +#' measurementInvarianceCat(model = syntax, data = datCat, group = "g", +#' parameterization = "theta", estimator = "wlsmv", +#' ordered = c("u1", "u2", "u3", "u4")) +#' } +#' +#' @export +measurementInvarianceCat <- function(..., std.lv = FALSE, strict = FALSE, + quiet = FALSE, fit.measures = "default", + baseline.model = NULL, + method = "default") { 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.") + 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") + 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 <- lavaan::parTable(template) + 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 <- lavaan::lavInspect(template, "samp")[[1]] + 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.") + 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.") + 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) @@ -33,7 +117,8 @@ 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") + 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"]) @@ -45,7 +130,7 @@ # Find marker variables marker <- rep(NA, length(factorRep)) numThresholdMarker <- rep(NA, length(factorRep)) - for(i in seq_along(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]] @@ -56,74 +141,74 @@ constraintSecondThreshold <- constraintSecondThreshold[!is.na(constraintSecondThreshold)] # Find the marker variable of each facto - for(i in names(numThreshold)) { + for (i in names(numThreshold)) { lavaanParTable <- constrainParTable(lavaanParTable, i, "|", "t1", 1:ngroups) } - if(length(constraintSecondThreshold) > 0) { - for(i in constraintSecondThreshold) { + if (length(constraintSecondThreshold) > 0) { + for (i in constraintSecondThreshold) { lavaanParTable <- constrainParTable(lavaanParTable, i, "|", "t2", 1:ngroups) } } # Group 1 - for(i in facName) { + for (i in facName) { lavaanParTable <- fixParTable(lavaanParTable, i, "~1", "", 1, 0) # Fix factor means as 0 - if(std.lv) { + 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) { + for (i in varList) { lavaanParTable <- fixParTable(lavaanParTable, i, "~~", i, 1, 1) } # Other groups - for(k in 2:ngroups) { - for(i in facName) { + for (k in 2:ngroups) { + for (i in facName) { lavaanParTable <- freeParTable(lavaanParTable, i, "~1", "", k, NA) - if(std.lv) { + if (std.lv) { lavaanParTable <- fixParTable(lavaanParTable, i, "~~", i, k, 1) } else { lavaanParTable <- freeParTable(lavaanParTable, i, "~~", i, k, NA) } } - for(i in varList) { + 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) + 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)) { + 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 <- do.call(lavaanlavaan, ListConfigural) + fitConfigural <- try(do.call(lavaanlavaan, ListConfigural), silent = TRUE) # Create the parameter table for metric invariance ptMetric <- lavaanParTable - for(i in seq_along(factorRep)) { + for (i in seq_along(factorRep)) { varwithin <- factorRep[[i]] - if(!std.lv) { + if (!std.lv) { varwithin <- setdiff(varwithin, marker[i]) } - for(j in seq_along(varwithin)) { + 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) { + if (std.lv) { + for (k in 2:ngroups) { + for (i in facName) { ptMetric <- freeParTable(ptMetric, i, "~~", i, k, NA) } } @@ -131,16 +216,16 @@ ListMetric <- List ListMetric$model <- ptMetric - fitMetric <- do.call(lavaanlavaan, ListMetric) + 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) { + if (scalar) { ptScalar <- ptMetric - for(i in seq_along(numThreshold)) { + 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) @@ -148,77 +233,85 @@ } ListScalar <- List ListScalar$model <- ptScalar - fitScalar <- do.call(lavaanlavaan, ListScalar) + 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) { - ptStrict <- ptScalar - for(k in 2:ngroups) { + if (strict) { + if (scalar) ptStrict <- ptScalar + for (k in 2:ngroups) { # Constrain measurement error variances - for(i in varList) { + for (i in varList) { ptStrict <- fixParTable(ptStrict, i, "~~", i, k, 1) } } ListStrict <- List ListStrict$model <- ptStrict - fitStrict <- do.call(lavaanlavaan, ListStrict) + 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) { + for (k in 2:ngroups) { ptMeans <- fixParTable(ptMeans, facName, "~1", "", k, ustart = 0) } ListMeans <- List ListMeans$model <- ptMeans - fitMeans <- do.call(lavaanlavaan, ListMeans) + 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 <- 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, method) + if (!quiet) { + printInvarianceResult(FIT, fit.measures, baseline.model, method) } invisible(FIT) } + + +## ---------------- +## Hidden Functions +## ---------------- + multipleAllEqual <- function(...) { - obj <- list(...) - multipleAllEqualList(obj) + 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) - } + 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) + } + return(TRUE) } multipleAnyEqual <- function(...) { - obj <- list(...) - multipleAnyEqualList(obj) + 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) - } + 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) + } + return(FALSE) } diff -Nru r-cran-semtools-0.4.14/R/measurementInvariance.R r-cran-semtools-0.5.0/R/measurementInvariance.R --- r-cran-semtools-0.4.14/R/measurementInvariance.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/measurementInvariance.R 2018-06-25 17:31:25.000000000 +0000 @@ -1,145 +1,272 @@ -measurementInvariance <- measurementinvariance <- function(..., std.lv = FALSE, - strict=FALSE, quiet=FALSE, fit.measures = "default", method = "satorra.bentler.2001") { +### Sunthud Pornprasertmanit, Yves Rosseel, and Terrence D. Jorgensen +### Last updated: 25 June 2018 + + +#' Measurement Invariance Tests +#' +#' Testing measurement invariance across groups using a typical sequence of +#' model comparison tests. +#' +#' 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} +#' +#' @importFrom lavaan parTable +#' @aliases measurementInvariance measurementinvariance +#' +#' @param ... The same arguments as for any lavaan model. See +#' \code{\link{cfa}} for more information. +#' @param 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. +#' @param strict If \code{TRUE}, the sequence requires `strict' invariance. +#' See details for more information. +#' @param 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. +#' @param fit.measures Fit measures used to calculate the differences between +#' nested models. +#' @param baseline.model custom baseline model passed to +#' \code{\link[lavaan]{fitMeasures}} +#' @param method The method used to calculate likelihood ratio test. See +#' \code{\link[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}) +#' +#' @seealso \code{\link{longInvariance}} for the measurement invariance test +#' within person; \code{partialInvariance} for the automated function for +#' finding partial invariance models +#' +#' @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. +#' +#' @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")) +#' +#' @export +measurementInvariance <- measurementinvariance <- + function(..., std.lv = FALSE, strict = FALSE, quiet = FALSE, + fit.measures = "default", baseline.model = NULL, + method = "satorra.bentler.2001") { + + 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 - lavaancfa <- function(...) { lavaan::cfa(...)} - # check for a group.equal argument in ... - dotdotdot <- list(...) - if(!is.null(dotdotdot$group.equal)) - stop("lavaan ERROR: group.equal argument should not be used") - - res <- list() - # base-line model: configural invariance - configural <- dotdotdot configural$group.equal <- "" - template <- do.call(lavaancfa, configural) - pttemplate <- lavaan::partable(template) + template <- try(do.call(lavaancfa, configural), silent = TRUE) + if (class(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 (ngroups <= 1) stop("Well, the number of groups is 1. Measurement", + " invariance across 'groups' cannot be done.") - if(std.lv) { - for(i in facnames) { + 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]) + for (i in fixloadings) { + pttemplate <- freeParTable(pttemplate, pttemplate$lhs[i], "=~", + pttemplate$rhs[i], pttemplate$group[i]) } - res$fit.configural <- refit(pttemplate, template) + 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) { + + ## 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 findloadings) { + pttemplate <- constrainParTable(pttemplate, pttemplate$lhs[i], + "=~", pttemplate$rhs[i], 1:ngroups) } - for(i in facnames) { + for (i in facnames) { pttemplate <- freeParTable(pttemplate, i, "~~", i, 2:ngroups) - } - res$fit.loadings <- refit(pttemplate, template) + } + dotdotdot$model <- pttemplate + res$fit.loadings <- try(do.call(lavaancfa, dotdotdot), silent = TRUE) } else { loadings <- dotdotdot loadings$group.equal <- c("loadings") - res$fit.loadings <- do.call("cfa", 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) + + ## 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) { + for (i in facnames) { pttemplate <- freeParTable(pttemplate, i, "~1", "", 2:ngroups) - } - res$fit.intercepts <- refit(pttemplate, template) + } + 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 <- do.call(lavaancfa, 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) + + 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) } - res$fit.residuals <- refit(pttemplate, template) - for(i in facnames) { + 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) } - res$fit.means <- refit(pttemplate, template) + 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 <- do.call(lavaancfa, 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 <- do.call(lavaancfa, means) + res$fit.means <- try(do.call(lavaancfa, means), silent = TRUE) } - } else { - if(std.lv) { - for(i in facnames) { + } else { + if (std.lv) { + for (i in facnames) { pttemplate <- fixParTable(pttemplate, i, "~1", "", 1:ngroups, 0) } - res$fit.means <- refit(pttemplate, template) + 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 <- do.call(lavaancfa, means) + res$fit.means <- try(do.call(lavaancfa, means), silent = TRUE) } - } + } - if(!quiet) { - printInvarianceResult(res, fit.measures, method) - } - - invisible(res) + if (!quiet) printInvarianceResult(res, fit.measures, baseline.model, method) + invisible(res) } -printInvarianceResult <- function(FIT, fit.measures, method) { - # compare models - NAMES <- names(FIT); names(FIT) <- NULL - lavaanLavTestLRT <- function(...) { lavaan::lavTestLRT(...) } + + +## ---------------- +## Hidden Functions +## ---------------- + +#' @importFrom lavaan lavInspect +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))) + method = method))) - if(length(fit.measures) == 1L && fit.measures == "default") { - # scaled test statistic? - if(length(lavaan::lavInspect(FIT[[1]], "test")) > 1L) { - fit.measures <- c("cfi.scaled", "rmsea.scaled") + 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)) { + ## add some fit measures + if (length(fit.measures)) { - FM <- lapply(FIT, lavaan::fitMeasures, fit.measures) + FM <- lapply(FIT, lavaan::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.table1 <- rbind( rep(as.numeric(NA), length(fit.measures)), FM.table1) } - if(length(FM) > 1L) { + 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="") + 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") } @@ -149,10 +276,14 @@ cat("\n\n") print(TABLE) - if(length(fit.measures)) { + 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 } + + diff -Nru r-cran-semtools-0.4.14/R/miPowerFit.R r-cran-semtools-0.5.0/R/miPowerFit.R --- r-cran-semtools-0.4.14/R/miPowerFit.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/miPowerFit.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,27 +1,197 @@ -# miPowerFit: Evaluate model fit by Satorra, Saris, & van der Weld (2009) method +### Sunthud Pornprasertmanit +### Last updated: 9 March 2018 -miPowerFit <- function(lavaanObj, stdLoad=0.4, cor=0.1, stdBeta=0.1, intcept=0.2, stdDelta=NULL, delta=NULL, cilevel=0.90) { - mi <- lavaan::lavInspect(lavaanObj, "mi") + +#' Modification indices and their power approach for model fit evaluation +#' +#' The model fit evaluation approach using modification indices and expected +#' parameter changes. +#' +#' In the lavaan object, one can inspect the modification indices and expected +#' parameter changes. Those values can be used to evaluate model fit by two +#' methods. +#' +#' First, Saris, Satorra, and van der Veld (2009, pp. 570-573) used the power +#' to detect modification indices and expected parameter changes to evaluate +#' model fit. First, one should evaluate whether the modification index of each +#' parameter is significant. Second, one should evaluate whether the power to +#' detect a target expected parameter change is high enough. If the +#' modification index is not significant and the power is high, there is no +#' misspecification. If the modification index is significant and the power is +#' low, the fixed parameter is misspecified. If the modification index is +#' significant and the power is high, the expected parameter change is +#' investigated. If the expected parameter change is large (greater than the +#' the target expected parameter change), the parameter is misspecified. If the +#' expected parameter change is low (lower than the target expected parameter +#' change), the parameter is not misspecificied. If the modification index is +#' not significant and the power is low, the decision is inconclusive. +#' +#' Second, the confidence intervals of the expected parameter changes are +#' formed. These confidence intervals are compared with the range of trivial +#' misspecification, which could be (-\code{delta}, \code{delta}) or (0, +#' \code{delta}) for nonnegative parameters. If the confidence intervals are +#' outside of the range of trivial misspecification, the fixed parameters are +#' severely misspecified. If the confidence intervals are inside the range of +#' trivial misspecification, the fixed parameters are trivially misspecified. +#' If confidence intervals are overlapped the range of trivial +#' misspecification, the decision is inconclusive. +#' +#' @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 +#' \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). +#' @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 +#' \code{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 \code{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. +#' @return A data frame with these variables: +#' \enumerate{ +#' \item lhs: The left-hand side variable, with respect to the operator in +#' in the lavaan \code{\link[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 expected parameter change if the parameter is freely +#' estimated +#' \item target.epc: The target expected parameter change 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 expected parameter change 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: \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 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: The lower bound of the confidence interval of +#' standardized expected parameter changes. +#' \item upper.std.epc: The upper bound of the confidence interval of +#' standardized expected parameter changes. +#' \item decision.ci: The decision whether the parameter is misspecified or +#' not based on the confidence interval 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. +#' +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \code{\link{moreFitIndices}} For the additional fit indices +#' information +#' @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 +#' @examples +#' +#' library(lavaan) +#' +#' HS.model <- ' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 ' +#' +#' fit <- cfa(HS.model, data = HolzingerSwineford1939, +#' group = "sex", meanstructure = TRUE) +#' miPowerFit(fit) +#' +#' 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 <- lavInspect(lavaanObj, "mi") 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)) + 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)) + 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) + 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) + 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])) @@ -30,31 +200,44 @@ 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") - result <- format(result, scientific=FALSE, digits=4) + 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") + result <- format(result, scientific = FALSE, digits = 4) return(result) } -# totalFacVar: Find total factor variances when regression coeffient matrix and factor residual covariance matrix are specified + + +## ---------------- +## 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)) + 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 <- lavaan::lavInspect(lavaanObj, "ngroups") - cov.all <- lavaan::lavInspect(lavaanObj, "cov.all") - if(nGroups == 1) cov.all <- list(cov.all) - for(i in 1:nGroups) { + 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 @@ -62,7 +245,8 @@ return(result) } -# getTrivialEpc: find the trivial misspecified expected parameter changes given the type of parameters in each row of modification indices +## 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"] @@ -73,7 +257,7 @@ return(result) } -# unstandardizeEpc: Transform from standardized EPC to unstandardized EPC +## unstandardizeEpc: Transform from standardized EPC to unstandardized EPC unstandardizeEpc <- function(mi, delta, totalVar) { name <- names(totalVar[[1]]) @@ -105,9 +289,11 @@ 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 +## 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) { +standardizeEpc <- function(mi, totalVar, delta = NULL) { if(is.null(delta)) delta <- mi[,"epc"] name <- names(totalVar[[1]]) lhsPos <- match(mi[,"lhs"], name) @@ -141,7 +327,8 @@ return(stdDelta) } -# decisionMIPow: provide the decision given the significance of modification indices and power to detect trivial misspecification +## 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) @@ -180,6 +367,8 @@ return("NM") } else { return("I") - } + } } } + + diff -Nru r-cran-semtools-0.4.14/R/missingBootstrap.R r-cran-semtools-0.5.0/R/missingBootstrap.R --- r-cran-semtools-0.4.14/R/missingBootstrap.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/missingBootstrap.R 2018-06-25 20:33:26.000000000 +0000 @@ -1,14 +1,51 @@ ### Terrence D. Jorgensen -### Last updated: 26 February 2016 +### Last updated: 25 June 2018 ### Savalei & Yuan's (2009) model-based bootstrap for missing data -setClass("BootMiss", representation(time = "list", transData = "data.frame", bootDist = "vector", origChi = "numeric", df = "numeric", bootP="numeric")) - - -######################################### -## Define methods for class "BootMiss" ## -######################################### +## ---------------------------- +## "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 +#' \code{\link{bsBootMiss}} function. +#' @slot 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. +#' @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 \emph{p} value comparing the original \eqn{chi^2} with the +#' bootstrap distribution +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @seealso \code{\link{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 = ", @@ -20,6 +57,10 @@ 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") @@ -36,6 +77,22 @@ invisible(object) }) +#' @rdname BootMiss-class +#' @aliases hist,BootMiss-method +#' @importFrom stats qchisq dchisq quantile +#' @param object,x object of class \code{BootMiss} +#' @param ... Additional arguments to pass to \code{\link[graphics]{hist}} +#' @param alpha alpha level used to draw confidence limits +#' @param nd number of digits to display +#' @param printLegend \code{logical}. If \code{TRUE} (default), a legend will +#' be printed with the histogram +#' @param legendArgs \code{list} of arguments passed to the +#' \code{\link[graphics]{legend}} function. The default argument is a list +#' placing the legend at the top-left of the figure. +#' @return 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. +#' @export setMethod("hist", "BootMiss", function(x, ..., alpha = .05, nd = 2, printLegend = TRUE, legendArgs = list(x = "topleft")) { @@ -98,6 +155,403 @@ 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 \code{lavaan} using the FIML estimator, then pass that +#' \code{lavaan} object to \code{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 \emph{p} value, users of other +#' programs must still specify their model using lavaan syntax. +#' +#' +#' @importFrom lavaan lavInspect parTable +#' @param x A target \code{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 \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. +#' @param nBoot The number of bootstrap samples. +#' @param model Optional. The target model if \code{x} is not provided. +#' @param rawData Optional. The target raw data set if \code{x} is not +#' provided. +#' @param Sigma Optional. The model-implied covariance matrix if \code{x} is +#' not provided. +#' @param Mu Optional. The model-implied mean vector if \code{x} is not +#' provided. +#' @param group Optional character string specifying the name of the grouping +#' variable in \code{rawData} if \code{x} is not provided. +#' @param ChiSquared Optional. The model's \eqn{\chi^2} test statistic if +#' \code{x} is not provided. +#' @param EMcov Optional, if \code{x} is not provided. The EM (or Two-Stage ML) +#' estimated covariance matrix used to speed up Transformation 2 algorithm. +#' @param transDataOnly Logical. If \code{TRUE}, the result will provide the +#' transformed data only. +#' @param 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. +#' @param bootSamplesOnly Logical. If \code{TRUE}, the result will provide +#' bootstrap data sets only. +#' @param 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. +#' @param writeArgs Optional \code{list}. If \code{writeBootData = TRUE} or +#' \code{writeBootData = TRUE}, user can pass arguments to the +#' \code{\link[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. +#' @param seed The seed number used in randomly drawing bootstrap samples. +#' @param suppressWarn Logical. If \code{TRUE}, warnings from \code{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 \code{\link[lavaan]{lavaan}} +#' function. See also \code{\link[lavaan]{lavOptions}} +#' @return As a default, this function returns a \code{\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}. +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' +#' Syntax for transformations borrowed from http://www2.psych.ubc.ca/~vsavalei/ +#' @seealso \code{\linkS4class{BootMiss}} +#' @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 +#' @examples +#' +#' \dontrun{ +#' 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) +#' +#' # The number of bootstrap samples should be much higher. +#' 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. + nG <- lavInspect(x, "ngroups") + if (hasArg(x)) { + 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 (class(rawData) == "data.frame") rawData <- list(rawData) + if (class(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 (class(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 (class(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.") + + ## 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) @@ -151,7 +605,7 @@ Mjs <- vector("list", J) ## Create Duplication Matrix and its inverse (Magnus & Neudecker, 1999) - Dup <- lavaan::duplicationMatrix(p) + Dup <- lavaan::lav_matrix_duplication(p) Dupinv <- solve(t(Dup) %*% Dup) %*% t(Dup) ## step through each MD pattern, populate Hjs and Mjs @@ -338,6 +792,7 @@ } ## 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(...) } @@ -347,275 +802,11 @@ fit <- do.call(lavaanlavaan, args) } if (!exists("fit")) return(c(chisq = NA)) - if (lavaan::lavInspect(fit, "converged")) { - chisq <- lavaan::lavInspect(fit, "fit")[c("chisq", "chisq.scaled")] + 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]) } - - -## overall function to apply any of the above functions -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)) { - rawData <- lapply(lavaan::lavInspect(x, "data"), as.data.frame) - for (g in seq_along(rawData)) colnames(rawData[[g]]) <- lavaan::lavNames(x) - ChiSquared <- lavaan::lavInspect(x, "fit")[c("chisq", "chisq.scaled")] - ChiSquared <- ifelse(is.na(ChiSquared[2]), ChiSquared[1], ChiSquared[2]) - group <- lavaan::lavInspect(x, "group") - if (length(group) == 0) group <- "group" - group.label <- lavaan::lavInspect(x, "group.label") - if (length(group.label) == 0) group.label <- 1 - Sigma <- lavaan::lavInspect(x, "cov.ov") - Mu <- lavaan::lavInspect(x, "mean.ov") - EMcov <- lavaan::lavInspect(x, "sampstat")$cov - } 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 (class(rawData) == "data.frame") { - rawData <- list(rawData) - } - if (class(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 (class(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 (class(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.") - - ## 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]],vSigma = 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 <- lavaan::parTable(x) - lavaanArgs$slotModel <- x@Model - lavaanArgs$slotOptions <- lavaan::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 <- 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) - 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 <- lavaan::lavInspect(x, "fit")["df"] - } else { - convSamp <- which(!is.na(bootFits))[1] - lavaanArgs$data <- bootSamples[[convSamp]] - lavaanlavaan <- function(...) { lavaan::lavaan(...) } - output$Degrees.Freedom <- lavaan::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 -} - diff -Nru r-cran-semtools-0.4.14/R/monteCarloMed.R r-cran-semtools-0.5.0/R/monteCarloMed.R --- r-cran-semtools-0.4.14/R/monteCarloMed.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/monteCarloMed.R 2018-06-25 20:13:54.000000000 +0000 @@ -1,63 +1,190 @@ -## Monte Carlo test of mediation for complex mediation cases -## Corbin Quick, Alex Schoemann, James Selig -## Function that takes an expression for an indirect effect, related parameter estimates and SEs and outputs a Monte Carlo SE -##Output: matrix of LL and UL, optional plot of indirect effect, or values of indirect effect. - -monteCarloMed<-function(expression, ..., ACM=NULL, object = NULL, rep=20000, CI=95, plot=FALSE, outputValues=FALSE){ - - input<- c(...) - - #Get names and the number of unique variables in the expression - uniquepar<-function(var){ - var<-gsub(" ","",var) - var<-strsplit(var,'+',fixed=TRUE) - var<-strsplit(var[[1]],'*',fixed=TRUE) - varb<-var[[1]] - if(length(var)>1){ - for(i in 2:length(var)){ - varb<-c(varb,var[[i]])} - var<-unique(varb)} - if(is.list(var)){var<-var[[1]]} - return(var)} - - paramnames<-uniquepar(expression) - - #If input is a lavaan object pull out coefs and ACM - if(class(object)=="lavaan"){ - input <- lavaan::coef(object)[paramnames] - ACM <- lavaan::vcov(object)[paramnames,paramnames] +### Corbin Quick, Alex Schoemann, James Selig, Terrence D. Jorgnensen +### Last updated: 25 June 2018 + +# FIXME: work out a path-analysis example like slide 25: +# http://www.da.ugent.be/cvs/pages/en/Presentations/Presentation%20Yves%20Rosseel.pdf +# add example to help page, to illustrate a complex function of parameters + + +#' Monte Carlo Confidence Intervals to Test Complex Indirect Effects +#' +#' This function takes an expression for an indirect effect, the parameters and +#' standard errors associated with the expression and returns a confidence +#' interval based on a Monte Carlo test of mediation (MacKinnon, Lockwood, & +#' Williams, 2004). +#' +#' This function implements the Monte Carlo test of mediation first described +#' in MacKinnon, Lockwood, & Williams (2004) and extends it to complex cases +#' where the indirect effect is more than a function of two parameters. The +#' function takes an expression for the indirect effect, randomly simulated +#' values of the indirect effect based on the values of the parameters (and the +#' associated standard errors) comprising the indirect effect, and outputs a +#' confidence interval of the indirect effect based on the simulated values. +#' For further information on the Monte Carlo test of mediation see MacKinnon, +#' Lockwood, & Williams (2004) and Preacher & Selig (2012). +#' +#' The asymptotic covariance matrix can be easily found in many popular SEM +#' software applications. +#' \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 Mplus Include the command TECH3; in the OUTPUT section. The ACM will be +#' printed in the output. +#' \item lavaan: Use the command \code{vcov} on the fitted lavaan object to +#' print the ACM to the screen +#' } +#' +#' +#' @importFrom stats quantile +#' +#' @param expression A character scalar representing the computation of an +#' indirect effect. Different parameters in the expression should have +#' different alphanumeric values. Expressions can use either addition (+) or +#' multiplication (*) operators. +#' @param \dots Parameter estimates for all parameters named in +#' \code{expression}. The order of parameters should follow from +#' \code{expression} (the first parameter named in \code{expression} should be +#' the first parameter listed in \dots{}). Alternatively \dots can be a +#' vector of parameter estimates. +#' @param ACM A matrix representing the asymptotic covariance matrix of the +#' parameters described in \code{expression}. This matrix should be a symetric +#' matrix with dimensions equal to the number of parameters names in +#' \code{expression}. Information on finding the ACOV is popular SEM software +#' is described below.) +#' @param object A lavaan model object fitted after running the running the +#' \code{cfa}, \code{sem}, \code{growth}, or \code{lavaan} functions. The model +#' must have parameters labelled with the same labels used in +#' \code{expression}. When using this option do not specify values for \dots +#' or \code{ACM} +#' @param rep The number of replications to compute. Many thousand are +#' reccomended. +#' @param CI Width of the confidence interval computed. +#' @param plot Should the function output a plot of simulated values of the +#' indirect effect? +#' @param outputValues Should the function output all simulated values of the +#' indirect effect? +#' @return A list with two elements. The first element is the point estimate +#' for the indirect effect. The second element is a matrix with values for the +#' upper and lower limits of the confidence interval generated from the Monte +#' Carlo test of mediation. If \code{outputValues = TRUE}, output will be a list +#' with a list with the point estimate and values for the upper and lower +#' limits of the confidence interval as the first element and a vector of +#' simulated values of the indirect effect as the second element. +#' @author +#' Corbin Quick (University of Michigan; \email{corbinq@@umich.edu}) +#' +#' Alexander M. Schoemann (East Carolina University; \email{schoemanna@@ecu.edu}) +#' +#' James P. Selig (University of New Mexico; \email{selig@@unm.edu}) +#' +#' 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. +#' \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/}. +#' @examples +#' +#' ## Simple two path mediation +#' ## Write expression of indirect effect +#' med <- 'a*b' +#' ## Paramter values from analyses +#' aparam <- 1 +#' bparam <- 2 +#' ## Asymptotic covariance matrix from analyses +#' AC <- matrix(c(.01,.00002, +#' .00002,.02), nrow=2, byrow=TRUE) +#' ## Compute CI, include a plot +#' monteCarloMed(med, coef1 = aparam, coef2 = bparam, outputValues = FALSE, +#' plot = TRUE, ACM = AC) +#' +#' ## Use a vector of parameter estimates as input +#' aparam <- c(1,2) +#' monteCarloMed(med, coef1 = aparam, outputValues = FALSE, +#' plot = TRUE, ACM = AC) +#' +#' +#' ## Complex mediation with two paths for the indirect effect +#' ## Write expression of indirect effect +#' med <- 'a1*b1 + a1*b2' +#' ## Paramter values and standard errors from analyses +#' aparam <- 1 +#' b1param <- 2 +#' b2param <- 1 +#' ## Asymptotic covariance matrix from analyses +#' AC <- matrix(c(1, .00002, .00003, +#' .00002, 1, .00002, +#' .00003, .00002, 1), nrow = 3, byrow = TRUE) +#' ## Compute CI do not include a plot +#' monteCarloMed(med, coef1 = aparam, coef2 = b1param, +#' coef3 = b2param, ACM = AC) +#' +#' @export +monteCarloMed <- function(expression, ..., ACM = NULL, object = NULL, + rep = 20000, CI = 95, plot = FALSE, + outputValues = FALSE) { + + input <- c(...) + + ## Get names and the number of unique variables in the expression + paramnames <- all.vars(stats::as.formula(paste("~", expression))) + + ## If input is a lavaan object pull out coefs and ACM + if (class(object) == "lavaan"){ + input <- lavaan::coef(object)[paramnames] + ACM <- lavaan::vcov(object)[paramnames, paramnames] } - vecs<-list() - #Matrix of values, need to be converted to a list - dat <- MASS::mvrnorm(n=rep, mu=input, Sigma=ACM) - #Add parameters as the first row - dat <-rbind(input, dat) - #Convert to a list, - vecs<-as.list(as.data.frame(dat)) - #Give names to it works with assign - for(i in 1:length(vecs)){assign(paramnames[i],vecs[[i]])} - - #Apply the expression to compute the indirect effect - indirect<-eval(parse(text=expression)) - #Get the CI - low=(1-CI/100)/2 - upp=((1-CI/100)/2)+(CI/100) - LL=round(quantile(indirect[-1],low),digits=4) - UL=round(quantile(indirect[-1],upp),digits=4) - interval<-list(indirect[1],rbind(LL,UL)) - dimnames(interval[[2]]) <- list(c("LL", "UL"),c(" ")) - names(interval) <- c("Point Estimate", paste(CI, "% Confidence Interval", sep="")) - - #Switch for outputting a plot - if(plot) { - hist(indirect,breaks='FD',col='skyblue',xlab=paste(CI,'% Confidence Interval ','LL',LL,' UL',UL), main='Distribution of Indirect Effect') + vecs <- list() + ## Matrix of values, need to be converted to a list + dat <- MASS::mvrnorm(n = rep, mu = input, Sigma = ACM) + ## Add parameters as the first row + dat <-rbind(input, dat) + ## Convert to a list, + vecs <- as.list(as.data.frame(dat)) + ## Give names to it works with assign + for (i in 1:length(vecs)){assign(paramnames[i], vecs[[i]])} + + ## Apply the expression to compute the indirect effect + indirect <- eval(parse(text = expression)) + ## Get the CI + low <- (1-CI/100)/2 + upp <- ((1-CI/100)/2) + (CI/100) + LL <- round(quantile(indirect[-1], low), digits = 4) + UL <- round(quantile(indirect[-1], upp), digits = 4) + interval <- list(indirect[1], rbind(LL,UL)) + dimnames(interval[[2]]) <- list(c("LL", "UL"), c(" ")) + names(interval) <- c("Point Estimate", + paste(CI, "% Confidence Interval", sep = "")) + + ## Switch for outputting a plot + if (plot) { + hist(indirect, breaks = 'FD', col = 'skyblue', + xlab = paste(CI, '% Confidence Interval ', 'LL', LL, ' UL', UL), + main = 'Distribution of Indirect Effect') } - - #Switch to return simulated values - if(outputValues) { - interval <- list(interval, indirect) + + ## Switch to return simulated values + if (outputValues) { + interval <- list(interval, indirect) } - + return(interval) } + + diff -Nru r-cran-semtools-0.4.14/R/mvrnonnorm.R r-cran-semtools-0.5.0/R/mvrnonnorm.R --- r-cran-semtools-0.4.14/R/mvrnonnorm.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/mvrnonnorm.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,26 +1,88 @@ -mvrnonnorm <- function(n, mu, Sigma, skewness = NULL, kurtosis = NULL, empirical = FALSE) { - p <- length(mu) - if (!all(dim(Sigma) == c(p, p))) stop("incompatible arguments") - eS <- eigen(Sigma, symmetric = TRUE) - ev <- eS$values - if (!all(ev >= -1e-06 * abs(ev[1L]))) - stop("'Sigma' is not positive definite") - X <- NULL - if(is.null(skewness) && is.null(kurtosis)) { - X <- MASS::mvrnorm(n=n, mu=mu, Sigma=Sigma, empirical = empirical) - } else { - if(empirical) warnings("The empirical argument does not work when the Vale and Maurelli's method is used.") - 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="+") - } - X +### Yves Rosseel, Sunthud Pornprasertmanit, & Terrence D. Jorgensen +### Last updated: 9 March 2018 + + +#' 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 \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. +#' +#' +#' @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 \code{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 If \code{TRUE}, \code{mu} and \code{Sigma} specify the +#' empirical rather than population mean and covariance matrix +#' @return A data matrix +#' @author The original function is the \code{\link[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}. +#' @references Vale, C. D. & Maurelli, V. A. (1983). Simulating multivariate +#' nonormal distributions. \emph{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 <- MASS::mvrnorm(n = n, mu = mu, Sigma = Sigma, empirical = empirical) + } else { + if (empirical) warning(c("The empirical argument does not work when the ", + "Vale and Maurelli's method is used.")) + 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 } -# Copied from lavaan package -ValeMaurelli1983copied <- function(n=100L, COR, skewness, kurtosis, debug = FALSE) { + +## ---------------- +## 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) { @@ -33,10 +95,9 @@ sum(eq^2) ## SS } - out <- nlminb(start=c(1,0,0), objective=system.function, - scale=10, - control=list(trace=0), - skewness=skewness, kurtosis=kurtosis) + 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.) @@ -121,4 +182,5 @@ } X -} \ No newline at end of file +} + diff -Nru r-cran-semtools-0.4.14/R/NET.R r-cran-semtools-0.5.0/R/NET.R --- r-cran-semtools-0.4.14/R/NET.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/NET.R 2018-06-26 09:48:50.000000000 +0000 @@ -1,62 +1,167 @@ ### Terrence D. Jorgensen -### Last updated: 14 October 2016 -### semTools function for Nesting and Equivalence Testing +### Last updated: 25 June 2018 +### semTools functions for Nesting and Equivalence Testing -setClass("Net", representation(test = "matrix", df = "vector")) +## ----------------- +## 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 \code{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 +#' \code{\link{net}} function. +#' +#' @param object An object of class \code{Net}. +#' +#' @return +#' \item{show}{\code{signature(object = "Net")}: prints the logical matrix of +#' test results.} +#' \item{summary}{\code{signature(object = "Net")}: prints a narrative +#' description of results. The original \code{object} is invisibly returned.} +#' +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @seealso \code{\link{net}} +#' @examples +#' +#' # See the example in the net function. +#' +setClass("Net", representation(test = "matrix", df = "vector")) -## function to test whether model "x" is nested within model "y" -x.within.y <- function(x, y, crit = crit) { - if (length(c(lavaan::lavNames(x, "ov.ord"), lavaan::lavNames(y, "ov.ord")))) - stop("The net() function is not available for categorical-data estimators.") - exoX <- lavaan::lavInspect(x, "options")$fixed.x & length(lavaan::lavNames(x, "ov.x")) - exoY <- lavaan::lavInspect(y, "options")$fixed.x & length(lavaan::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 <- lavaan::lavNames(x) - Ynames <- lavaan::lavNames(y) - if (!identical(sort(Xnames), sort(Ynames))) - stop("Models do not contain the same variables") +#' @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. - ## check that the analyzed data matches - xData <- lavaan::lavInspect(x, "data") - if (is.list(xData)) xData <- do.call(rbind, xData) - xData <- xData[ , rank(Xnames)] - yData <- lavaan::lavInspect(y, "data") - if (is.list(yData)) yData <- do.call(rbind, yData) - yData <- yData[ , rank(Ynames)] - if (!identical(xData, yData)) stop("Models must apply to the same data") - ############################################################################## + If the models also have the same degrees of freedom, they are equivalent. - ## check degrees of freedom support nesting structure - if (lavaan::lavInspect(x, "fit")["df"] < lavaan::lavInspect(y, "fit")["df"]) - stop("x cannot be nested within y because y is more restricted than x") + 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. - ## model-implied moments - Sigma <- lavaan::lavInspect(x, "cov.ov") - Mu <- lavaan::lavInspect(x, "mean.ov") - N <- lavaan::lavInspect(x, "nobs") + 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) +}) - ## fit model and check that chi-squared < crit - suppressWarnings(try(newFit <- lavaan::update(y, data = NULL, - sample.cov = Sigma, - sample.mean = Mu, - sample.nobs = N))) - if(!lavaan::lavInspect(newFit, "converged")) return(NA) else { - result <- lavaan::lavInspect(newFit, "fit")["chisq"] < crit - names(result) <- NULL - if (lavaan::lavInspect(x, "fit")["df"] == - lavaan::lavInspect(y, "fit")["df"]) return(c(Equivalent = result)) +#' @rdname Net-class +#' @aliases summary,Net-method +#' @export +setMethod("summary", "Net", +function(object) { + DFs <- object@df + x <- object@test + mods <- colnames(x) + 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" + } else { + rel <- "nested within" + } + cat("Model \"", mods[R], "\" is ", rel, " model \"", mods[C], "\"\n", sep = "") + } } - c(Nested = result) -} + invisible(object) +}) + + -## generic function that utilizes "x.within.y" to test a set of models +## -------------------- +## Constructor Function +## -------------------- + +#' Nesting and Equivalence Testing +#' +#' This test examines whether models are nested or equivalent based on Bentler +#' and Satorra's (2010) procedure. +#' +#' 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 does not apply to models that +#' estimate thresholds for categorical data, so an error message will be issued +#' if such a model is provided. +#' +#' +#' @importFrom lavaan lavInspect +#' +#' @param \dots The \code{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 +#' chi-squared fit statistics is less than this criterion. +#' @return 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. +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @references Bentler, P. M., & Satorra, A. (2010). Testing model nesting and +#' equivalence. \emph{Psychological Methods, 15}(2), 111--123. +#' doi:10.1037/a0019625 +#' @examples +#' +#' \dontrun{ +#' 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 +#' +#' tests <- net(fit1, fit1a, fit2, fit3) +#' tests +#' summary(tests) +#' } +#' +#' @export net <- function(..., crit = .0001) { ## put fitted objects in a list fitList <- list(...) @@ -71,11 +176,11 @@ } ## check whether any models include categorical outcomes - catMod <- sapply(fitList, function(x) lavaan::lavInspect(x, "options")$categorical) + catMod <- sapply(fitList, function(x) lavInspect(x, "options")$categorical) if (any(catMod)) stop("This method only applies to continuous outcomes.") ## get degrees of freedom for each model - DFs <- sapply(fitList, function(x) lavaan::lavInspect(x, "fit")["df"]) + DFs <- sapply(fitList, function(x) lavInspect(x, "fit")["df"]) ## name according to named objects, with DF in parentheses fitNames <- names(fitList) @@ -114,65 +219,66 @@ } } } - - # class(nestMat) <- c("Net", class(nestMat)) - # attr(nestMat, "df") <- orderedDFs - out <- new("Net", - test = nestMat, - df = orderedDFs - ) + out <- new("Net", test = nestMat, df = orderedDFs) out } -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 cell [R, C] is TRUE and the models have the same degrees of freedom, - they are equivalent models. See Bentler & Satorra (2010) for details. +## -------------------------------------------------------------------- +## Hidden Function to test whether model "x" is nested within model "y" +## -------------------------------------------------------------------- - If cell [R, C] is NA, then the model in column C did not converge when - fit to the implied means and covariance matrix from the model in row R. +#' @importFrom lavaan lavInspect +x.within.y <- function(x, y, crit = .0001) { + if (length(c(lavaan::lavNames(x, "ov.ord"), lavaan::lavNames(y, "ov.ord")))) + stop("The net() function is not available for categorical-data estimators.") - 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 = "") + exoX <- lavInspect(x, "options")$fixed.x & length(lavaan::lavNames(x, "ov.x")) + exoY <- lavInspect(y, "options")$fixed.x & length(lavaan::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'")) } - invisible(object) -}) + ## variable names + Xnames <- lavaan::lavNames(x) + Ynames <- lavaan::lavNames(y) + if (!identical(sort(Xnames), sort(Ynames))) + stop("Models do not contain the same variables") + ## check that the analyzed data matches + 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") -setMethod("summary", "Net", -function(object) { - DFs <- object@df - x <- object@test - mods <- colnames(x) - 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" - } else { - rel <- "nested within" - } - cat("Model \"", mods[R], "\" is ", rel, " model \"", mods[C], "\"\n", sep = "") - } + ## 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") + + ## model-implied moments + Sigma <- lavInspect(x, "cov.ov") + Mu <- lavInspect(x, "mean.ov") + N <- lavInspect(x, "nobs") + + ## fit model and check that chi-squared < crit + + suppressWarnings(try(newFit <- lavaan::update(y, data = NULL, + sample.cov = Sigma, + sample.mean = Mu, + sample.nobs = N, + estimator = "ML", + se = "none", # to save time + test = "standard"))) + if(!lavInspect(newFit, "converged")) return(NA) else { + result <- lavInspect(newFit, "fit")["chisq"] < crit + names(result) <- NULL + if (lavInspect(x, "fit")["df"] == + lavInspect(y, "fit")["df"]) return(c(Equivalent = result)) } - invisible(object) -}) + c(Nested = result) +} + diff -Nru r-cran-semtools-0.4.14/R/parcelAllocation.R r-cran-semtools-0.5.0/R/parcelAllocation.R --- r-cran-semtools-0.4.14/R/parcelAllocation.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/parcelAllocation.R 2018-06-25 21:50:30.000000000 +0000 @@ -1,331 +1,311 @@ -##Parcel Allocation -##Corbin Quick & Alex Schoemann -##6/4/12 -##Bug fix 1/30/2014 - works with single factor in the model -##Vector of numbers of indicators in each parcel, vector assigning each indicator to its factor, Number allocations, lavaan syntax, Data set, parcel names, variables left out of parceling, additional arguments to be passed to lavaan - -parcelAllocation <- function(nPerPar,facPlc,nAlloc=100,syntax,dataset,names='default',leaveout=0, ...) { - if(is.character(dataset)){ - dataset <- 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 - +### Terrence D. Jorgensen +### Last updated: 25 June 2018 + + +#' Random Allocation of Items to Parcels in a Structural Equation Model +#' +#' 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. +#' +#' 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 +#' \link[lavaan]{lavaan}), 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 the random allocation of +#' itesm to parcels, see Sterba (2011) and Sterba and MccCallum (2010). +#' +#' @importFrom stats sd +#' @importFrom lavaan parTable lavInspect lavaanList lavaanify +#' @param model \code{\link[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]{lavaanify}} for more details. +#' @param 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. +#' @param parcel.names \code{character} vector containing names of all parcels +#' appearing as indicators in \code{model}. +#' @param item.syntax \link[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 \code{model}. +#' @param nAlloc The number of random items-to-parcels allocations to generate. +#' @param fun \code{character} string indicating the name of the +#' \code{\link[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"}. +#' @param alpha Alpha level used as criterion for significance. +#' @param fit.measures \code{character} vector containing names of fit measures +#' to request from each fitted \code{\link[lavaan]{lavaan}} model. See the +#' output of \code{\link[lavaan]{fitMeasures}} for a list of available measures. +#' @param \dots Additional arguments to be passed to +#' \code{\link[lavaan]{lavaanList}} +#' @param show.progress If \code{TRUE}, show a \code{\link[utils]{txtProgressBar}} +#' indicating how fast the model-fitting iterates over allocations. +#' @param 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). +#' @return \item{Estimates}{A data frame containing results related to +#' parameter estimates with columns corresponding to parameter names, average +#' parameter estimates across allocations, the standard deviation of parameter +#' estimates across allocations, the minimum parameter estimate across +#' allocations, the maximum parameter estimate across allocations, the range of +#' parameter estimates across allocations, and the proportions of allocations +#' in which the parameter estimate is significant.} \item{SE}{A data frame +#' containing results related to standard errors with columns corresponding to +#' parameter names, average standard errors across allocations, the standard +#' deviation of standard errors across allocations, the minimum standard error +#' across allocations, the maximum standard error across allocations, and the +#' range of standard errors across allocations.} \item{Fit}{A data frame +#' containing results related to model fit with columns corresponding to fit +#' index names, the average of each index across allocations, the standard +#' deviation of each fit index across allocations, the minimum of each fit +#' index across allocations, the maximum of each fit index across allocations, +#' and the range of each fit index across allocations.} +#' @author +#' Terrence D. Jorgensen (University of Amsterdam; \email{TJorgensen314@@gmail.com}) +#' +#' @seealso \code{\link{PAVranking}}, \code{\link{poolMAlloc}} +#' @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 +#' @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)) +#' +#' \dontrun{ +#' parcelAllocation(mod.parcels, data = simParcel, parcel.names, item.syntax, +#' nAlloc = 20, std.lv = TRUE, parallel = "snow", iseed = 12345) +#' } +#' +#' +#' ## 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)) +#' +#' set.seed(12345) +#' 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)) +#' +#' set.seed(12345) +#' 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)) +#' +#' set.seed(12345) +#' 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, do.fit = TRUE) { + 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 + factorNames <- lavaan::lavNames(PT, type = "lv") + if (!all(sort(lavaan::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(lavaan::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, names(data)) + assignments[[i]]$items <- setdiff(items, parcels) + + ## 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 } - - # 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 - } + + ## 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 } - facPlc <- facPlc2 + names(assignments[[i]]$nPerParcel) <- assignments[[i]]$parcels } - - 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) + + ## 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]) } - leaveout <- as.numeric(leaveoutb) - } - - k1 <- .001 - for(i in 1:length(leaveout)){ - facPlc[leaveout[i]] <- facPlc[leaveout[i]] + k1 - k1 <- k1 +.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 (!do.fit) return(dataList) -if(is.list(nPerPar)){ - - nPerPar2 <- c() - for (i in 1:length(nPerPar)){ - Onesp <- sum(facPlc>i & facPlc qnorm(alpha / 2, + lower.tail = FALSE) + out$Estimates[ , "Percent_Sig"] <- rowMeans(Sig) + out$Estimates[fitList@ParTableList[[which(conv)[1]]]$free == 0L, "Percent_Sig"] <- 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))) + + ## 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 + out } - - 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('** WARNING! ** 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('** WARNING! ** 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){ - print('** WARNING! ** Single-variable parcels have been requested. Check input!')} - - if(NleaveA > NleaveP) - print('** 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)){ - print('** WARNING! ** Number of parcel names provided not equal to number of parcels requested. Check input!')}} - - if(NA %in% dataset == TRUE){ - print('** WARNING! ** Missing data detected. Prior multiple imputation recommended.')} - - 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) - ## 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) - ## 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 - } - - if(as.vector(regexpr("/",syntax))!=-1){ - replist<-matrix(NA,nAlloc,1) - for (i in 1:nAlloc){ - if(names!='default'){colnames(Allocations[[i]])<-names}else{colnames(Allocations[[i]])<-NULL} - write.table(Allocations[[i]],paste(syntax,'parcelruns',i,'.dat',sep=''),row.names=FALSE,col.names=TRUE) - replist[i,1]<-paste('parcelrun',i,'.dat',sep='') - } - write.table(replist,paste(syntax,"parcelrunsreplist.dat",sep=''),quote=FALSE,row.names=FALSE,col.names=FALSE) - } - else{ - - Param <- list() - ## list for parameter estimated for each imputation - Fitind <- list() - ## list for fit indices estimated for each imputation - - 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(syntax, data=data, ...) - ## estimate model in lavaan - Param[[i]] <- lavaan::parameterEstimates(fit) - ## assign allocation parameter estimates to list - Fitind[[i]] <- lavaan::fitMeasures(fit, c("chisq", "df", "cfi", "tli", "rmsea", "srmr")) - ## assign allocation parameter estimates to list - } - - 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 - - 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 <- ParSEmn + Param[[i]][,5]} - - 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)] <- Parmn[,4:ncol(Parmn)] + Param[[i]][,4:ncol(Parmn)]} - ## add together all parameter estimates - - if(i>1){Fitmn <- Fitmn + Fitind[[i]]} - ## add together all fit indices - } - - - Sigp <- Sigp + .45 - Sigp <- apply(Sigp, c(1,2), round) - Sigp <- 1 - as.vector(rowMeans(Sigp)) - ## calculate percentage significant parameters - - Parsum <- cbind(apply(Parsd,1,sd),apply(Parsd,1,max),apply(Parsd,1,min),apply(Parsd,1,max)-apply(Parsd,1,min), Sigp) - colnames(Parsum) <- c("S.D.","MAX","MIN","Range", "% Sig") - ## calculate parameter S.D., minimum, maximum, range, bind to percentage significant - - ParSEmn <- cbind(Parmn[,1:3], ParSEmn/nAlloc) - ParSEfn <- cbind(ParSEmn,apply(ParSE,1,sd),apply(ParSE,1,max),apply(ParSE,1,min),apply(ParSE,1,max)-apply(ParSE,1,min)) - colnames(ParSEfn) <- c("lhs", "op", "rhs", "Avg SE","S.D.","MAX","MIN","Range") - - Fitsum <- cbind(apply(Fitsd,1,sd),apply(Fitsd,1,max),apply(Fitsd,1,min),apply(Fitsd,1,max)-apply(Fitsd,1,min)) - rownames(Fitsum) <- c("chisq", "df", "cfi", "tli", "rmsea", "srmr") - ## calculate fit S.D., minimum, maximum, range - - Parmn[,4:ncol(Parmn)] <- Parmn[,4:ncol(Parmn)] / nAlloc - ## divide totalled parameter estimates by number allocations - Parmn <- Parmn[,1:4] - ## remove confidence intervals from output - Parmn <- cbind(Parmn, Parsum) - ## bind parameter average estimates to cross-allocation information - Fitmn <- Fitmn / nAlloc - ## divide totalled fit indices by number allocations - - Fitsum <- cbind(Fitmn,Fitsum) - colnames(Fitsum) <- c("Avg Ind","S.D.","MAX","MIN","Range") - ## bind to fit averages - - ParSEfn[,4:8] <- apply(ParSEfn[,4:8], 2, round, digits = 3) - Parmn[,4:9] <- apply(Parmn[,4:9], 2, round, digits = 3) - Fitsum <- apply(Fitsum, 2, round, digits = 3) - ## round output to three digits - - Output <- list(Parmn,ParSEfn,Fitsum) - names(Output) <- c('Estimates', 'SE', 'Fit') - - return(Output) - -}} -#parcelAllocation(list(c(3,3,3)), list(name1), nAlloc=20, syntax=syntax, dataset=simParcel) diff -Nru r-cran-semtools-0.4.14/R/partialInvarianceCat.R r-cran-semtools-0.5.0/R/partialInvarianceCat.R --- r-cran-semtools-0.4.14/R/partialInvarianceCat.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/partialInvarianceCat.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,739 +0,0 @@ -# Wald stat did not show up - -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 <- lavaan::partable(fit1) - pt0 <- lavaan::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 <- lavaan::lavInspect(fit0, "nobs") - groupvar <- lavaan::lavInspect(fit0, "group") - grouplab <- lavaan::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)) - } -} - -thetaImpliedTotalVar <- function(object) { - param <- lavaan::lavInspect(object, "coef") - ngroup <- lavaan::lavInspect(object, "ngroups") - name <- names(param) - if(ngroup == 1) { - ly <- param[name == "lambda"] - } else { - ly <- lapply(param, "[[", "lambda") - } - ps <- lavaan::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 -} diff -Nru r-cran-semtools-0.4.14/R/partialInvariance.R r-cran-semtools-0.5.0/R/partialInvariance.R --- r-cran-semtools-0.4.14/R/partialInvariance.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/partialInvariance.R 2018-06-25 21:56:47.000000000 +0000 @@ -1,6 +1,272 @@ -# Work with only with congeneric models +### Sunthud Pornprasertmanit +### Last updated: 25 June 2018 -partialInvariance <- function(fit, type, free = NULL, fix = NULL, refgroup = 1, poolvar = TRUE, p.adjust = "none", fbound = 2, return.fit = FALSE, method = "satorra.bentler.2001") { + +#' 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 \code{partialInvariance} is used for continuous +#' variable. The \code{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 \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}} 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")}. +#' +#' @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 +#' \code{\link{measurementInvariance}} or +#' \code{\link{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 \code{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 +#' \code{\link[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 +#' \code{\link[lavaan]{lavTestLRT}} for available options +#' +#' @return 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. +#' } +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \code{\link{measurementInvariance}} for measurement invariance for +#' continuous variables; \code{\link{measurementInvarianceCat}} for measurement +#' invariance for categorical variables; \code{\link[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.), \emph{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") +#' +#' \dontrun{ +#' 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 @@ -46,9 +312,9 @@ if("fit.means" %in% names(fit)) { fit0 <- fit$fit.means if("fit.residuals" %in% names(fit)) { - fit1 <- fit$fit.residuals + fit1 <- fit$fit.residuals } else if ("fit.intercepts" %in% names(fit)) { - fit1 <- fit$fit.intercepts + fit1 <- fit$fit.intercepts } else { stop("The elements named either 'fit.residuals' or 'fit.intercepts ' is needed in the 'fit' argument") } @@ -58,8 +324,8 @@ } else { stop("Please specify the correct type of measurement invariance. See the help page.") } - pt1 <- lavaan::partable(fit1) - pt0 <- lavaan::partable(fit0) + 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)) == "."] <- "" @@ -91,9 +357,9 @@ names(fixIntceptFac) <- names(facList) ngroups <- max(pt0$group) - neach <- lavaan::lavInspect(fit0, "nobs") - groupvar <- lavaan::lavInspect(fit0, "group") - grouplab <- lavaan::lavInspect(fit0, "group.label") + 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)) @@ -108,7 +374,7 @@ } result <- fixCon <- freeCon <- NULL estimates <- NULL - listFreeCon <- listFixCon <- list() + listFreeCon <- listFixCon <- list() beta <- lavaan::coef(fit1) beta0 <- lavaan::coef(fit0) waldMat <- matrix(0, ngroups - 1, length(beta)) @@ -120,7 +386,7 @@ 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) + pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } else { oldmarker <- fixLoadingFac[[facinfix[i]]] if(length(oldmarker) > 0) { @@ -138,7 +404,7 @@ } } else { pt0 <- constrainParTable(pt0, facinfix[i], "=~", fix[i], 1:ngroups) - pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) + pt1 <- constrainParTable(pt1, facinfix[i], "=~", fix[i], 1:ngroups) } } } @@ -171,13 +437,13 @@ waldMat <- matrix(0, ngroups - 1, length(beta)) varfree <- setdiff(varfree, c(free, fix)) } - - obsmean <- sapply(lavaan::lavInspect(fit0, "sampstat"), "[[", "mean") + + obsmean <- sapply(lavInspect(fit0, "sampstat"), "[[", "mean") 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)) @@ -186,13 +452,13 @@ 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") @@ -205,7 +471,7 @@ 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] @@ -238,7 +504,7 @@ 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)) @@ -248,7 +514,7 @@ loaddiff <- loadVal[2:ngroups] - loadVal[1] intdiff <- intVal[2:ngroups] - intVal[1] lowdiff[pos,] <- intdiff + wlow * loaddiff - highdiff[pos,] <- intdiff + whigh * 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)) @@ -312,7 +578,7 @@ 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)) @@ -332,7 +598,7 @@ 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) + result <- cbind(freeCon, fixCon, waldCon) } else if (numType == 2) { if(!is.null(free) | !is.null(fix)) { if(!is.null(fix)) { @@ -341,7 +607,7 @@ 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) + pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } else { oldmarker <- fixIntceptFac[[facinfix[i]]] if(length(oldmarker) > 0) { @@ -359,7 +625,7 @@ } } else { pt0 <- constrainParTable(pt0, fix[i], "~1", "", 1:ngroups) - pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) + pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } } } @@ -393,7 +659,7 @@ varfree <- setdiff(varfree, c(free, fix)) } - obsmean <- sapply(lavaan::lavInspect(fit0, "sampstat"), "[[", "mean") + obsmean <- sapply(lavInspect(fit0, "sampstat"), "[[", "mean") obsmean <- obsmean[,grouporder] obsdiff <- obsmean[,2:ngroups, drop = FALSE] - matrix(obsmean[,1], nrow(obsmean), ngroups - 1) obsdiff <- obsdiff[varfree, , drop = FALSE] @@ -421,7 +687,7 @@ 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] @@ -446,7 +712,7 @@ 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,] } @@ -514,16 +780,16 @@ 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) + 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) + pt1 <- constrainParTable(pt1, fix[i], "~~", fix[i], 1:ngroups) } } if(!is.null(free)) { @@ -586,7 +852,7 @@ 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] @@ -596,20 +862,20 @@ 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) + 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) + pt1 <- constrainParTable(pt1, fix[i], "~1", "", 1:ngroups) } } if(!is.null(free)) { @@ -683,7 +949,7 @@ rownames(fixCon) <- names(listFixCon) <- rownames(freeCon) <- names(listFreeCon) <- rownames(waldCon) <- rownames(estimates) <- namept1[index] estimates <- cbind(estimates, stdestimates, esstd) - result <- cbind(freeCon, fixCon, waldCon) + 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)))) @@ -692,19 +958,784 @@ } } + +#' @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) + element <- apply(target, 1, matchElement, parTable = pt) freeIndex <- pt$free[element] tempMat[,freeIndex[1]] <- -1 for(m in 2:length(freeIndex)) { @@ -724,4 +1755,33 @@ sum(var * nm) / sum(nm) } -deltacfi <- function(parent, nested) lavaan::fitmeasures(nested)["cfi"] - lavaan::fitmeasures(parent)["cfi"] \ No newline at end of file +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") +} + diff -Nru r-cran-semtools-0.4.14/R/PAVranking.R r-cran-semtools-0.5.0/R/PAVranking.R --- r-cran-semtools-0.4.14/R/PAVranking.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/PAVranking.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,947 +1,1226 @@ +### Jason D. Rights +### Last updated: 9 March 2018 -PAVranking <- function(nPerPar, facPlc, nAlloc=100, parceloutput=0, syntaxA, syntaxB, dataset, names = NULL, leaveout=0, seed=NA, ...) { - if(is.character(dataset)){ - dataset <- read.csv(dataset) - } - - if(is.null(names)) names <- matrix(NA,length(nPerPar), 1) - - if (is.na(seed)==FALSE) set.seed(seed) - ## set random seed if specified - - options(max.print=1000000) - ### allow many tables to be outputted - - -##Create parceled datasets - + +#' 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 is a +#' modified version of \code{\link{parcelAllocation}} which can be used with +#' only one SEM in isolation. The \code{PAVranking} function repeatedly +#' generates a specified number of random item-to-parcel allocations, and then +#' fits two models to each allocation. 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 \code{seed}). +#' +#' This is a modified version of \code{\link{parcelAllocation}} which was, in +#' turn, based on the 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 uses a modified version of parcelAllocation to generate a +#' given number (\code{nAlloc}) of item-to-parcel allocations. Then, +#' \code{PAVranking} provides the following new developments: specifying more +#' than one SEM and producing results for Model A and Model B separately that +#' summarize parcel allocation variability in estimates, standard errors, and +#' fit indices. \code{PAVranking} also newly produces results summarizing +#' parcel allocation variability in model selection index values and model +#' ranking between Models A and B. Additionally, \code{PAVranking} newly allows +#' for nonconverged solutions and outputs the proportion of allocations that +#' converged as well as the proportion of proper solutions (results are +#' summarized for 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). +#' +#' \emph{Note}: This function requires the \code{lavaan} package. Missing data +#' codeneeds to be \code{NA}. If function returns \code{"Error in plot.new() : +#' figure margins too large,"} user may need to increase size of the plot +#' window and rerun. +#' +#' +#' @importFrom stats sd 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 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 seed (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. +#' @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 \dots Additional arguments to be passed to +#' \code{\link[lavaan]{lavaan}}. See also \code{\link[lavaan]{lavOptions}} +#' @return +#' \item{Estimates_A, Estimates_B}{A table containing results related +#' to parameter estimates (in table Estimates_A for Model A and in table +#' Estimates_B for Model B) with columns corresponding to parameter name, +#' average parameter estimate across allocations, standard deviation of +#' parameter estimate across allocations, the maximum parameter estimate across +#' allocations, the minimum parameter estimate across allocations, the range of +#' parameter estimates across allocations, and the percent of allocations in +#' which the parameter estimate is significant.} +#' \item{SE_A, SE_B}{A table containing results related to standard errors (in +#' table SE_A for Model A and in table SE_B for Model B) with columns +#' corresponding to parameter name, average standard error across allocations, +#' the standard deviation of standard errors across allocations, the maximum +#' standard error across allocations, the minimum standard error across +#' allocations, and the range of standard errors across allocations.} +#' \item{Fit_A, Fit_B}{A table containing results related to model fit (in +#' table Fit_A for Model A and in table Fit_B for Model B) with columns +#' corresponding to fit index name, the average of the fit index across +#' allocations, the standard deviation of the fit index across allocations, +#' the maximum of the fit index across allocations, the minimum of the fit +#' index across allocations, the range of the fit index across allocations, and +#' the percent of allocations where the chi-square test of absolute fit was +#' significant.} +#' \item{LRT Summary, Model A vs. Model B}{A table with columns corresponding +#' to: average likelihood ratio test (LRT) statistic for comparing Model A vs. +#' Model B (null hypothesis is no difference in fit between Models A and B in +#' the population), degrees of freedom (i.e. difference in the number of free +#' parameters between Models A and B), as well as the standard deviation, +#' maximum, and minimum of LRT statistics across allocations, and the percent of +#' allocations where the LRT was significant (indicating preference for the more +#' complex Model B). } +#' \item{LRT Summary, Model A vs. Model B}{A table with columns corresponding +#' to: average likelihood ratio test (LRT) statistic for comparing Model A vs. +#' Model B (null hypothesis is no difference in fit between Models A and B in +#' the population), degrees of freedom (i.e. difference in the number of free +#' parameters between Models A and B), as well as the standard deviation, +#' maximum, and minimum of LRT statistics across allocations, and the percent +#' of allocations where the LRT was significant (indicating preference for the +#' more complex Model B). } +#' \item{Fit index differences}{A table containing percentage of allocations +#' where Model A is preferred over Model B according to BIC, AIC, RMSEA, CFI, +#' TLI and SRMR and where Model B is preferred over Model A according to the +#' same indices. Also includes the average amount by which the given model is +#' preferred (calculated only using allocations where it was preferred).} +#' \item{Fit index difference histograms}{Histograms are automatically outputted +#' showing the distribution of the differences (Model A - Model B) for each fit +#' index and for the p-value of the likelihood ratio difference test.} +#' \item{Percent of Allocations with | BIC Diff | > 10}{A table containing the +#' percentage of allocations with (BIC for Model A) - (BIC for Model B) < -10, +#' indicating "very strong evidence" to prefer Model A over Model B and the +#' percentage of allocations with (BIC for Model A) - (BIC for Model B) > 10, +#' indicating "very strong evidence" to prefer Model B over Model A (Raftery, +#' 1995).} +#' \item{Converged and proper}{A table containing the proportion of allocations +#' that converged for Model A, Model B, and both models, and the proportion of +#' allocations with converged and proper solutions for Model A, Model B, and +#' both 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 parcelAllocation function on which this function +#' is based. +#' @seealso \code{\link{parcelAllocation}}, \code{\link{poolMAlloc}} +#' @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: A Multidisciplinary Journal, 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. (2017). Effects of parceling on model +#' selection: Parcel-allocation variability in model ranking. +#' \emph{Psychological Methods, 22}(1), 47--68. doi:10.1037/met0000067 +#' @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")) +#' } +#' +#' @export +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){ + + 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) + + 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 <- 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)) + + 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) + + for (i in 1:length(leaveout)) { + leaveoutb[i] <- match(leaveout[i], Namesv) } leaveout <- as.numeric(leaveoutb) - } - - k1 <- .001 - for(i in 1:length(leaveout)){ + k1 <- 0.001 + for (i in 1:length(leaveout)) { facPlc[leaveout[i]] <- facPlc[leaveout[i]] + k1 - k1 <- k1 +.001 + 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] + + 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 + ## 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 & facPlc < i + 1) + nPerPar2 <- c(nPerPar2, nPerPar[i], rep(1, Onesp), recursive = TRUE) + } + nPerPar <- nPerPar2 } - - nPerPar <- nPerPar2 -} - + Npp <- c() - for (i in 1:length(nPerPar)){ + 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('** WARNING! ** 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('** WARNING! ** 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 - + 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){ - print('** WARNING! ** Single-variable parcels have been requested. Check input!')} - - if(NleaveA > NleaveP) - print('** 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)){ - print('** WARNING! ** Number of parcel names provided not equal to number of parcels requested. Check input!')}} + 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) + ## creates a vector of the number of indicators e.g. for three indicators, c(1, 2, + ## 3) Nfactors <- max(facPlc) - ## scalar, number of factors + ## scalar, number of factors Nindicators <- length(Data) - ## scalar, number of indicators + ## scalar, number of indicators Npar <- length(nPerPar) - ## scalar, number of parcels + ## scalar, number of parcels Rmize <- runif(Nindicators, 1, Nindicators) - ## create vector of randomly ordered numbers, - ## length of number of indicators - + ## 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 - + ## '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)){ + ## create empty matrix for parcel allocation matrix - Pin <- c(Pin, nPerPar[i]+Pin[i-1]) - ## creates vector which indicates the range - ## of columns (endpoints) in each parcel + 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[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' - 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 + ## create empty list for allocation data matrices - for (i in 1:nAlloc){ - + 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] + 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" - + + 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 + ## 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){ + if (length(names) > 1) colnames(Temp) <- names - } - Allocations[[i]] <- Temp - ## assign result to list of parcel datasets - - - } - + ## 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( + ## 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 - 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(Allocations[[i]], paste(parceloutput, "/parcelruns", i, + ".dat", sep = ""), + row.names = FALSE, col.names = TRUE) + replist[i, 1] <- paste("parcelruns", i, ".dat", sep = "") } - 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 (lavaan::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 (lavaan::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] + 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 - - 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 + .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]]<.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 - + + 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 (lavaan::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 (lavaan::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] + 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 - - - 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 + .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]]<.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 - + + 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) + + ## 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]]<.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 - + 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)) + + return(list(Output_A, Output_B, Output_AB)) ## returns output for model A, model B, and the comparison of these } - - - \ No newline at end of file + diff -Nru r-cran-semtools-0.4.14/R/permuteMeasEq.R r-cran-semtools-0.5.0/R/permuteMeasEq.R --- r-cran-semtools-0.4.14/R/permuteMeasEq.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/permuteMeasEq.R 2018-06-25 21:09:18.000000000 +0000 @@ -1,9 +1,110 @@ ### Terrence D. Jorgensen -### Last updated: 24 April 2016 +### Last updated: 25 June 2018 ### permutation randomization test for measurement equivalence and DIF -## create s4 class for result object +## ----------------- +## 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 \code{data.frame} returned by a call to +#' \code{\link[lavaan]{parTable}} on the constrained model +#' @slot modelType A character indicating the specified \code{modelType} in the +#' call to \code{permuteMeasEq} +#' @slot 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 +#' @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 \code{data.frame} with \code{n.Permutations} rows and one column for each +#' \code{AFI.obs}. +#' @slot 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 +#' @slot 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}} on the +#' constrained model. +#' @slot 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} +#' @slot 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 +#' @slot extra.dist A \code{data.frame}, each column of which contains the +#' permutation distribution of the corresponding statistic in slot +#' \code{extra.obs} +#' @slot n.Permutations An \code{integer} indicating the number of permutations +#' requested by the user +#' @slot n.Converged An \code{integer} indicating the number of permuation +#' iterations which yielded a converged solution +#' @slot 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 +#' @slot 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. +#' @slot 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[semTools]{permuteMeasEq}} function. +#' @return +#' \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[semTools]{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} +#' } +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @seealso \code{\link[semTools]{permuteMeasEq}} +#' @examples +#' +#' # See the example from the permuteMeasEq function +#' setClass("permuteMeasEq", slots = c(PT = "data.frame", modelType = "character", ANOVA = "vector", @@ -20,477 +121,744 @@ n.Sparse = "vector", oldSeed = "integer")) -## function to check validity of arguments to permuteMeasEq() -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" && lavaan::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 - } +#' @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")) } - fixedCall$parallelType <- parallelType - if (is.null(ncpus)) { - fixedCall$ncpus <- NULL - fixedCall <- c(fixedCall, list(ncpus = NULL)) - } else fixedCall$ncpus <- ncpus + ## 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) +}) - ## check that "param" is NULL if uncon is NULL, and check for lavaan class - notLavaan <- "Non-NULL 'con', 'uncon', or 'null' must be fitted lavaan object." - 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 (class(con) != "lavaan") stop(notLavaan) - } else { - if (class(con) != "lavaan") stop(notLavaan) - if (class(uncon) != "lavaan") stop(notLavaan) - } - if (!is.null(null)) { - if (class(null) != "lavaan") stop(notLavaan) +#' @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) - ############ FIXME: check that lavaan::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.")) + ## 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)) } - ## collect parameter types for "mgcfa" - if (fixedCall$modelType != "mimic") { - ## save all estimates from constrained model - PT <- lavaan::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 == "~~", ]) + 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 = "") } - ## 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) + cat("\nUse lavTestScore(..., epc = TRUE) on your constrained model to", + "display expected parameter changes for these equality constraints\n\n") } - } - - - 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 & lavaan::lavInspect(con, "ngroups") > 1L) - stop("ECVI is not available for multigroup models.") - - ## check estimators - leastSq <- grepl("LS", lavaan::lavInspect(con, "options")$estimator) - if (!is.null(uncon)) { - if (uncon@Options$estimator != lavaan::lavInspect(con, "options")$estimator) - stop("Models must be fit using same estimator.") - } - if (!is.null(null)) { - if (lavaan::lavInspect(null, "options")$estimator != lavaan::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) -} + } else return(invisible(object)) -## function to extract fit measures -getAFIs <- function(...) { - dots <- list(...) + invisible(MI) +}) - AFI1 <- list() - AFI0 <- list() - leastSq <- grepl("LS", lavaan::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")) +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 (!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) + if (MI$tukey.p.value[i] < alpha) MI$flag[i] <- "* -->" } - AFI.obs + MI } -## Function to extract modification indices for equality constraints -getMIs <- function(...) { - dots <- list(...) - - if (dots$modelType == "mgcfa") { - ## save all estimates from constrained model - PT <- lavaan::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 +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 } -## 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 - - 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 = lavaan::lavInspect(con, "group.label")) - } +#' @rdname permuteMeasEq-class +#' @aliases hist,permuteMeasEq-method +#' @importFrom stats qchisq dchisq quantile +#' @param object,x object of class \code{permuteMeasEq} +#' @param ... Additional arguments to pass to \code{\link[graphics]{hist}} +#' @param AFI \code{character} indicating the fit measure whose permutation +#' distribution should be plotted +#' @param alpha alpha level used to draw confidence limits in \code{hist} and +#' flag significant statistics in \code{summary} output +#' @param nd number of digits to display +#' @param 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. +#' @param printLegend \code{logical}. If \code{TRUE} (default), a legend will +#' be printed with the histogram +#' @param legendArgs \code{list} of arguments passed to the +#' \code{\link[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" - ## fit constrained model, check for convergence - try(out0 <- lavaan::update(con, data = d, group.label = lavaan::lavInspect(con, "group.label"))) - if (!exists("out0")) { - nTries <- nTries + 1L - next + 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 (!lavaan::lavInspect(out0, "converged")) { - nTries <- nTries + 1L - next + 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)) } + } - ## fit unconstrained model (unless NULL), check for convergence - if (!is.null(uncon)) { - try(out1 <- lavaan::update(uncon, data = d, group.label = lavaan::lavInspect(con, "group.label"))) - if (!exists("out1")) { - nTries <- nTries + 1L - next + 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))) } - if (!lavaan::lavInspect(out1, "converged")) { - nTries <- nTries + 1L - next + } 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))) } - } - ## 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 + 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 { - MI <- max(do.call(getMIs, c(availableArgs, modelType = "mgcfa"))$X2) + Crit <- quantile(histArgs$x, probs = alpha) } - ## 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 + 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))) - nTries <- 1L - while (nTries <= maxNonconv) { - ## permute covariate(s) within each group - if (length(G)) { - for (gg in lavaan::lavInspect(con, "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 = lavaan::lavInspect(con, "group.label")) - } + 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))) - ## fit constrained model - try(out0 <- lavaan::update(con, data = d, group.label = lavaan::lavInspect(con, "group.label"))) - ## check for convergence - if (!exists("out0")) { - nTries <- nTries + 1L - next + } } - if (!lavaan::lavInspect(out0, "converged")) { - nTries <- nTries + 1L - next + if (printLegend) { + legendArgs <- c(legendArgs, list(lty = c(1, 1, 0, 0), + lwd = c(2, 3, 0, 0), + col = c("black","red","",""))) } - ## 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) + ## 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) } - ## 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)) -} + 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)) +}) -## Function to permute difference in fits + +## -------------------- +## Constructor Function +## -------------------- + +#' Permutation Randomization Tests of Measurement Equivalence and Differential +#' Item Functioning (DIF) +#' +#' The function \code{permuteMeasEq} provides tests of hypotheses involving +#' measurement equivalence, in one of two frameworks: multigroup CFA or MIMIC +#' models. +#' +#' +#' 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}}. +#' +#' 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[semTools]{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}}'s \code{group.label} +#' argument is used to preserve the order of groups seen in \code{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 (\code{"mgcfa"}) or MIMIC (\code{"mimic"}). +#' @param 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). +#' @param 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-\code{NULL uncon} is silently set to +#' \code{NULL}. +#' @param 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. +#' @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 +#' (\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}}). 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{\link[lavaan]{lavTestScore}}\code{(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. +#' @param 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}}). +#' @param 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). +#' @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 \code{con} hold in the +#' population. Any fit measures returned by \code{\link[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. +#' @param moreAFIs Optional. A character vector indicating which (if any) +#' alternative fit indices returned by \code{\link[semTools]{moreFitIndices}} +#' are to be used to test the multiparameter omnibus null hypothesis that the +#' constraints specified in \code{con} hold in the population. +#' @param 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. +#' @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 \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}. +#' @param showProgress Logical. Indicating whether to display a progress bar +#' while permuting. Silently set to \code{FALSE} when using parallel options. +#' @param warn Sets the handling of warning messages when fitting model(s) to +#' permuted data sets. See \code{\link[base]{options}}. +#' @param 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}. +#' @param 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. +#' @param 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. +#' @param 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}}. 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 +#' \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}} object is supplied, +#' \code{parallelType} is silently set to \code{"snow"}, and \code{ncpus} is +#' silently set to \code{length(cl)}. +#' @param iseed Integer: Only used to set the states of the RNG when using +#' parallel options, in which case \code{\link[base]{RNGkind}} is set to +#' \code{"L'Ecuyer-CMRG"} with a message. See +#' \code{\link[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]{set.seed}} before calling \code{permuteMeasEq}. +#' +#' @return 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. +#' +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' +#' @seealso \code{\link[stats]{TukeyHSD}}, \code{\link[lavaan]{lavTestScore}}, +#' \code{\link[semTools]{measurementInvariance}}, +#' \code{\link[semTools]{measurementInvarianceCat}} +#' +#' @references +#' +#' \bold{Papers about permutation tests of measurement equivalence:} +#' +#' Jorgensen, T. D., Kite, B. A., Chen, P.-Y., & Short, S. D. (in press). +#' Permutation randomization methods for testing measurement equivalence and +#' detecting differential item functioning in multiple-group confirmatory +#' factor analysis. \emph{Psychological Methods}. doi:10.1037/met0000152 +#' +#' Kite, B. A., Jorgensen, T. D., & Chen, P.-Y. (in press). Random permutation +#' testing applied to measurement invariance testing with ordered-categorical +#' indicators. \emph{Structural Equation Modeling}. +#' 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 +#' +#' \bold{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 +#' @examples +#' +#' \dontrun{ +#' +#' ######################## +#' ## 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 +#' ' +#' miout <- measurementInvariance(mod.config, data = HS, std.lv = TRUE, +#' group = "ageGroup") +#' +#' (fit.config <- miout[["fit.configural"]]) +#' (fit.metric <- miout[["fit.loadings"]]) +#' (fit.scalar <- miout[["fit.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[, !names(data) %in% 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, @@ -540,7 +908,7 @@ ######################### PREP DATA ############################## argList <- fullCall[c("con","uncon","null","param","freeParam","covariates", "AFIs","moreAFIs","maxSparse","maxNonconv","warn","iseed")] - argList$G <- lavaan::lavInspect(con, "group") + argList$G <- lavInspect(con, "group") ## check for categorical variables # catVars <- lavaan::lavNames(con, type = "ov.ord") # numVars <- lavaan::lavNames(con, type = "ov.num") @@ -552,12 +920,12 @@ names(y) <- c(n, argList$G) y }, SIMPLIFY = FALSE, - x = lavaan::lavInspect(con, "data"), g = lavaan::lavInspect(con, "group.label"), + x = lavInspect(con, "data"), g = lavInspect(con, "group.label"), n = lavaan::lavNames(con, type = "ov", - group = seq_along(lavaan::lavInspect(con, "group.label")))) + group = seq_along(lavInspect(con, "group.label")))) argList$d <- do.call(rbind, dataList) } else { - argList$d <- as.data.frame(lavaan::lavInspect(con, "data")) + argList$d <- as.data.frame(lavInspect(con, "data")) names(argList$d) <- lavaan::lavNames(con, type = "ov") } ## check that covariates are actual variables @@ -573,13 +941,13 @@ ###################### PERMUTED RESULTS ########################### ## permute and return distributions of (delta)AFIs, largest MI, and extras if (showProgress) { - mypb <- txtProgressBar(min = 1, max = nPermute, initial = 1, char = "=", - width = 50, style = 3, file = "") + 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)) - setTxtProgressBar(mypb, j) + utils::setTxtProgressBar(mypb, j) } close(mypb) } else if (parallelType == "multicore") { @@ -599,10 +967,10 @@ cl <- parallel::makePSOCKcluster(rep("localhost", ncpus)) } parallel::clusterSetRNGStream(cl, iseed = iseed) - # clusterExport(cl, c("getAFIs","getMIs","permuteOnce.mgcfa","permuteOnce.mimic")) 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) @@ -614,286 +982,542 @@ 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))) + ## 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 + notLavaan <- "Non-NULL 'con', 'uncon', or 'null' must be fitted lavaan object." + 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 (class(con) != "lavaan") stop(notLavaan) + } else { + if (class(con) != "lavaan") stop(notLavaan) + if (class(uncon) != "lavaan") stop(notLavaan) + } + if (!is.null(null)) { + if (class(null) != "lavaan") stop(notLavaan) + } + + ############ 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 (length(AFI.obs) == 1L) { - AFI.dist <- data.frame(sapply(permuDist, function(x) x$AFI)) - colnames(AFI.dist) <- names(AFI.obs) + if (!is.null(null)) { + if (lavInspect(null, "options")$estimator != lavInspect(con, "options")$estimator) + stop("Models must be fit using same estimator.") } - ## 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) + ## 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 = ", ")) } - - ## anything extra? if (!missing(extra)) { - extra.dist <- do.call(rbind, lapply(permuDist, function(x) x$extra)) - } else extra.dist <- data.frame(NULL) + 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 = ", ")) + } - ## save parameter table for show/summary methods - PT <- as.data.frame(lavaan::parTable(con)) - PT$par <- paste0(PT$lhs, PT$op, PT$rhs) - if (length(lavaan::lavInspect(con, "group"))) - PT$group.label[PT$group > 0] <- lavaan::lavInspect(con, "group.label")[PT$group[PT$group > 0] ] + ## return evaluated list of other arguments + lapply(fixedCall, eval) +} - ## return observed results, permutation p values, and ANOVA results - if (is.null(uncon)) { - delta <- lavaan::anova(con) + +## 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 { - delta <- lavaan::anova(uncon, con) + AFI.obs <- unlist(AFI0) - unlist(AFI1) } - 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 + AFI.obs } -## methods -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) -}) +## Function to extract modification indices for equality constraints +#' @importFrom lavaan parTable +getMIs <- function(...) { + dots <- list(...) -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")) + 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 } - ## 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") - } + MI.obs +} - } else return(invisible(object)) +## Functions to find delta-AFIs & maximum modification index in one permutation +#' @importFrom lavaan lavInspect +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 - invisible(MI) -}) + 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 = ", ")) + } -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) + ## 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 = lavInspect(con, "group.label")) } - 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 -} + ## fit constrained model, check for convergence + try(out0 <- lavaan::update(con, data = d, group.label = lavInspect(con, "group.label"))) + if (!exists("out0")) { + nTries <- nTries + 1L + next + } + if (!lavInspect(out0, "converged")) { + nTries <- nTries + 1L + next + } -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" + ## fit unconstrained model (unless NULL), check for convergence + if (!is.null(uncon)) { + try(out1 <- lavaan::update(uncon, data = d, group.label = lavInspect(con, "group.label"))) + if (!exists("out1")) { + nTries <- nTries + 1L + next + } + if (!lavInspect(out1, "converged")) { + nTries <- nTries + 1L + next + } - 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 = "") + ## 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 { - pVal <- paste("=", round(x@AFI.pval[[AFI]], nd)) + 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) +} - 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))) +#' @importFrom lavaan lavInspect +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 + + nTries <- 1L + while (nTries <= maxNonconv) { + ## permute covariate(s) within each group + if (length(G)) { + for (gg in lavInspect(con, "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 { - 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","",""))) + N <- nrow(d) + newd <- d[sample(1:N, N), covariates, drop = FALSE] + for (COV in covariates) d[ , COV] <- newd[ , COV] } - } 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) + ## 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 = ", ")) } - 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))) - } + ## fit null model, if it exists + if (!is.null(null)) { + out.null <- lavaan::update(null, data = d, group.label = lavInspect(con, "group.label")) } - if (printLegend) { - legendArgs <- c(legendArgs, list(lty = c(1, 1, 0, 0), - lwd = c(2, 3, 0, 0), - col = c("black","red","",""))) + + ## fit constrained model + try(out0 <- lavaan::update(con, data = d, group.label = lavInspect(con, "group.label"))) + ## check for convergence + if (!exists("out0")) { + nTries <- nTries + 1L + next + } + if (!lavInspect(out0, "converged")) { + nTries <- nTries + 1L + next } + ## If you get this far, everything converged, so break WHILE loop + break } - ## 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) + ## 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) } - 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)) -}) + ## 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)) +} + + diff -Nru r-cran-semtools-0.4.14/R/poolMAlloc.R r-cran-semtools-0.5.0/R/poolMAlloc.R --- r-cran-semtools-0.4.14/R/poolMAlloc.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/poolMAlloc.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,1064 +1,959 @@ -##PoolMAlloc +### Authors: +### Jason D. Rights (Vanderbilt University; jason.d.rights@vanderbilt.edu) +### - based on research from/with Sonya Sterba +### - adapted from parcelAllocation() by Corbin Quick and Alexander Schoemann +### - additional "indices" argument added by Terrence D. Jorgensen +### Last updated: 9 March 2018 + + +#' Pooled estimates and standard errors across M parcel-allocations: Combining +#' sampling variability and parcel-allocation variability. +#' +#' 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 parameter and standard error estimates from this SEM +#' can be outputted at this final selected number of allocations. 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 using a modified version +#' of the \code{\link{parcelAllocation}} function (Quick & Schoemann, 2012), +#' fits a SEM to each allocation, pools results 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). +#' +#' This is a modified version of \code{\link{parcelAllocation}}. It implements +#' a new algorithm for choosing the number of allocations (\emph{M}), +#' (described in Sterba & Rights (2016)), newly pools parameter estimate and +#' standard error results across these \emph{M} allocations, and produces +#' indices for assessing the relative contributions of parcel-allocation +#' variability vs. sampling variability in each estimate. 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 parameter +#' estimates and pooled standard errors fulfill stopping criteria +#' (\code{stopProp} and \code{stopValue}, defined above). Results from the +#' model that was fit to the \emph{M} allocations are outputted. +#' +#' Additionally, this function newly 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. The original parcelAllocation function +#' could not be employed if any allocations yielded nonconverged solutions. +#' +#' For further details on the benefits of the random allocation of items to +#' parcels, see Sterba (2011) and Sterba & MacCallum (2010). +#' +#' 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. +#' +#' @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, \code{nAllocAdd} can +#' be set to \eqn{0} and results will be output for \code{nAllocStart} +#' allocationsonly. +#' @param syntax lavaan syntax that defines the model. +#' @param dataset Item-level dataset +#' @param 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 (\code{\\}). See \code{\link[base]{path.expand}} +#' for details. If \code{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 +#' \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}) x +#' (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. +#' @param 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. +#' @param 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. +#' @param indices Optional \code{character} vector indicating the names of +#' available \code{\link[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}}), \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")} +#' @param 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. +#' @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 \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). +#' @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 +#' \code{\link[lavaan]{lavaan}}. See also \code{\link[lavaan]{lavOptions}} +#' +#' @return +#' \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, \emph{z}-based +#' 95\% confidence interval, \emph{p}-value for a \emph{t}-test of the +#' parameter (using degrees of freedom described in Sterba & Rights, 2016), and +#' \emph{t}-based 95\% confidence interval 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 average of each index across allocations, +#' the standard deviation of each fit index across allocations, the maximum of +#' each fit index across allocations, the minimum of each fit index across +#' allocations, the 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{Proportion of converged and proper allocations}{A table +#' containing the proportion of the final \emph{M} allocations that converged +#' (using a maximum likelihood estimator) and the proportion of allocations +#' that converged to proper solutions. Note that pooled estimates, pooled +#' standard errors, and other results are computed using only the converged, +#' proper allocations.} +#' \item{Allocations needed for stability (M)}{The number of allocations +#' (\emph{M}) at which the algorithm's stopping criteria (defined above) were +#' met.} +#' \item{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{Total runtime (minutes)}{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}} 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 on which this function +#' is based. +#' +#' @seealso \code{\link{parcelAllocation}}, \code{\link{PAVranking}} +#' +#' @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 +#' +#' @examples +#' +#' \dontrun{ +#' ## 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, AllocAdd = 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) +#' } +#' +#' @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, ...) { + if (!is.null(parceloutput)) { + if (!dir.exists(parceloutput)) stop('invalid directory:\n', + paste(parceloutput), "\n\n") + } -poolMAlloc <- function(nPerPar, facPlc, nAllocStart, - nAllocAdd=0, parceloutput=0, syntax, - dataset, stopProp, stopValue, - selectParam = NULL, - double = FALSE, checkConv=FALSE, - names='default', leaveout=0, useTotalAlloc=FALSE, ...) -{ - StartTimeFull <- proc.time() - #### start clock for calculating loop runtime - - if(is.character(dataset)){ - dataset <- read.csv(dataset) - } - - - - { + 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 - ### start loop counter - nAllocStarttemp <- nAllocStart - ### save initial nAllocStart for final calculation - - options(max.print=1000000) - ### allow many tables to be outputted - + options(max.print = 1e+06) BreakCounter <- NA - ### start break counter for double and checkConv options - -repeat -{ - - - StartTime <- proc.time() - #### start clock for calculating loop runtime - - nloop <- nloop + 1 - ## add to loop counter - - if (double==TRUE & is.na(BreakCounter)==FALSE) BreakCounter <- BreakCounter + 1 - ### add to break counter after stopping criteria reached - - if (checkConv==TRUE & is.na(BreakCounter)==FALSE) BreakCounter <- BreakCounter + 1 - ### add to break counter after stopping criteria reached - - - if (nloop > 1) { - -##Final output## - - if (is.na(BreakCounter)==TRUE){ - - Parmn_revFinal <- Parmn_rev[[nloop-1]] - ## save parameter estimates and pooled se table from previous loop for final output - - nConvergedOutput <- nConverged - ## save # allocations converged from previous loop for final output - - nConvergedProperOutput <- nConvergedProper - ## save # allocations converged and proper from previous loop for final output - - PooledSEwithinvarFinal <- PooledSEwithinvar - ## save pooled se within variance for final output - - PooledSEbetweenvarFinal <- PooledSEbetweenvar - ## save pooled se between variance for final output - - PooledSEFinal <- PooledSE - ## save pooled se between variance for final output - - FitsumOutput <- Fitsum - ## save Fit table from previous loop for final output - - nAllocOutput <- nAllocStart - nAllocAdd - #### save nAlloc for output - - AllocationsOutput <- Allocations - ## save datasets from previous loop for final output - - ParamFinal <- Param - - - } - - - - ParamPooledSE_temp <- ParamPooledSE - ### make current "pre-loop" parameter estimates a temporary vector for comparison with "post-loop" estimates - - ParamTest_temp <- ParamTest - #### make current "pre-loop" parameter estimates a temporary vector for comparison with "post-loop" estimates (parameter estimates only) - - PooledSE_temp <- PooledSE - #### make current "pre-loop" parameter estimates a temporary vector for comparison with "post-loop" estimates (pooled SE only) - - ParamPoolSEdiffmin <- abs(ParamPooledSE_temp*stopProp) - ### create vector of minimum differences to continue looping - - ParamPoolSEdiffmin[ParamPoolSEdiffmin 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) + 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 } - facPlcb[[i]] <- as.numeric(facPlcb[[i]]) } - facPlc <- facPlcb - + facPlc <- facPlc2 } - - # 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 + 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 } } - 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) + if (0 %in% facPlc == TRUE) { + Zfreq <- sum(facPlc == 0) + for (i in 1:Zfreq) { + Zplc <- match(0, facPlc) + dataset <- dataset[, -Zplc] + facPlc <- facPlc[-Zplc] } - leaveout <- as.numeric(leaveoutb) - } - - k1 <- .001 - for(i in 1:length(leaveout)){ - facPlc[leaveout[i]] <- facPlc[leaveout[i]] + k1 - k1 <- k1 +.001 + 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 } - } - - if(0 %in% facPlc == TRUE){ - Zfreq <- sum(facPlc==0) - for (i in 1:Zfreq){ - Zplc <- match(0,facPlc) - dataset <- dataset[ , -Zplc] - facPlc <- facPlc[-Zplc] + Npp <- c() + for (i in 1:length(nPerPar)) { + Npp <- c(Npp, rep(i, nPerPar[i])) } - ## 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 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('** WARNING! ** 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){ - print('** WARNING! ** Single-variable parcels have been requested. Check input!')} - - if(NleaveA > NleaveP) - print('** 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)){ - print('** WARNING! ** Number of parcel names provided not equal to number of parcels requested. Check input!')}} - - - 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), nAllocStart, 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:nAllocStart) { - 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: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 - ## 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 - - - } - - 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:(nAllocStart)){ - data_parcel <- as.data.frame(Allocations[[i]], row.names = NULL, optional = FALSE) - ## convert allocation matrix to dataframe for model estimation - fit <- lavaan::sem(syntax, control=list(iter.max=100), data=data_parcel, ...) - ## estimate model in lavaan - if (lavaan::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 (lavaan::lavInspect(fit, "post.check") & 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]][,4:9] <- matrix(data=NA,nrow(Param[[i]]),6) - ## make parameter estimates null for nonconverged, improper solutions - - if (ConvergedProper[[i]]==1) { - Fitind[[i]] <- lavaan::fitMeasures(fit, c("chisq", "df", "cfi", "tli", "rmsea")) - } else Fitind[[i]] <- c(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 a given loop.") - ## stop program if no allocations converge - - Parmn <- Param[[1]] - ## assign first parameter estimates to mean dataframe - if(is.null(selectParam)) selectParam <- 1:nrow(Parmn) - - ParSE <- matrix(NA, nrow(Parmn), nAllocStart) - ParSEmn <- Parmn[,5] - - Parsd <- matrix(NA, nrow(Parmn), nAllocStart) - ## assign parameter estimates for S.D. calculation - - Fitmn <- Fitind[[1]] - ## assign first fit indices to mean dataframe - - Fitsd <- matrix(NA, length(Fitmn), nAllocStart) - ## assign fit indices for S.D. calculation - - Sigp <- matrix(NA, nrow(Parmn), nAllocStart) - ## assign p-values to calculate percentage significant - - Fitind <- data.frame(Fitind) - ## convert fit index table to dataframe - - ParamSEsquared <- list() - #### create empty list for squared SE - - - 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) - ### square SE for each allocation - - Parsd[,i] <- Param[[i]][,4] - ## assign parameter estimates for S.D. estimation - - ParSE[,i] <- Param[[i]][,5] - - 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 - } - - - Sigp <- Sigp + .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) - 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") - ## 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 <- 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:nAllocStart){ - - 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]]<.05) { - sigChisq[[i]] <- 1 - } else sigChisq[[i]] <- 0 - } - ## count number of allocations with significant chi-square - - PerSigChisq <- (Reduce("+",sigChisq))/nConvergedProper*100 - PerSigChisq <- round(PerSigChisq,4) - ## calculate percent of allocations with significant chi-square - - PerSigChisqCol <- c(PerSigChisq,"n/a","n/a","n/a","n/a") - ## create list of Chi-square Percent Significant and "n/a" - - 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 (changed to dataframe) - - options(stringsAsFactors=TRUE) - ## unset option to allow strings into dataframe without converting to factors; - - PooledSEwithinvar <- Reduce("+",ParamSEsquared)/nConvergedProper - #### calculate within variance for pooled SE - - PooledSEbetweenvar <- Parmn[,5]^2 - ## calculate between variance for pooled SE - - PooledSE <- sqrt(PooledSEwithinvar + PooledSEbetweenvar + PooledSEbetweenvar/nConvergedProper) - ### calculate pooled SE - - ParamPooledSE <- c(Parmn[,4],PooledSE) - ### create vector of "post-loop" paramater estimates and pooled SE - - - - - ParamTest <- Parmn[,4] - #### create vector of parameter estimates - - if (nloop>1){ - - ParamPoolSEdiff <- abs(ParamPooledSE_temp - ParamPooledSE) - ### create vector of absolute differences between "pre-loop" and "post-loop" vectors - - Paramdiff <- abs(ParamTest_temp - ParamTest) - #### create vector of absolute differences between "pre-loop" and "post-loop" vectors (parameter estimates only) - - PooledSEdiff <- abs(PooledSE - PooledSE_temp) - #### create vector of absolute differences between "pre-loop" and "post-loop" vectors (pooled SE only) - - ParamPoolSEdifftest <- ParamPoolSEdiff - ParamPoolSEdiffmin - ParamPoolSEdifftest[ParamPoolSEdifftest<=0] <- 0 - ParamPoolSEdifftest[ParamPoolSEdifftest>0] <- 1 - ##create vector of difference between (absolute differences between "pre-loop" and "post-loop" vectors) - ##and (minimum differences required to continue looping) and set all negative values to 0 - - Paramdifftest <- Paramdiff - ParamDiffMin - Paramdifftest[Paramdifftest<=0] <- 0 - Paramdifftest[Paramdifftest>0] <- 1 - PooledSEdifftest <- PooledSEdiff - PooledSEmin - PooledSEdifftest[PooledSEdifftest<=0] <- 0 - PooledSEdifftest[PooledSEdifftest>0] <- 1 - ##create vector of difference between (absolute differences between "pre-loop" and "post-loop" vectors) - ##and (minimum differences required to continue looping) and set all negative values to 0 (parameter estimates and pooled SE separately) - - if (nloop==2){ - ParamPoolSEdifftesttable <- cbind(ParamPoolSEdifftest) - Paramdifftesttable <- cbind(Paramdifftest) - PooledSEdifftesttable <- cbind(PooledSEdifftest) - ### create table of whether or not parameter estimates/ pooled se met stopping criteria for each parameter - } - - if (nloop>2){ - ParamPoolSEdifftesttable <- cbind(ParamPoolSEdifftesttable,ParamPoolSEdifftest) - Paramdifftesttable <- cbind(Paramdifftesttable,Paramdifftest) - PooledSEdifftesttable <- cbind(PooledSEdifftesttable,PooledSEdifftest) - ##create table indicating whether or not parameter estimates/ pooled se met stopping criteria for each parameter - } - - 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))) - ##calculate proportion of values meeting stopping criteria - - - 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) - #### print number of allocations, proportion of parameters meeting stop criteria, and proportion of pooled SE meeting stop criteria - } - - 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) - #### print number of allocations, proportion of parameters meeting stop criteria, and proportion of pooled SE meeting stop criteria - } - - - } - - nAllocStart <- nAllocStart + nAllocAdd - ### update # allocations for potential next loop - - StopTime <- proc.time() - StartTime - #### calculate time taken to run loop - - print("Runtime:") - print(StopTime) - #### print time needed for loop - - 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") - #### calc estimates + pooled SE table - - - 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) - } - ## create table of parameter estimates and pooled se for each loop - -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 - - } - - - #print(Parmn_rev[[nloop]]) - #print(ParSEfn) - #### print all relevant tables - - - 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; - ### with double option selected, break loop after two consecutive hits - } - - if (nloop>1 & double==TRUE){ - if (Reduce("+",ParamPoolSEdifftesttable[c(selectParam,selectParam+nrow(Parmn_rev[[nloop]])),nloop-1])==0){ - BreakCounter <- 1 - } else BreakCounter <- NA - ### with double option selected, start break counter if stopping criteria are met, otherwise reset BreakCounter to 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 - ### with checkConv option, start break counter if stopping criteria are met - } - - if (nloop>1 & double==FALSE & checkConv==FALSE){ - if (Reduce("+",ParamPoolSEdifftesttable[c(selectParam,selectParam+nrow(Parmn_rev[[nloop]])),nloop-1])==0) - break; - } - ### break loop if differences between "pre-loop" and "post-loop" estimates are sufficiently small - - if (nAllocAdd==0) - break; - - ### break loop if nAllocAdd is 0 - - - - if (checkConv==TRUE & is.na(BreakCounter)==FALSE & BreakCounter==9) - break; - ### for checkConv option, break loop after 9 loops after stopping criteria met - - - } - - -##Write objects for Output when nAllocAdd is set to 0 - -if (nAllocAdd==0){ - - Parmn_revFinal <- Parmn_rev[[nloop]] - ## save parameter estimates and pooled se table from previous loop for final output - - nConvergedOutput <- nConverged - ## save # allocations converged from previous loop for final output - - nConvergedProperOutput <- nConvergedProper - ## save # allocations converged and proper from previous loop for final output - - PooledSEwithinvarFinal <- PooledSEwithinvar - ## save pooled se within variance for final output - - PooledSEbetweenvarFinal <- PooledSEbetweenvar - ## save pooled se between variance for final output - - PooledSEFinal <- PooledSE - ## save pooled se between variance for final output - - FitsumOutput <- Fitsum - ## save Fit table from previous loop for final output - - nAllocOutput <- nAllocStart - nAllocAdd - #### save nAlloc for output - - AllocationsOutput <- Allocations - ## save datasets from previous loop for final output -} - - -##Write parceled datasets - -if(as.vector(regexpr("/",parceloutput))!=-1){ - replist<-matrix(NA,nAllocOutput,1) - for (i in 1:(nAllocOutput)){ - colnames(AllocationsOutput[[i]])<-names - write.table(AllocationsOutput[[i]],paste(parceloutput,'/parcelruns',i,'.dat',sep=''),row.names=FALSE,col.names=TRUE) - replist[i,1]<-paste('parcelruns',i,'.dat',sep='') - } - write.table(replist,paste(parceloutput,"/parcelrunsreplist.dat",sep=''),quote=FALSE,row.names=FALSE,col.names=FALSE) } - - - -##Results for using all Allocations - - - if (useTotalAlloc==TRUE) -{ - - ParmnTotal <- ParamTotal[[1]] - ## assign first parameter estimates to mean dataframe - - ParSETotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) - ParSEmnTotal <- ParmnTotal[,5] - - ParsdTotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) - ## assign parameter estimates for S.D. calculation - - FitmnTotal <- FitindTotal[[1]] - ## assign first fit indices to mean dataframe - - FitsdTotal <- matrix(NA, length(FitmnTotal), nAllocTotal) - ## assign fit indices for S.D. calculation - - SigpTotal <- matrix(NA, nrow(ParmnTotal), nAllocTotal) - ## assign p-values to calculate percentage significant - - FitindTotal <- data.frame(FitindTotal) - ## convert fit index table to dataframe - - ParamSEsquaredTotal <- list() - #### create empty list for squared SE - - - - 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) - ### square SE for each allocation - - ParsdTotal[,i] <- ParamTotal[[i]][,4] - ## assign parameter estimates for S.D. estimation - - ParSETotal[,i] <- ParamTotal[[i]][,5] - - SigpTotal[,ncol(Sigp)-i+1] <- ParamTotal[[i]][,7] - ## assign p-values to calculate percentage significant - - FitsdTotal[,i] <- FitindTotal[[i]] - ## assign fit indices for S.D. estimation - - } - - - SigpTotal <- SigpTotal + .45 - SigpTotal <- apply(SigpTotal, c(1,2), round) - SigpTotal <- 1 - as.vector(rowMeans(SigpTotal, na.rm = TRUE)) - ## calculate percentage significant parameters - - - - 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") - ## calculate parameter S.D., minimum, maximum, range, bind to percentage significant - - 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) <- c("chisq", "df", "cfi", "tli", "rmsea") - ## calculate fit S.D., minimum, maximum, range - - ParmnTotal[,4:ncol(ParmnTotal)] <- ParmnTotal[,4:ncol(Parmn)] / nConvergedProperTotal - ## divide totalled parameter estimates by number converged allocations - ParmnTotal <- ParmnTotal[,1:3] - ## remove confidence intervals from output - ParmnTotal <- cbind(ParmnTotal, ParsumTotal) - ## bind parameter average estimates to cross-allocation information - FitmnTotal <- FitmnTotal / nConvergedProperTotal - ## divide totalled fit indices by number converged allocations - - pChisqTotal <- list() - ## create empty list for Chi-square p-values - sigChisqTotal <- list() - ## create empty list for Chi-square significance - - for (i in 1:nAllocTotal){ - - pChisqTotal[[i]] <- (1-pchisq(FitsdTotal[1,i],FitsdTotal[2,i])) - ## calculate p-value for each Chi-square - - if (is.na(pChisqTotal[[i]])==FALSE & pChisqTotal[[i]]<.05) { - sigChisqTotal[[i]] <- 1 - } else sigChisqTotal[[i]] <- 0 - } - ## count number of allocations with significant chi-square - - PerSigChisqTotal <- (Reduce("+",sigChisqTotal))/nConvergedProperTotal*100 - PerSigChisqTotal <- round(PerSigChisqTotal,4) - ## calculate percent of allocations with significant chi-square - - PerSigChisqColTotal <- c(PerSigChisqTotal,"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 - - FitsumTotal <- data.frame(FitsumTotal,PerSigChisqColTotal) - colnames(FitsumTotal) <- c("Avg Ind","S.D.","MAX","MIN","Range","% Sig") - ### bind to fit averages (changed to dataframe) - - options(stringsAsFactors=TRUE) - ## unset option to allow strings into dataframe without converting to factors; - - PooledSEwithinvarTotal <- Reduce("+",ParamSEsquaredTotal)/nConvergedProperTotal - #### calculate within variance for pooled SE - - PooledSEbetweenvarTotal <- ParmnTotal[,5]^2 - ## calculate between variance for pooled SE - - PooledSETotal <- sqrt(PooledSEwithinvarTotal + PooledSEbetweenvarTotal + PooledSEbetweenvarTotal/nConvergedProperTotal) - ### calculate pooled SE - - ParamPooledSETotal <- c(ParmnTotal[,4],PooledSETotal) - ### create vector of "post-loop" paramater estimates and pooled SE - - - - - ParamTestTotal <- ParmnTotal[,4] - #### create vector of parameter estimates - - - - #Parmn_revTotal <- list() - 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") - #### calc estimates + pooled SE table - - - - df_tTotal <- (nConvergedProperTotal-1)*(1 + (nConvergedProperTotal*PooledSEwithinvarTotal)/(nConvergedProperTotal*PooledSEbetweenvarTotal + PooledSEbetweenvarTotal))^2 - crit_tTotal <- abs(qt(0.05/2, df_tTotal)) - ### compute degrees of freedom and critical value for t - - pval_zTotal <- 2*(1-pnorm(abs(Parmn_revTotal[,4]/PooledSETotal))) - pval_tTotal <- 2*(1-pt(abs(Parmn_revTotal[,4]/PooledSETotal),df=df_tTotal)) - ### calc p-value for z and t distribution - - - CI95_Lower_zTotal <- Parmn_revTotal[,4]-1.959963985*PooledSETotal - CI95_Upper_zTotal <- Parmn_revTotal[,4]+1.959963985*PooledSETotal - ## compute confidence interval for z-tests - - CI95_Lower_tTotal <- Parmn_revTotal[,4]-crit_tTotal*PooledSETotal - CI95_Upper_tTotal <- Parmn_revTotal[,4]+crit_tTotal*PooledSETotal - ## compute confidence interval for t-tests - - 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") - ## add confidence intervals to final output table - - for (i in 1:nrow(Parmn_revTotal)){ - if (Parmn_revTotal[i,5]==0) Parmn_revTotal[i,6:11] <- NA - } - ## make all z/t p-values and CI's NA for fixed parameters (or when pooled se = 0) - - RPAVTotal <- (PooledSEbetweenvarTotal+(PooledSEbetweenvarTotal/(nConvergedProperTotal)))/PooledSEwithinvarTotal - PPAVTotal <- (((nConvergedProperTotal+1)/(nConvergedProperTotal))*PooledSEbetweenvarTotal)/(PooledSEwithinvarTotal+(((nConvergedProperTotal+1)/(nConvergedProperTotal))*PooledSEbetweenvarTotal)) - PAVtableTotal <- cbind(ParmnTotal[1:3],RPAVTotal,PPAVTotal) - ### create table for RPAV and PPAV - - - - 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) - ### round output to three digits - - FitsumTotal[2,2:5] <- c("n/a","n/a","n/a","n/a") - ## Change df row to "n/a" for sd, max, min, and range - - - ConvergedProperSumTotal <- rbind((nConvergedTotal)/(nAllocTotal),(nConvergedProperTotal)/(nAllocTotal)) - rownames(ConvergedProperSumTotal) <- c("Converged","Converged and Proper") - colnames(ConvergedProperSumTotal) <- "Proportion of Allocations" - ### create table summarizing proportions of converged allocations and allocations with proper solutions - - } - - - - -##Output results - - if (nAllocAdd!=0){ - if (nloop==2) PropParamMet <- matrix(data=1,nrow(Parmn),1) - if (nloop==2) PropPooledSEMet <- matrix(data=1,nrow(Parmn),1) - if (nloop !=2) PropParamMet <- (1-apply(Paramdifftesttable[,1:nloop-1],1,mean))*100 - if (nloop !=2) PropPooledSEMet <- (1-apply(PooledSEdifftesttable[,1:nloop-1],1,mean))*100 - #### calc percent of loops where stopping criteria were met for parameters and pooledse - - FirstParamMet <- apply(Paramdifftesttable==0,1,which.max) - FirstPooledSEMet <- apply(PooledSEdifftesttable==0,1,which.max) - #### determine first loop in which stopping criteria were met for parameters and pooledse - } - - 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) - } - ### if only running one loop, change columns regarding stopping criteria to NA - - - 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") - ### create tables with parameter estimates, pooled SE, and critical value - - 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 - ### if parameter is not used for stopping criteria, change "percent of loops when met" and "loop when first met" to NA + 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 (requestedTest %in% c("Satorra.Bentler","Yuan.Bentler", + "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)))) + options(stringsAsFactors = FALSE) + Fitsum <- data.frame(Fitsum, PerSigChisqCol) + colnames(Fitsum) <- c("Avg Ind", "S.D.", "MAX", "MIN", + "Range", "% Sig") + options(stringsAsFactors = TRUE) + 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") + options(stringsAsFactors = FALSE) + FitsumTotal <- data.frame(FitsumTotal, PerSigChisqColTotal) + colnames(FitsumTotal) <- c("Avg Ind", "S.D.", "MAX", "MIN", "Range", "% Sig") + options(stringsAsFactors = TRUE) + 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) } - } - - - df_t <- (nConvergedProperOutput-1)*(1 + (nConvergedProperOutput*PooledSEwithinvarFinal)/(nConvergedProperOutput*PooledSEbetweenvarFinal + PooledSEbetweenvarFinal))^2 - crit_t <- abs(qt(0.05/2, df_t)) - ### compute degrees of freedom and critical value for t - - pval_z <- 2*(1-pnorm(abs(Parmn_revFinal[,4]/PooledSEFinal))) - pval_t <- 2*(1-pt(abs(Parmn_revFinal[,4]/PooledSEFinal),df=df_t)) - ### calc p-value for z and t distribution - - - CI95_Lower_z <- Parmn_revFinal[,4]-1.959963985*PooledSEFinal - CI95_Upper_z <- Parmn_revFinal[,4]+1.959963985*PooledSEFinal - ## compute confidence interval for z-tests - - CI95_Lower_t <- Parmn_revFinal[,4]-crit_t*PooledSEFinal - CI95_Upper_t <- Parmn_revFinal[,4]+crit_t*PooledSEFinal - ## compute confidence interval for t-tests - - 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") - ## add confidence intervals to final output table - - for (i in 1:nrow(Parmn_revFinal)){ - if (Parmn_revFinal[i,5]==0) Parmn_revFinal[i,6:11] <- NA + 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 + } } - ## make all z/t p-values and CI's NA for fixed parameters (or when pooled se = 0) - - RPAV <- (PooledSEbetweenvarFinal+(PooledSEbetweenvarFinal/(nConvergedProperOutput)))/PooledSEwithinvarFinal - PPAV <- (((nConvergedProperOutput+1)/(nConvergedProperOutput))*PooledSEbetweenvarFinal)/(PooledSEwithinvarFinal+(((nConvergedProperOutput+1)/(nConvergedProperOutput))*PooledSEbetweenvarFinal)) - PAVtable <- cbind(Parmn[1:3],RPAV,PPAV) - ### create table for RPAV and PPAV - - colnames(Param_revTotal) <- c("lhs","op","rhs",c(1:nloop)) - colnames(PooledSE_revTotal) <- c("lhs","op","rhs",c(1:nloop)) - ### create column names for tables with parameters estimates and pooled se for each loop - - 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) - ### round output to three digits - - FitsumOutput[2,2:5] <- c("n/a","n/a","n/a","n/a") - ## Change df row to "n/a" for sd, max, min, and range - - - ConvergedProperSum <- rbind((nConvergedOutput)/(nAllocOutput),(nConvergedProperOutput)/(nAllocOutput)) - rownames(ConvergedProperSum) <- c("Converged","Converged and Proper") + 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" - ### create table summarizing proportions of converged allocations and allocations with proper solutions - - - - #Output_mod <- list(Parmn_revFinal,FitsumOutput,ConvergedProperSum,nAllocOutput,PAVtable,Param_revTotal,PooledSE_revTotal) - #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","Pooled Estimates by Loop","Pooled SE by Loop") - ### output summary for model estimation when checkConv is true (includes results by loop) - - StopTimeFull <- proc.time() - StartTimeFull - #### calculate time taken to run loop - - -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)") - ### output summary for model estimation - } - -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)") - ### output summary for model estimation -} - - + 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) - ### returns output for model + return(Output_mod) } diff -Nru r-cran-semtools-0.4.14/R/powerAnalysisNested.R r-cran-semtools-0.5.0/R/powerAnalysisNested.R --- r-cran-semtools-0.4.14/R/powerAnalysisNested.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/powerAnalysisNested.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,23 +1,48 @@ -# Power analysis for nested model comparison +### Sunthud Pornprasertmanit, Bell Clinton, Pavel Panko +### Last updated: 9 March 2018 -# Note: Model0 = Null hypothesis -# Model1 = Alternative hypothesis -# ModelA = More-restricted models (higher df; higher RMSEA) -# ModelB = Less-restricted models (lower df; lower RMSEA) - -# findRMSEApowernested -# Find the proportion of the samples from the alternative pair of RMSEAs in nested model comparison rejected by the cutoff dervied from the null pair of RMSEAs in nested model comparison -# rmsea0A: The H0 baseline RMSEA -# rmsea0B: The H0 alternative RMSEA (trivial misfit) -# rmsea1A: The H1 baseline RMSEA -# rmsea1B: The H1 alternative RMSEA (target misfit to be rejected) -# n: sample size -# dfA: degree of freedom of the more-restricted model -# dfB: degree of freedom of the less-restricted model -# alpha: The alpha level -# group: The number of group in calculating RMSEA -# Return power +#' 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 \code{\link{plotRMSEApowernested}} to plot the statistical power for +#' nested model comparison based on population RMSEA given the sample size +#' \item \code{\link{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. \emph{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 @@ -37,33 +62,50 @@ Power } -test.findRMSEApowernested <- function() { - alpha <- 0.05 - rmsea0A <- 0.06 - rmsea0B <- 0.05 - rmsea1A <- 0.08 - rmsea1B <- 0.05 - dfA <- 22 - dfB <- 20 - n <- 200 - group <- 1 - findRMSEApowernested(rmsea0A, rmsea0B, rmsea1A, rmsea1B, dfA, dfB, n, alpha, group) -} -# findRMSEAsamplesizenested -# Find the sample size that the power in rejection the samples from the alternative pair of RMSEA is just over the specified power -# rmsea0A: The H0 baseline RMSEA -# rmsea0B: The H0 alternative RMSEA (trivial misfit) -# rmsea1A: The H1 baseline RMSEA -# rmsea1B: The H1 alternative RMSEA (target misfit to be rejected) -# dfA: degree of freedom of the more-restricted model -# dfB: degree of freedom of the less-restricted model -# power: The desired statistical power -# alpha: The alpha level -# group: The number of group in calculating RMSEA -# Return The estimated sample size -findRMSEAsamplesizenested <- function(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, power=0.80, alpha=.05, group=1) { +#' 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 \code{\link{plotRMSEApowernested}} to plot the statistical power for +#' nested model comparison based on population RMSEA given the sample size +#' \item \code{\link{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. \emph{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 @@ -89,44 +131,56 @@ } } -test.findRMSEAsamplesizenested <- function() { - alpha <- 0.05 - rmseaA <- 0.06 - rmseaB <- 0.05 - da <- 22 - db <- 20 - powd <- 0.8 - G <- 1 - findRMSEAsamplesizenested(rmsea0A = 0, rmsea0B = 0, rmsea1A = rmseaA, rmsea1B = rmseaB, da, db, power=0.80, alpha=.05, group=1) -} -# plotRMSEApowernested -#Plot power of nested model RMSEA over a range of possible sample sizes -# rmsea0A: The H0 baseline RMSEA -# rmsea0B: The H0 alternative RMSEA (trivial misfit) -# rmsea1A: The H1 baseline RMSEA -# rmsea1B: The H1 alternative RMSEA (target misfit to be rejected) -# dfA: degree of freedom of the more-restricted model -# dfB: degree of freedom of the less-restricted model -# nlow: Lower bound of sample size -# nhigh: Upper bound of sample size -# steps: Step size -# alpha: The alpha level -# group: The number of group in calculating RMSEA -# ...: Additional parameters for graphs -# Return plot of power -plotRMSEApowernested <- function(rmsea0A = NULL, rmsea0B = NULL, rmsea1A, rmsea1B = NULL, dfA, dfB, nlow, nhigh, steps=1, alpha=.05, group=1, ...){ +#' 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 \code{\link{findRMSEApowernested}} to find the power for a given +#' sample size in nested model comparison based on population RMSEA +#' \item \code{\link{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. \emph{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", ...) } -test.plotRMSEApowernested <- function() { - alpha <- 0.05 - rmseaA <- 0.06 - rmseaB <- 0.05 - da <- 22 - db <- 20 - plotRMSEApowernested(rmsea0A = 0, rmsea0B = 0, rmsea1A = rmseaA, rmsea1B = rmseaB, da, db, nlow=50, nhigh=500, steps=1, alpha=.05, group=1) -} + diff -Nru r-cran-semtools-0.4.14/R/powerAnalysis.R r-cran-semtools-0.5.0/R/powerAnalysis.R --- r-cran-semtools-0.4.14/R/powerAnalysis.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/powerAnalysis.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -# plotRMSEApower -#Plot power of RMSEA over a range of possible sample sizes -#input: rmsea of null and alternative model, degress of freedom, lower sampel size, upper sample sample, sample size steps, alpha, the number of group in calculating RMSEA -#Output: plot of power -#Alexander M. Schoemann, Kristopher J. Preacher, Donna Coffman -#5/30/2012 - -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", ...) -} - -#Example Code -#plotRMSEApower(.025, .075, 23, 100, 500, 10) - -# 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) -} - -# plotRMSEAdist -# Plot the overlapping distributions of RMSEA based on noncentral chi-square distribution -# rmsea: A vector of RMSEA -# n: sample size -# df: degree of freedom of the chi-square distribution -# ptile: The percentile rank of the first specified rmsea to put the vertical line -# caption: The description of each rmsea -# rmseaScale: If TRUE, use RMSEA as the scale in x-axis. If FALSE, use chi-square as the scale in x-axis. -# group: The number of group in calculating RMSEA -plotRMSEAdist <- function(rmsea, n, df, ptile=NULL, caption=NULL, rmseaScale = TRUE, group=1) { - graph <- cbind(rmsea, df) - ncp <- apply(graph, 1, 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, xlab=ifelse(rmseaScale, "RMSEA", "Chi-Square"), ylab="Density") - 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.") -} - -# findRMSEApower -# Find the proportion of the samples from the alternative RMSEA rejected by the cutoff dervied from the null RMSEA -# rmsea0: The null RMSEA -# rmseaA: The alternative RMSEA -# n: sample size -# df: degree of freedom of the chi-square distribution -# alpha: The alpha level -# group: The number of group in calculating RMSEA -# Return power -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) - } -} diff -Nru r-cran-semtools-0.4.14/R/powerAnalysisRMSEA.R r-cran-semtools-0.5.0/R/powerAnalysisRMSEA.R --- r-cran-semtools-0.4.14/R/powerAnalysisRMSEA.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/powerAnalysisRMSEA.R 2018-05-01 13:33:39.000000000 +0000 @@ -0,0 +1,356 @@ +### Sunthud Pornprasertmanit, Alexander M. Schoemann, Kristopher J. Preacher, Donna Coffman +### Last updated: 9 March 2018 + + +#' 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: +#' \url{http://quantpsy.org/rmsea/rmseaplot.htm}. +#' +#' +#' @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 \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions +#' \item \code{\link{findRMSEApower}} to find the statistical power based on +#' population RMSEA given a sample size +#' \item \code{\link{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. \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. +#' @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 \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. +#' +#' +#' @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 \code{rmsea} +#' @param 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. +#' @param group The number of group that is used to calculate RMSEA. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{plotRMSEApower}} to plot the statistical power +#' based on population RMSEA given the sample size +#' \item \code{\link{findRMSEApower}} to find the statistical power based on +#' population RMSEA given a sample size +#' \item \code{\link{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. \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 +#' @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 \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). +#' +#' +#' @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 \code{\link{plotRMSEApower}} to plot the statistical power based on +#' population RMSEA given the sample size +#' \item \code{\link{plotRMSEAdist}} to visualize the RMSEA distributions +#' \item \code{\link{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. +#' \emph{Psychological Methods, 1}(2), 130--149. doi:10.1037/1082-989X.1.2.130 +#' +#' @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) +} + + + diff -Nru r-cran-semtools-0.4.14/R/powerAnalysisSS.R r-cran-semtools-0.5.0/R/powerAnalysisSS.R --- r-cran-semtools-0.4.14/R/powerAnalysisSS.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/powerAnalysisSS.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,101 +1,174 @@ -###Function to do power analysis for parameters with Satorra & Sarris method -###Alexander M. Schoemann -###11/4/2014 - - -##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. - - - -##Function to return power for a given model parameter -#inputs: popModel = lavaan syntax specifying data generating model (be sure to provide a value for all parameters), n =sample size (either scalar or vector), powerModel=Model to be fit, with parameter of interest fixed to 0, fun = lavaan function to use, nparam = number of parameters fixed in the power Model, ... additional arguments to pass to lavaan -SSpower <- function(popModel, n, powerModel, fun = "cfa", nparam = 1, alpha = .05, ...) { -##Two item list, first item is covariance matrix, second item is mean vector -popCov <- lavaan::fitted(do.call(fun, list(model=popModel))) - -##Fit model with parameter(s) fixed to 0 -out <- list(model=powerModel, sample.cov=popCov[[1]], sample.mean = popCov[[2]], sample.nobs=n) -out <- c(out, list(...)) -mod <- do.call(fun, out) - -##get NCP from chi square -ncp <- lavaan::fitmeasures(mod)["chisq"] -critVal <- qchisq(1-alpha, nparam) - -1-pchisq(critVal, nparam, ncp) - +### Alexander M. Schoemann & Terrence D. Jorgensen +### Last updated: 9 March 2018 +### 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 providng 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 (\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 constrains at least +#' one nonzero parameter to an incorrect value. Note the number in the +#' \code{nparam} argument. +#' +#' +#' @importFrom stats qchisq pchisq +#' +#' @param powerModel lavaan \code{\link[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 \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. +#' @param nparam \code{integer}. Number of invalid constraints in \code{powerModel}. +#' @param popModel lavaan \code{\link[lavaan]{model.syntax}} specifying the +#' data-generating model. This syntax should specify values for all nonzero +#' paramters in the model. If \code{length(n) > 1}, the same population +#' values will be used for each group. Different population values per group +#' can only be specified by utilizing \code{Sigma} (and \code{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 +#' \code{mu} and \code{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 \code{powerModel} +#' (i.e., \code{"cfa"}, \code{"sem"}, \code{"growth"}, or \code{"lavaan"}). +#' @param alpha Type I error rate used to set a criterion for rejecting H0. +#' @param ... additional arguments to pass to \code{\link[lavaan]{lavaan}}. +#' +#' @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. \emph{Psychometrika, 50}, 83--90. +#' doi:10.1007/BF02294150 +#' +#' @examples +#' ## Specify population values. Note every paramter 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") +#' +#' ## Specify second population to calculate power for multigroup model +#' +#' popMoments1 <- fitted(cfa(modelP)) +#' modelP2 <- ' +#' f1 =~ .7*V1 + .7*V2 + .7*V3 + .7*V4 +#' f2 =~ .7*V5 + .7*V6 + .7*V7 + .7*V8 +#' f1 ~~ .5*f2 ## higher correlation in Group 2 +#' 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 +#' ' +#' popMoments2 <- fitted(cfa(modelP2)) +#' modelA2 <- ' +#' f1 =~ V1 + V2 + V3 + V4 +#' f2 =~ V5 + V6 + V7 + V8 +#' f1 ~~ c(0, 0)*f2 +#' ' +#' mu <- list(popMoments1$mean, popMoments2$mean) +#' Sigma <- list(popMoments1$cov, popMoments2$cov) +#' SSpower(powerModel = modelA2, mu = mu, Sigma = Sigma, +#' n = c(60, 65), nparam = 2) +#' +#' @export +SSpower <- function(powerModel, n, nparam, popModel, mu, Sigma, + fun = "cfa", alpha = .05, ...) { + if (missing(Sigma)) { + ## Two item list, first item is covariance matrix, second item is mean vector + popMoments <- lavaan::fitted(do.call(fun, list(model = popModel))) + if (length(n) > 1L) { + for (i in 1:length(n)) { + Sigma <- popMoments$cov + mu <- popMoments$mean + } + } else { + Sigma <- popMoments$cov + mu <- popMoments$mean + } + } else { + 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] + if (missing(mu)) { + mu <- list() + for (i in 1:nG) mu[[i]] <- rep(0, nrow(Sigma[[1]])) + } + } else { + if (missing(mu)) mu <- rep(0, nrow(Sigma)) + n <- n[[1]] + } + } + + ## Fit overly constrained 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) + + ## 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) } -#Test the function -# model <- ' - # 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 - # ' - - -# model2 <- ' - # f1 =~ .7?V1 + .7?V2 + .7?V3 + .7?V4 - # f2 =~ .7?V5 + .7?V6 + .7?V7 + .7?V8 - - # f1 ~~ 0*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 - # ' - - -# SSpower(model, 150, model2) - -#Get power for a range of values - -# powVals <- NULL -# Ns <- seq(120, 500, 10) -# for(i in Ns){ -# powVals <- c(powVals, SSpower(model, i, model2)) -# } -# plot(Ns, powVals, type = 'l') - -#Test with multiple params -# model3 <- ' - # f1 =~ 1*V1 + 1*V2 + 1*V3 + 1*?V4 - # f2 =~ .7?V5 + .7?V6 + .7?V7 + .7?V8 - - # f1 ~~ 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 - # ' -# SSpower(model, 150, model3, nparam=4) + diff -Nru r-cran-semtools-0.4.14/R/probeInteraction.R r-cran-semtools-0.5.0/R/probeInteraction.R --- r-cran-semtools-0.4.14/R/probeInteraction.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/probeInteraction.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,59 +1,194 @@ -## Title: Probing Interaction -## Author: Sunthud Pornprasertmanit -## Description: Probing Interaction with Residual Centering -##----------------------------------------------------------------------------## +### Sunthud Pornprasertmanit +### Last updated: 9 March 2018 + + +#' 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 \code{\link{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 varaible (\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. +#' +#' For probing 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_2Z. } +#' +#' The simple slope of the independent varaible at each value of the moderator +#' can be obtained by \deqn{ b_{X|Z} = b_1 + b_3Z. } +#' +#' The variance of the simple intercept formula is \deqn{ Var\left(b_{0|X = 0, +#' Z}\right) = Var\left(b_0\right) + 2ZCov\left(b_0, b_2\right) + +#' Z^2Var\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) + 2ZCov\left(b_1, b_3\right) + Z^2Var\left(b_3\right) } +#' +#' Wald statistic is used for test statistic. +#' +#' +#' @importFrom lavaan lavInspect +#' @importFrom stats pnorm +#' +#' @param fit The lavaan model object used to evaluate model fit +#' @param nameX The vector of the factor names used as the predictors. The +#' first-order factor will be listed first. The last name must be the name +#' representing the interaction term. +#' @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 on each moderator variable value will be +#' probed. +#' @param valProbe The values of the moderator that will be used to probe the +#' effect of the other independent factor. +#' @return A list with two elements: +#' \enumerate{ +#' \item \code{SimpleIntercept}: The intercepts given each value of the +#' moderator. This element will be shown only if the factor intercept is +#' estimated (e.g., not fixed as 0). +#' \item \code{SimpleSlope}: The 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 \emph{SE} of the simple +#' intercept or simple slope. The fourth column is the Wald (\emph{z}) +#' statistic. The fifth column is the \emph{p} value testing whether the simple +#' intercepts or slopes are different from 0. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{indProd}} For creating the indicator products with no +#' centering, mean centering, double-mean centering, or residual centering. +#' \item \code{\link{probe3WayMC}} For probing the three-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe2WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{probe3WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the +#' latent interaction. +#' } +#' @references +#' 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 +#' @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, std.lv = FALSE, +#' meanstructure = TRUE) +#' summary(fitMC2way) +#' +#' result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), +#' "f3", "f2", c(-1, 0, 1)) +#' result2wayMC +#' +#' @export probe2WayMC <- function(fit, nameX, nameY, modVar, valProbe) { # 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.") # Check whether the fit object does not use mlm, mlr, or mlf estimator (because the variance-covariance matrix of parameter estimates cannot be computed - estSpec <- lavaan::lavInspect(fit, "call")$estimator + estSpec <- lavInspect(fit, "call")$estimator if(!is.null(estSpec) && (estSpec %in% c("mlr", "mlm", "mlf"))) stop("This function does not work when 'mlr', 'mlm', or 'mlf' is used as the estimator because the covariance matrix of the parameter estimates cannot be computed.") - + # Get the parameter estimate values from the lavaan object - est <- lavaan::lavInspect(fit, "coef") + est <- lavInspect(fit, "est") # Compute the intercept of no-centering betaNC <- as.matrix(est$beta[nameY, nameX]); colnames(betaNC) <- nameY # Extract all varEst - varEst <- lavaan::vcov(fit) - + varEst <- lavaan::vcov(fit) + # Check whether intercept are estimated - targetcol <- paste(nameY, "~", 1, sep="") - estimateIntcept <- targetcol %in% rownames(varEst) - - pvalue <- function(x) (1 - pnorm(abs(x))) * 2 - - resultIntcept <- NULL - resultSlope <- NULL + targetcol <- paste(nameY, "~", 1, sep="") + estimateIntcept <- targetcol %in% rownames(varEst) + + pvalue <- function(x) (1 - pnorm(abs(x))) * 2 + + resultIntcept <- NULL + resultSlope <- NULL if(estimateIntcept) { # Extract SE from residual centering - targetcol <- c(targetcol, paste(nameY, "~", nameX, sep="")) + targetcol <- c(targetcol, paste(nameY, "~", nameX, sep="")) # Transform it to non-centering SE - usedVar <- varEst[targetcol, targetcol] - usedBeta <- rbind(est$alpha[nameY,], betaNC) - - # Change the order of usedVar and usedBeta if the moderator variable is listed first + usedVar <- varEst[targetcol, targetcol] + usedBeta <- rbind(est$alpha[nameY,], betaNC) + + # 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)] } - - # Find simple intercept - simpleIntcept <- usedBeta[1] + usedBeta[3] * valProbe + + # Find simple intercept + 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 <- round(pvalue(zIntcept),6) #JG: rounded values to make them more readable resultIntcept <- cbind(valProbe, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "Intcept", "SE", "Wald", "p") - - # Find simple slope + + # Find simple slope simpleSlope <- usedBeta[2] + usedBeta[4] * valProbe varSlope <- usedVar[2, 2] + 2 * valProbe * usedVar[2, 4] + (valProbe^2) * usedVar[4, 4] zSlope <- simpleSlope/sqrt(varSlope) @@ -61,19 +196,19 @@ resultSlope <- cbind(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } else { - targetcol <- paste(nameY, "~", nameX, sep="") + targetcol <- paste(nameY, "~", nameX, sep="") - # Transform it to non-centering SE + # Transform it to non-centering SE usedVar <- varEst[targetcol, targetcol] usedBeta <- betaNC - - # Change the order of usedVar and usedBeta if the moderator variable is listed first + + # Change the order of usedVar and usedBeta if the moderator variable is listed first if(modVar == 2) { usedVar <- usedVar[c(2, 1, 3), c(2, 1, 3)] # usedBeta <- usedBeta[c(2, 1, 3)] } - - # Find simple slope + + # Find simple slope simpleSlope <- usedBeta[1] + usedBeta[3] * valProbe varSlope <- usedVar[1, 1] + 2 * valProbe * usedVar[1, 3] + (valProbe^2) * usedVar[3, 3] zSlope <- simpleSlope/sqrt(varSlope) @@ -81,24 +216,147 @@ resultSlope <- cbind(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } - + return(list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope)) } + + +#' 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 (Pornprasertmanit, Schoemann, +#' Geldhof, & Little, submitted) +#' +#' 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}} 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 +#' Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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{probe2WayMC}} for further details. +#' +#' +#' @importFrom lavaan lavInspect +#' @importFrom stats pnorm +#' +#' @param fit The lavaan model object used to evaluate model fit +#' @param nameX The vector of the factor names used as the predictors. The +#' first-order factor will be listed first. The last name must be the name +#' representing the interaction term. +#' @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 on each moderator variable value will be +#' probed. +#' @param valProbe The values of the moderator that will be used to probe the +#' effect of the other independent factor. +#' @return A list with two elements: +#' \enumerate{ +#' \item \code{SimpleIntercept}: The intercepts given each value of the +#' moderator. This element will be shown only if the factor intercept is +#' estimated (e.g., not fixed as 0). +#' \item \code{SimpleSlope}: The 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 simple slope. The fourth column is the Wald (\emph{z}) +#' statistic. The fifth column is the \emph{p} value testing whether the simple +#' intercepts or slopes are different from 0. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{indProd}} For creating the indicator products with no +#' centering, mean centering, double-mean centering, or residual centering. +#' \item \code{\link{probe2WayMC}} For probing the two-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe3WayMC}} For probing the three-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe3WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the +#' latent interaction. +#' } +#' @references +#' +#' 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 +#' @examples +#' +#' library(lavaan) +#' +#' 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 +#' 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 +#' " +#' +#' fitRC2way <- sem(model1, data = dat2wayRC, std.lv = FALSE, +#' meanstructure = TRUE) +#' summary(fitRC2way) +#' +#' result2wayRC <- probe2WayRC(fitRC2way, c("f1", "f2", "f12"), +#' "f3", "f2", c(-1, 0, 1)) +#' result2wayRC +#' +#' @export probe2WayRC <- function(fit, nameX, nameY, modVar, valProbe) { # 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.") # Check whether the fit object does not use mlm, mlr, or mlf estimator (because the variance-covariance matrix of parameter estimates cannot be computed - estSpec <- lavaan::lavInspect(fit, "call")$estimator + estSpec <- lavInspect(fit, "call")$estimator if(!is.null(estSpec) && (estSpec %in% c("mlr", "mlm", "mlf"))) stop("This function does not work when 'mlr', 'mlm', or 'mlf' is used as the estimator because the covariance matrix of the parameter estimates cannot be computed.") - + # Get the parameter estimate values from the lavaan object - est <- lavaan::lavInspect(fit, "coef") - + est <- lavInspect(fit, "est") + # Find the mean and covariance matrix of independent factors varX <- est$psi[nameX, nameX] meanX <- as.matrix(est$alpha[nameX,]); colnames(meanX) <- "intcept" @@ -109,87 +367,87 @@ betaRC <- as.matrix(est$beta[nameY, nameX]); colnames(betaRC) <- nameY # Find the number of observations - numobs <- lavaan::lavInspect(fit, "nobs") - - # Compute SSRC - meanXwith1 <- rbind(1, meanX) - varXwith0 <- cbind(0, rbind(0, varX)) - SSRC <- numobs * (varXwith0 + (meanXwith1 %*% t(meanXwith1))) + numobs <- lavInspect(fit, "nobs") + + # 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 + meanY <- t(meanXwith1) %*% betaRCWithIntcept + varY <- (t(betaRCWithIntcept) %*% SSRC %*% betaRCWithIntcept)/numobs - meanY^2 + resVarRC # Compute Cov(Y, X) - covY <- as.matrix((varX %*% betaRC)[1:2,]) + covY <- as.matrix((varX %*% betaRC)[1:2,]) # Compute E(XZ) - meanX[3] <- meanX[1] * meanX[2] + varX[1, 2] - + 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 + 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] + 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]) + 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) + fullCov <- rbind(cbind(varX, covY), c(covY, varY)) + fullMean <- rbind(meanX, meanY) # Compute the intercept of no-centering - intceptNC <- meanY - t(betaNC) %*% meanX + 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))) + 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 + resVarNC <- varY - (t(betaNCWithIntcept) %*% SSNC %*% betaNCWithIntcept)/numobs + meanY^2 # Extract all varEst - varEst <- lavaan::vcov(fit) - + varEst <- lavaan::vcov(fit) + # Check whether intercept are estimated - targetcol <- paste(nameY, "~", 1, sep="") - estimateIntcept <- targetcol %in% rownames(varEst) - - pvalue <- function(x) (1 - pnorm(abs(x))) * 2 - - resultIntcept <- NULL - resultSlope <- NULL + targetcol <- paste(nameY, "~", 1, sep="") + estimateIntcept <- targetcol %in% rownames(varEst) + + pvalue <- function(x) (1 - pnorm(abs(x))) * 2 + + resultIntcept <- NULL + resultSlope <- NULL if(estimateIntcept) { # Extract SE from residual centering - targetcol <- c(targetcol, paste(nameY, "~", nameX, sep="")) - varEstSlopeRC <- varEst[targetcol, targetcol] + targetcol <- c(targetcol, paste(nameY, "~", nameX, sep="")) + varEstSlopeRC <- varEst[targetcol, targetcol] # Transform it to non-centering SE - 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 + 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)] } - - # Find simple intercept - simpleIntcept <- usedBeta[1] + usedBeta[3] * valProbe + + # Find simple intercept + 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 <- round(pvalue(zIntcept),6) #JG: rounded values to make them more readable resultIntcept <- cbind(valProbe, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "Intcept", "SE", "Wald", "p") - - # Find simple slope + + # Find simple slope simpleSlope <- usedBeta[2] + usedBeta[4] * valProbe varSlope <- usedVar[2, 2] + 2 * valProbe * usedVar[2, 4] + (valProbe^2) * usedVar[4, 4] zSlope <- simpleSlope/sqrt(varSlope) @@ -197,20 +455,20 @@ resultSlope <- cbind(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } else { - targetcol <- paste(nameY, "~", nameX, sep="") - varEstSlopeRC <- varEst[targetcol, targetcol] + targetcol <- paste(nameY, "~", nameX, sep="") + varEstSlopeRC <- varEst[targetcol, targetcol] - # Transform it to non-centering SE + # Transform it to non-centering SE usedVar <- as.numeric(resVarNC/resVarRC) * (varEstSlopeRC %*% SSRC[2:4, 2:4] %*% solve(SSNC[2:4, 2:4])) usedBeta <- betaNC - - # Change the order of usedVar and usedBeta if the moderator variable is listed first + + # Change the order of usedVar and usedBeta if the moderator variable is listed first if(modVar == 2) { usedVar <- usedVar[c(2, 1, 3), c(2, 1, 3)] # usedBeta <- usedBeta[c(2, 1, 3)] } - - # Find simple slope + + # Find simple slope simpleSlope <- usedBeta[1] + usedBeta[3] * valProbe varSlope <- usedVar[1, 1] + 2 * valProbe * usedVar[1, 3] + (valProbe^2) * usedVar[3, 3] zSlope <- simpleSlope/sqrt(varSlope) @@ -218,41 +476,211 @@ resultSlope <- cbind(valProbe, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } - + return(list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope)) } + +#' 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 \code{\link{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 varaible (\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. +#' +#' For probing 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 varaible 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) + 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) + 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 statistic is used for test statistic. +#' +#' +#' @importFrom lavaan lavInspect +#' @importFrom stats pnorm +#' +#' @param fit The lavaan model object used to evaluate model fit +#' @param nameX The vector of the factor names used as the predictors. The +#' three first-order factors will be listed first. Then the second-order +#' factors will be listeed. The last element of the name will represent the +#' three-way interaction. Note that the fourth element must be the interaction +#' between the first and the second variables. The fifth element must be the +#' interaction between the first and the third variables. The sixth element +#' must be the interaction between the second and the third variables. +#' @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. +#' @return A list with two elements: +#' \enumerate{ +#' \item \code{SimpleIntercept}: The intercepts given each value of the moderator. +#' This element will be shown only if the factor intercept is estimated +#' (e.g., not fixed as 0). +#' \item \code{SimpleSlope}: The slopes given each value of the moderator. +#' } +#' 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. The sixth column is the \emph{p} +#' value testing whether the simple intercepts or slopes are different from 0. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{indProd}} For creating the indicator products with no +#' centering, mean centering, double-mean centering, or residual centering. +#' \item \code{\link{probe2WayMC}} For probing the two-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe2WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{probe3WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the +#' latent interaction. +#' } +#' @references +#' 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 +#' @examples +#' +#' library(lavaan) +#' +#' 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) +#' summary(fitMC3way) +#' +#' result3wayMC <- probe3WayMC(fitMC3way, +#' c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), +#' "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) +#' result3wayMC +#' +#' @export probe3WayMC <- function(fit, nameX, nameY, modVar, valProbe1, valProbe2) { # 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.") + } + 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.") # Check whether the fit object does not use mlm, mlr, or mlf estimator (because the variance-covariance matrix of parameter estimates cannot be computed - estSpec <- lavaan::lavInspect(fit, "call")$estimator + estSpec <- lavInspect(fit, "call")$estimator if(!is.null(estSpec) && (estSpec %in% c("mlr", "mlm", "mlf"))) stop("This function does not work when 'mlr', 'mlm', or 'mlf' is used as the estimator because the covariance matrix of the parameter estimates cannot be computed.") # Get the parameter estimate values from the lavaan object - est <- lavaan::lavInspect(fit, "coef") + est <- lavInspect(fit, "est") # Compute the intercept of no-centering betaNC <- as.matrix(est$beta[nameY, nameX]); colnames(betaNC) <- nameY # Extract all varEst varEst <- lavaan::vcov(fit) - + # Check whether intercept are estimated targetcol <- paste(nameY, "~", 1, sep="") estimateIntcept <- targetcol %in% rownames(varEst) - + pvalue <- function(x) (1 - pnorm(abs(x))) * 2 - + # Find the order to rearrange ord <- c(setdiff(1:3, modVar), modVar) ord <- c(ord, 7 - rev(ord)) - + resultIntcept <- NULL resultSlope <- NULL if(estimateIntcept) { @@ -260,17 +688,17 @@ targetcol <- c(targetcol, paste(nameY, "~", nameX, sep="")) # Transform it to non-centering SE - usedVar <- varEst[targetcol, targetcol] - usedBeta <- rbind(est$alpha[nameY,], betaNC) + usedVar <- varEst[targetcol, targetcol] + usedBeta <- rbind(est$alpha[nameY,], betaNC) if(sum(diag(usedVar) < 0) > 0) stop("This method does not work. The resulting calculation provided negative standard errors.") # JG: edited this error - + # Change the order of usedVar and usedBeta if the moderator variable is listed first usedVar <- usedVar[c(1, ord+1, 8), c(1, ord+1, 8)] usedBeta <- usedBeta[c(1, ord+1, 8)] - + # Find probe value val <- expand.grid(valProbe1, valProbe2) - + # Find simple intercept 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] @@ -278,7 +706,7 @@ pIntcept <- pvalue(zIntcept) resultIntcept <- cbind(val, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "Intcept", "SE", "Wald", "p") - + # Find simple slope 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] @@ -293,14 +721,14 @@ usedVar <- varEst[targetcol, targetcol] usedBeta <- betaNC if(sum(diag(usedVar) < 0) > 0) stop("This method does not work. The resulting calculation provided negative standard errors.") # JG: edited this error - + # Change the order of usedVar and usedBeta if the moderator variable is listed first usedVar <- usedVar[c(ord, 7), c(ord, 7)] usedBeta <- usedBeta[c(ord, 7)] # Find probe value val <- expand.grid(valProbe1, valProbe2) - + # Find simple slope simpleSlope <- usedBeta[1] + usedBeta[4] * val[,1] + usedBeta[5] * val[,2] + usedBeta[7] * val[,1] * val[,2] varSlope <- usedVar[1, 1] + val[,1]^2 * usedVar[4, 4] + val[,2]^2 * usedVar[5, 5] + val[,1]^2 * val[,2]^2 * usedVar[7, 7] + 2 * val[,1] * usedVar[1, 4] + 2 * val[,2] * usedVar[1, 5] + 2 * val[,1] * val[,2] * usedVar[1, 7] + 2 * val[,1] * val[,2] * usedVar[4, 5] + 2 * val[,1]^2 * val[,2] * usedVar[4, 7] + 2 * val[,1] * val[,2]^2 * usedVar[5, 7] @@ -309,24 +737,181 @@ resultSlope <- cbind(val, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } - + return(list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope)) } + + +#' 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 (Pornprasertmanit, Schoemann, +#' Geldhof, & Little, submitted) +#' +#' 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}} 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, Pornprasertmanit, Schoemann, & +#' Little, in press). 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 +#' Pornprasertmanit, Schoemann, Geldhof, and Little (submitted) 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}} for further details. +#' +#' +#' @importFrom lavaan lavInspect +#' @importFrom stats pnorm +#' +#' @param fit The lavaan model object used to evaluate model fit +#' @param nameX The vector of the factor names used as the predictors. The +#' three first-order factors will be listed first. Then the second-order +#' factors will be listeed. The last element of the name will represent the +#' three-way interaction. Note that the fourth element must be the interaction +#' between the first and the second variables. The fifth element must be the +#' interaction between the first and the third variables. The sixth element +#' must be the interaction between the second and the third variables. +#' @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. +#' @return A list with two elements: +#' \enumerate{ +#' \item \code{SimpleIntercept}: The intercepts given each value of the moderator. +#' This element will be shown only if the factor intercept is estimated +#' (e.g., not fixed as 0). +#' \item \code{SimpleSlope}: The slopes given each value of the moderator. +#' } +#' 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. The sixth column is the \emph{p} value +#' testing whether the simple intercepts or slopes are different from 0. +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \itemize{ +#' \item \code{\link{indProd}} For creating the indicator products with no +#' centering, mean centering, double-mean centering, or residual centering. +#' \item \code{\link{probe2WayMC}} For probing the two-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe3WayMC}} For probing the three-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe2WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{plotProbe}} Plot the simple intercepts and slopes of the +#' latent interaction. +#' } +#' @references +#' 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.} +#' @examples +#' +#' library(lavaan) +#' +#' dat3wayRC <- orthogonalize(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 +#' " +#' +#' fitRC3way <- sem(model3, data = dat3wayRC, std.lv = FALSE, +#' meanstructure = TRUE) +#' summary(fitRC3way) +#' +#' result3wayRC <- probe3WayRC(fitRC3way, +#' c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), +#' "f4", c("f1", "f2"), c(-1, 0, 1), c(-1, 0, 1)) +#' result3wayRC +#' +#' @export probe3WayRC <- function(fit, nameX, nameY, modVar, valProbe1, valProbe2) { # 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 # Check whether the fit object does not use mlm, mlr, or mlf estimator (because the variance-covariance matrix of parameter estimates cannot be computed - estSpec <- lavaan::lavInspect(fit, "call")$estimator + estSpec <- lavInspect(fit, "call")$estimator if(!is.null(estSpec) && (estSpec %in% c("mlr", "mlm", "mlf"))) stop("This function does not work when 'mlr', 'mlm', or 'mlf' is used as the estimator because the covariance matrix of the parameter estimates cannot be computed.") # Get the parameter estimate values from the lavaan object - est <- lavaan::lavInspect(fit, "coef") - + est <- lavInspect(fit, "est") + # Find the mean and covariance matrix of independent factors varX <- est$psi[nameX, nameX] meanX <- as.matrix(est$alpha[nameX,]); colnames(meanX) <- "intcept" @@ -338,7 +923,7 @@ betaRC <- as.matrix(est$beta[nameY, nameX]); colnames(betaRC) <- nameY # Find the number of observations - numobs <- lavaan::lavInspect(fit, "nobs") + numobs <- lavInspect(fit, "nobs") # Compute SSRC meanXwith1 <- rbind(1, meanX) @@ -358,29 +943,29 @@ 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)]) @@ -388,22 +973,22 @@ 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)) @@ -427,17 +1012,17 @@ # Extract all varEst varEst <- lavaan::vcov(fit) - + # Check whether intercept are estimated targetcol <- paste(nameY, "~", 1, sep="") estimateIntcept <- targetcol %in% rownames(varEst) - + pvalue <- function(x) (1 - pnorm(abs(x))) * 2 - + # Find the order to rearrange ord <- c(setdiff(1:3, modVar), modVar) ord <- c(ord, 7 - rev(ord)) - + resultIntcept <- NULL resultSlope <- NULL if(estimateIntcept) { @@ -449,14 +1034,14 @@ usedVar <- as.numeric(resVarNC/resVarRC) * (varEstSlopeRC %*% SSRC %*% solve(SSNC)) usedBeta <- betaNCWithIntcept if(sum(diag(usedVar) < 0) > 0) stop("This method does not work. The resulting calculation provided negative standard errors.") # JG: edited this error - + # Change the order of usedVar and usedBeta if the moderator variable is listed first usedVar <- usedVar[c(1, ord+1, 8), c(1, ord+1, 8)] usedBeta <- usedBeta[c(1, ord+1, 8)] - + # Find probe value val <- expand.grid(valProbe1, valProbe2) - + # Find simple intercept 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] @@ -464,7 +1049,7 @@ pIntcept <- pvalue(zIntcept) resultIntcept <- cbind(val, simpleIntcept, sqrt(varIntcept), zIntcept, pIntcept) colnames(resultIntcept) <- c(nameX[modVar], "Intcept", "SE", "Wald", "p") - + # Find simple slope 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] @@ -480,14 +1065,14 @@ usedVar <- as.numeric(resVarNC/resVarRC) * (varEstSlopeRC %*% SSRC[2:8, 2:8] %*% solve(SSNC[2:8, 2:8])) usedBeta <- betaNC if(sum(diag(usedVar) < 0) > 0) stop("This method does not work. The resulting calculation provided negative standard errors.") # JG: edited this error - + # Change the order of usedVar and usedBeta if the moderator variable is listed first usedVar <- usedVar[c(ord, 7), c(ord, 7)] usedBeta <- usedBeta[c(ord, 7)] # Find probe value val <- expand.grid(valProbe1, valProbe2) - + # Find simple slope simpleSlope <- usedBeta[1] + usedBeta[4] * val[,1] + usedBeta[5] * val[,2] + usedBeta[7] * val[,1] * val[,2] varSlope <- usedVar[1, 1] + val[,1]^2 * usedVar[4, 4] + val[,2]^2 * usedVar[5, 5] + val[,1]^2 * val[,2]^2 * usedVar[7, 7] + 2 * val[,1] * usedVar[1, 4] + 2 * val[,2] * usedVar[1, 5] + 2 * val[,1] * val[,2] * usedVar[1, 7] + 2 * val[,1] * val[,2] * usedVar[4, 5] + 2 * val[,1]^2 * val[,2] * usedVar[4, 7] + 2 * val[,1] * val[,2]^2 * usedVar[5, 7] @@ -496,10 +1081,196 @@ resultSlope <- cbind(val, simpleSlope, sqrt(varSlope), zSlope, pSlope) colnames(resultSlope) <- c(nameX[modVar], "Slope", "SE", "Wald", "p") } - + return(list(SimpleIntcept = resultIntcept, SimpleSlope = resultSlope)) } + + +#' Plot the graphs for probing latent interaction +#' +#' This function will plot the line graphs representing the simple effect of +#' the independent variable given the values of the moderator. +#' +#' +#' @param object The result of probing latent interaction obtained from +#' \code{\link{probe2WayMC}}, \code{\link{probe2WayRC}}, +#' \code{\link{probe3WayMC}}, or \code{\link{probe3WayRC}} function. +#' @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 \code{logical}. If \code{TRUE} (default), a legend is printed. +#' @param legendArgs \code{list} of arguments passed to \code{\link{legend}} +#' function if \code{legend=TRUE}. +#' @param \dots Any addition argument for the \code{\link{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 \code{\link{indProd}} For creating the indicator products with no +#' centering, mean centering, double-mean centering, or residual centering. +#' \item \code{\link{probe2WayMC}} For probing the two-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe3WayMC}} For probing the three-way latent interaction +#' when the results are obtained from mean-centering, or double-mean centering +#' \item \code{\link{probe2WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' \item \code{\link{probe3WayRC}} For probing the two-way latent interaction +#' when the results are obtained from residual-centering approach. +#' } +#' @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, std.lv = FALSE, +#' meanstructure = TRUE) +#' result2wayMC <- probe2WayMC(fitMC2way, c("f1", "f2", "f12"), +#' "f3", "f2", 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, +#' c("f1", "f2", "f3", "f12", "f13", "f23", "f123"), +#' "f4", c("f1", "f2"), c(-1, 0, 1), 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)) + 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'.") + } +} + + + +## ---------------- +## 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 @@ -507,6 +1278,8 @@ 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 @@ -514,12 +1287,14 @@ 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 <- combn(1:4, 2) + com <- utils::combn(1:4, 2) forSecond <- function(draw, meanval, covval, index) { draw2 <- setdiff(index, draw) prod(meanval[draw2]) * covval[draw[1], draw[2]] @@ -535,22 +1310,24 @@ 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) { +expect5NormProd <- function(m, s) { first <- prod(m) - com <- combn(1:5, 2) + 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 <- combn(1:5, 4) + com2 <- utils::combn(1:5, 4) forThirdOuter <- function(index, m, s, indexall) { targetMean <- m[setdiff(indexall, index)] - cominner <- combn(index, 2)[,1:3] #select only first three terms containing the first element only + 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]] @@ -562,6 +1339,8 @@ 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 @@ -573,11 +1352,13 @@ 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 <- combn(1:3, 2) + com <- utils::combn(1:3, 2) forFirst <- function(draw, meanval, covval, index) { # draw = 2, 3; draw2 = 1 draw2 <- setdiff(index, draw) @@ -595,53 +1376,7 @@ return(first + second + third + fourth) } -# plotProbe: plot the probing interaction result -plotProbe <- function(object, xlim, xlab="Indepedent Variable", ylab="Dependent Variable", ...) { - 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)) estIntercept <- object$SimpleIntcept[,ncol(slope) - 3] - if(numInt == 2) { - plotSingleProbe(estSlope, estIntercept, xlim=xlim, xlab=xlab, ylab=ylab, colLine=estSlopeSig, legendMain=colnames(slope)[1], legendVal=slope[,1], ...) - } 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] - plotSingleProbe(estSlope[select], estIntercept[select], xlim=xlim, xlab=xlab, ylab=ylab, colLine=estSlopeSig[select], main=paste(colnames(slope)[2], "=", mod2[i]), legendMain=colnames(slope)[1], legendVal=mod1, ...) - } - if (length(mod2) > 1) - par(obj) - } else { - stop("Please make sure that the object argument is obtained from 'probe2wayMC', 'probe2wayRC', 'probe3wayMC', or 'probe3wayRC'.") - } -} + # plotSingleProbe : plot the probing interaction result specific for only one moderator # estSlope = slope of each line @@ -651,22 +1386,34 @@ # ylab = the lable for the dependent variable # main = the title of the graph # colLine = the color of each line -# legendMain = the title of the legend -# legendVal = the description of each line representing in the plot -plotSingleProbe <- function(estSlope, estIntercept=NULL, xlim, xlab="Indepedent Variable", ylab="Dependent Variable", main=NULL, colLine="black", legendMain=NULL, legendVal=NULL, ...) { - if(is.null(estIntercept)) estIntercept <- rep(0, length(estSlope)) - if(length(colLine) == 1) colLine <- rep(colLine, length(estSlope)) +# 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) + 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(!is.null(legendVal)) { + if (legend) { positionX <- 0.25 - if(all(estSlope > 0)) positionX <- 0.01 - if(all(estSlope < 0)) positionX <- 0.50 - legend(positionX * (xlim[2] - xlim[1]) + xlim[1], 0.99 * (ylim[2] - ylim[1]) + ylim[1], legendVal, col=colLine, lty=1:length(estSlope), title=legendMain) + 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) } } + + diff -Nru r-cran-semtools-0.4.14/R/quark.R r-cran-semtools-0.5.0/R/quark.R --- r-cran-semtools-0.4.14/R/quark.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/quark.R 2018-06-26 11:11:33.000000000 +0000 @@ -1,9 +1,108 @@ -quark <- function(data, id, order = 1, silent = FALSE){ +### Steven R. Chesnut, Danny Squire, Terrence D. Jorgensen +### Last updated: 26 June 2018 + + + +#' Quark +#' +#' 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. +#' +#' 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}} 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 \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. +#' @param 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. +#' @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 \code{order = 2} in order to reorder the +#' imputation method procedure. Otherwise, use the default \code{order = 1}. +#' @param silent If \code{FALSE}, the details of the \code{quark} process are +#' printed. +#' @param \dots additional arguments to pass to \code{\link[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 \code{FactoMineR} package. +#' @seealso \code{\link{combinequark}} +#' @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 +#' @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) +#' \dontrun{ +#' 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){ @@ -12,130 +111,196 @@ } 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)] - 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) + ##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") + 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) } -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) + + +#' Combine the results from the quark function +#' +#' This function builds upon the \code{\link{quark}} function to provide a +#' final dataset comprised of the original dataset provided to +#' \code{\link{quark}} and enough principal components to be able to account +#' for a certain level of variance in the data. +#' +#' +#' @param quark Provide the \code{\link{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 \code{\link{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) } -gImp <- function(data, silent = FALSE){ +#' @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") - if(!silent) printCor(data.cor) + 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)) + 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=T),digits=1) - } - else if(is.na(data[b,a])){ - for(p in 1:ncol(data)){ - temp_mat[b,p] <- data[b,p] - } + 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 + + # 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=T) + # 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("\t", colnames(data)[a]) + } } - if(!silent) cat("\n") - imputed_data <- cleanMat(m1=data,m2=imputed_data,impact=num_adds) + 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){ +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])){ + 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] + } 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) +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){ +aImp <- function(data, silent = FALSE, ...) { + miceArgs <- list(...) + miceArgs$data <- data + miceArgs$maxit <- 1 + miceArgs$m <- 1 + miceArgs$printFlag <- !silent requireNamespace("mice") - if(!("package:mice" %in% search())) attachNamespace("mice") - if(!silent) cat("Starting Algorithm Imputation...\n") - data <- mice::mice(data,maxit=1,m=1, printFlag = !silent) - data <- mice::complete(data) - if(!silent) cat("Ending Algorithm Imputation...\n") - return(data) + 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") +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") + 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)){ + 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)])) } } @@ -144,9 +309,9 @@ return(data) } -compquark <- function(data, silent = FALSE){ - if(!silent) cat("Calculating values for the PCA\n") - pcam <- pcaquark(data, ncp=ncol(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] @@ -154,231 +319,167 @@ 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%..") -} - -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])) +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 = "-")) +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 + 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, "*") + 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) + 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) + 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 +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.handler <- function(w) { # warning handler W <<- w invokeRestart("muffleWarning") } list(value = withCallingHandlers(tryCatch(expr, error = function(e) e), - warning = w.handler), - warning = W) + 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) + 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="/") + 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="*") + 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 <- 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="/") + 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 + 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="*") + 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="*") + 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] } - res <- list(vs = vs, U = U, V = V) - return(res) + 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) } -# This function is copied from the psych package: lowerMat -printCor <- function (R, digits = 2) { - lowleft <- lower.tri(R, diag = TRUE) - nvar <- ncol(R) - nc <- digits + 3 - width <- getOption("width") - k1 <- width/(nc + 2) - if (is.null(colnames(R))) { - colnames(R) <- paste("C", 1:nvar, sep = "") - } - if (is.null(rownames(R))) { - rownames(R) <- paste("R", 1:nvar, sep = "") - } - colnames(R) <- abbreviate(colnames(R), minlength = digits + - 3) - nvar <- ncol(R) - nc <- digits + 3 - if (k1 * nvar < width) { - k1 <- nvar - } - k1 <- floor(k1) - fx <- format(round(R, digits = digits)) - if (nrow(R) == ncol(R)) { - fx[!lowleft] <- "" - } - for (k in seq(0, nvar, k1)) { - if (k < nvar) { - print(fx[(k + 1):nvar, (k + 1):min((k1 + k), nvar)], - quote = FALSE) - } - } -} + diff -Nru r-cran-semtools-0.4.14/R/reliability.R r-cran-semtools-0.5.0/R/reliability.R --- r-cran-semtools-0.4.14/R/reliability.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/reliability.R 2018-06-25 20:07:23.000000000 +0000 @@ -1,78 +1,227 @@ -## Title: Reliability of factors -## Author: Sunthud Pornprasertmanit ; Yves Rosseel -## Description: Find the relability values of each factor -##----------------------------------------------------------------------------## +### Sunthud Pornprasertmanit , Yves Rosseel +### Last updated: 25 June 2018 + + +#' Calculate reliability values of factors +#' +#' Calculate reliability values of factors by coefficient omega +#' +#' 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}. +#' +#' The coefficient omega (Bollen, 1980; see also Raykov, 2001) can be +#' calculated by +#' +#' \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}. +#' +#' The second coefficient omega (Bentler, 1972, 2009) can be 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 when the model has simple +#' structure, but different values when there are (for example) 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 third coefficient omega (McDonald, 1999), which is sometimes referred to +#' 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, the third coefficient omega will be similar to the +#' \eqn{\omega_2}. Note that if there is a directional effect in the model, all +#' coefficients omega will use the total factor variances, which is calculated +#' by \code{\link[lavaan]{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. +#' +#' Regarding categorical indicators, coefficient alpha and AVE are calculated +#' based on polychoric correlations. The coefficient alpha from this function +#' may be not the same as the standard alpha calculation for categorical items. +#' Researchers may check the \code{alpha} function in the \code{psych} package +#' for the standard coefficient alpha calculation. +#' +#' Item thresholds are not accounted for. Coefficient omega for categorical +#' items, however, is calculated by accounting for both item covariances and +#' item thresholds 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 in the model, an error is returned. If the categorical indicators +#' load on a different factor(s) than continuous indicators, then reliability +#' can be calculated separately for those scales by fitting separate models and +#' submitting each to the \code{reliability} function. +#' +#' +#' @importFrom lavaan lavInspect lavNames +#' @param object The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{lavaan} functions. +#' @return Reliability values (coefficient alpha, coefficients omega, average +#' variance extracted) of each factor in each group +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' +#' Yves Rosseel (Ghent University; \email{Yves.Rosseel@@UGent.be}) +#' +#' @seealso \code{\link{reliabilityL2}} for reliability value of a desired +#' second-order factor, \code{\link{maximalRelia}} for the maximal reliability +#' of weighted composite +#' @references +#' Bollen, K. A. (1980). Issues in the comparative measurement of +#' political democracy. \emph{American Sociological Review, 45}(3), 370--390. +#' Retrieved from \url{http://www.jstor.org/stable/2095172} +#' +#' 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 +#' +#' 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 +#' @examples +#' +#' library(lavaan) +#' +#' HS.model <- ' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 ' +#' +#' fit <- cfa(HS.model, data = HolzingerSwineford1939) +#' reliability(fit) +#' +#' @export reliability <- function(object) { - param <- lavaan::lavInspect(object, "coef") - ngroup <- lavaan::lavInspect(object, "ngroups") + param <- lavInspect(object, "est") + ngroup <- lavInspect(object, "ngroups") + categorical <- length(lavNames(object, "ov.ord")) name <- names(param) - if(ngroup == 1) { + if (ngroup == 1L) { ly <- param[name == "lambda"] } else { ly <- lapply(param, "[[", "lambda") } - ps <- lavaan::lavInspect(object, "cov.lv") - if(ngroup == 1) ps <- list(ps) - if(ngroup == 1) { + ps <- lavInspect(object, "cov.lv") + if (ngroup == 1L) { + ps <- list(ps) te <- param[name == "theta"] } else { te <- lapply(param, "[[", "theta") } - SigmaHat <- lavaan::lavInspect(object, "cov.ov") - if(ngroup == 1) SigmaHat <- list(SigmaHat) - if(ngroup == 1) { - tau <- param[name == "tau"] - } else { - tau <- lapply(param, "[[", "tau") - } - implied <- lavaan::fitted.values(object)[name = "cov"] - categorical <- (length(tau) > 0) && !is.null(tau[[1]]) + SigmaHat <- lavInspect(object, "cov.ov") + if (ngroup == 1L) SigmaHat <- list(SigmaHat) threshold <- NULL - if(ngroup == 1) { - S <- list(lavaan::lavInspect(object, "sampstat")$cov) + if (ngroup == 1L) { + S <- list(lavInspect(object, "sampstat")$cov) } else { - S <- lapply(lavaan::lavInspect(object, "sampstat"), function(x) x$cov) - } - if(categorical) { - polycor <- polycorLavaan(object) - if(ngroup == 1) polycor <- list(polycor) - S <- lapply(polycor, function(x) x[rownames(ly[[1]]), rownames(ly[[1]])]) - threshold <- getThreshold(object) - SigmaHat <- thetaImpliedTotalVar(object) + S <- lapply(lavInspect(object, "sampstat"), function(x) x$cov) } + if (categorical) threshold <- getThreshold(object) flag <- FALSE result <- list() - for(i in 1:ngroup) { + for (i in 1:ngroup) { common <- (apply(ly[[i]], 2, sum)^2) * diag(ps[[i]]) - truevar <- ly[[i]]%*%ps[[i]]%*%t(ly[[i]]) + truevar <- ly[[i]] %*% ps[[i]] %*% t(ly[[i]]) error <- rep(NA, length(common)) alpha <- 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)) - for(j in 1:length(error)) { + for (j in 1:length(common)) { index <- which(ly[[i]][,j] != 0) - error[j] <- sum(te[[i]][index, index]) - sigma <- S[[i]][index, index] + error[j] <- sum(te[[i]][index, index, drop = FALSE]) + sigma <- S[[i]][index, index, drop = FALSE] alpha[j] <- computeAlpha(sigma, length(index)) total[j] <- sum(sigma) - impliedTotal[j] <- sum(SigmaHat[[i]][index, index]) - faccontrib <- ly[[i]][,j, drop = FALSE] %*%ps[[i]][j,j,drop = FALSE]%*%t(ly[[i]][,j, drop = FALSE]) - truefac <- diag(faccontrib[index, index]) - commonfac <- sum(faccontrib[index, index]) - trueitem <- diag(truevar[index, index]) - erritem <- diag(te[[i]][index, index]) - if(sum(abs(trueitem - truefac)) < 0.00001) { + impliedTotal[j] <- sum(SigmaHat[[i]][index, index, drop = FALSE]) + faccontrib <- ly[[i]][,j, drop = FALSE] %*% ps[[i]][j,j, drop = FALSE] %*% t(ly[[i]][,j, drop = FALSE]) + truefac <- diag(faccontrib[index, index, drop = FALSE]) + commonfac <- sum(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) { avevar[j] <- sum(trueitem) / sum(trueitem + erritem) } else { avevar[j] <- NA } - if(categorical) { - omega1[j] <- omegaCat(faccontrib[index, index], SigmaHat[[i]][index, index], threshold[[i]][index], faccontrib[index, index] + te[[i]][index, index]) - omega2[j] <- omegaCat(faccontrib[index, index], SigmaHat[[i]][index, index], threshold[[i]][index], SigmaHat[[i]][index, index]) - omega3[j] <- omegaCat(faccontrib[index, index], SigmaHat[[i]][index, index], threshold[[i]][index], sigma) + if (categorical) { + omega1[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], + implied = SigmaHat[[i]][index, index, drop = FALSE], + threshold = threshold[[i]][index], + denom = faccontrib[index, index, drop = FALSE] + te[[i]][index, index, drop = FALSE]) + omega2[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], + implied = SigmaHat[[i]][index, index, drop = FALSE], + threshold = threshold[[i]][index], + denom = SigmaHat[[i]][index, index, drop = FALSE]) + omega3[j] <- omegaCat(truevar = faccontrib[index, index, drop = FALSE], + implied = SigmaHat[[i]][index, index, drop = FALSE], + threshold = threshold[[i]][index], + denom = sigma) } else { omega1[j] <- commonfac / (commonfac + error[j]) omega2[j] <- commonfac / impliedTotal[j] @@ -81,10 +230,19 @@ } alpha <- c(alpha, total = computeAlpha(S[[i]], nrow(S[[i]]))) names(alpha) <- c(names(common), "total") - if(categorical) { - omega1 <- c(omega1, total = omegaCat(truevar, SigmaHat[[i]], threshold[[i]], truevar + te[[i]])) - omega2 <- c(omega2, total = omegaCat(truevar, SigmaHat[[i]], threshold[[i]], SigmaHat[[i]])) - omega3 <- c(omega3, total = omegaCat(truevar, SigmaHat[[i]], threshold[[i]], S[[i]])) + if (categorical) { + omega1 <- c(omega1, total = omegaCat(truevar = truevar, + implied = SigmaHat[[i]], + threshold = threshold[[i]], + denom = truevar + te[[i]])) + omega2 <- c(omega2, total = omegaCat(truevar = truevar, + implied = SigmaHat[[i]], + threshold = threshold[[i]], + denom = SigmaHat[[i]])) + omega3 <- c(omega3, total = omegaCat(truevar = truevar, + implied = SigmaHat[[i]], + threshold = threshold[[i]], + denom = S[[i]])) } else { omega1 <- c(omega1, total = sum(truevar) / (sum(truevar) + sum(te[[i]]))) omega2 <- c(omega2, total = sum(truevar) / (sum(SigmaHat[[i]]))) @@ -92,31 +250,119 @@ } avevar <- c(avevar, total = sum(diag(truevar))/ sum((diag(truevar) + diag(te[[i]])))) singleIndicator <- apply(ly[[i]], 2, function(x) sum(x != 0)) %in% 0:1 - result[[i]] <- rbind(alpha=alpha, omega=omega1, omega2=omega2,omega3=omega3, avevar = avevar)[,!singleIndicator] + result[[i]] <- rbind(alpha = alpha, omega = omega1, omega2 = omega2, + omega3 = omega3, avevar = avevar)[ , !singleIndicator] } - if(flag) warning("The alpha and the average variance extracted are calculated from polychoric (polyserial) correlation not from Pearson's correlation.\n") - if(ngroup == 1) { + if (flag) warning("The alpha and the average variance extracted are", + " calculated from polychoric (polyserial) correlation not", + " from Pearson's correlation.\n") + if (ngroup == 1L) { result <- result[[1]] } else { - names(result) <- lavaan::lavInspect(object, "group.label") + names(result) <- lavInspect(object, "group.label") } result } -computeAlpha <- function(S, k) k/(k - 1) * (1.0 - sum(diag(S))/sum(S)) + +#' 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 +#' \code{\link{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 factor, the uniqueness of the +#' first-order factor, and the measurement error of 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} is the first-order factor loading, \eqn{\bold{B}} is the +#' second-order factor loading, \eqn{\Phi_2} is the covariance matrix of the +#' second-order factors, \eqn{\Psi_{u}} is the covariance matrix of the unique +#' scores from first-order factors, and \eqn{\Theta} is the covariance matrix +#' of the measurement errors from indicators. Thus, the proportion of the +#' second-order factor explaining the total score, or the coefficient omega at +#' Level 1, can be calculated: +#' +#' \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. When model-implied covariance matrix among +#' first-order factors (\eqn{\Phi_1}) can be calculated: +#' +#' \deqn{ \Phi_1 = \bold{B} \Phi_2 \bold{B}^{\prime} + \Psi_{u}, } +#' +#' Thus, the proportion of the second-order factor explaining the varaince at +#' first-order factor level, or the coefficient omega at Level 2, can be +#' calculated: +#' +#' \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. +#' +#' The partial coefficient omega at Level 1, or the proportion of observed +#' variance explained by the second-order factor after partialling the +#' uniqueness from the first-order factor, can be calculated: +#' +#' \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. +#' +#' +#' @importFrom lavaan lavInspect +#' +#' @param object The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{lavaan} functions that has a +#' second-order factor +#' @param secondFactor The name of the second-order factor +#' @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}) +#' @seealso \code{\link{reliability}} for the reliability of the first-order +#' factors. +#' @examples +#' +#' library(lavaan) +#' +#' 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") +#' +#' @export reliabilityL2 <- function(object, secondFactor) { - param <- lavaan::lavInspect(object, "coef") - ngroup <- lavaan::lavInspect(object, "ngroups") + param <- lavInspect(object, "est") + ngroup <- lavInspect(object, "ngroups") name <- names(param) - if(ngroup == 1) { + if (ngroup == 1L) { ly <- param[name == "lambda"] } else { ly <- lapply(param, "[[", "lambda") } - ve <- lavaan::lavInspect(object, "cov.lv") - if(ngroup == 1) ve <- list(ve) - if(ngroup == 1) { + ve <- lavInspect(object, "cov.lv") + if (ngroup == 1L) ve <- list(ve) + if (ngroup == 1L) { ps <- param[name == "psi"] te <- param[name == "theta"] be <- param[name == "beta"] @@ -125,58 +371,200 @@ te <- lapply(param, "[[", "theta") be <- lapply(param, "[[", "beta") } - SigmaHat <- lavaan::lavInspect(object, "cov.ov") - if(ngroup == 1) { + SigmaHat <- lavInspect(object, "cov.ov") + if (ngroup == 1L) { SigmaHat <- list(SigmaHat) - S <- list(lavaan::lavInspect(object, "sampstat")$cov) + S <- list(lavInspect(object, "sampstat")$cov) } else { - S <- lapply(lavaan::lavInspect(object, "sampstat"), function(x) x$cov) + S <- lapply(lavInspect(object, "sampstat"), function(x) x$cov) } - threshold <- lavaan::lavInspect(object, "th") result <- list() - for(i in 1:ngroup) { - + for (i in 1:ngroup) { + # Prepare for higher-order reliability - l2var <- ve[[i]][secondFactor, secondFactor] + 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]) + errorl2 <- sum(ps[[i]][indexl2, indexl2, drop = FALSE]) # Prepare for lower-order reliability indexl1 <- which(apply(ly[[i]][,indexl2], 1, function(x) sum(x != 0)) > 0) - l1load <- ly[[i]][,indexl2] %*% as.matrix(be[[1]][indexl2,secondFactor]) + l1load <- ly[[i]][,indexl2] %*% as.matrix(be[[1]][indexl2, secondFactor, drop = FALSE]) commonl1 <- (sum(l1load)^2) * l2var - errorl1 <- sum(te[[i]][indexl1, indexl1]) + 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]] + 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)) { + 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.") + 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]) + 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]) + 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) + result[[i]] <- c(omegaL1 = omegaL1, omegaL2 = omegaL2, partialOmegaL1 = partialOmegaL1) } - if(ngroup == 1) { + if (ngroup == 1L) { result <- result[[1]] } else { - names(result) <- lavaan::lavInspect(object, "group.label") + names(result) <- lavInspect(object, "group.label") } result } + + +#' 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 The lavaan model object provided after running the \code{cfa}, +#' \code{sem}, \code{growth}, or \code{lavaan} functions. +#' @return 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). +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' @seealso \code{\link{reliability}} for reliability of an unweighted +#' composite score +#' @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. +#' @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) { + param <- lavInspect(object, "est") + ngroup <- lavInspect(object, "ngroups") + categorical <- length(lavNames(object, "ov.ord")) + name <- names(param) + if (ngroup == 1L) { + ly <- param[name == "lambda"] + } else { + ly <- lapply(param, "[[", "lambda") + } + ps <- lavInspect(object, "cov.lv") + SigmaHat <- lavInspect(object, "cov.ov") + if (ngroup == 1L) { + ps <- list(ps) + SigmaHat <- list(SigmaHat) + S <- list(lavInspect(object, "sampstat")$cov) + } else { + S <- lapply(lavInspect(object, "sampstat"), function(x) x$cov) + } + threshold <- NULL + result <- list() + if (categorical) threshold <- getThreshold(object) # change to lavInspect(object, "th")? + ## No, it is a list per item, rather than a single vector + for (i in 1:ngroup) { + truevar <- ly[[i]] %*% ps[[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 (ngroup == 1L) { + result <- result[[1]] + } else { + names(result) <- lavInspect(object, "group.label") + } + result +} + + + +## ---------------- +## Hidden Functions +## ---------------- + +computeAlpha <- function(S, k) k/(k - 1) * (1.0 - sum(diag(S)) / sum(S)) + +#' @importFrom stats cov2cor pnorm omegaCat <- function(truevar, implied, threshold, denom) { # denom could be polychoric correlation, model-implied correlation, or model-implied without error correlation polyc <- truevar @@ -186,23 +574,23 @@ denom <- cov2cor(denom) sumnum <- 0 addden <- 0 - 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)) - sumnum <- sumnum + (sumprobn2 - sumprobn1 * sumprobn1p) - addden <- addden + (addprobn2 - sumprobn1 * sumprobn1p) - } + 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)) + sumnum <- sumnum + (sumprobn2 - sumprobn1 * sumprobn1p) + addden <- addden + (addprobn2 - sumprobn1 * sumprobn1p) + } } reliab <- sumnum / addden reliab @@ -214,43 +602,45 @@ } -polycorLavaan <- function(object) { - ngroups <- lavaan::lavInspect(object, "ngroups") - coef <- lavaan::lavInspect(object, "coef") - targettaunames <- NULL - if(ngroups == 1) { - 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), 1, function(x) substr(x[1], 1, x[2]))) - 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 == 1) { - return(lavaan::lavInspect(newobject, "coef")$theta) - } else { - return(lapply(lavaan::lavInspect(newobject, "coef"), "[[", "theta")) - } -} +# 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 getThreshold <- function(object) { - ngroups <- lavaan::lavInspect(object, "ngroups") - coef <- lavaan::lavInspect(object, "coef") + ngroups <- lavInspect(object, "ngroups") + coef <- lavInspect(object, "est") result <- NULL - if(ngroups == 1) { + if (ngroups == 1L) { targettaunames <- rownames(coef$tau) barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|")) varthres <- apply(data.frame(targettaunames, barpos - 1), 1, function(x) substr(x[1], 1, x[2])) result <- list(split(coef$tau, varthres)) } else { result <- list() - for(g in 1:ngroups) { + for (g in 1:ngroups) { targettaunames <- rownames(coef[[g]]$tau) barpos <- sapply(strsplit(targettaunames, ""), function(x) which(x == "|")) varthres <- apply(data.frame(targettaunames, barpos - 1), 1, function(x) substr(x[1], 1, x[2])) @@ -261,108 +651,59 @@ } invGeneralRelia <- function(w, truevar, totalvar) { - 1-(t(w) %*% truevar %*% w) / (t(w) %*% totalvar %*% w) + 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) + 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) + 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 was not converged.") + if (out$convergence != 0) stop("The numerical method for finding the maximal", + " reliability was not converged.") result <- 1 - out$objective - weight <- out$par - weight <- weight/mean(weight) + 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 was not converged.") + if (out$convergence != 0) stop("The numerical method for finding the maximal", + " reliability was not converged.") result <- 1 - out$objective - weight <- out$par - weight <- weight/mean(weight) + weight <- out$par / mean(out$par) names(weight) <- varnames attr(result, "weight") <- weight result } -maximalRelia <- function(object) { - param <- lavaan::lavInspect(object, "coef") - ngroup <- lavaan::lavInspect(object, "ngroups") - name <- names(param) - if(ngroup == 1) { - ly <- param[name == "lambda"] - } else { - ly <- lapply(param, "[[", "lambda") - } - ps <- lavaan::lavInspect(object, "cov.lv") - if(ngroup == 1) ps <- list(ps) - SigmaHat <- lavaan::lavInspect(object, "cov.ov") - if(ngroup == 1) { - SigmaHat <- list(SigmaHat) - S <- list(lavaan::lavInspect(object, "sampstat")$cov) - } else { - S <- lapply(lavaan::lavInspect(object, "sampstat"), function(x) x$cov) - } - if(ngroup == 1) { - tau <- param[name = "tau"] - } else { - tau <- lapply(param, "[[", "tau") - } - categorical <- length(tau) > 0 && !is.null(tau[[1]]) - threshold <- NULL - result <- list() - if(categorical) { - polycor <- polycorLavaan(object) - if(ngroup == 1) polycor <- list(polycor) - S <- lapply(polycor, function(x) x[rownames(ly[[1]]), rownames(ly[[1]])]) - threshold <- getThreshold(object) # change to lavaan::lavInspect(object, "th") - SigmaHat <- thetaImpliedTotalVar(object) - } - for(i in 1:ngroup) { - truevar <- ly[[i]]%*%ps[[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(ngroup == 1) { - result <- result[[1]] - } else { - names(result) <- lavaan::lavInspect(object, "group.label") - } - result -} + diff -Nru r-cran-semtools-0.4.14/R/residualCovariate.R r-cran-semtools-0.5.0/R/residualCovariate.R --- r-cran-semtools-0.4.14/R/residualCovariate.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/residualCovariate.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,14 +1,45 @@ -# residualCovariate: Residual centered all target indicators by covariates +### Sunthud Pornprasertmanit +### Last updated: 9 March 2018 + +#' 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 \code{\link{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. \emph{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 = "") + 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) -} +} + + diff -Nru r-cran-semtools-0.4.14/R/runMI-methods.R r-cran-semtools-0.5.0/R/runMI-methods.R --- r-cran-semtools-0.4.14/R/runMI-methods.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/runMI-methods.R 2018-06-26 12:18:56.000000000 +0000 @@ -0,0 +1,1588 @@ +### Terrence D. Jorgensen +### Last updated: 26 June 2018 +### Class and Methods for lavaan.mi object, returned by runMI() + + +#' Class for a lavaan Model Fitted to Multiple Imputations +#' +#' This class extends the \code{\linkS4class{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. +#' +#' +#' @name lavaan.mi-class +#' @importClassesFrom lavaan lavaanList +#' @aliases lavaan.mi-class show,lavaan.mi-method summary,lavaan.mi-method +#' anova,lavaan.mi-method nobs,lavaan.mi-method coef,lavaan.mi-method +#' vcov,lavaan.mi-method fitted,lavaan.mi-method fitted.values,lavaan.mi-method +#' residuals,lavaan.mi-method resid,lavaan.mi-method +#' @docType class +#' +#' @slot coefList \code{list} of estimated coefficients in matrix format (one +#' per imputation) as output by \code{\link[lavaan]{lavInspect}(fit, "est")} +#' @slot GLIST pooled \code{list} of coefficients in GLIST format +#' @slot miList \code{list} of modification indices output by +#' \code{\link[lavaan]{modindices}} +#' @slot seed \code{integer} seed set before running imputations +#' @slot lavListCall call to \code{\link[lavaan]{lavaanList}} used to fit the +#' model to the list of imputed data sets in \code{@@DataList}, stored as a +#' \code{list} of arguments +#' @slot imputeCall call to imputation function (if used), stored as a +#' \code{list} of arguments +#' @slot 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. +#' @slot lavaanList_slots All remaining slots are from +#' \code{\linkS4class{lavaanList}}, but \code{\link{runMI}} only populates a +#' subset of the \code{list} slots, two of them with custom information: +#' @slot DataList The \code{list} of imputed data sets +#' @slot SampleStatsList List of output from +#' \code{\link[lavaan]{lavInspect}(fit, "sampstat")} applied to each fitted +#' model +#' @slot ParTableList See \code{\linkS4class{lavaanList}} +#' @slot vcovList See \code{\linkS4class{lavaanList}} +#' @slot testList See \code{\linkS4class{lavaanList}} +#' +#' @param object An object of class \code{lavaan.mi} +#' @param se,ci,level,standardized,rsquare,header,add.attributes See +#' \code{\link[lavaan]{parameterEstimates}}. +#' @param fmi \code{logical} indicating whether to include the Fraction Missing +#' Information (FMI) for parameter estimates in the \code{summary} output +#' (see \bold{Value} section). +#' @param asymptotic \code{logical}. If \code{FALSE} (typically a default, but +#' see \bold{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. +#' @param 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 calcualtes its pooled standard errors, as +#' well as the Wald test (\code{anova(..., test = "D1")}). +#' @param labels \code{logical} indicating whether the \code{coef} output should +#' include parameter labels. Default is \code{TRUE}. +#' @param 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. +#' @param type The meaning of this argument varies depending on which method it +#' it used for. Find detailed descriptions in the \bold{Value} section +#' under \code{coef}, \code{vcov}, \code{residuals}, and \code{anova}. +#' @param h1 An object of class \code{lavaan.mi} in which \code{object} is +#' nested, so that their difference in fit can be tested using +#' \code{anova} (see \bold{Value} section for details). +#' @param test \code{character} indicating the method used to pool model-fit or +#' model-comparison test statistics: +#' \itemize{ +#' \item{\code{"D3": }}{The default test (\code{"D3"}, or any of +#' \code{"mr", "Meng.Rubin", "likelihood", "LRT"}) is a pooled +#' likeliehood-ratio test (see Enders, 2010, ch. 8). +#' \code{test = "mplus"} implies \code{"D3"} and \code{asymptotic = +#' TRUE} (see Asparouhov & Muthen, 2010). When using a non-likelihood +#' estimator (e.g., DWLS for categorical outcomes), \code{"D3"} is +#' unavailable, so the default is changed to \code{"D2"}.} +#' \item{\code{"D2": }}{Returns a pooled test statistic, as described by +#' Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010, chapter 8). +#' Aliases include \code{"lmrr", "Li.et.al", "pooled.wald"}).} +#' \item{\code{"D1": }}{Returns a Wald test calculated for constraints on +#' the pooled point estimates, using the pooled covariance matrix of +#' parameter estimates; see \code{\link[lavaan]{lavTestWald}} for +#' details. \code{h1} is ignored when \code{test = "D1"}, and +#' \code{constraints} is ignored when \code{test != "D1"}. The +#' \code{scale.W} argument is passed to the \code{vcov} method (see +#' \bold{Value} section for details).} +#' } +#' @param 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}). +#' If \code{test = "D2"} and \code{pool.robust = TRUE}, further options +#' can be passed to \code{\link[lavaan]{lavTestLRT}} (see below). +#' @param indices \code{logical}, or \code{character} vector naming fit indices +#' to be printed with test of model fit. Ignored \code{if (!is.null(h1))}. +#' See description of \code{anova} in \bold{Value} section for details. +#' @param constraints See \code{\link[lavaan]{lavTestWald}}. +#' @param method,A.method,H1,scaled.shifted See \code{\link[lavaan]{lavTestLRT}}. +#' @param fit.measures,baseline.model See \code{\link[lavaan]{fitMeasures}}. +#' +#' @return +#' \item{coef}{\code{signature(object = "lavaan.mi", type = "free", labels = TRUE)}: +#' See \code{\linkS4class{lavaan}}. Returns the pooled point estimates (i.e., +#' averaged across imputed data sets; see Rubin, 1987).} +#' +#' \item{vcov}{\code{signature(object = "lavaan.mi", scale.W = TRUE, +#' 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 = "lavaan.mi")}: See +#' \code{\linkS4class{lavaan}}. Returns model-implied moments, evaluated at the +#' pooled point estimates.} +#' \item{fitted}{\code{signature(object = "lavaan.mi")}: +#' alias for \code{fitted.values}} +#' +#' \item{residuals}{\code{signature(object = "lavaan.mi", type = c("raw","cor"))}: +#' See \code{\linkS4class{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}{\code{signature(object = "lavaan.mi", type = c("raw","cor"))}: +#' alias for \code{residuals}} +#' +#' \item{nobs}{\code{signature(object = "lavaan.mi", total = TRUE)}: either +#' the total (default) sample size or a vector of group sample sizes +#' (\code{total = FALSE}).} +#' +#' \item{anova}{\code{signature(object = "lavaan.mi", h1 = NULL, +#' test = c("D3","D2","D1"), pool.robust = FALSE, scale.W = TRUE, +#' asymptotic = FALSE, constraints = NULL, indices = FALSE, baseline.model = NULL, +#' method = "default", A.method = "delta", H1 = TRUE, type = "Chisq")}: +#' Returns a test of model fit if \code{h1} is \code{NULL}, or a test +#' of the difference in fit between nested models if \code{h1} is another +#' \code{lavaan.mi} object, assuming \code{object} is nested in \code{h1}. If +#' \code{asymptotic}, the returned test statistic will follow a \eqn{\chi^2} +#' distribution in sufficiently large samples; otherwise, it will follow an +#' \emph{F} distribution. If a robust test statistic is detected in the +#' \code{object} results (it is assumed the same was requested in \code{h1}, +#' if provided), then \code{asymptotic} will be set to \code{TRUE} and the +#' pooled test statistic will be scaled using the average scaling factor (and +#' average shift parameter or \emph{df}, if applicable) across imputations +#' (unless \code{pool.robust = FALSE} and \code{test = "D2"}; see below). +#' +#' When \code{indices = TRUE} and \code{is.null(h1)}, popular indices of +#' approximate fit (CFI, TLI/NNFI, RMSEA with CI, and SRMR) will be returned +#' for \code{object}; see \code{\link[lavaan]{fitMeasures}} for more details. +#' Specific indices can be requested with a \code{character} vector (any of +#' \code{"mfi", "rmsea", "gammaHat", "rmr", "srmr", "cfi", "tli", "nnfi", +#' "rfi", "nfi", "pnfi", "ifi", "rni"}), or all available indices will be +#' returned if \code{indices = "all"}. Users can specify a custom +#' \code{baseline.model}, also fit using \code{runMI}, to calculate +#' incremental fit indices (e.g., CFI, TLI). If \code{baseline.model = NULL}, +#' the default independence model will be used.} +#' +#' \item{fitMeasures}{\code{signature(object = "lavaan.mi", +#' fit.measures = "all", baseline.model = NULL)}: arguments are consistent +#' with lavaan's \code{\link[lavaan]{fitMeasures}}. This merely calls the +#' \code{anova} method described above, with \code{indices = fit.measures} +#' and \code{baseline.model = baseline.model}, and default values for the +#' remaining arguments. The user has more control (e.g., over pooling methods) +#' using \code{anova} directly.} +#' \item{fitmeasures}{alias for \code{fitMeasures}.} +#' +#' \item{show}{\code{signature(object = "lavaan.mi")}: returns a message about +#' convergence rates and estimation problems (if applicable) across imputed +#' data sets.} +#' +#' \item{summary}{\code{signature(object = "lavaan.mi", se = TRUE, ci = FALSE, +#' level = .95, standardized = FALSE, rsquare = FALSE, fmi = FALSE, +#' scale.W = FALSE, asymptotic = FALSE, add.attributes = TRUE)}: see +#' \code{\link[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 intervales +#' 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{add.attributes = FALSE}, the returned \code{data.frame} will resemble +#' the \code{parameterEstimates} output. The \code{scale.W} argument is +#' passed to \code{vcov} (see description above).} +#' +#' @section Objects from the Class: See the \code{\link{runMI}} function for +#' details. Wrapper functions include \code{\link{lavaan.mi}}, +#' \code{\link{cfa.mi}}, \code{\link{sem.mi}}, and \code{\link{growth.mi}}. +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @references Asparouhov, T., & Muthen, B. (2010). \emph{Chi-square statistics +#' with multiple imputation}. Technical Report. Retrieved from +#' \url{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{http://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. Retrieved +#' from \url{http://www.jstor.org/stable/2337151} +#' +#' Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. +#' New York, NY: Wiley. +#' @examples +#' +#' ## See ?runMI help page +#' +setClass("lavaan.mi", contains = "lavaanList", + slots = c(coefList = "list", # coefficients in matrix format + GLIST = "list", # list of pooled coefs in GLIST format + 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 lavaan.mi-class +#' @aliases show,lavaan.mi-method +#' @export +setMethod("show", "lavaan.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('lavaan.mi object based on ', nData, ' imputed data sets. \n', + 'See class?lavaan.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 +summary.lavaan.mi <- function(object, se = TRUE, ci = FALSE, level = .95, + standardized = FALSE, rsquare = FALSE, + fmi = FALSE, header = TRUE, scale.W = TRUE, + asymptotic = FALSE, add.attributes = TRUE) { + useImps <- sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + ## extract parameter table with attributes for printing + PT <- parTable(object) + myCols <- c("lhs","op","rhs") + if (lavListInspect(object, "ngroups") > 1L) myCols <- c(myCols,"block","group") + PE <- PT[ , myCols] + free <- PT$free > 0L | PT$op == ":=" + STDs <- !(PT$op %in% c("==","<",">")) # which rows can be standardized + + PE$est <- rowMeans(sapply(object@ParTableList[useImps], "[[", i = "est")) + + if (lavListInspect(object, "options")$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","lavaan.mi")(object, scale.W = scale.W) + 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) { + PE$std.lv[STDs] <- lavaan::standardizedSolution(object, se = FALSE, + type = "std.lv", + GLIST = object@GLIST, + est = PE$est)$est.std + PE$std.all[STDs] <- lavaan::standardizedSolution(object, se = FALSE, + type = "std.all", + GLIST = object@GLIST, + est = PE$est)$est.std + } + } else if (tolower(as.character(standardized)[1]) == "std.lv") { + PE$std.lv[STDs] <- lavaan::standardizedSolution(object, se = FALSE, + type = "std.lv", + GLIST = object@GLIST, + est = PE$est)$est.std + } else if (tolower(as.character(standardized)[1]) == "std.all") { + PE$std.all[STDs] <- lavaan::standardizedSolution(object, se = FALSE, + type = "std.all", + GLIST = object@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 (add.attributes) { + PE$label <- PT$label + PE$exo <- 0L # because PT$exo must be when !fixed.x + class(PE) <- c("lavaan.parameterEstimates","lavaan.data.frame","data.frame") + lavops <- lavListInspect(object, "options") + attr(PE, "information") <- lavops$information + attr(PE, "se") <- lavops$se + attr(PE, "group.label") <- lavListInspect(object, "group.label") + attr(PE, "level.label") <- object@Data@level.label #FIXME: lavListInspect? + attr(PE, "bootstrap") <- lavops$bootstrap + attr(PE, "bootstrap.successful") <- 0L #FIXME: assumes none. Implement Wei & Fan's mixing method? + attr(PE, "missing") <- lavops$missing + attr(PE, "observed.information") <- lavops$observed.information + attr(PE, "h1.information") <- lavops$h1.information + attr(PE, "header") <- header + # FIXME: lavaan may add more!! + if (fmi) cat("\n", messRIV, sep = "") + } else { + class(PE) <- c("lavaan.data.frame","data.frame") + } + ## requested R-squared? + endoNames <- c(lavaan::lavNames(object, "ov.nox"), + lavaan::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","group","est","exo")))) { + rsqPE[ , i] <- NA + } + STD <- lavaan::standardizedSolution(object, se = FALSE, type = "std.all", + GLIST = object@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 (add.attributes) rsqPE$label <- "" + PE <- rbind(PE, rsqPE) + } + + if (!add.attributes) PE <- PE[!(PE$op %in% c("==","<",">")), ] + rownames(PE) <- NULL + if (add.attributes) { + getMethod("show", "lavaan.mi")(object) + cat(messPool) + } + ## FIXME: ask Yves to make this accessible somehow, or hack it? + # if (fit.measures) lavaan:::print.fit.measures(fitMeasures(object)) + PE +} +#' @name lavaan.mi-class +#' @aliases summary,lavaan.mi-method +#' @export +setMethod("summary", "lavaan.mi", summary.lavaan.mi) + + +#' @name lavaan.mi-class +#' @aliases nobs,lavaan.mi-method +#' @importFrom lavaan lavListInspect +#' @export +setMethod("nobs", "lavaan.mi", function(object, total = TRUE) { + if (total) return(lavListInspect(object, "ntotal")) + N <- lavListInspect(object, "norig") + if (length(N) > 1L) names(N) <- lavListInspect(object, "group.label") + N +}) + + + +#' @importFrom lavaan parTable +coef.lavaan.mi <- function(object, type = "free", labels = TRUE) { + useImps <- sapply(object@convergence, "[[", i = "converged") + 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 lavaan.mi-class +#' @aliases coef,lavaan.mi-method +#' @export +setMethod("coef", "lavaan.mi", coef.lavaan.mi) + + + +#' @importFrom stats cov +#' @importFrom lavaan lavListInspect parTable +vcov.lavaan.mi <- function(object, type = c("pooled","between","within","ariv"), + scale.W = TRUE) { + 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 + useImps <- sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + + useSE <- sapply(object@convergence, "[[", i = "SE") + useSE[is.na(useSE)] <- FALSE + + 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) + + if (sum(useSE) == 0L) stop('Standard errors could not be computed in any ', + 'imputations, so it is not possible to calculate ', + 'the within-imputation portion of sampling variance.') + W <- Reduce("+", lapply(object@vcovList[useSE], function(x) x$vcov)) / sum(useSE) + class(W) <- c("lavaan.matrix.symmetric","matrix") + dimnames(W) <- dimnames(B) + if (type == "within") return(W) + + if (!all(useImps == useSE)) + warning('Between-imputation covariance matrix based on estimated parameters', + ' from ', m, ' converged solutions, but the mean within-imputation', + ' covariance matrix based on ', sum(useSE), ' solutions for which', + ' standard errors could be calculated. Pooled total covariance', + ' matrix is therefore based on different imputed data sets.') + + ## 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.\n", + "It may be safer to set `scale.W = FALSE'.") + } + 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 lavaan.mi-class +#' @aliases vcov,lavaan.mi-method +#' @export +setMethod("vcov", "lavaan.mi", vcov.lavaan.mi) + + +#' @importFrom stats pf pchisq +#' @importFrom lavaan parTable +D1 <- function(object, constraints = NULL, scale.W = FALSE, + asymptotic = FALSE, verbose = FALSE) { + ## "borrowed" lavTestWald() + nImps <- sum(sapply(object@convergence, "[[", i = "converged")) + if (nImps == 1L) stop("model did not converge on any imputations") + 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", "lavaan.mi")(object) #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","lavaan.mi")(object, scale.W = scale.W) + + # 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", "lavaan.mi")(object, type = "within") + B <- getMethod("vcov", "lavaan.mi")(object, type = "between") + #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/nImps) * sum(diag(B.r %*% W.inv)) / DF + ## calculate denominator DF for F statistic + a <- DF*(nImps - 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)) + } + + class(out) <- c("lavaan.vector","numeric") + out +} +#' @importFrom stats var pf pchisq +calculate.D2 <- function(w, DF, asymptotic = FALSE) { + if (!length(w)) return(NA) + nImps <- sum(!is.na(w)) + if (nImps == 0) return(NA) + 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) + 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)) + } 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)) + } + out +} +#' @importFrom lavaan lavListInspect parTable +D2 <- function(object, h1 = NULL, asymptotic = FALSE, pool.robust = FALSE, + method = "default", A.method = "delta", H1 = TRUE, + scaled.shifted = TRUE, type = "Chisq") { + useImps <- sapply(object@convergence, "[[", i = "converged") + lavoptions <- lavListInspect(object, "options") + + 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 (lavoptions$warn) warning("Unable to pass lavaan::lavTestLRT() ", + "arguments when parallel = 'snow'.\n", + "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") + out <- try(lavaan::lavTestLRT(obj, fit1, H1 = H1, method = method, + A.method = A.method, type = type, + scaled.shifted = scaled.shifted), + 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[useImps & !(noFit | noLRT)], "[[", i = "chisq") + dfList <- sapply(FIT@funList[useImps & !(noFit | noLRT)], "[[", 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 <- if (pool.robust) 2L else 1L + ## pool Wald tests + if (is.null(h1)) { + 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[[1]][["df"]])) + DF1 <- mean(sapply(h1@testList[useImps], function(x) x[[1]][["df"]])) + DF <- DF0 - DF1 + w0 <- sapply(object@testList[useImps], function(x) x[[1]][["stat"]]) + w1 <- sapply(h1@testList[useImps], function(x) x[[1]][["stat"]]) + w <- w0 - w1 + } + 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, saturated = FALSE) { + useImps <- sapply(object@convergence, "[[", i = "converged") + ## 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 + if (saturated) { + fit <- lavaan(parTable(object), data = dataList[[ which(useImps)[1] ]], + slotOptions = lavoptions, group = group) + ## 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))$est + }) + ## set all parameters fixed + PT$free <- 0L + PT$user <- 1L + ## fix them to pooled estimates + PT$ustart <- colMeans(do.call(rbind, satParams)) + 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","lavaan.mi")(object, type = "user") + 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(object@DataList[useImps], function(d) { + lavaan::logLik(lavaan(PT, data = d, slotOptions = lavoptions, group = group)) + }) +} +#' @importFrom stats pf pchisq +#' @importFrom lavaan lavListInspect parTable +D3 <- function(object, h1 = NULL, asymptotic = FALSE) { + N <- lavListInspect(object, "ntotal") + useImps <- sapply(object@convergence, "[[", i = "converged") + nImps <- sum(useImps) + # m <- length(object@testList) + if (is.null(h1)) { + DF <- object@testList[[ which(useImps)[1] ]][[1]][["df"]] + } else { + DF1 <- h1@testList[[ which(useImps)[1] ]][[1]][["df"]] + DF0 <- object@testList[[ which(useImps)[1] ]][[1]][["df"]] + DF <- DF0 - DF1 + } + + ## calculate m log-likelihoods under pooled H0 estimates + LL0 <- getLLs(object) + ## calculate m log-likelihoods under pooled H1 estimates + LL1 <- if (is.null(h1)) getLLs(object, saturated = TRUE) else getLLs(h1) + #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[[1]]$stat)) + } else { + LRT_bar <- mean(sapply(object@testList[useImps], function(x) x[[1]]$stat) - + sapply(h1@testList[useImps], function(x) x[[1]]$stat)) + } + ## calculate average relative increase in variance + a <- DF*(nImps - 1) + ariv <- ((nImps + 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)) + } 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)) + } + ## 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 = lavListInspect(object, "ntotal"), + 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) { + useImps <- sapply(object@convergence, "[[", i = "converged") + scaleshift <- lavListInspect(object, "options")$test == "scaled.shifted" + + d0 <- mean(sapply(object@testList[useImps], function(x) x[[2]][["df"]])) + c0 <- mean(sapply(object@testList[useImps], + function(x) x[[2]][["scaling.factor"]])) + if (!is.null(h1)) { + d1 <- mean(sapply(h1@testList[useImps], function(x) x[[2]][["df"]])) + c1 <- mean(sapply(h1@testList[useImps], + function(x) x[[2]][["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(object@testList[useImps], + function(x) sum(x[[2]][["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 +} +#' @importFrom stats pchisq uniroot +#' @importFrom lavaan lavListInspect +anova.lavaan.mi <- function(object, h1 = NULL, test = c("D3","D2","D1"), + pool.robust = FALSE, scale.W = FALSE, + asymptotic = FALSE, constraints = NULL, + indices = FALSE, baseline.model = NULL, + method = "default", A.method = "delta", + scaled.shifted = TRUE, H1 = TRUE, type = "Chisq") { + useImps <- sapply(object@convergence, "[[", i = "converged") + nImps <- sum(useImps) + ## check class + if (!inherits(object, "lavaan.mi")) stop("object is not class 'lavaan.mi'") + if (!is.null(h1) & !inherits(object, "lavaan.mi")) stop("h1 is not class 'lavaan.mi'") + test <- as.character(test[1]) + ## check test options, backward compatibility? + if (tolower(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 (toupper(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" + } + + ## Everything else obsolete if test = "D1" + if (toupper(test) == "D1") { + out <- D1(object, constraints = constraints, scale.W = scale.W, + asymptotic = asymptotic) + message('D1 (Wald test) calculated using pooled "', + lavListInspect(object, "options")$se, + '" asymptotic covariance matrix of model parameters') + return(out) + } + + ## check for robust + robust <- lavListInspect(object, "options")$test != "standard" + if (robust & !pool.robust) { + if (!asymptotic) + message('Robust correction can only be applied to pooled chi-squared', + ' statistic, not F statistic. "asymptotic" was switched to TRUE.') + asymptotic <- TRUE + } + scaleshift <- lavListInspect(object, "options")$test == "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().\n") + pool.robust <- TRUE + test <- 'D2' + } + + + ## check request for fit indices + if (is.null(h1)) { + incremental <- c("cfi","tli","nnfi","rfi","nfi","pnfi","ifi","rni") + } else { + indices <- FALSE + incremental <- c("") + } + if (is.logical(indices)) { + moreFit <- is.null(h1) & indices + if (moreFit) indices <- c("cfi","tli","rmsea","srmr") + } else if (is.character(indices)) { + indices <- tolower(indices) + moreFit <- is.null(h1) & any(indices %in% c(incremental, "all","mfi","rmr", + "srmr","rmsea","gammaHat")) + if (moreFit & any(indices == "all")) { + indices <- c(incremental, "mfi","rmsea","gammaHat","rmr","srmr") + } + } else indices <- moreFit <- FALSE + ## fit baseline model if necessary + if (moreFit & any(indices %in% incremental)) { + if (is.null(baseline.model)) { + PTb <- lavaan::lav_partable_independence(lavdata = object@Data, + lavoptions = lavListInspect(object, "options")) + # 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 + baseFit <- runMI(model = PTb, data = object@DataList[useImps], + group = group, se = "none", # to save time + test = lavListInspect(object, "options")$test, + estimator = lavListInspect(object, "options")$estimator, + ordered = lavListInspect(object, "ordered"), + parameterization = lavListInspect(object, + "parameterization")) + } else if (!inherits(baseline.model, "lavaan.mi")) { + stop('User-supplied baseline.model must be "lavaan.mi" class fit', + ' to the same imputed data') + } else baseFit <- baseline.model + baseImps <- sapply(baseFit@convergence, "[[", i = "converged") + if (!all(baseImps)) warning('baseline.model did not converge for data set(s): ', + which(useImps)[!baseImps]) + } + + ## check DF + DF0 <- object@testList[[ which(useImps)[1] ]][[1]][["df"]] + if (!is.null(h1)) { + if (!inherits(h1, "lavaan.mi")) stop("h1 is not class 'lavaan.mi'") + DF1 <- h1@testList[[ which(useImps)[1] ]][[1]][["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 + if (DF == 0) indices <- moreFit <- FALSE # arbitrary perfect fit, no indices + if (moreFit) asymptotic <- TRUE + + ## calculate pooled test + if (test == "D3") { + if (pool.robust & moreFit) stop('pool.robust = TRUE only applicable ', + 'when test = "D2".') + out <- D3(object, h1 = h1, asymptotic = asymptotic) + if (any(indices %in% incremental)) baseOut <- D3(baseFit, asymptotic = TRUE) + } else if (test == "D2") { + out <- D2(object, h1 = h1, asymptotic = asymptotic, pool.robust = FALSE) + if (any(indices %in% incremental)) baseOut <- D2(baseFit, asymptotic = TRUE, + pool.robust = FALSE) + if (robust & pool.robust) { + out <- c(out, + D2(object, h1 = h1, asymptotic = asymptotic, pool.robust = TRUE, + method = method, A.method = A.method, + scaled.shifted = scaled.shifted, H1 = H1, type = type)) + if (any(indices %in% incremental)) { + baseOut <- c(baseOut, D2(baseFit, asymptotic = TRUE, pool.robust = TRUE, + method = method, A.method = A.method, H1 = H1, + scaled.shifted = scaled.shifted, type = type)) + } + } + } else stop("'", test, "' is an invalid option for the 'test' argument.") + ## If test statistic is negative, return without any indices or robustness + if (asymptotic & (moreFit | robust)) { + if (out[["chisq"]] == 0) { + message('Negative test statistic set to zero, so fit will appear to be ', + 'arbitrarily perfect. Robust corrections and additional fit ', + 'indices are not returned because they are uninformative.\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, h1) + if (scaleshift) { + extraWarn <- ' and shift parameter' + } else if (lavListInspect(object, "options")$test == "mean.var.adjusted") { + extraWarn <- ' and degrees of freedom' + } else extraWarn <- '' + message('Robust corrections are made by pooling the naive chi-squared ', + 'statistic across ', nImps, ' 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') + } + + ## add fit indices for single model + if (moreFit) { + X2 <- out[["chisq"]] + # if (pool.robust) message('All fit indices are calculated using the pooled', + # ' robust test statistic. \n') + 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[[2]][["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) { + if (!pool.robust) baseOut <- robustify(ChiSq = baseOut, object = baseFit) + 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 & lavListInspect(object, "options")$test %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 & lavListInspect(object, "options")$test %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 & lavListInspect(object, "options")$test %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") + nG <- lavListInspect(object, "ngroups") + nVars <- length(lavaan::lavNames(object)) + if (!(lavListInspect(object, "options")$likelihood == "normal" | + lavListInspect(object, "options")$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.sc < 1 | getLambda(0, X2, DF.sc, .95) < 0.0) { + out["rmsea.ci.lower.scaled"] <- 0 + } else { + lambda.l <- try(uniroot(f = getLambda, chi = X2, df = DF.sc, 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.sc < 1 | getLambda(N.RMSEA, X2, DF.sc, .05) > 0.0) { + out["rmsea.ci.upper.scaled"] <- 0 + } else { + lambda.u <- try(uniroot(f = getLambda, chi = X2, 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.scaled"] <- sqrt( lambda.u/(N*DF) ) * sqrt(nG) + } + ## p value + out["rmsea.pvalue.scaled"] <- pchisq(X2, DF.sc, ncp = N*DF.sc*0.05^2/nG, + lower.tail = FALSE) + + if (!pool.robust & lavListInspect(object, "options")$test %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)$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 (scaleshift) { + ## naive only + out["rmsea.scaled"] <- sqrt( max(0, (X2.sc/N)/DF - 1/N) ) * sqrt(nG) + ## lower confidence limit + if (DF.sc < 1 | getLambda(0, X2.sc, DF.sc, .95) < 0.0) { + out["rmsea.ci.lower.scaled"] <- 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.scaled"] <- sqrt( 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.scaled"] <- 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.scaled"] <- sqrt( lambda.u/(N*DF.sc) ) * sqrt(nG) + } + ## p value + out["rmsea.pvalue.scaled"] <- pchisq(X2.sc, DF.sc, ncp = N*DF.sc*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"]) + } + } + + getSRMR <- function(object, type) { + vv <- lavaan::lavNames(object, type = "ov.num") + R <- getMethod("resid", "lavaan.mi")(object, type = type) + index <- if (type == "raw") "cov" else "cor" + if (nG > 1L) { + RR <- list() + for (g in 1:nG) { + RR[[g]] <- c(R[[g]][[index]][lower.tri(R[[g]][[index]], diag = FALSE)]^2, + diag(R[[g]][[index]])[vv]^2) + } + } else RR <- c(R[[index]][lower.tri(R[[index]], diag = FALSE)]^2, + diag(R[[index]])[vv]^2) + + if (lavListInspect(object, "meanstructure")) { + if (nG > 1L) { + for (g in 1:nG) RR[[g]] <- c(RR[[g]], R[[g]]$mean[vv]^2) + } else RR <- c(RR, R$mean[vv]^2) + } + + SS <- if (nG > 1L) sqrt(sapply(RR, mean)) else sqrt(mean(RR)) + as.numeric( (lavListInspect(object, "nobs") %*% SS) / lavListInspect(object, "ntotal") ) + } + if("rmr" %in% indices) out["rmr"] <- getSRMR(object, type = "raw") + if("srmr" %in% indices) { + out["srmr_bollen"] <- getSRMR(object, type = "cor.bollen") + out["srmr_bentler"] <- getSRMR(object, type = "cor.bentler") + } + + class(out) <- c("lavaan.vector","numeric") + out # FIXME: in future, accept more than 2 models, arrange sequentially by DF +} +#' @name lavaan.mi-class +#' @aliases anova,lavaan.mi-method +#' @export +setMethod("anova", "lavaan.mi", anova.lavaan.mi) + + +#' @name lavaan.mi-class +#' @aliases fitMeasures,lavaan.mi-method +#' @importFrom lavaan fitMeasures +#' @export +setMethod("fitMeasures", "lavaan.mi", function(object, fit.measures = "all", + baseline.model = NULL) { + if (!is.character(fit.measures)) stop("'fit.measures' must be a character ", + "string specifying name(s) of desired ", + "fit indices.") + message('anova() provides more control over options for pooling chi-squared', + ' before calculating fit indices from multiple imputations. ', + 'See the class?lavaan.mi help page for details.\n\n') + fits <- anova.lavaan.mi(object, indices = "all", baseline.model = baseline.model) + if ("all" %in% fit.measures) return(fits) + out <- fits[grepl(paste(fit.measures, collapse = "|"), + names(fits), ignore.case = TRUE)] + out <- out[which(!is.na(names(out)))] + class(out) <- c("lavaan.vector","numeric") + out +}) +# lowercase 'm' +#' @name lavaan.mi-class +#' @aliases fitmeasures,lavaan.mi-method +#' @importFrom lavaan fitmeasures +#' @export +setMethod("fitmeasures", "lavaan.mi", function(object, fit.measures = "all", + baseline.model = NULL) { + if (!is.character(fit.measures)) stop("'fit.measures' must be a character ", + "string specifying name(s) of desired ", + "fit indices.") + message('anova() provides more control over options for pooling chi-squared', + ' before calculating fit indices from multiple imputations. ', + 'See the class?lavaan.mi help page for details.\n\n') + fits <- anova.lavaan.mi(object, indices = "all", baseline.model = baseline.model) + if ("all" %in% fit.measures) return(fits) + out <- fits[grepl(paste(fit.measures, collapse = "|"), + names(fits), ignore.case = TRUE)] + out <- out[which(!is.na(names(out)))] + class(out) <- c("lavaan.vector","numeric") + out +}) + + +## function to pool each group's list of sample stats +sampstat.lavaan.mi <- function(lst, means = FALSE, categ = FALSE, m = m) { + ## average sample stats across imputations + out <- list(cov = Reduce("+", lapply(lst, "[[", i = "cov")) / m) + if (means) out$mean <- Reduce("+", lapply(lst, "[[", i = "mean")) / m + if (categ) out$th <- Reduce("+", lapply(lst, "[[", i = "th")) / m + out +} +#' @importFrom lavaan lavListInspect +fitted.lavaan.mi <- function(object) { + useImps <- sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + meanstructure <- lavListInspect(object, "meanstructure") + categ <- lavListInspect(object, "categorical") + nG <- lavListInspect(object, "ngroups") + ov.names <- lavaan::lavNames(object) + + est <- getMethod("coef", "lavaan.mi")(object) + imp <- lavaan::lav_model_implied(lavaan::lav_model_set_parameters(object@Model, + x = est)) + out <- list() + if (nG > 1L) { + group.label <- lavListInspect(object, "group.label") + for (i in seq_along(imp)) names(imp[[i]]) <- group.label + for (g in group.label) { + out[[g]]$cov <- imp$cov[[g]] + dimnames(out[[g]]$cov) <- list(ov.names, ov.names) + class(out[[g]]$cov) <- c("lavaan.matrix.symmetric","matrix") + if (meanstructure) { + out[[g]]$mean <- as.numeric(imp$mean[[g]]) + names(out[[g]]$mean) <- ov.names + class(out[[g]]$mean) <- c("lavaan.vector","numeric") + } else { + out[[g]]$mean <- sampstat.lavaan.mi(lapply(object@SampleStatsList[useImps], "[[", g), + means = TRUE, categ = categ, m = m)$mean + } + if (categ) { + out[[g]]$th <- imp$th[[g]] + names(out[[g]]$th) <- lavaan::lavNames(object, "th") + class(out[[g]]$th) <- c("lavaan.vector","numeric") + } + } + } else { + out$cov <- imp$cov[[1]] + dimnames(out$cov) <- list(ov.names, ov.names) + class(out$cov) <- c("lavaan.matrix.symmetric","matrix") + if (meanstructure) { + out$mean <- as.numeric(imp$mean[[1]]) + names(out$mean) <- ov.names + class(out$mean) <- c("lavaan.vector","numeric") + } else { + out$mean <- sampstat.lavaan.mi(object@SampleStatsList[useImps], + means = TRUE, categ = categ, m = m)$mean + } + if (categ) { + out$th <- imp$th[[1]] + names(out$th) <- lavaan::lavNames(object, "th") + class(out$th) <- c("lavaan.vector","numeric") + } + } + out +} +#' @name lavaan.mi-class +#' @aliases fitted,lavaan.mi-method +#' @export +setMethod("fitted", "lavaan.mi", fitted.lavaan.mi) +#' @name lavaan.mi-class +#' @aliases fitted.values,lavaan.mi-method +#' @export +setMethod("fitted.values", "lavaan.mi", fitted.lavaan.mi) + + + +## function to calculate residuals for one group +#' @importFrom stats cov2cor +gp.resid.lavaan.mi <- function(Observed, N, Implied, type, + means = FALSE, categ = FALSE, m) { + obsMats <- sampstat.lavaan.mi(Observed, means = means, categ = categ, m = m) + ## average sample stats across imputations + S_mean <- if (is.null(N)) obsMats$cov else (obsMats$cov * ((N - 1L) / N)) + if (means) M_mean <- obsMats$mean + if (categ) Th_mean <- obsMats$th + + if (type == "raw") { + out <- list(cov = S_mean - Implied$cov) + if (means) out$mean <- M_mean - Implied$mean else { + out$mean <- rep(0, nrow(out$cov)) + names(out$mean) <- rownames(out$cov) + } + if (categ) out$th <- Th_mean - Implied$th + return(out) + } else if (type == "cor.bollen") { + out <- list(cor = cov2cor(S_mean) - cov2cor(Implied$cov)) + if (!means) { + out$mean <- rep(0, nrow(out$cor)) + names(out$mean) <- rownames(out$cor) + } else { + std.obs.M <- M_mean / sqrt(diag(S_mean)) + std.mod.M <- Implied$mean / sqrt(diag(Implied$cov)) + out$mean <- std.obs.M - std.mod.M + } + } else if (type == "cor.bentler") { + SDs <- diag(sqrt(diag(S_mean))) + dimnames(SDs) <- dimnames(S_mean) + out <- list(cor = solve(SDs) %*% (S_mean - Implied$cov) %*% solve(SDs)) + class(out$cor) <- c("lavaan.matrix.symmetric","matrix") + if (!means) { + out$mean <- rep(0, nrow(out$cor)) + names(out$mean) <- rownames(out$cor) + } else out$mean <- (M_mean - Implied$mean) / diag(SDs) + } else stop("argument 'type' must be 'raw', 'cor', 'cor.bollen', ", + "or 'cor.bentler'.") + if (categ) out$th <- Th_mean - Implied$th + out +} +#' @importFrom lavaan lavListInspect +resid.lavaan.mi <- function(object, type = c("raw","cor")) { + ## @SampleStatsList is (for each imputation) output from: + ## getSampStats <- function(obj) lavInspect(obj, "sampstat") + useImps <- sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + rescale <- lavListInspect(object, "options")$sample.cov.rescale + meanstructure <- lavListInspect(object, "meanstructure") + categ <- lavListInspect(object, "categorical") + type <- tolower(type[1]) + ## check for type = "cor" ("cor.bollen") or "cor.bentler" + if (type == "cor") type <- "cor.bollen" + ## model-implied moments, already pooled + Implied <- getMethod("fitted", "lavaan.mi")(object) + ## Calculate residuals + nG <- lavListInspect(object, "ngroups") + N <- lavListInspect(object, "nobs") + if (nG > 1L) { + group.label <- names(Implied) + if (is.null(group.label)) group.label <- 1:length(Implied) else names(N) <- group.label + out <- list() + for (g in group.label) { + out[[g]] <- gp.resid.lavaan.mi(Observed = lapply(object@SampleStatsList[useImps], "[[", g), + N = if (rescale) N[g] else NULL, + Implied = Implied[[g]], type = type, + means = meanstructure, m = m, categ = categ) + } + } else { + out <- gp.resid.lavaan.mi(Observed = object@SampleStatsList[useImps], + N = if (rescale) N else NULL, + Implied = Implied, type = type, + means = meanstructure, m = m, categ = categ) + } + out +} +#' @name lavaan.mi-class +#' @aliases residuals,lavaan.mi-method +#' @export +setMethod("residuals", "lavaan.mi", resid.lavaan.mi) +#' @name lavaan.mi-class +#' @aliases resid,lavaan.mi-method +#' @export +setMethod("resid", "lavaan.mi", resid.lavaan.mi) + + + diff -Nru r-cran-semtools-0.4.14/R/runMI-modification.R r-cran-semtools-0.5.0/R/runMI-modification.R --- r-cran-semtools-0.4.14/R/runMI-modification.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/runMI-modification.R 2018-06-25 19:53:59.000000000 +0000 @@ -0,0 +1,333 @@ +### Terrence D. Jorgensen & Yves rosseel +### Last updated: 25 June 2018 +### adaptation of lavaan::modindices() for lavaan.mi-class objects + + +#' Modification Indices for Multiple Imputations +#' +#' 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 using Rubin's (1987) rules, or by pooling the +#' test statistics across imputed data sets (Li, Meng, Raghunathan, & +#' Rubin, 1991). +#' +#' @aliases modificationIndices.mi modificationindices.mi modindices.mi +#' @importFrom lavaan lavInspect lavListInspect +#' @importFrom methods getMethod +#' @importFrom stats cov pchisq qchisq +#' +#' @param object An object of class \code{\linkS4class{lavaan.mi}} +#' @param type \code{character} indicating which pooling method to use. +#' \code{type = "D2"} (default), \code{"LMRR"}, or \code{"Li.et.al"} indicates +#' that modification indices that were calculated within each imputed data set +#' will be pooled across imputations, as described in Li, Meng, Raghunathan, +#' & Rubin (1991) and Enders (2010). +#' \code{"Rubin"} indicates Rubin's (1987) rules will be applied to the +#' gradient and information, and those pooled values will be used to +#' calculate modification indices in the usual manner. +#' @param standardized \code{logical}. If \code{TRUE}, two extra columns +#' (\code{$sepc.lv} and \code{$sepc.all}) will contain standardized values for +#' the EPCs. In the first column (\code{$sepc.lv}), standardizization is based +#' on the variances of the (continuous) latent variables. In the second column +#' (\code{$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 \code{logical}. \code{TRUE} if \code{type == "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. +#' @param 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}. +#' @param delta The value of the effect size, as used in the post-hoc power +#' computation, currently using the unstandardized metric of the \code{$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 \code{$decision} column in the output. +#' @param sort. \code{logical}. If \code{TRUE}, sort the output using the +#' values of the modification index values. Higher values appear first. +#' @param minimum.value \code{numeric}. Filter output and only show rows with a +#' modification index value equal or higher than this minimum value. +#' @param maximum.number \code{integer}. Filter output and only show the first +#' maximum number rows. Most useful when combined with the \code{sort.} option. +#' @param na.remove \code{logical}. If \code{TRUE} (default), filter output by +#' removing all rows with \code{NA} values for the modification indices. +#' @param op \code{character} string. Filter the output by selecting only those +#' rows with operator \code{op}. +#' +#' @note When \code{type = "D2"}, each (S)EPC will be pooled by taking its +#' average across imputations. When \code{type = "Rubin"}, 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 \code{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}) +#' +#' \code{type = "Rubin"} method proposed by +#' Maxwell Mansolf (University of California, Los Angeles; +#' \email{mamansolf@@gmail.com}) +#' +#' @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{http://www.jstor.org/stable/24303994} +#' +#' Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. +#' New York, NY: Wiley. +#' +#' @examples +#' \dontrun{ +#' ## 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) +#' +#' ## impute missing data +#' library(Amelia) +#' set.seed(12345) +#' HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +#' imps <- HS.amelia$imputations +#' +#' ## specify CFA model from lavaan's ?cfa help page +#' HS.model <- ' +#' visual =~ x1 + x2 + x3 +#' textual =~ x4 + x5 + x6 +#' speed =~ x7 + x8 + x9 +#' ' +#' +#' out <- cfa.mi(HS.model, data = imps) +#' +#' modindices.mi(out) # default: Li et al.'s (1991) "D2" method +#' modindices.mi(out, type = "Rubin") # Rubin's rules +#' +#' } +#' +#' @export +modindices.mi <- function(object, + type = c("D2","Rubin"), + + standardized = TRUE, + cov.std = TRUE, + + # 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) { + stopifnot(inherits(object, "lavaan.mi")) + useSE <- sapply(object@convergence, "[[", i = "SE") + useSE[is.na(useSE)] <- FALSE + useImps <- useSE & sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + type <- tolower(type[1]) + N <- lavListInspect(object, "ntotal") + #FIXME: if (lavoptions$mimic == "EQS") N <- N - 1 # not in lavaan, why? + + ## check if model has converged + if (m == 0L) stop("No models converged. Modification indices unavailable.") + + # 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 + myCols <- c("lhs","op","rhs") + #FIXME: add "level" column? how to check for multilevel data? + if (lavListInspect(object, "ngroups") > 1L) myCols <- c(myCols,"block","group") + for (i in which(useImps)) { + LIST <- object@miList[[ which(useImps)[i] ]][myCols] + nR <- try(nrow(LIST), silent = TRUE) + if (class(nR) == "try-error" || is.null(nR)) { + if (i == max(which(useImps))) { + stop("No modification indices could be computed for any imputations.") + } else next + } else break + } + + + + ## D2 pooling method + if (type == "d2") { + chiList <- lapply(object@miList[useImps], "[[", i = "mi") + ## imputations in columns, parameters in rows + LIST$mi <- apply(do.call(cbind, chiList), 1, function(x) { + calculate.D2(x, DF = 1, asymptotic = TRUE)[1] + }) + ## 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)) + } + } else { + + scoreOut <- lavTestScore.mi(object, add = cbind(LIST, user = 10L, + free = 1, start = 0), + type = "Rubin", scale.W = FALSE, + epc = TRUE, asymptotic = TRUE)$uni + LIST$mi <- scoreOut$X2 + LIST$epc <- scoreOut$epc + + # standardize? + if (standardized) { + ## Need full parameter table for lavaan::standardizedSolution() + ## Merge parameterEstimates() with modindices() + oldPE <- getMethod("summary","lavaan.mi")(object, se = FALSE, + add.attributes = FALSE) + 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) + rownames(PE) <- paste0(PE$lhs, PE$op, PE$rhs, ".g", PE$group) + PE[rownames(LIST), "epc"] <- LIST$epc + 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) + + PE$sepc.lv <- EPC.sign * lavaan::standardizedSolution(object, se = FALSE, + type = "std.lv", + cov.std = cov.std, + partable = PE, + GLIST = object@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@GLIST, + est = abs(EPC))$est.std + if (length(small.idx) > 0L) { + PE$sepc.lv[small.idx] <- 0 + PE$sepc.all[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 + 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 +} + +# aliases +modificationIndices.mi <- modificationindices.mi <- modindices.mi diff -Nru r-cran-semtools-0.4.14/R/runMI.R r-cran-semtools-0.5.0/R/runMI.R --- r-cran-semtools-0.4.14/R/runMI.R 2016-10-14 21:37:19.000000000 +0000 +++ r-cran-semtools-0.5.0/R/runMI.R 2018-06-02 22:37:50.000000000 +0000 @@ -1,574 +1,320 @@ -## Functon to impute missing data, run Lavaan on each one -## input: data frames of raw data with missing data, model specification (lavaan script), number of imputations wanted.) -## Output: lavaanStar object which filled with the appropriate information -## Alexander Schoemann, Patrick Miller, Mijke Rhemtulla, Sunthud Pornprasertmanit, Alexander Robitzsch, Mauricio Garnier Villarreal -## Last modified 5/25/2012 - -##Currently outputs a list of parameter estimates, standard errors, fit indices and fraction missing information - -cfa.mi <- function(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", seed=12345, nullModel = NULL, includeImproper = FALSE, ...) { - runMI(model=model, data=data, m=m, miArgs=miArgs, chi=chi, miPackage=miPackage, seed=seed, fun="cfa", nullModel = nullModel, includeImproper = includeImproper, ...) -} - -sem.mi <- function(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", seed=12345, nullModel = NULL, includeImproper = FALSE, ...) { - runMI(model=model, data=data, m=m, miArgs=miArgs, chi=chi, miPackage=miPackage, seed=seed, fun="sem", nullModel = nullModel, includeImproper = includeImproper, ...) -} - -growth.mi <- function(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", seed=12345, nullModel = NULL, includeImproper = FALSE, ...) { - runMI(model=model, data=data, m=m, miArgs=miArgs, chi=chi, miPackage=miPackage, seed=seed, fun="growth", nullModel = nullModel, includeImproper = includeImproper, ...) -} - -lavaan.mi <- function(model, data, m, miArgs=list(), miPackage="Amelia", chi="all", seed=12345, nullModel = NULL, includeImproper = FALSE, ...) { - runMI(model=model, data=data, m=m, miArgs=miArgs, chi=chi, miPackage=miPackage, seed=seed, fun="lavaan", nullModel = nullModel, includeImproper = includeImproper, ...) -} - - -runMI <- function(model, data, m, miArgs=list(), chi="all", miPackage="Amelia", seed=12345, fun, nullModel = NULL, includeImproper = FALSE, ...) -{ - set.seed(seed) - chi <- tolower(chi) - if(!(chi %in% c("none", "mplus", "mr", "lmrr", "all"))) { - stop("The chi argument should be one of the followings only: 'none, 'mr', 'lmrr', 'mplus', or 'all'.") - } - - imputed.data <- is.list(data) & (!is.data.frame(data)) - imputed.l <- NULL - if (!imputed.data){ - if( ( miPackage!="Amelia" ) & ( miPackage !="mice") ) { - stop("Currently runMI only supports imputation by Amelia or mice") - } - if(miPackage=="Amelia"){ - imputed.l<-imputeMissingAmelia(data,m, miArgs) - } else if(miPackage=="mice"){ - imputed.l<-imputeMissingMice(data,m, miArgs) - } - } else { - imputed.l <- data - m <- length( data ) - data <- data[[1]] - } - out <- list(model=model, data=imputed.l[[1]], se="none", do.fit=FALSE) - out <- c(out, list(...)) - template <- do.call(fun, out) - imputed.results.l <- suppressWarnings(lapply(imputed.l, runlavaanMI, syntax=model, fun=fun, ...)) - converged.l <- sapply(imputed.results.l, lavaan::lavInspect, what = "converged") - - coefAll <- sapply(imputed.results.l, function(x) lavaan::parTable(x)$est) - seAll <- sapply(imputed.results.l, function(x) lavaan::parTable(x)$se) - partableImp <- lavaan::partable(imputed.results.l[[1]]) - posVar <- (partableImp$op == "~~") & (partableImp$lhs == partableImp$rhs) - convergedtemp <- converged.l - properSE <- apply(seAll, 2, function(x) all(!is.na(x)) & all(x >= 0) & !(all(x == 0))) - - properVariance <- apply(coefAll[posVar, ,drop=FALSE], 2, function(x) all(x >= 0)) - if(!includeImproper) { - converged.l <- converged.l & properSE & properVariance - } - if(sum(converged.l) < 2) { - tab <- cbind(convergedtemp, properSE, properVariance, converged.l) - colnames(tab) <- c("1. Convergence", "2. Proper SE", "3. Proper Variance Estimate", "Used for pooling") - print(tab) - stop("Please increase the number of imputations. The number of convergent replications is less than or equal to 1. See the details above.") - } - - mOriginal <- m - m <- sum(converged.l) - convergenceRate <- m/mOriginal - imputed.results.l <- imputed.results.l[converged.l] - - coefs <- sapply(imputed.results.l, function(x) lavaan::parTable(x)$est) - se <- sapply(imputed.results.l, function(x) lavaan::parTable(x)$se) - Sigma.hat <- lapply(imputed.results.l, lavaan::lavInspect, what = "cov.ov") - Mu.hat <- lapply(imputed.results.l, lavaan::lavInspect, what = "mean.ov") - meanSigmaHat <- list() - meanMuHat <- list() - for(g in seq_len(lavaan::lavInspect(template, "ngroups"))) { - tempSigma <- lapply(Sigma.hat, "[[", g) - meanSigmaHat[[g]] <- Reduce("+", tempSigma)/m - tempMu <- lapply(Mu.hat, "[[", g) - meanMuHat[[g]] <- Reduce("+", tempMu)/m - } - template@Fit@Sigma.hat <- meanSigmaHat - template@Fit@Mu.hat <- meanMuHat - comb.results <- miPoolVector(t(coefs),t(se), m) - - - template@Fit@est <- template@ParTable$est <- comb.results$coef - template@Fit@se <- template@ParTable$se <- comb.results$se - template@Fit@x <- comb.results$coef[comb.results$se != 0] - template@Model <- imposeGLIST(template@Model, comb.results$coef, lavaan::parTable(template)) - - selectVCOV <- lavaan::partable(imputed.results.l[[1]])$free != 0 - # VCOV - VCOVs <- sapply(imputed.results.l, function(x) vecsmat(lavaan::vcov(x))) - template@vcov$vcov <- vcovPool(t(coefs[selectVCOV, ]),t(VCOVs), m) - - fmi.results <- cbind(lavaan::parameterEstimates(template, remove.system.eq = FALSE, remove.eq = FALSE, remove.ineq = FALSE)[,1:3], group=lavaan::parTable(template)$group, fmi1 = comb.results[[3]], fmi2 = comb.results[[4]]) - - fit <- lavaan::lavInspect(imputed.results.l[[1]], "test") - df <- fit[[1]]$df - #if (df == 0) chi <- "none" # for saturated models, no model fit available - chi1 <- sapply(imputed.results.l, function(x) lavaan::lavInspect(x, "test")[[1]]$stat) - - if(length(lavaan::lavNames(template, "ov.ord")) | (length(fit) > 1)) { - if(chi=="all") chi <- "lmrr" - if(chi %in% c("mplus", "mr")) { - stop("The 'mplus' or 'mr' method for pooling chi-square values is not available with categorical variables.") - } - } - - chiScaled1 <- NULL - dfScaled <- NULL - if(length(fit) > 1) { - chiScaled1 <- sapply(imputed.results.l, function(x) lavaan::lavInspect(x, "test")[[2]]$stat) - dfScaled <- fit[[2]]$df - } - - if(lavaan::lavInspect(template, "ngroups") == 1) { - fit[[1]]$stat.group <- mean(sapply(imputed.results.l, function(x) lavaan::lavInspect(x, "test")[[1]]$stat.group)) - } else { - fit[[1]]$stat.group <- rowMeans(sapply(imputed.results.l, function(x) lavaan::lavInspect(x, "test")[[1]]$stat.group)) - } - if(is.null(nullModel)) nullModel <- lavaan::lav_partable_independence(template) - if(is.list(nullModel)) nullModel$ustart[nullModel$exo == 1] <- NA - - null.results <- suppressWarnings(lapply(imputed.l, runlavaanMI, syntax=nullModel, fun=fun, ...)) - - convergedNull.l <- sapply(null.results, lavaan::lavInspect, what = "converged") - seNullAll <- sapply(null.results, function(x) lavaan::parTable(x)$se) - if(!includeImproper) { - convergedNull.l <- convergedNull.l & apply(seNullAll, 2, function(x) all(!is.na(x) & (x >= 0))) - } - - dfNull <- lavaan::lavInspect(null.results[[1]], "test")[[1]]$df - if(dfNull == 0) convergedNull.l <- rep(TRUE, m) - if(!any(convergedNull.l)) stop("No null model is converged") - - mNull <- sum(convergedNull.l) - convergenceNullRate <- mNull/mOriginal - null.results <- null.results[convergedNull.l] - chiNull <- sapply(null.results, function(x) lavaan::lavInspect(x, "test")[[1]]$stat) - - chiNullScaled1 <- NULL - dfNullScaled <- NULL - if(length(fit) > 1) { - chiNullScaled1 <- sapply(null.results, function(x) lavaan::lavInspect(x, "test")[[2]]$stat) - dfNullScaled <- lavaan::lavInspect(null.results[[1]], "test")[[2]]$df - } - outNull <- list(model=nullModel, data=imputed.l[[1]], se="none", do.fit=FALSE) - outNull <- c(outNull, list(...)) - templateNull <- suppressWarnings(do.call(fun, outNull)) - - coefsNull <- sapply(null.results, function(x) lavaan::parTable(x)$est) - seNull <- sapply(null.results, function(x) lavaan::parTable(x)$se) - - comb.results.null <- miPoolVector(t(coefsNull),t(seNull), mNull) - fitNull <- lavaan::lavInspect(null.results[[1]], "test") - - lmrr <- NULL - lmrrNull <- NULL - mr <- NULL - mrNull <- NULL - mplus <- NULL - mplusNull <- NULL - lmrrScaled <- NULL - lmrrScaledNull <- NULL - logsat <- NA - logalt <- NA - loglnull <- NULL - loglsat <- NULL - loglmod <- NULL - - if(chi %in% c("lmrr", "all")){ - lmrr <- lmrrPooledChi(chi1, df) - lmrrNull <- lmrrPooledChi(chiNull, dfNull) - fit[[1]]$stat <- as.numeric(lmrr[1] * lmrr[2]) - fit[[1]]$pvalue <- as.numeric(lmrr[4]) - fitNull[[1]]$stat <- as.numeric(lmrrNull[1] * lmrrNull[2]) - fitNull[[1]]$pvalue <- as.numeric(lmrrNull[4]) - - if(!is.null(chiScaled1)) { - lmrrScaled <- lmrrPooledChi(chiScaled1, dfScaled) - lmrrScaledNull <- lmrrPooledChi(chiNullScaled1, dfNullScaled) - fit[[2]] <- lavaan::lavInspect(imputed.results.l[[1]], "test")[[2]] - fit[[2]]$stat <- as.numeric(lmrrScaled[1] * lmrrScaled[2]) - fit[[2]]$pvalue <- as.numeric(lmrrScaled[4]) - fitNull[[2]] <- lavaan::lavInspect(null.results[[1]], "test")[[2]] - fitNull[[2]]$stat <- as.numeric(lmrrScaledNull[1] * lmrrScaledNull[2]) - fitNull[[2]]$pvalue <- as.numeric(lmrrScaledNull[4]) - template@Options$estimator <- lavaan::lavInspect(imputed.results.l[[1]], "options")$estimator - template@Options$test <- lavaan::lavInspect(imputed.results.l[[1]], "options")$test - templateNull@Options$estimator <- lavaan::lavInspect(null.results[[1]], "options")$estimator - templateNull@Options$test <- lavaan::lavInspect(null.results[[1]], "options")$test - } - } - - if(chi %in% c("mplus", "mr", "all")){ - mrplusOut <- mrplusPooledChi(template, imputed.l[converged.l], chi1, df, coef=comb.results$coef, coefs = coefs, m=m, fun=fun, ...) - mrplus <- mrplusOut[[1]] - mrplusChi <- mrplusOut[[2]] - mrplusNullOut <- mrplusPooledChi(templateNull, imputed.l[convergedNull.l], chiNull, dfNull, coef=comb.results.null$coef, coefs = coefsNull, m=mNull, fun=fun, par.sat=lavaan::lav_partable_unrestricted(template), ...) - mrplusNull <- mrplusNullOut[[1]] - mrplusNullChi <- mrplusNullOut[[2]] - logsat <- mrplus[5] / (1 + mrplus[4]) - logalt <- mrplus[6] / (1 + mrplus[4]) - loglnull <- mrplusNullChi[,2] - loglsat <- mrplusChi[,1] - loglmod <- mrplusChi[,2] - - if(chi %in% c("mr", "all")){ - mr <- mrPooledChi(mrplus[1], mrplus[2], mrplus[3], mrplus[4]) - mrNull <- mrPooledChi(mrplusNull[1], mrplusNull[2], mrplusNull[3], mrplusNull[4]) - - fit[[1]]$stat <- as.numeric(mr[1] * mr[2]) - fit[[1]]$pvalue <- as.numeric(mr[4]) - fitNull[[1]]$stat <- as.numeric(mrNull[1] * mrNull[2]) - fitNull[[1]]$pvalue <- as.numeric(mrNull[4]) - } - if(chi %in% c("mplus", "all")){ - mplus <- mplusPooledChi(mrplus[1], mrplus[3], mrplus[4]) - mplusNull <- mplusPooledChi(mrplusNull[1], mrplusNull[3], mrplusNull[4]) - fit[[1]]$stat <- as.numeric(mplus[1]) - fit[[1]]$pvalue <- as.numeric(mplus[3]) - fitNull[[1]]$stat <- as.numeric(mplusNull[1]) - fitNull[[1]]$pvalue <- as.numeric(mplusNull[3]) - } - } - template@test <- fit - template@Fit@npar <- lavaan::fitMeasures(imputed.results.l[[1]], "npar")[[1]] - template@Options <- lavaan::lavInspect(imputed.results.l[[1]], "options") - templateNull@test <- fitNull - result <- as(template, "lavaanStar") - ## HACK! YR - templateNull@Fit@converged <- TRUE ### ! to trick fitMeasures - ## - notused <- capture.output(fitVec <- suppressWarnings(lavaan::fitMeasures(templateNull))) - name <- names(fitVec) - fitVec <- as.vector(fitVec) - names(fitVec) <- name - result@nullfit <- fitVec - - result@Fit@iterations <- as.integer(m) - result@Fit@converged <- TRUE - - summaryImputed <- list() - summaryImputed[[1]] <- c("target model" = convergenceRate, "null model" = convergenceNullRate) - summaryImputed[[2]] <- fmi.results - summaryImputed[[3]] <- list(lmrr = lmrr, mr = mr, mplus = mplus) - summaryImputed[[4]] <- list(lmrr = lmrrNull, mr = mrNull, mplus = mplusNull) - summaryImputed[[5]] <- list(unrestricted.logl = logsat, logl = logalt) - summaryImputed[[6]] <- list(chiorig = chi1, loglmod = loglmod, loglnull = loglnull, loglsat = loglsat) - nameImputed <- c("convergenceRate", "fractionMissing", "targetFit", "nullFit", "logl", "indivlogl") - if(!is.null(lmrrScaled)) { - summaryImputed[[7]] <- list(lmrr = lmrrScaled) - summaryImputed[[8]] <- list(lmrr = lmrrScaledNull) - names(summaryImputed) <- c(nameImputed, "targetFit.scaled", "nullFit.scaled") - } else { - names(summaryImputed) <- nameImputed - } - result@imputed <- summaryImputed - result@imputedResults <- imputed.results.l - - return(result) -} - -#Convenient function to run lavaan models and get results out. For easy use with lapply -runlavaanMI <- function(MIdata, syntax, fun, ...) { - out <- list(model=syntax, data=MIdata) - out <- c(out, list(...)) - fit <- NULL - try(fit <- do.call(fun, out), silent=TRUE) - return(fit) -} - -#Conveniance function to run impuations on data and only return list of data -imputeMissingAmelia <- function(data,m, miArgs){ - # pull out only the imputations - out <- c(list(Amelia::amelia, x = data, m = m, p2s=0), miArgs) - temp.am <- eval(as.call(out)) - return(temp.am$imputations) - -} # end imputeMissingAmelia - -imputeMissingMice <- function(data,m, miArgs){ - # pull out only the imputations - requireNamespace("mice") - if(!("package:mice" %in% search())) attachNamespace("mice") - out <- c(list(mice::mice, data=data, m = m, diagnostics=FALSE, printFlag=FALSE), miArgs) - temp.mice <- eval(as.call(out)) - temp.mice.imp <- NULL - for(i in 1:m) { - temp.mice.imp[[i]] <- mice::complete(x=temp.mice, action=i, include=FALSE) +### Terrence D. Jorgensen +### Last updated: 3 June 2018 +### runMI creates lavaan.mi object, inherits from lavaanList class + + +#' 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 \code{data.frame} with +#' missing observations, using either the Amelia package or the mice package. +#' +#' +#' @aliases runMI lavaan.mi cfa.mi sem.mi growth.mi +#' @importFrom lavaan lavInspect parTable +#' +#' @param model The analysis model can be specified using lavaan +#' \code{\link[lavaan]{model.syntax}} or a parameter table (as returned by +#' \code{\link[lavaan]{parTable}}). +#' @param 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 +#' \code{@DataList} slot, so \code{data} can also be a \code{lavaan.mi} object +#' from which the same imputed data will be used for additional analyses. +#' @param 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{runMI}. +#' @param \dots additional arguments to pass to \code{\link[lavaan]{lavaan}} or +#' \code{\link[lavaan]{lavaanList}}. See also \code{\link[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. +#' @param m \code{integer}. Request the number of imputations. Ignored if +#' \code{data} is already a \code{list} of imputed data sets or a +#' \code{lavaan.mi} object. +#' @param miArgs Addition arguments for the multiple-imputation function +#' (\code{miPackage}). The arguments should be put in a list (see example +#' below). Ignored if \code{data} is already a \code{list} of imputed data sets +#' or a \code{lavaan.mi} object. +#' @param 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 a +#' \code{lavaan.mi} object. +#' @param 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 a \code{lavaan.mi} object. +#' @return A \code{\linkS4class{lavaan.mi}} object +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @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. +#' @examples +#' \dontrun{ +#' ## 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 +#' ' +#' +#' ## impute data within runMI... +#' out1 <- cfa.mi(HS.model, data = HSMiss, m = 20, seed = 12345, +#' miArgs = list(noms = "school")) +#' +#' ## ... or impute missing data first +#' library(Amelia) +#' set.seed(12345) +#' HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +#' imps <- HS.amelia$imputations +#' out2 <- cfa.mi(HS.model, data = imps) +#' +#' ## same results (using the same seed results in the same imputations) +#' cbind(impute.within = coef(out1), impute.first = coef(out2)) +#' +#' summary(out1) +#' summary(out1, ci = FALSE, fmi = TRUE, add.attributes = FALSE) +#' summary(out1, ci = FALSE, stand = TRUE, rsq = TRUE) +#' +#' ## model fit. D3 includes information criteria +#' anova(out1) +#' anova(out1, test = "D2", indices = TRUE) # request D2 and fit indices +#' +#' +#' +#' ## fit multigroup model without invariance constraints +#' mgfit1 <- cfa.mi(HS.model, data = imps, estimator = "mlm", group = "school") +#' ## add invariance constraints, and use previous fit as "data" +#' mgfit0 <- cfa.mi(HS.model, data = mgfit1, estimator = "mlm", group = "school", +#' group.equal = c("loadings","intercepts")) +#' +#' ## compare fit (scaled likelihood ratio test) +#' anova(mgfit0, h1 = mgfit1) +#' +#' ## correlation residuals +#' resid(mgfit0, type = "cor.bentler") +#' +#' +#' ## use D1 to test a parametrically nested model (whether latent means are ==) +#' anova(mgfit0, test = "D1", constraints = ' +#' .p70. == 0 +#' .p71. == 0 +#' .p72. == 0') +#' +#' +#' +#' ## ordered-categorical data +#' data(datCat) +#' lapply(datCat, class) +#' ## impose missing values +#' set.seed(123) +#' for (i in 1:8) datCat[sample(1:nrow(datCat), size = .1*nrow(datCat)), i] <- NA +#' +#' catout <- cfa.mi(' f =~ u1 + u2 + u3 + u4 ', data = datCat, +#' m = 3, seed = 456, +#' miArgs = list(ords = paste0("u", 1:8), noms = "g"), +#' FUN = function(fit) { +#' list(wrmr = lavaan::fitMeasures(fit, "wrmr"), +#' zeroCells = lavaan::lavInspect(fit, "zero.cell.tables")) +#' }) +#' summary(catout) +#' anova(catout, indices = "all") # note the scaled versions of indices, too +#' +#' ## extract custom output +#' sapply(catout@funList, function(x) x$wrmr) # WRMR for each imputation +#' catout@funList[[1]]$zeroCells # zero-cell tables for first imputation +#' catout@funList[[2]]$zeroCells # zero-cell tables for second imputation ... +#' +#' } +#' +#' @export +runMI <- function(model, data, fun = "lavaan", ..., + m, miArgs = list(), miPackage = "Amelia", seed = 12345) { + CALL <- match.call() + dots <- list(...) + if (!is.null(dots$fixed.x)) { + if (dots$fixed.x) warning('fixed.x set to FALSE') } - return(temp.mice.imp) -} # end imputeMissingAmelia - - - - -# miPoolVector -# Function -- simsem package -# Pool MI results that providing in matrix or vector formats -# Argument: -# MI.param: Coefficients matrix (row = imputation, col = parameters) -# MI.se: Standard errors matrix (row = imputation, col = parameters) -# imps: Number of imputations -# Return: -# coef: Parameter estimates -# se: Standard error combining the between and within variances -# FMI.1: Fraction missing? -# FMI.2: Fraction missing? -# Author: Mijke Rhumtella -# Alex Schoemann -# Sunthud Pornprasertmanit (University of Kansas; psunthud@ku.edu) -# Date Modified: February 8, 2012 - -miPoolVector <- function(MI.param, MI.se, imps) { - #compute parameter estimates - Estimates <- colMeans(MI.param) - -#compute between-imputation variance: variance of parameter estimates - Bm <- apply(MI.param,2,var) - -#compute within-imputation variance: average of squared estimated SEs -#Um <- colSums(MI.se^2/m) - Um <- apply(MI.se^2,2,mean) - -#Total variance -#Tm <- Um + (Bm)*((1+m)/m+1) -#compute total variance: sum of between- and within- variance with correction - TV <- Um + ((imps+1)/imps)*Bm - -#compute correction factor for fraction of missing info - nu <- (imps-1)*((((1+1/imps)*Bm)/TV)^-2) - -#compute 2 estimates of fraction of missing information - FMI.1 <- 1-(Um/TV) - FMI.2 <- 1- ((nu+1)*Um)/((nu+3)*TV) - FMI.2[is.nan(FMI.2)] <- 0 - FMI<-rbind(FMI.1,FMI.2) - -#Get rid of estimates from fixed variables -#fixedParam <- Bm==0 - -#Estimates <- subset(Estimates, !fixedParam) -#TV <- subset(TV, !fixedParam) -#FMI.1 <- subset(FMI.1, !fixedParam) -#FMI.2 <- subset(FMI.2, !fixedParam) -SE <- sqrt(TV) -MI.res<-list(Estimates,SE,FMI.1,FMI.2) -names(MI.res)<-c('coef','se','FMI.1','FMI.2') -#compute chi-square proportion (is this useful?) -#(MI.fit.mat$chisq.p is a placeholder for however we'll index the p-value of chi square) -#chisq <- sum(MI.fit.mat$chisq.pval<.05)/m - return(MI.res) -} -#Examples: -#param <- matrix(c(0.7, 0.1, 0.5, -# 0.75, 0.12, 0.54, -# 0.66, 0.11, 0.56, -# 0.74, 0.09, 0.55), nrow=4, byrow=T) -#SE <- matrix(c(0.1, 0.01, 0.05, -# 0.11, 0.023, 0.055, -# 0.10, 0.005, 0.04, -# 0.14, 0.012, 0.039), nrow=4, byrow=T) -#nimps <- 4 -#miPoolVector(param, SE, nimps) - -# lmrrPooledChi -# Function -- simsem package -# Pool Chi-square statistic based on Li, Meng, Raghunathan, & Rubin (1991) adapted from http://psychology.clas.asu.edu/files/CombiningLikelihoodRatioChi-SquareStatisticsFromaMIAnalysis.sas -# Argument: -# chis: vector of chi-square values -# df: degree of freedom -# Author: Craig Enders -# Sunthud Pornprasertmanit (University of Kansas; psunthud@ku.edu) -# Date Modified: March 31, 2012 - -vecsmat <- function(X) X[lower.tri(X, diag = TRUE)] - -invvecsmat <- function(x) { - p <- (sqrt(1 + 8 * length(x)) - 1) /2 - X <- matrix(0, p, p) - X[lower.tri(X, diag = TRUE)] <- x - vars <- diag(X) - X <- X + t(X) - diag(X) <- vars - X -} - -vcovPool <- function(MI.param, MI.cov, imps) { - #compute parameter estimates - Estimates <- colMeans(MI.param) - -#compute between-imputation variance: variance of parameter estimates - Bm <- vecsmat(cov(MI.param)) - -#compute within-imputation variance: average of squared estimated SEs -#Um <- colSums(MI.se^2/m) - Um <- apply(MI.cov,2,mean) - -#Total variance -#Tm <- Um + (Bm)*((1+m)/m+1) -#compute total variance: sum of between- and within- variance with correction - TV <- Um + ((imps+1)/imps)*Bm - - return(invvecsmat(TV)) -} - -lmrrPooledChi <- function(chis, df) { - # From Li, Meng, Raghunathan, & Rubin (1991) - if(is.matrix(chis)) { - ifelse(ncol(chis) == 1 | nrow(chis) == 1, chis <- as.vector(chis), stop("Please put a vector of chi-square values")) - } - m <- length(chis) - dbar <- mean(chis) - sqrtd <- sqrt(chis) - xbarsqrtd <- mean(sqrtd) - # Equation 2.2 - r <- (1 + 1/m) * (sum((sqrtd - xbarsqrtd)^2)/(m - 1)) - # Equation 2.1 - D <- (dbar/df - ((m + 1) * r /(m - 1)))/(1 + r) - if(D < 0) D <- 0 - # Equation 2.16 and 2.17 - aw <- df^(-(3/m)) * (m - 1) * (1 + (1/r))^2 - p <- 1 - pf(D, df, aw) - result <- c(D, df, aw, p) - names(result) <- c("F", "df1", "df2", "p.F") - return(result) -} -#Examples: -#lmrrPooledChi(c(89.864, 81.116,71.500,49.022,61.986,64.422,55.256,57.890,79.416,63.944), 2) + if (!is.null(dots$conditional.x)) { + if (dots$conditional.x) warning('conditional.x set to FALSE') + } + dots$fixed.x <- dots$conditional.x <- FALSE -##### function that does the part of the MR and Mplus combination methods are equal -mrplusPooledChi <- function(template, imputed.l, chi1, df, coef, coefs, m, fun, par.sat=NULL, ...) { - - if(is.null(par.sat)) par.sat <- lavaan::lav_partable_unrestricted(template) - comb.sat <- suppressWarnings(lapply(imputed.l, runlavaanMI, syntax=par.sat, fun=fun, ...)) - converged.sat1 <- sapply(comb.sat, lavaan::lavInspect, what = "converged") - - coefs.sat1 <- sapply(comb.sat, function(x) lavaan::parTable(x)$est) - est.sat1 <- rowMeans(coefs.sat1[,converged.sat1]) - par.sat2 <- par.sat - par.sat2$free <- as.integer(rep(0, length(par.sat2$free))) - par.sat2$ustart <- est.sat1 - par.sat2$start <- est.sat1 - par.sat2$est <- est.sat1 - comb.sat2 <- suppressWarnings(lapply(imputed.l, runlavaanMI, syntax=par.sat2, fun=fun, ...)) - comb.sat2 <- lapply(comb.sat2, forceTest) - fit.sat2 <- sapply(comb.sat2, function(x) lavaan::lavInspect(x, "fit")["logl"]) - - par.alt2 <- lavaan::partable(template) - par.alt2$free <- as.integer(rep(0, length(par.alt2$free))) - par.alt2$ustart <- coef - par.alt2$start <- coef - par.alt2$est <- coef - par.alt2.l <- rep(list(par.alt2), m) - TEMPFUN <- function(ptable, origcoef) { - exo <- ptable$exo == 1 - ptable$ustart[exo] <- origcoef[exo] - ptable$start[exo] <- origcoef[exo] - ptable$est[exo] <- origcoef[exo] - ptable - } - par.alt2.l <- mapply(TEMPFUN, par.alt2.l, data.frame(coefs), SIMPLIFY = FALSE) - comb.alt2 <- suppressWarnings(mapply(runlavaanMI, MIdata = imputed.l, syntax = par.alt2.l, SIMPLIFY = FALSE, MoreArgs = list(fun = fun, ...))) - #comb.alt2 <- suppressWarnings(lapply(imputed.l, runlavaanMI, syntax=par.alt2, fun=fun, ...)) - comb.alt2 <- lapply(comb.alt2, forceTest) - fit.alt2 <- sapply(comb.alt2, function(x) lavaan::lavInspect(x, "fit")["logl"]) - chinew <- cbind(fit.sat2, fit.alt2, (fit.sat2-fit.alt2)*2) - - - chimean <- mean(chinew[,3]) - logsat <- mean(chinew[,1]) - logalt <- mean(chinew[,2]) - - fit.altcc <- mean(chi1) - ariv <- ((m+1)/((m-1)*df))*(fit.altcc-chimean) - resmrCHI <- c(chimean, m, df, ariv, logsat, logalt) - return(list(resmrCHI, chinew)) -} + seed <- as.integer(seed[1]) + ## Create (or acknowledge) list of imputed data sets + imputedData <- NULL + 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(x = miceOut, action = i, include = FALSE) + } + } else stop("Currently runMI only supports imputation by Amelia or mice") + } else if (is.list(data)) { + 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, "lavaan.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 lavaan.mi object") + + ## Function to get custom output for lavaan.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) { + 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"), + modindices = try(lavaan::modindices(obj), silent = TRUE), + GLIST = obj@Model@GLIST, # FIXME: @Model slot may disappear; need GLIST for std.all and in simsem + converged = converged, SE = se.test, + Heywood.lv = Heywood.lv, Heywood.ov = Heywood.ov) + } -##### function that does the calculations for the Mplus chi combination -mplusPooledChi <- function(chimean, k, ariv){ - comb.chi.mplus <- matrix(NA, nrow=1, ncol=3) - comb.chi.mplus[1] <- chimean/(1+ariv) - comb.chi.mplus[2] <- k - comb.chi.mplus[3] <- 1 - pchisq(comb.chi.mplus[1], comb.chi.mplus[2]) - colnames(comb.chi.mplus) <- c("chisq", "df", "pvalue") - comb.chi.mplus <- as.data.frame(comb.chi.mplus) - rownames(comb.chi.mplus) <- "" - return(comb.chi.mplus) -} + ## 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") + 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","modindices","converged", + "SE","Heywood.lv","Heywood.ov","GLIST") + })) + 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 + ## assign class and add new slots + fit <- as(fit, "lavaan.mi") + fit@coefList <- lapply(fit@funList, "[[", i = "coefMats") + fit@miList <- lapply(fit@funList, "[[", i = "modindices") + 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) + } -##### function that does the calculations for the MR chi combination -mrPooledChi <-function(chimean, m, k, ariv){ - km <- m*k - kmtest <- km-k - - if(kmtest<=4){ - v4 <- 4+(km-k-4)*(1+(1-(2/kmtest))*(1/ariv))^2 + fit@convergence <- lapply(convList, function(x) do.call(c, x)) + conv <- which(sapply(fit@convergence, "[", i = "converged")) + if (length(conv)) { + firstConv <- conv[1] + fit@GLIST <- list() + ## loop over GLIST elements + for (mat in seq_along(fit@funList[[firstConv]][["GLIST"]])) { + matList <- lapply(fit@funList[conv], function(x) x$GLIST[[mat]]) + fit@GLIST[[mat]] <- Reduce("+", matList) / length(matList) + } + names(fit@GLIST) <- names(fit@funList[[firstConv]][["GLIST"]]) + } else { + fit@GLIST <- list() + warning('The model did not converge for any imputed data sets.') } - else{ - v4 <- (kmtest*(1+k^-1)*(1+(1/ariv))^2)/2 - } - comb.chi.mr <- matrix(NA, nrow=1, ncol=4) - comb.chi.mr[1] <- chimean/((1+ariv)*k) - comb.chi.mr[2] <- k - comb.chi.mr[3] <- v4 - comb.chi.mr[4] <- 1 - pf(comb.chi.mr[1], comb.chi.mr[2], comb.chi.mr[3]) - colnames(comb.chi.mr) <- c("F", "df1", "df2", "pvalue") - comb.chi.mr <- as.data.frame(comb.chi.mr) - rownames(comb.chi.mr) <- "" - return(comb.chi.mr) -} -forceTest <- function(object) { - previousCall <- lavaan::lavInspect(object, "call") - args <- previousCall[-1] - args$model <- lavaan::parTable(object) - args$control <- list(optim.method="none", optim.force.converged=TRUE) - funcall <- as.character(previousCall[[1]]) - lav <- do.call(funcall[length(funcall)], args) - lav + ## 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","modindices","converged", + "SE","Heywood.lv","Heywood.ov","GLIST") + })) + 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() + + fit@ParTable$start <- getMethod("coef", "lavaan.mi")(fit, type = "user", labels = FALSE) + fit +} + +#' @rdname runMI +#' @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) +} + +#' @rdname runMI +#' @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) +} + +#' @rdname runMI +#' @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) +} + +#' @rdname runMI +#' @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) } -imposeGLIST <- function(object, coef, partable) { - GLIST <- object@GLIST - for(i in 1:length(GLIST)) { - if(!is.matrix(GLIST[[i]])) GLIST[[i]] <- as.matrix(GLIST[[i]]) - dimnames(GLIST[[i]]) <- object@dimNames[[i]] - } - for(i in 1:length(coef)) { - group <- partable$group[i] - lhs <- partable$lhs[i] - rhs <- partable$rhs[i] - if(partable$op[i] == "=~") { - targetName <- "lambda" - if(!(rhs %in% rownames(GLIST[names(GLIST) == "lambda"][[group]]))) targetName <- "beta" - GLIST[names(GLIST) == targetName][[group]][rhs, lhs] <- coef[i] - } else if (partable$op[i] == "~~") { - if(lhs %in% rownames(GLIST[names(GLIST) == "psi"][[group]])) { - GLIST[names(GLIST) == "psi"][[group]][rhs, lhs] <- coef[i] - GLIST[names(GLIST) == "psi"][[group]][lhs, rhs] <- coef[i] - } else { - GLIST[names(GLIST) == "theta"][[group]][rhs, lhs] <- coef[i] - GLIST[names(GLIST) == "theta"][[group]][lhs, rhs] <- coef[i] - } - } else if (partable$op[i] == "~") { - targetName <- "beta" - if(!(rhs %in% colnames(GLIST[names(GLIST) == "beta"][[group]]))) targetName <- "gamma" - GLIST[names(GLIST) == targetName][[group]][lhs, rhs] <- coef[i] - } else if (partable$op[i] == "~1") { - if(lhs %in% rownames(GLIST[names(GLIST) == "alpha"][[group]])) { - GLIST[names(GLIST) == "alpha"][[group]][lhs, 1] <- coef[i] - } else { - GLIST[names(GLIST) == "nu"][[group]][lhs, 1] <- coef[i] - } - } else if (partable$op[i] == "|") { - GLIST[names(GLIST) == "tau"][[group]][paste0(lhs, "|", rhs), 1] <- coef[i] - } - } - object@GLIST <- GLIST - object -} diff -Nru r-cran-semtools-0.4.14/R/runMI-score.R r-cran-semtools-0.5.0/R/runMI-score.R --- r-cran-semtools-0.4.14/R/runMI-score.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/runMI-score.R 2018-06-25 19:54:13.000000000 +0000 @@ -0,0 +1,685 @@ +### Terrence D. Jorgensen & Yves Rosseel +### Last updated: 25 June 2018 +### classic score test (= Lagrange Multiplier test) +### borrowed source code from lavaan/R/lav_test_score.R + +## 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 +#' using Rubin's (1987) rules, or by pooling the score test statistics +#' across imputed data sets (Li, Meng, Raghunathan, & Rubin, 1991). +#' +#' @aliases lavTestScore.mi +#' @importFrom lavaan lavListInspect parTable +#' @importFrom stats cov pchisq pf +#' @importFrom methods getMethod +#' +#' @param object An object of class \code{\linkS4class{lavaan}}. +#' @param 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. +#' @param 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. +#' @param type \code{character} indicating which pooling method to use. +#' \code{"Rubin"} indicates Rubin's (1987) rules will be applied to the +#' gradient and information, and those pooled values will be used to +#' calculate modification indices in the usual manner. \code{"D2"} (default), +#' \code{"LMRR"}, or \code{"Li.et.al"} indicate that modification indices +#' calculated from each imputed data set will be pooled across imputations, +#' as described in Li, Meng, Raghunathan, & Rubin (1991) and Enders (2010). +#' @param scale.W \code{logical}. If \code{FALSE} (default), 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; see Enders, 2010, p. 235). +#' Not recommended, and ignored (irrelevant) if \code{type = "D2"}. +#' @param 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. +#' @param univariate \code{logical}. If \code{TRUE}, compute the univariate +#' score statistics, one for each constraint. +#' @param 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. +#' @param 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}. +#' @param verbose \code{logical}. Not used for now. +#' @param warn \code{logical}. If \code{TRUE}, print out warnings if they occur. +#' +#' @return +#' A list containing at least one \code{data.frame}: +#' \itemize{ +#' \item{\code{$test}: The total score test, with columns for the score +#' test statistic (\code{X2}), the degrees of freedom (\code{df}), and +#' a \emph{p} value under the \eqn{\chi^2} distribution (\code{p.value}).} +#' \item{\code{$uni}: Optional (if \code{univariate=TRUE}). +#' Each 1-\emph{df} score test, equivalent to modification indices.} +#' \item{\code{$cumulative}: Optional (if \code{cumulative=TRUE}). +#' Cumulative score tests.} +#' \item{\code{$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}} 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}) +#' +#' \code{type = "Rubin"} 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. \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{http://www.jstor.org/stable/24303994} +#' +#' Rubin, D. B. (1987). \emph{Multiple imputation for nonresponse in surveys}. +#' New York, NY: Wiley. +#' +#' @examples +#' \dontrun{ +#' ## 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) +#' +#' ## impute missing data +#' library(Amelia) +#' set.seed(12345) +#' HS.amelia <- amelia(HSMiss, m = 20, noms = "school", p2s = FALSE) +#' imps <- HS.amelia$imputations +#' +#' ## specify CFA model from lavaan's ?cfa help page +#' HS.model <- ' +#' speed =~ c(L1, L1)*x7 + c(L1, L1)*x8 + c(L1, L1)*x9 +#' ' +#' +#' out <- cfa.mi(HS.model, data = imps, group = "school", std.lv = TRUE) +#' +#' ## Mode 1: Score test for releasing equality constraints +#' +#' ## default type: Li et al.'s (1991) "D2" method +#' lavTestScore.mi(out, cumulative = TRUE) +#' ## Rubin's rules +#' lavTestScore.mi(out, type = "Rubin") +#' +#' ## Mode 2: Score test for adding currently fixed-to-zero parameters +#' lavTestScore.mi(out, add = 'x7 ~~ x8 + x9') +#' +#' } +#' +#' @export +lavTestScore.mi <- function(object, add = NULL, release = NULL, + type = c("D2","Rubin"), scale.W = FALSE, + asymptotic = !is.null(add), # as F or chi-squared + univariate = TRUE, cumulative = FALSE, + #standardized = TRUE, #FIXME: add std.lv and std.all if(epc)? + epc = FALSE, verbose = FALSE, warn = TRUE) { + stopifnot(inherits(object, "lavaan.mi")) + lavoptions <- object@Options + + useSE <- sapply(object@convergence, "[[", i = "SE") + useSE[is.na(useSE)] <- FALSE + useImps <- useSE & sapply(object@convergence, "[[", i = "converged") + m <- sum(useImps) + type <- tolower(type[1]) + + ## 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 (type == "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, + cumulative = cumulative, + univariate = univariate, epc = epc, + warn = FALSE), 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[[ which(useImps & !noScores)[1] ]] + + ## at a minimum, pool the total score test + chiList <- sapply(FIT@funList[useImps & !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"]] + + ## 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 + } + for (i in 1:nrow(OUT$uni)) { + chiList <- sapply(FIT@funList[useImps & !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"]] + } + if (!asymptotic) names(OUT$uni)[names(OUT$uni) == "df"] <- "df1" + #FIXME: If Yves allows EPC here, add it if(epc) + } + + ## 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 + } + for (i in 1:nrow(OUT$cumulative)) { + chiList <- sapply(FIT@funList[useImps & !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"]] + } + if (!asymptotic) names(OUT$cumulative)[names(OUT$cumulative) == "df"] <- "df1" + } + + ## EPCs? + if (epc) { + estList <- lapply(FIT@funList[useImps & !noScores], + function(x) x$epc$est) + OUT$epc$est <- rowMeans(do.call(cbind, estList)) + + epcList <- lapply(FIT@funList[useImps & !noScores], + function(x) x$epc$epc) + OUT$epc$epc <- rowMeans(do.call(cbind, epcList)) + + OUT$epc$epv <- OUT$epc$est + OUT$epc$epc + #FIXME: if (standardized) repeat for std.lv and std.all + } + + return(OUT) + } # else type == "Rubin", 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") + + ## -------------------------------------- + ## borrowed code from lav_object_extend() + ## -------------------------------------- + + # partable original model + oldPT <- lavaan::parTable(obj)[c("lhs","op","rhs","block","group", + "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 + myCols <- c("lhs","op","rhs") + #FIXME: add "level" column? how to check for multilevel data? + if (ngroups > 1L) myCols <- c(myCols,"block","group") + # 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("lhs","op","rhs","block","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 (class(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, "information"), + nadd = nrow(ADD), parTable = lavaan::parTable(obj2)) + } + 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 + ariv <- (1 + 1/m)/nrow(B) * sum(diag(B %*% inv.W)) + + 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 + } + + ## obtain list of inverted Jacobians: within-impuation covariance matrices + R.model <- object@Model@con.jac[,,drop = FALSE] + nadd <- FIT@funList[[ which(useImps)[1] ]]$nadd + 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[[ which(useImps)[1] ]]$parTable + 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 + } + 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, "information")) + } + 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 + ariv <- (1 + 1/m)/nrow(B) * sum(diag(B %*% inv.W)) + 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 (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 + 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)) + } + 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) + } + + ## FIXME: experimentally add univariate EPCs for added parameters, as would accompany modification indices + if (epc && !is.null(add)) Table2$epc <- EPC.uni + + 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 + 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) + } + attr(Table3, "header") <- "cumulative score tests:" + OUT$cumulative <- Table3 + } + + if (epc) { + ################# 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","lavaan.mi")(object) + myCols <- c("lhs","op","rhs","group","user","free","label","plabel") + LIST <- if (!is.null(add) && nchar(add) > 0L) { + PT[ , myCols] + } else parTable(object)[ , myCols] + + if (lavListInspect(object, "ngroups") == 1L) LIST$group <- NULL + 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 + LIST$free[ LIST$user == 10L ] <- 0 + LIST$user <- 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 +} diff -Nru r-cran-semtools-0.4.14/R/semTools-deprecated.R r-cran-semtools-0.5.0/R/semTools-deprecated.R --- r-cran-semtools-0.4.14/R/semTools-deprecated.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/semTools-deprecated.R 2018-05-01 13:33:39.000000000 +0000 @@ -0,0 +1,13 @@ +### Terrence D. Jorgensen +### Last updated 9 March 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 \code{help("semTools-deprecated")}. +#' @name semTools-deprecated +#' @keywords internal +NULL + diff -Nru r-cran-semtools-0.4.14/R/semTools.R r-cran-semtools-0.5.0/R/semTools.R --- r-cran-semtools-0.4.14/R/semTools.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/semTools.R 2018-06-25 21:24:28.000000000 +0000 @@ -0,0 +1,98 @@ +### Terrence D. Jorgensen +### Last updated: 25 June 2018 +### 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 \emph{suite}. Our suites include: +#' \itemize{ +#' \item{Model Fit Evaluation: +#' \code{\link{moreFitIndices}}, +#' \code{\link{nullRMSEA}}, +#' \code{\link{singleParamTest}}, +#' \code{\link{miPowerFit}}, and +#' \code{\link{chisqSmallN}}} +#' \item{Measurement Invariance: +#' \code{\link{measurementInvariance}}, +#' \code{\link{measurementInvarianceCat}}, +#' \code{\link{longInvariance}}, +#' \code{\link{partialInvariance}}, +#' \code{\link{partialInvarianceCat}}, and +#' \code{\link{permuteMeasEq}}} +#' \item{Power Analysis: +#' \code{\link{SSpower}}, +#' \code{\link{findRMSEApower}}, +#' \code{\link{plotRMSEApower}}, +#' \code{\link{plotRMSEAdist}}, +#' \code{\link{findRMSEAsamplesize}}, +#' \code{\link{findRMSEApowernested}}, +#' \code{\link{plotRMSEApowernested}}, and +#' \code{\link{findRMSEAsamplesizenested}}} +#' \item{Missing Data Analysis: +#' \code{\link{auxiliary}}, +#' \code{\link{runMI}}, +#' \code{\link{twostage}}, +#' \code{\link{fmi}}, +#' \code{\link{bsBootMiss}}, +#' \code{\link{quark}}, and +#' \code{\link{combinequark}}} +#' \item{Latent Interactions: +#' \code{\link{indProd}}, +#' \code{\link{orthogonalize}}, +#' \code{\link{probe2WayMC}}, +#' \code{\link{probe3WayMC}}, +#' \code{\link{probe2WayRC}}, +#' \code{\link{probe3WayRC}}, and +#' \code{\link{plotProbe}}} +#' \item{Exploratory Factor Analysis (EFA): +#' \code{\link{efa.ekc}}, +#' \code{\link{efaUnrotate}}, +#' \code{\link{orthRotate}}, +#' \code{\link{oblqRotate}}, and +#' \code{\link{funRotate}}} +#' \item{Reliability Estimation: +#' \code{\link{reliability}}, +#' \code{\link{reliabilityL2}}, and +#' \code{\link{maximalRelia}}} +#' \item{Parceling: +#' \code{\link{parcelAllocation}}, +#' \code{\link{PAVranking}}, and +#' \code{\link{poolMAlloc}}} +#' \item{Non-Normality: +#' \code{\link{skew}}, +#' \code{\link{kurtosis}}, +#' \code{\link{mardiaSkew}}, +#' \code{\link{mardiaKurtosis}}, and +#' \code{\link{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")} +#' +#' @docType package +#' @name semTools +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 + + diff -Nru r-cran-semtools-0.4.14/R/singleParamTest.R r-cran-semtools-0.5.0/R/singleParamTest.R --- r-cran-semtools-0.4.14/R/singleParamTest.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/singleParamTest.R 2018-06-25 21:55:13.000000000 +0000 @@ -1,4 +1,91 @@ -singleParamTest <- function(model1, model2, return.fit = FALSE, method = "satorra.bentler.2001") { +### Sunthud Pornprasertmanit +### Last updated: 25 June 2018 + + +#' 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 identify the differences between these two models. The +#' model with more free parameters is referred to as parent model and the model +#' with less free parameters is referred to as nested model. Three 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 free. 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. +#' +#' @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 +#' \code{\link[lavaan]{lavTestLRT}} for available options +#' @return 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. +#' @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 weak (Model 2) and scalar invariance +#' ## (Model 3) cannot be done by this function # because the weak invariance +#' ## model fixes factor means as 0 in Group 2 but the strong invariance model +#' ## frees the factor means in Group 2. Users may try to compare +#' ## strong (Model 3) and means invariance models by this function. +#' +#' @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 @@ -8,13 +95,13 @@ fit1 <- model1 } # fit0 = Nested model, fit1 = Parent model - pt1 <- lavaan::partable(fit1) - pt0 <- lavaan::partable(fit0) + 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 == "==" @@ -23,8 +110,8 @@ 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.") @@ -37,18 +124,18 @@ textcon0 <- paste0(con0$lhs, con0$op, con0$rhs) indexsamecon <- match(textcon1, textcon0) indexdiffcon <- setdiff(seq_along(textcon0), indexsamecon) - diffcon <- lapply(con0, "[", indexdiffcon) + 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 + + # 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]]) + 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) @@ -72,14 +159,14 @@ 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]]) + 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) @@ -89,7 +176,7 @@ 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) @@ -102,7 +189,7 @@ } poscon <- seq_along(diffcon$id) + length(fixval) rownames(fixCon)[poscon] <- names(listFixCon)[poscon] <- namept0[diffcon$id] - + result <- cbind(freeCon, fixCon) if(return.fit) { @@ -112,10 +199,16 @@ } } + + +## ---------------- +## Hidden Functions +## ---------------- + paramNameFromPt <- function(pt) { ngroups <- max(pt$group) result <- NULL - if(ngroups == 1) { + if (ngroups == 1) { result <- paste0(pt$lhs, pt$op, pt$rhs) } else { grouplab <- paste0(".g", pt$group) @@ -129,11 +222,14 @@ result } +#' @importFrom lavaan lavInspect refit <- function(pt, object, resetstart = TRUE) { - if(resetstart && "start" %in% names(pt)) pt <- pt[-which("start" == names(pt))] - previousCall <- lavaan::lavInspect(object, "call") + if (resetstart && "start" %in% names(pt)) pt <- pt[-which("start" == names(pt))] + previousCall <- lavInspect(object, "call") args <- previousCall[-1] args$model <- pt funcall <- as.character(previousCall[[1]]) tempfit <- do.call(funcall[length(funcall)], args) -} \ No newline at end of file +} + + diff -Nru r-cran-semtools-0.4.14/R/splitSample.R r-cran-semtools-0.5.0/R/splitSample.R --- r-cran-semtools-0.4.14/R/splitSample.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/splitSample.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,73 +1,157 @@ -splitSample<-function(dataset,path="default",div=2,type="default",name="splitSample"){ +### Corbin Quick +### Last updated: 4 April 2017 - 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="") + +#' 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 (\code{/}) 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 \code{path = "object"}, \code{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) + temp <- strsplit(fileN, ".", fixed = TRUE) type <- temp[[1]][2] name <- temp[[1]][1] - if(type=='dat'){ - if(is.numeric(as.matrix(read.table(file, nrows=1)))==FALSE){ - data <- as.matrix(read.table(file,header=TRUE)) - hea=TRUE + 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)) } - else{data <- as.matrix(read.table(file))} } - if(type=='csv'){ - if(is.numeric(as.matrix(read.table(file, nrows=1)))==FALSE){ - data <- as.matrix(read.csv(file,header=TRUE)) - hea=TRUE - }else{data <- as.matrix(read.csv(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)){ + } else { + if (is.matrix(file) | is.data.frame(file)) { data <- as.matrix(file) - }else{stop("PROVIDE DATA IN .DAT OR .CSV FORMAT")} + } else { + stop("Provide data in *.dat or *.csv format") + } } - if(type1!="default"){ - type<-type1 + if (type1 != "default") { + type <- type1 } - if(is.character(colnames(data))){ - hea=TRUE + if (is.character(colnames(data))) { + hea = TRUE } - random <- runif(nrow(data),1,nrow(data)) + random <- runif(nrow(data), 1, nrow(data)) data <- cbind(random, data) - data <- data[order(random),] - data <- data[,2:ncol(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))) + 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],] + 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"){ - write.table(dataL[[i]],paste(path,name,"_s",i,".dat",sep=''),sep=' ',row.names=FALSE,col.names=hea)} - if(type=="csv"){ - write.table(dataL[[i]],paste(path,name,"_s",i,".csv",sep=''),sep=",",row.names=FALSE,col.names=hea)} - if(type=="default"){ - write.table(dataL[[i]],paste(path,name,"_s",i,".dat",sep=''),sep=' ',row.names=FALSE,col.names=hea)} + 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) + } } } } -} \ No newline at end of file +} + + diff -Nru r-cran-semtools-0.4.14/R/standardizeMx.R r-cran-semtools-0.5.0/R/standardizeMx.R --- r-cran-semtools-0.4.14/R/standardizeMx.R 1970-01-01 00:00:00.000000000 +0000 +++ r-cran-semtools-0.5.0/R/standardizeMx.R 2018-06-27 12:12:14.000000000 +0000 @@ -0,0 +1,203 @@ +### Sunthud Pornprasertmanit +### Last updated: 27 June 2018 +### deprecated because it is obsolete (now available in OpenMx) + + +#' Find standardized estimates for OpenMx output +#' +#' Find standardized estimates for OpenMx output. This function is applicable +#' for the \code{MxRAMObjective} only. +#' +#' +#' @param object Target OpenMx output using \code{MxRAMObjective} +#' @param free If \code{TRUE}, the function will show only standardized values +#' of free parameters. If \code{FALSE}, the function will show the results for +#' fixed and free parameters. +#' +#' @return A vector of standardized estimates +#' +#' @author Sunthud Pornprasertmanit (\email{psunthud@@gmail.com}) +#' +#' @examples +#' +#' \dontrun{ +#' library(OpenMx) +#' data(myFADataRaw) +#' myFADataRaw <- myFADataRaw[,c("x1","x2","x3","x4","x5","x6")] +#' oneFactorModel <- mxModel("Common Factor Model Path Specification", +#' type="RAM", +#' mxData( +#' observed=myFADataRaw, +#' type="raw" +#' ), +#' manifestVars=c("x1","x2","x3","x4","x5","x6"), +#' latentVars="F1", +#' mxPath(from=c("x1","x2","x3","x4","x5","x6"), +#' arrows=2, +#' free=TRUE, +#' values=c(1,1,1,1,1,1), +#' labels=c("e1","e2","e3","e4","e5","e6") +#' ), +#' # residual variances +#' # ------------------------------------- +#' mxPath(from="F1", +#' arrows=2, +#' free=TRUE, +#' values=1, +#' labels ="varF1" +#' ), +#' # latent variance +#' # ------------------------------------- +#' mxPath(from="F1", +#' to=c("x1","x2","x3","x4","x5","x6"), +#' arrows=1, +#' free=c(FALSE,TRUE,TRUE,TRUE,TRUE,TRUE), +#' values=c(1,1,1,1,1,1), +#' labels =c("l1","l2","l3","l4","l5","l6") +#' ), +#' # factor loadings +#' # ------------------------------------- +#' mxPath(from="one", +#' to=c("x1","x2","x3","x4","x5","x6","F1"), +#' arrows=1, +#' free=c(TRUE,TRUE,TRUE,TRUE,TRUE,TRUE,FALSE), +#' values=c(1,1,1,1,1,1,0), +#' labels =c("meanx1","meanx2","meanx3","meanx4","meanx5","meanx6",NA) +#' ) +#' # means +#' # ------------------------------------- +#' ) # close model +#' # Create an MxModel object +#' # ----------------------------------------------------------------------------- +#' oneFactorFit <- mxRun(oneFactorModel) +#' standardizeMx(oneFactorFit) +#' +#' # Compare with lavaan +#' library(lavaan) +#' script <- "f1 =~ x1 + x2 + x3 + x4 + x5 + x6" +#' fit <- cfa(script, data=myFADataRaw, meanstructure=TRUE) +#' standardizedSolution(fit) +#' } +#' +#' @name standardizeMx-deprecated +#' @usage standardizeMx(object, free = TRUE) +#' @seealso \code{\link{semTools-deprecated}} +#' @keywords internal +NULL + + +#' @rdname semTools-deprecated +#' @section \code{standardizeMx}: +#' The \code{standardizeMx} and \code{fitMeasuresMx} functions will no longer +#' be supported, nor will there be replacement functions. Their functionality +#' is now available in the \pkg{OpenMx} package, making these functions +#' obsolete. The utility functions \code{nullMx} and \code{saturateMx} will +#' also no longer be supported. These have already been removed from +#' \pkg{semTools}, except that \code{standardizeMx} remains deprecated due to +#' the temporary depndency on it of the \pkg{semPlot} package. The exception +#' is that \code{\link[OpenMx]{mxStandardizeRAMpaths}} currently only provides +#' standardized estimates of covariance-structure parameters, whereas +#' \code{standardizeMx} also provides standardized means. +#' +#' @export +standardizeMx <- function(object, free = TRUE) { + # objectOrig <- object + multigroup <- length(object@submodels) > 0 + if(multigroup) { + defVars <- lapply(object@submodels, findDefVars) + defVars <- do.call(c, defVars) + } else { + defVars <- findDefVars(object) + } + if(length(defVars) > 0) stop("The standardizeMx is not available for the model with definition variable.") + if(multigroup) { + object@submodels <- lapply(object@submodels, standardizeMxSingleGroup) + } else { + object <- standardizeMxSingleGroup(object) + } + vectorizeMx(object, free=free) +} + +## ---------------- +## Hidden functions +## ---------------- + +findDefVars <- function(object) { + ## borrowed from OpenMx::imxIsDefinitionVariable + imxSeparatorChar <- "." + imxIsDefinitionVariable <- function (name) { + if (is.na(name)) { + return(FALSE) + } + components <- unlist(strsplit(name, imxSeparatorChar, fixed = TRUE)) + if (length(components) == 2 && components[[1]] == "data") { + return(TRUE) + } + else if (length(components) > 2 && components[[2]] == "data") { + return(TRUE) + } + else { + return(FALSE) + } + } + ## end borrowed code + mat <- lapply(object@matrices, slot, "labels") + defvars <- sapply(mat, function(x) x[apply(x, c(1,2), imxIsDefinitionVariable)]) + Reduce("c", defvars) +} + +vectorizeMx <- function(object, free = TRUE) { + multigroup <- length(object@submodels) > 0 + if(multigroup) { + object <- object@submodels + } else { + object <- list(object) + } + result <- NULL + for(i in seq_along(object)) { + name <- "" + if(multigroup) name <- paste0(object[[i]]@name, ".") + mat <- object[[i]]@matrices + for(j in seq_along(mat)) { + tempname <- paste0(name, mat[[j]]@name) + lab <- mat[[j]]@labels + tempfree <- as.vector(mat[[j]]@free) + madeLab <- paste0(tempname, "[", row(lab), ",", col(lab), "]") + lab <- as.vector(lab) + madeLab[!is.na(lab)] <- lab[!is.na(lab)] + if(!free) tempfree <- rep(TRUE, length(tempfree)) + temp <- mat[[j]]@values[tempfree] + names(temp) <- madeLab[tempfree] + result <- c(result, temp) + } + } + + result[!duplicated(names(result))] +} + +standardizeMxSingleGroup <- function(object) { + if (!is(object@expectation, "MxExpectationRAM")) + stop("The standardizeMx function is available for the MxExpectationRAM only.") + A <- object@matrices$A@values + I <- diag(nrow(A)) + S <- object@matrices$S@values + # F <- object@matrices$F@values + Z <- solve(I - A) + impliedCov <- Z %*% S %*% t(Z) + temp <- sqrt(diag(impliedCov)) + if (length(temp) == 1) { + ImpliedSd <- as.matrix(temp) + } else { + ImpliedSd <- diag(temp) + } + ImpliedInvSd <- solve(ImpliedSd) + object@matrices$S@values <- ImpliedInvSd %*% S %*% ImpliedInvSd + object@matrices$A@values <- ImpliedInvSd %*% A %*% ImpliedSd + if (!is.null(object@matrices$M)) { + M <- object@matrices$M@values + object@matrices$M@values <- M %*% ImpliedInvSd + } + object +} + + diff -Nru r-cran-semtools-0.4.14/R/TSML.R r-cran-semtools-0.5.0/R/TSML.R --- r-cran-semtools-0.4.14/R/TSML.R 2016-10-20 10:00:48.000000000 +0000 +++ r-cran-semtools-0.5.0/R/TSML.R 2018-06-26 12:13:43.000000000 +0000 @@ -1,211 +1,124 @@ ## Terrence D. Jorgensen -### Last updated: 14 October 2016 +### Last updated: 26 June 2018 ### 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 \code{summary}, \code{anova}, \code{vcov} +#' methods return corrected \emph{SE}s and test statistics. Other methods are +#' simply wrappers around the corresponding \code{\linkS4class{lavaan}} +#' 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 \code{\linkS4class{lavaan}} object containing the +#' saturated model results +#' @slot target A fitted \code{\linkS4class{lavaan}} object containing the +#' target/hypothesized model results +#' @slot baseline A fitted \code{\linkS4class{lavaan}} object containing the +#' baseline/null model results +#' @slot auxNames A character string (potentially of \code{length == 0}) of any +#' auxiliary variable names, if used +#' +#' @param object An object of class \code{twostage}. +#' @param ... arguments passed to \code{\link[lavaan]{parameterEstimates}}. +#' @param 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 \bold{Value} section for details). +#' @param baseline \code{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 \bold{Value} section +#' under \code{coef}, \code{nobs}, and \code{residuals}. +#' @param model \code{character} naming the slot for which to return the +#' model-implied sample moments (see \code{fitted.values} description.) +#' @param labels \code{logical} indicating whether the model-implied sample +#' moments should have (row/column) labels. +#' +#' @return +#' \item{show}{\code{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}{\code{signature(object = "twostage", ...):} The summary +#' function prints the same information from the \code{show} method, but also +#' provides (and returns) the output of +#' \code{\link[lavaan]{parameterEstimates}(object@target, ...)} with corrected +#' \emph{SE}s, test statistics, and confidence intervals. Additional +#' arguments can be passed to \code{\link[lavaan]{parameterEstimates}}, +#' including \code{fmi = TRUE} to provide an estimate of the fraction of +#' missing information.} +#' \item{anova}{\code{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}{\code{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}{\code{signature(object = "twostage", type = c("free", "user")):} +#' This is simply a wrapper around the corresponding +#' \code{\linkS4class{lavaan}} method, providing point estimates from the +#' \code{target} slot.} +#' \item{vcov}{\code{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}{\code{signature(object = "twostage", +#' model = c("target", "saturated", "baseline")):} This is simply a wrapper +#' around the corresponding \code{\linkS4class{lavaan}} method, providing +#' model-implied sample moments from the slot specified in the \code{model} +#' argument.} +#' \item{residuals, resid}{\code{signature(object = "twostage", type = c("raw", +#' "cor", "normalized", "standardized")):} This is simply a wrapper around the +#' corresponding \code{\linkS4class{lavaan}} method, providing residuals of +#' the specified \code{type} from the \code{target} slot.} +#' +#' @section Objects from the Class: Objects can be created via the +#' \code{\link{twostage}} function. +#' +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' +#' @seealso \code{\link{twostage}} +#' +#' @examples +#' +#' # See the example from the twostage function +#' setClass("twostage", slots = c(saturated = "lavaan", target = "lavaan", baseline = "lavaan", auxNames = "character")) -cfa.2stage <- function(..., aux = NULL, baseline.model = NULL) { - twostage(..., aux = aux, fun = "cfa", baseline.model = baseline.model) -} - -sem.2stage <- function(..., aux = NULL, baseline.model = NULL) { - twostage(..., aux = aux, fun = "sem", baseline.model = baseline.model) -} - -growth.2stage <- function(..., aux = NULL, baseline.model = NULL) { - twostage(..., aux = aux, fun = "growth", baseline.model = baseline.model) -} - -lavaan.2stage <- function(..., aux = NULL, baseline.model = NULL) { - twostage(..., aux = aux, fun = "lavaan", baseline.model = baseline.model) -} - -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)))] - funArgs <- dots[intersect(names(dots), names(formals(lavaan::lavaan)))] - ## 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 == "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 <- lavaan::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 <- lavaan::lavInspect(satFit, "cov.ov") - targetArgs$sample.mean <- lavaan::lavInspect(satFit, "mean.ov") - targetArgs$sample.nobs <- lavaan::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 -} - -## methods -setMethod("coef", "twostage", function(object, type = c("free","user")) { - type <- type[1] - lavaan::coef(object@target, type = type) -}) - -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) -}) -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) -}) - -setMethod("residuals", "twostage", function(object, type = c("raw","cor","normalized","standardized")) { - type <- type[1] - lavaan::residuals(object@target, type = type) -}) -setMethod("resid", "twostage", function(object, type = c("raw","cor","normalized","standardized")) { - type <- type[1] - lavaan::residuals(object@target, type = type) -}) - -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" - lavaan::lavInspect(object@saturated, what = type) -}) - -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 -}) - -## chi-squared test results (difference tests not available yet) -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 (lavaan::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 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") @@ -215,6 +128,12 @@ 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) @@ -223,7 +142,7 @@ 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 <- lavaan::parTable(object@target) + 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))) @@ -247,15 +166,17 @@ PE }) -## (hidden?) function utilized by vcov and anova methods + +## (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 <- lavaan::parTable(object@saturated) + PTsat <- parTable(object@saturated) nG <- max(PTsat$group) isMG <- nG > 1L ## model derivatives - delta <- lavaan::lavInspect(slot(object, SLOT), "delta") + delta <- lavInspect(slot(object, SLOT), "delta") if (!isMG) delta <- list(delta) for (g in 1:nG) { covparams <- grep(pattern = "~~", x = rownames(delta[[g]])) @@ -266,8 +187,8 @@ delta <- do.call(rbind, delta) ## extract estimated moments from saturated model, and number of moments - satSigma <- lavaan::lavInspect(object@saturated, "cov.ov") - satMu <- lavaan::lavInspect(object@saturated, "mean.ov") + satSigma <- lavInspect(object@saturated, "cov.ov") + satMu <- lavInspect(object@saturated, "mean.ov") if (!isMG) { satSigma <- list(satSigma) satMu <- list(satMu) @@ -283,8 +204,8 @@ p <- length(satMu[[1]]) pStar <- p*(p + 1) / 2 ## extract model-implied moments - muHat <- lavaan::lavInspect(slot(object, SLOT), "mean.ov") - sigmaHat <- lavaan::lavInspect(slot(object, SLOT), "cov.ov") + muHat <- lavInspect(slot(object, SLOT), "mean.ov") + sigmaHat <- lavInspect(slot(object, SLOT), "cov.ov") if (!isMG) { sigmaHat <- list(sigmaHat) muHat <- list(muHat) @@ -299,13 +220,13 @@ H <- list() for (g in 1:nG) H[[g]] <- matrix(0, (pStar + p), (pStar + p)) - if (lavaan::lavInspect(slot(object, SLOT), "options")$estimator == "expected") { + if (lavInspect(slot(object, SLOT), "options")$estimator == "expected") { 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 { - ## estimator == "observed" + ## estimator == "observed" dMu <- list() for (g in 1:nG) { dMu[[g]] <- satMu[[g]] - muHat[[g]] @@ -324,31 +245,33 @@ ## 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) + 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 <- lavaan::lavInspect(slot(object, SLOT), "ngroups") + 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 <- lavaan::lavInspect(slot(object, SLOT), "fit")[["df"]] + 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") @@ -357,7 +280,7 @@ meat <- MATS$H %*% MATS$delta bread <- MASS::ginv(t(MATS$delta) %*% meat) # FIXME: why not solve()? cc <- DF / sum(diag(MATS$satACOV %*% (MATS$H - meat %*% bread %*% t(meat)))) - chisq <- lavaan::lavInspect(slot(object, SLOT), "fit")[["chisq"]] + chisq <- lavInspect(slot(object, SLOT), "fit")[["chisq"]] T.scaled <- cc * chisq pval.scaled <- pchisq(T.scaled, df = DF, lower.tail = FALSE) scaled <- c(chisq.naive = chisq, scaling.factor = 1 / cc, @@ -366,7 +289,7 @@ ## return both statistics if (print) { - if (lavaan::lavInspect(object@saturated, "options")$se == "standard") { + if (lavInspect(object@saturated, "options")$se == "standard") { cat("Browne (1984) residual-based test statistic:\n\n") print(residual) } @@ -376,8 +299,373 @@ 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 (\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). +#' +#' 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}}, +#' this function will automatically set \code{meanstructure = TRUE}, +#' \code{estimator = "ML"}, \code{missing = "fiml"}, and \code{test = +#' "standard"}. \code{\link[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. +#' +#' +#' @aliases twostage cfa.2stage sem.2stage growth.2stage lavaan.2stage +#' @importFrom lavaan lavInspect +#' +#' @param \dots Arguments passed to the \code{\link[lavaan]{lavaan}} function +#' specified in the \code{fun} argument. See also +#' \code{\link[lavaan]{lavOptions}}. At a minimum, the user must supply the +#' first two named arguments to \code{\link[lavaan]{lavaan}} (i.e., +#' \code{model} and \code{data}). +#' @param aux An optional character vector naming auxiliary variable(s) in +#' \code{data} +#' @param 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"}). +#' @param baseline.model An optional character string, specifying the lavaan +#' \code{\link[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 \code{\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. +#' @return The \code{\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 \code{\linkS4class{twostage}} to extract corrected +#' \emph{SE}s and test statistics. +#' @author Terrence D. Jorgensen (University of Amsterdam; +#' \email{TJorgensen314@@gmail.com}) +#' @seealso \code{\linkS4class{twostage}} +#' @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 +#' @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'.") + ####################### FIXME: also check intersect(names(dots), names(lavOptions())) + lavaanifyArgs <- dots[intersect(names(dots), names(formals(lavaan::lavaanify)))] + funArgs <- dots[intersect(names(dots), names(formals(lavaan::lavaan)))] + ## 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 == "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) +} + + diff -Nru r-cran-semtools-0.4.14/R/tukeySEM.R r-cran-semtools-0.5.0/R/tukeySEM.R --- r-cran-semtools-0.4.14/R/tukeySEM.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/tukeySEM.R 2018-05-01 13:33:39.000000000 +0000 @@ -1,28 +1,70 @@ -############################################# -## tukeySEM -- a function to compute ## -## tukey's post-hoc test with unequal ## -## sample sizes and variances ## -## ## -## Alexander M. Schoemann ## -## Last edited on 01/16/2013 ## -############################################# +### Alexander M. Schoemann +### Last updated: 9 March 2018 -##inputs: mean of group 1, mean of group2, variance of group 1, variance of group 2 -## sample size or group1, sample size of group2, number of groups in the ANOVA -##Output: vector containing the q statistic, degrees of freedom, and associated p value -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-2))) -p <- 1- ptukey(Tukeyq, ng, Tukeydf) -cols <- c("q", "df", "p") -res <- c(Tukeyq, Tukeydf, p) -names(res) <- cols -res +#' 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 \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 +#' } +#' @author Alexander M. Schoemann (East Carolina University; +#' \email{schoemanna@@ecu.edu}) +#' @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. +#' @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 - 2))) + 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) + diff -Nru r-cran-semtools-0.4.14/R/wald.R r-cran-semtools-0.5.0/R/wald.R --- r-cran-semtools-0.4.14/R/wald.R 2016-10-14 16:05:05.000000000 +0000 +++ r-cran-semtools-0.5.0/R/wald.R 1970-01-01 00:00:00.000000000 +0000 @@ -1,78 +0,0 @@ - -wald <- function(object, syntax) { - model <- unlist( strsplit(syntax, "\n") ) - - # remove comments starting with '#' or '!' - model <- gsub("#.*","", model); model <- gsub("!.*","", model) - - # replace semicolons by newlines and split in lines again - model <- gsub(";","\n", model); model <- unlist( strsplit(model, "\n") ) - - # strip all white space - model <- gsub("[[:space:]]+", "", model) - - # keep non-empty lines only - idx <- which(nzchar(model)) - model <- model[idx] - - beta <- lavaan::coef(object) - contrast <- matrix(0, length(model), length(beta)) - - for(i in 1:length(model)) { - rhs <- model[i] - out <- NULL - sign <- NULL - if(substr(rhs, 1, 1) == "-") { - sign <- "-" - rhs <- substr(rhs, 2, nchar(rhs)) - } else { - sign <- "+" - } - cont <- TRUE - while(cont) { - pos <- regexpr("[+-]", rhs) - if(pos == -1) { - out <- c(out, rhs) - cont <- FALSE - } else { - out <- c(out, substr(rhs, 1, pos - 1)) - sign <- c(sign, substr(rhs, pos, pos)) - rhs <- substr(rhs, pos + 1, nchar(rhs)) - } - } - - num <- rep(NA, length(out)) - vname <- rep(NA, length(out)) - for(j in seq_along(out)) { - pos <- regexpr("[*]", out[j]) - tmp <- 1 - if(pos == -1) { - vname[j] <- out[j] - } else { - tmp <- substr(out[j], 1, pos-1) - vname[j] <- substr(out[j], pos + 1, nchar(out[j])) - } - if(is.character(tmp) && regexpr("[/^]", tmp) != -1) tmp <- eval(parse(text = tmp)) - if(is.character(tmp)) tmp <- as.numeric(tmp) - num[j] <- tmp - if(sign[j] == "-") num[j] <- -num[j] - } - posmatch <- match(vname, names(beta)) - if(any(is.na(posmatch))) { - stop(paste("Unknown parameters:", paste(vname[is.na(posmatch)], collapse = ", "))) - } - contrast[i,posmatch] <- num - } - result <- waldContrast(object, contrast) - print(round(result, 6)) - invisible(result) -} - -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) -} \ No newline at end of file