diff --git a/DESCRIPTION b/DESCRIPTION index 770d8c43..d4396631 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: lavaan Title: Latent Variable Analysis -Version: 0.6-2.1265 +Version: 0.6-2.1268 Authors@R: c(person(given = "Yves", family = "Rosseel", role = c("aut", "cre"), email = "Yves.Rosseel@UGent.be"), diff --git a/R/00class.R b/R/00class.R index 78a20195..ea569d3e 100644 --- a/R/00class.R +++ b/R/00class.R @@ -1,5 +1,5 @@ # class definitions -# +# # initial version: YR 25/03/2009 # added ModelSyntax: YR 02/08/2010 # deleted ModelSyntax: YR 01/11/2010 (using flattened model syntax now) @@ -50,7 +50,7 @@ setClass("lavSampleStats", # sample moments res.var="list", # residual variances res.th="list", # residual thresholds res.th.nox="list", # residual thresholds ignoring x - res.slopes="list", # slopes exo (if conditional.x) + res.slopes="list", # slopes exo (if conditional.x) res.int="list", # intercepts (if conditional.x) mean.x="list", # mean exo @@ -191,7 +191,7 @@ setClass("lavaan", SampleStats = "lavSampleStats", # sample statistics Model = "lavModel", # internal matrix representation Cache = "list", # housekeeping stuff - Fit = "Fit", # fitted results + Fit = "Fit", # fitted results boot = "list", # bootstrap results optim = "list", # optimizer results loglik = "list", # loglik values and info @@ -201,7 +201,7 @@ setClass("lavaan", h1 = "list", # unrestricted model results baseline = "list", # baseline model results external = "list" # optional slot, for add-on packages - ) + ) ) setClass("lavaanList", @@ -234,4 +234,4 @@ setClass("lavaanList", - + diff --git a/R/00generic.R b/R/00generic.R index 6670374e..850f7e53 100644 --- a/R/00generic.R +++ b/R/00generic.R @@ -1,9 +1,9 @@ # for blavaan -setGeneric("fitMeasures", - function(object, fit.measures = "all", baseline.model = NULL) +setGeneric("fitMeasures", + function(object, fit.measures = "all", baseline.model = NULL) standardGeneric("fitMeasures")) setGeneric("fitmeasures", - function(object, fit.measures = "all", baseline.model = NULL) + function(object, fit.measures = "all", baseline.model = NULL) standardGeneric("fitmeasures")) diff --git a/R/01RefClass_00lavRefModel.R b/R/01RefClass_00lavRefModel.R index 29b0e056..aab3f58e 100644 --- a/R/01RefClass_00lavRefModel.R +++ b/R/01RefClass_00lavRefModel.R @@ -1,7 +1,7 @@ # generic statistical model -- YR 10 july 2012 -# super class -- virtual statistical model +# super class -- virtual statistical model lavRefModel <- setRefClass("lavRefModel", # fields diff --git a/R/01RefClass_01lavOptim.R b/R/01RefClass_01lavOptim.R index 4dbbcdf8..127b8383 100644 --- a/R/01RefClass_01lavOptim.R +++ b/R/01RefClass_01lavOptim.R @@ -32,7 +32,7 @@ minGradient = function(x) { minHessian = function(x) { cat("this is dummy a function [minHessian]\n") return(matrix(as.numeric(NA), npar, npar)) -}, +}, optimize = function(method = "nlminb", control = list(), verbose = FALSE, start.values = NULL) { @@ -40,7 +40,7 @@ optimize = function(method = "nlminb", control = list(), verbose = FALSE, hessian <- FALSE if( method == "none" ) { .self$optim.method <- "none" - } else if( method %in% c("nlminb", "quasi-newton", "quasi.newton", + } else if( method %in% c("nlminb", "quasi-newton", "quasi.newton", "nlminb.hessian") ) { .self$optim.method <- "nlminb" if(verbose) @@ -59,7 +59,7 @@ optimize = function(method = "nlminb", control = list(), verbose = FALSE, .self$optim.control <- control.nlminb[c("eval.max", "iter.max", "trace", "abs.tol", "rel.tol", "x.tol", "step.min")] - + } else if( method %in% c("newton", "newton-raphson", "newton.raphson") ) { .self$optim.method <- "newton" if(verbose) @@ -76,7 +76,7 @@ optimize = function(method = "nlminb", control = list(), verbose = FALSE, } # user provided starting values? - if(!is.null(start.values)) { + if(!is.null(start.values)) { stopifnot(length(start.values) == npar) .self$theta.start <- start.values } @@ -94,14 +94,14 @@ optimize = function(method = "nlminb", control = list(), verbose = FALSE, gradient = .self$minGradient, control = optim.control) } else { out <- nlminb(start = theta, objective = .self$minObjective, - gradient = .self$minGradient, + gradient = .self$minGradient, hessian = .self$minHessian, control = optim.control) } # FIXME: use generic fields .self$optim.out <- out } - # just in case, a last call to objective() + # just in case, a last call to objective() tmp <- minObjective() } @@ -114,10 +114,10 @@ optimize = function(method = "nlminb", control = list(), verbose = FALSE, # - it assumes that the hessian is always positive definite (no check!) # - it may do some backstepping, but there is no guarantee that it will # converge -# this function is NOT for general-purpose optimization, but should only be -# used or simple (convex!) problems (eg. estimating polychoric/polyserial +# this function is NOT for general-purpose optimization, but should only be +# used or simple (convex!) problems (eg. estimating polychoric/polyserial # correlations, probit regressions, ...) -# +# lavOptimNewtonRaphson <- function(object, control = list(iter.max = 100L, grad.tol = 1e-6, @@ -140,8 +140,8 @@ lavOptimNewtonRaphson <- function(object, for(i in seq_len(control$iter.max)) { if(control$verbose) { - cat("NR step ", sprintf("%2d", (i-1L)), ": max.grad = ", - sprintf("%12.9f", max.grad), " norm.grad = ", + cat("NR step ", sprintf("%2d", (i-1L)), ": max.grad = ", + sprintf("%12.9f", max.grad), " norm.grad = ", sprintf("%12.9f", norm.grad), "\n", sep="") } diff --git a/R/01RefClass_02lavML.R b/R/01RefClass_02lavML.R index c836c401..fd53e475 100644 --- a/R/01RefClass_02lavML.R +++ b/R/01RefClass_02lavML.R @@ -33,7 +33,7 @@ scores = function(x) { if(!missing(x)) .self$theta <- x cat("this is dummy function\n") return(matrix(as.numeric(NA), nobs, npar)) -}, +}, gradient = function(x) { SCORES <- scores(x) diff --git a/R/ctr_estfun.R b/R/ctr_estfun.R index 260739e3..ba293697 100644 --- a/R/ctr_estfun.R +++ b/R/ctr_estfun.R @@ -1,15 +1,15 @@ # contributed by Ed Merkle (17 Jan 2013) -# YR 12 Feb 2013: small changes to match the results of lav_model_gradient +# YR 12 Feb 2013: small changes to match the results of lav_model_gradient # in the multiple group case # YR 30 May 2014: handle 1-variable case (fixing apply in lines 56, 62, 108) -# YR 05 Nov 2015: add remove.duplicated = TRUE, to cope with strucchange in +# YR 05 Nov 2015: add remove.duplicated = TRUE, to cope with strucchange in # case of simple equality constraints # YR 19 Nov 2015: if constraints have been used, compute case-wise Lagrange # multipliers, and define the scores as: SC + (t(R) lambda) # YR 05 Feb 2016: catch conditional.x = TRUE: no support (for now), until -# we can use the generic 0.6 infrastructure for scores, +# we can use the generic 0.6 infrastructure for scores, # including the missing-values case # YR 16 Feb 2016: adapt to changed @Mp slot elements; add remove.empty.cases= # argument @@ -21,7 +21,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, stopifnot(inherits(object, "lavaan")) - # what if estimator != ML? + # what if estimator != ML? # avoid hard error (using stop); throw a warning, and return an empty matrix if(object@Options$estimator != "ML") { warning("lavaan WARNING: scores only availalbe if estimator is ML") @@ -53,7 +53,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, # npar <- NCOL(object@Model@eq.constraints.K) #} Score.mat <- matrix(NA, ntot, npar) - + for(g in 1:lavsamplestats@ngroups) { if (lavsamplestats@ngroups > 1){ moments <- fitted(object)[[g]] @@ -67,7 +67,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, } else { N1 <- 1 } - + if(!lavsamplestats@missing.flag) { # complete data #if(lavmodel@meanstructure) { # mean structure nvar <- ncol(lavsamplestats@cov[[g]]) @@ -115,7 +115,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, nvar <- ncol(lavsamplestats@cov[[g]]) score.sigma <- matrix(0, nsub, nvar*(nvar+1)/2) score.mu <- matrix(0, nsub, nvar) - + for(p in 1:length(M)) { ## Data #X <- M[[p]][["X"]] @@ -127,7 +127,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, ## (Used to keep track of scores in score.sigma) var.idx.mat <- tcrossprod(var.idx) Sigma.idx <- which(var.idx.mat[lower.tri(var.idx.mat, diag=T)]==1) - + J <- matrix(1, 1L, nobs) #[var.idx] J2 <- matrix(1, nvar, nvar)[var.idx, var.idx, drop = FALSE] diag(J2) <- 0.5 @@ -148,7 +148,7 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, scores.H1 <- group.w[g] * scores.H1 } } # missing - + Delta <- computeDelta(lavmodel = lavmodel)[[g]] #if(lavmodel@eq.constraints) { # Delta <- Delta %*% lavmodel@eq.constraints.K # + lavmodel@eq.constraints.k0 @@ -160,12 +160,12 @@ estfun.lavaan <- lavScores <- function(object, scaling = FALSE, if(scaling){ Score.mat[wi,] <- (-1/ntot) * Score.mat[wi,] } - + } # g # handle empty rows if(remove.empty.cases) { - #empty.idx <- which( apply(Score.mat, 1L, + #empty.idx <- which( apply(Score.mat, 1L, # function(x) sum(is.na(x))) == ncol(Score.mat) ) empty.idx <- unlist(lapply(lavdata@Mp, "[[", "empty.idx")) if(length(empty.idx) > 0L) { diff --git a/R/ctr_informative_testing.R b/R/ctr_informative_testing.R index 10199e5d..cd7e13cb 100644 --- a/R/ctr_informative_testing.R +++ b/R/ctr_informative_testing.R @@ -1,66 +1,66 @@ # This code is contributed by Leonard Vanbrabant -InformativeTesting <- function(model = NULL, data, constraints = NULL, +InformativeTesting <- function(model = NULL, data, constraints = NULL, R = 1000L, type = "bollen.stine", - return.LRT = TRUE, + return.LRT = TRUE, double.bootstrap = "standard", double.bootstrap.R = 249, double.bootstrap.alpha = 0.05, - parallel = c("no", "multicore", "snow"), + parallel = c("no", "multicore", "snow"), ncpus = 1L, cl = NULL, verbose = FALSE, ...){ - + fit.B1 <- sem(model, ..., - data = data, - se = "none", - test = "standard") - + data = data, + se = "none", + test = "standard") + fit.B0 <- fit.A1 <- sem(model, ..., - data = data, - se = "none", - test = "standard", - constraints = constraints) - + data = data, + se = "none", + test = "standard", + constraints = constraints) + con.idx <- (max(fit.B1@ParTable$id) + 1L):max(fit.A1@ParTable$id) - + user.equal <- fit.A1@ParTable user.equal$op[con.idx] <- "==" - + fit.A0 <- sem(user.equal, ..., - data = data, - se = "none", + data = data, + se = "none", test = "standard") - - lrt.bootA <- bootstrapLRT(fit.A0, fit.A1, - R = R, - type = type, + + lrt.bootA <- bootstrapLRT(fit.A0, fit.A1, + R = R, + type = type, verbose = verbose, - return.LRT = return.LRT, + return.LRT = return.LRT, double.bootstrap = double.bootstrap, - double.bootstrap.R = double.bootstrap.R, + double.bootstrap.R = double.bootstrap.R, double.bootstrap.alpha = double.bootstrap.alpha, - parallel = parallel, - ncpus = ncpus, + parallel = parallel, + ncpus = ncpus, cl = cl) - - lrt.bootB <- bootstrapLRT(fit.B0, fit.B1, - R = R, - type = type, + + lrt.bootB <- bootstrapLRT(fit.B0, fit.B1, + R = R, + type = type, verbose = verbose, - return.LRT = return.LRT, + return.LRT = return.LRT, double.bootstrap = double.bootstrap, - double.bootstrap.R = double.bootstrap.R, + double.bootstrap.R = double.bootstrap.R, double.bootstrap.alpha = double.bootstrap.alpha, - parallel = parallel, - ncpus = ncpus, + parallel = parallel, + ncpus = ncpus, cl = cl) - + output <- list(fit.A0 = fit.A0, fit.A1 = fit.A1, fit.B1 = fit.B1, lrt.bootA = lrt.bootA, lrt.bootB = lrt.bootB, double.bootstrap = double.bootstrap, double.bootstrap.alpha = double.bootstrap.alpha, return.LRT = return.LRT, type = type) - + class(output) <- "InformativeTesting" - + return(output) } @@ -68,9 +68,9 @@ InformativeTesting <- function(model = NULL, data, constraints = NULL, print.InformativeTesting <- function(x, digits = max(3, getOption("digits") - 3), ...) { object <- x cat("\nInformativeTesting: Order/Inequality Constrained Hypothesis Testing:\n\n") - cat(" Variable names in model :", unlist(object$fit.A1@Data@ov.names[1]), "\n") - cat(" Number of variables :", object$fit.A1@Model@nvar[1], "\n") - cat(" Number of groups :", object$fit.A1@Data@ngroups, "\n") + cat(" Variable names in model :", unlist(object$fit.A1@Data@ov.names[1]), "\n") + cat(" Number of variables :", object$fit.A1@Model@nvar[1], "\n") + cat(" Number of groups :", object$fit.A1@Data@ngroups, "\n") cat(" Used sample size per group :", unlist(object$fit.A1@Data@nobs), "\n") cat(" Used sample size :", sum(unlist(object$fit.A1@Data@nobs)), "\n") cat(" Total sample size :", sum(unlist(object$fit.A1@Data@norig)), "\n\n") @@ -78,7 +78,7 @@ print.InformativeTesting <- function(x, digits = max(3, getOption("digits") - 3) cat(" Missing data :", object$fit.A1@Options$missing, "\n") cat(" Bootstrap method :", object$type, "\n") cat(" Double bootstrap method :", object$double.bootstrap, "\n") - + dbtype <- object$double.bootstrap # original LRT for hypothesis test Type A TsA <- attr(object$lrt.bootA, "LRT.original") @@ -88,19 +88,19 @@ print.InformativeTesting <- function(x, digits = max(3, getOption("digits") - 3) pvalueA <- object$lrt.bootA[1] pvalueB <- object$lrt.bootB[1] alpha <- object$double.bootstrap.alpha - + ### if (dbtype == "no") { - cat("\n\n Type A test: H0: all restriktions active (=)", "\n", + cat("\n\n Type A test: H0: all restriktions active (=)", "\n", " vs. H1: at least one restriktion strictly true (>)", "\n") - cat(" Test statistic: ", format(round(TsA, digits), nsmall = digits), ", unadjusted p-value: ", + cat(" Test statistic: ", format(round(TsA, digits), nsmall = digits), ", unadjusted p-value: ", if (pvalueA < 1e-04) { "<0.0001" } else { format(round(pvalueA, digits), nsmall = digits)}, " (alpha = ", alpha, ") ", "\n\n", sep = "") - cat(" Type B test: H0: all restriktions true", "\n", + cat(" Type B test: H0: all restriktions true", "\n", " vs. H1: at least one restriktion false", "\n") - cat(" Test statistic: ", format(round(TsB, digits), nsmall = digits), ", unadjusted p-value: ", + cat(" Test statistic: ", format(round(TsB, digits), nsmall = digits), ", unadjusted p-value: ", if (pvalueB < 1e-04) { "<0.0001" } else { @@ -109,22 +109,22 @@ print.InformativeTesting <- function(x, digits = max(3, getOption("digits") - 3) # adjusted pvalues for Ts adj.pvalueA <- attr(object$lrt.bootA, "adj.pvalue") adj.pvalueB <- attr(object$lrt.bootB, "adj.pvalue") - cat("\n\n Type A test: H0: all restriktions active (=)", "\n", + cat("\n\n Type A test: H0: all restriktions active (=)", "\n", " vs. H1: at least one restriktion strictly true (>)", "\n") - cat(" Test statistic: ", format(round(TsA, digits), nsmall = digits), ", adjusted p-value: ", + cat(" Test statistic: ", format(round(TsA, digits), nsmall = digits), ", adjusted p-value: ", if (adj.pvalueA < 1e-04) { "<0.0001" } else { - format(round(adj.pvalueA, digits), nsmall = digits)}, " (alpha = ", + format(round(adj.pvalueA, digits), nsmall = digits)}, " (alpha = ", alpha, ") ", "\n\n", sep = "") - cat(" Type B test: H0: all restriktions true", "\n", + cat(" Type B test: H0: all restriktions true", "\n", " vs. H1: at least one restriktion false", "\n") - cat(" Test statistic: ", format(round(TsB, digits), - nsmall = digits), ", adjusted p-value: ", + cat(" Test statistic: ", format(round(TsB, digits), + nsmall = digits), ", adjusted p-value: ", if (adj.pvalueB < 1e-04) { "<0.0001" } else { - format(round(adj.pvalueB, digits), nsmall = digits)}, " (alpha = ", + format(round(adj.pvalueB, digits), nsmall = digits)}, " (alpha = ", alpha, ") ", "\n", sep = "") } else if (dbtype == "standard") { # adjusted nominal levels @@ -133,43 +133,43 @@ print.InformativeTesting <- function(x, digits = max(3, getOption("digits") - 3) # adjusted pvalues for Ts adj.pvalueA <- attr(object$lrt.bootA, "adj.pvalue") adj.pvalueB <- attr(object$lrt.bootB, "adj.pvalue") - cat("\n\n Type A test: H0: all restriktions active (=)", "\n", + cat("\n\n Type A test: H0: all restriktions active (=)", "\n", " vs. H1: at least one restriktion strictly true (>)", "\n") - cat(" Test statistic: ", format(round(TsA, digits), - nsmall = digits), ", adjusted p-value: ", + cat(" Test statistic: ", format(round(TsA, digits), + nsmall = digits), ", adjusted p-value: ", if (adj.pvalueA < 1e-04) { "<0.0001" } else { format(round(adj.pvalueA, digits), nsmall = digits)}, " (alpha = ", alpha, ") ", "\n", sep = "") - cat(" ", "unadjusted p-value: ", + cat(" ", "unadjusted p-value: ", if (pvalueA < 1e-04) { "<0.0001" } else { - format(round(pvalueA, digits), nsmall = digits)}, " (alpha = ", + format(round(pvalueA, digits), nsmall = digits)}, " (alpha = ", format(round(adj.alphaA, digits), nsmall = digits), ") ", "\n\n", sep = "") - cat(" Type B test: H0: all restriktions true", "\n", + cat(" Type B test: H0: all restriktions true", "\n", " vs. H1: at least one restriktion false", "\n") - cat(" Test statistic: ", format(round(TsB, digits), nsmall = digits), ", adjusted p-value: ", + cat(" Test statistic: ", format(round(TsB, digits), nsmall = digits), ", adjusted p-value: ", if (adj.pvalueB < 1e-04) { "<0.0001" } else { format(round(adj.pvalueB, digits), nsmall = digits)}, " (alpha = ", alpha, ") ", "\n", sep = "") - cat(" ", "unadjusted p-value: ", + cat(" ", "unadjusted p-value: ", if (pvalueB < 1e-04) { "<0.0001" } else { - format(round(pvalueB, digits), nsmall = digits)}, " (alpha = ", + format(round(pvalueB, digits), nsmall = digits)}, " (alpha = ", format(round(adj.alphaB, digits), nsmall = digits), ") ", "\n\n", sep = "") } - + if (dbtype == "no") { cat("\n No double bootstrap method is set. The results may be spurious.\n\n") } - + } -plot.InformativeTesting <- function(x, ..., +plot.InformativeTesting <- function(x, ..., type = c("lr", "ppv"), main = "main", xlab = "xlabel", @@ -181,8 +181,8 @@ plot.InformativeTesting <- function(x, ..., cex.axis = 1, col = "grey", border = par("fg"), - vline = TRUE, - vline.col = c("red", "blue"), + vline = TRUE, + vline.col = c("red", "blue"), lty = c(1,2), lwd = 1, legend = TRUE, @@ -194,155 +194,155 @@ plot.InformativeTesting <- function(x, ..., double.bootstrap <- object$double.bootstrap double.bootstrap.alpha <- object$double.bootstrap.alpha pvalue <- c(object$lrt.bootA[1], object$lrt.bootB[1]) - + par(mfrow = c(1, 2)) if (length(type) == 2) { par(mfrow = c(2, 2)) } - + if (return.LRT && (type == "lr" || length(type) == 2)) { - lrt.obs <- c(attr(object$lrt.bootA, "LRT.original"), + lrt.obs <- c(attr(object$lrt.bootA, "LRT.original"), attr(object$lrt.bootB, "LRT.original")) lrt.A <- attr(object$lrt.bootA, "LRT") lrt.B <- attr(object$lrt.bootB, "LRT") if (length(lrt.A) - length(lrt.B) < 0L) { - lrt <- as.data.frame(cbind(c(lrt.A, rep(as.numeric(NA), length(lrt.B) - - length(lrt.A))), lrt.B)) - } else { - lrt <- as.data.frame(cbind(lrt.A, c(lrt.B, rep(as.numeric(NA), - length(lrt.A) - + lrt <- as.data.frame(cbind(c(lrt.A, rep(as.numeric(NA), length(lrt.B) - + length(lrt.A))), lrt.B)) + } else { + lrt <- as.data.frame(cbind(lrt.A, c(lrt.B, rep(as.numeric(NA), + length(lrt.A) - length(lrt.B))))) } names(lrt) <- c("lrt.A", " lrt.B") - - if (xlab == "xlabel") { + + if (xlab == "xlabel") { xlab.lrt <- c("Bootstrapped LR values") } if (main == "main") { - main.lrt <- c("Distr. of LR values - Type A", + main.lrt <- c("Distr. of LR values - Type A", "Distr. of LR values - Type B") } - + for (i in 1:2) { - plot <- hist(lrt[,i], plot = FALSE, breaks = breaks) + plot <- hist(lrt[,i], plot = FALSE, breaks = breaks) plot(plot, ..., - freq = freq, - main = main.lrt[i], - xlab = xlab.lrt, - ylab = ylab, - cex.axis = cex.axis, - cex.main = cex.main, - cex.lab = cex.lab, - col = col, - border = border, - axes = FALSE, - xaxt = "n") - + freq = freq, + main = main.lrt[i], + xlab = xlab.lrt, + ylab = ylab, + cex.axis = cex.axis, + cex.main = cex.main, + cex.lab = cex.lab, + col = col, + border = border, + axes = FALSE, + xaxt = "n") + axis(side = 1) axis(side = 2) box(lty = 1, col = "black") - + if (vline) { - abline(v = lrt.obs[i], - col = vline.col[1], - lty = lty[1], + abline(v = lrt.obs[i], + col = vline.col[1], + lty = lty[1], lwd = lwd) - } + } if (legend) { - ppvalue <- sprintf("%.2f", pvalue[i]) + ppvalue <- sprintf("%.2f", pvalue[i]) obs.lrt <- sprintf("%.2f", lrt.obs[i]) ppval <- paste0("plug-in p value = ", ppvalue) obs.lrt <- paste0("observed LR = ", obs.lrt) legend.obj <- c(obs.lrt, ppval) if (!vline) { - legend(loc.legend, legend.obj, - lty = c(0, 0), - lwd = lwd, - cex = cex.legend, + legend(loc.legend, legend.obj, + lty = c(0, 0), + lwd = lwd, + cex = cex.legend, bty = bty) } else { - legend(loc.legend, legend.obj, - lty = c(lty[1], 0), - col = vline.col[1], - lwd = lwd, - cex = cex.legend, + legend(loc.legend, legend.obj, + lty = c(lty[1], 0), + col = vline.col[1], + lwd = lwd, + cex = cex.legend, bty = bty) } } - } + } } - + if (double.bootstrap == "standard" && (type == "ppv" || length(type) == 2)) { ppvalue.A <- attr(object$lrt.bootA, "plugin.pvalues") ppvalue.B <- attr(object$lrt.bootB, "plugin.pvalues") - adj.a <- c(quantile(ppvalue.A, double.bootstrap.alpha), + adj.a <- c(quantile(ppvalue.A, double.bootstrap.alpha), quantile(ppvalue.B, double.bootstrap.alpha)) - adj.ppv <- c(attr(object$lrt.bootA, "adj.pvalue"), + adj.ppv <- c(attr(object$lrt.bootA, "adj.pvalue"), attr(object$lrt.bootB, "adj.pvalue")) if (length(ppvalue.A) - length(ppvalue.B) < 0L) { - ppv <- as.data.frame(cbind(c(ppvalue.A, rep(NA, length(ppvalue.B) - + ppv <- as.data.frame(cbind(c(ppvalue.A, rep(NA, length(ppvalue.B) - length(ppvalue.A))), ppvalue.B)) - } else { - ppv <- as.data.frame(cbind(ppvalue.A, c(ppvalue.B, rep(NA, length(ppvalue.A) - + } else { + ppv <- as.data.frame(cbind(ppvalue.A, c(ppvalue.B, rep(NA, length(ppvalue.A) - length(ppvalue.B))))) } names(ppv) <- c("ppA", "ppB") - - if (xlab == "xlabel") { + + if (xlab == "xlabel") { xlab.ppv <- c("Bootstrapped plug-in p-values") } if (main == "main") { - main.ppv <- c("Distr. of plug-in p-values - Type A", + main.ppv <- c("Distr. of plug-in p-values - Type A", "Distr. of plug-in p-values - Type B") } - + for (i in 1:2) { - plot <- hist(ppv[,i], plot = FALSE, breaks=breaks) + plot <- hist(ppv[,i], plot = FALSE, breaks=breaks) plot(plot, ..., - freq = freq, - main = main.ppv[i], - xlab = xlab.ppv, - ylab = ylab, - cex.axis = cex.axis, - cex.main = cex.main, - cex.lab = cex.lab, - col = col, - border = border, - axes = FALSE, - xaxt = "n") - + freq = freq, + main = main.ppv[i], + xlab = xlab.ppv, + ylab = ylab, + cex.axis = cex.axis, + cex.main = cex.main, + cex.lab = cex.lab, + col = col, + border = border, + axes = FALSE, + xaxt = "n") + axis(side = 1, at = seq(0,1,0.1)) axis(side = 2) box(lty = 1, col = "black") if (vline) { - abline(v = adj.a[i], - col = vline.col[1], - lty = lty[1], + abline(v = adj.a[i], + col = vline.col[1], + lty = lty[1], lwd = lwd) - abline(v = adj.ppv[i], - col = vline.col[2], - lty = lty[2], + abline(v = adj.ppv[i], + col = vline.col[2], + lty = lty[2], lwd = lwd) } if (legend) { - adj.alpha <- sprintf("%.2f", adj.a[i]) + adj.alpha <- sprintf("%.2f", adj.a[i]) adj.pval <- sprintf("%.2f", adj.ppv[i]) adja <- paste0("Adjusted alpha = ", adj.alpha) adjp <- paste0("Adjusted p-value = ", adj.pval) legend.obj <- c(adja, adjp) if (!vline) { - legend(loc.legend, legend.obj, - lty = 0, - col = vline.col, - lwd = lwd, - cex = cex.legend, + legend(loc.legend, legend.obj, + lty = 0, + col = vline.col, + lwd = lwd, + cex = cex.legend, bty = bty) } else { - legend(loc.legend, legend.obj, - lty = lty, - col = vline.col, - lwd = lwd, - cex = cex.legend, + legend(loc.legend, legend.obj, + lty = lty, + col = vline.col, + lwd = lwd, + cex = cex.legend, bty = bty) } } diff --git a/R/ctr_modelcov.R b/R/ctr_modelcov.R index 532a2caa..476236f4 100644 --- a/R/ctr_modelcov.R +++ b/R/ctr_modelcov.R @@ -4,12 +4,12 @@ # matrix, try and invert the sample covariance matrix, etc. # update 5/27/2011 JEB -# changelog: using sem and inspect to get output. +# changelog: using sem and inspect to get output. # This way, all arguments such as groups, etc, can be used # update 3 june 2011 YR: removed se="none" (since now implied by do.fit=FALSE) -# update 13 dec 2011 YR: changed name (to avoid confusion with the +# update 13 dec 2011 YR: changed name (to avoid confusion with the # model-implied cov) inspectSampleCov <- function(model, data, ...) { fit <- sem(model, data=data, ..., do.fit=FALSE) inspect(fit, "sampstat") -} +} diff --git a/R/ctr_mplus2lavaan.R b/R/ctr_mplus2lavaan.R index 85cbd678..0803e19d 100644 --- a/R/ctr_mplus2lavaan.R +++ b/R/ctr_mplus2lavaan.R @@ -19,12 +19,12 @@ joinRegexExpand <- function(cmd, argExpand, matches, iterator, matchLength="matc if (iterator == 1 && matches[iterator] > 1) { pre <- substr(cmd, 1, matches[iterator] - 1) } else pre <- "" - + #if this is not the final match, then get sub-string between the end of this match and the beginning of the next #otherwise, match to the end of the command post.end <- ifelse(iterator < length(matches), matches[iterator+1] - 1, nchar(cmd)) post <- substr(cmd, matches[iterator] + attr(matches, matchLength)[iterator], post.end) - + cmd.expand <- paste(pre, argExpand, post, sep="") return(cmd.expand) } @@ -33,52 +33,52 @@ joinRegexExpand <- function(cmd, argExpand, matches, iterator, matchLength="matc expandCmd <- function(cmd, alphaStart=TRUE) { #use negative lookahead and negative lookbehind to eliminate possibility of hyphen being used as a negative starting value (e.g., x*-1) #also avoid match of anything that includes a decimal point, such as a floating-point starting value -10.5*x1 - + #if alphaStart==TRUE, then require that the matches before and after hyphens begin with alpha character #this is used for variable names, whereas the more generic expansion works for numeric constraints and such - + #need to do a better job of this so that u1-u20* is supported... I don't think the regexp below is general enough - + #if (alphaStart) { - # hyphens <- gregexpr("[_A-Za-z]+\\w*\\s*-\\s*[_A-Za-z]+\\w*", cmd, perl=TRUE)[[1]] + # hyphens <- gregexpr("[_A-Za-z]+\\w*\\s*-\\s*[_A-Za-z]+\\w*", cmd, perl=TRUE)[[1]] #} else { # hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]] #} hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]] - + if (hyphens[1L] > 0) { - + cmd.expand <- c() ep <- 1 - + for (v in 1:length(hyphens)) { #match one keyword before and after hyphen argsplit <- strsplit(substr(cmd, hyphens[v], hyphens[v] + attr(hyphens, "match.length")[v] - 1), "\\s*-\\s*", perl=TRUE)[[1]] - + v_pre <- argsplit[1] v_post <- argsplit[2] - + #the basic positive lookbehind blows up with pure numeric constraints (1 - 3) because no alpha char precedes digit #can use an non-capturing alternation grouping to allow for digits only or the final digits after alphas (as in v_post.num) v_pre.num <- as.integer(sub("\\w*(?<=[A-Za-z_])(\\d+)$", "\\1", v_pre, perl=TRUE)) #use positive lookbehind to avoid greedy \w+ match -- capture all digits - + v_post.match <- regexpr("^(?:\\w*(?<=[A-Za-z_])(\\d+)|(\\d+))$", v_post, perl=TRUE) stopifnot(v_post.match[1L] > 0) - + #match mat be under capture[1] or capture[2] because of alternation above whichCapture <- which(attr(v_post.match, "capture.start") > 0) - + v_post.num <- as.integer(substr(v_post, attr(v_post.match, "capture.start")[whichCapture], attr(v_post.match, "capture.start")[whichCapture] + attr(v_post.match, "capture.length")[whichCapture] - 1)) v_post.prefix <- substr(v_post, 1, attr(v_post.match, "capture.start")[whichCapture] - 1) #just trusting that pre and post match - + if (is.na(v_pre.num) || is.na(v_post.num)) stop("Cannot expand variables: ", v_pre, ", ", v_post) v_expand <- paste(v_post.prefix, v_pre.num:v_post.num, sep="", collapse=" ") - + #for first hyphen, there may be non-hyphenated syntax preceding the initial match - cmd.expand[ep] <- joinRegexExpand(cmd, v_expand, hyphens, v) + cmd.expand[ep] <- joinRegexExpand(cmd, v_expand, hyphens, v) ep <- ep + 1 - + } return(paste(cmd.expand, collapse="")) } else { @@ -93,23 +93,23 @@ parseFixStart <- function(cmd) { ep <- 1L if ((fixed.starts <- gregexpr("[\\w\\.-]+\\s*([@*])\\s*[\\w\\.-]+", cmd, perl=TRUE)[[1]])[1L] > 0) { #shouldn't it be \\*, not * ?! Come back to this. for (f in 1:length(fixed.starts)) { - + #capture above obtains the fixed/start character (@ or *), whereas match obtains the full regex match opchar <- substr(cmd, attr(fixed.starts, "capture.start")[f], attr(fixed.starts, "capture.start")[f] + attr(fixed.starts, "capture.length")[f] - 1) - + #match arguments around asterisk/at symbol argsplit <- strsplit(substr(cmd, fixed.starts[f], fixed.starts[f] + attr(fixed.starts, "match.length")[f] - 1), paste0("\\s*", ifelse(opchar=="*", "\\*", opchar), "\\s*"), perl=TRUE)[[1]] v_pre <- argsplit[1] v_post <- argsplit[2] - + if (suppressWarnings(is.na(as.numeric(v_pre)))) { #fixed.starts value post-multiplier - var <- v_pre - val <- v_post + var <- v_pre + val <- v_post } else if (suppressWarnings(is.na(as.numeric(v_post)))) { #starting value pre-multiplier var <- v_post val <- v_pre } else stop("Cannot parse Mplus fixed/starts values specification: ", v_pre, v_post) - + if (opchar == "@") { cmd.parse[ep] <- joinRegexExpand(cmd, paste0(val, "*", var, sep=""), fixed.starts, f) ep <- ep + 1L @@ -117,14 +117,14 @@ parseFixStart <- function(cmd) { cmd.parse[ep] <- joinRegexExpand(cmd, paste0("start(", val, ")*", var, sep=""), fixed.starts, f) ep <- ep + 1L } - + } - return(paste(cmd.parse, collapse="")) - + return(paste(cmd.parse, collapse="")) + } else { return(cmd) } - + } parseConstraints <- function(cmd) { @@ -132,46 +132,46 @@ parseConstraints <- function(cmd) { #Dump leading and trailing newlines, which contain no information about constraints, but may add dummy elements to vector after strsplit #Maybe return LHS and RHS parsed command where constraints only appear on the RHS, whereas the LHS contains only parameters. #Example: LHS is v1 v2 v3 and RHS is con1*v1 con2*v2 con3*v3 - + cmd.split <- strsplit(cmd, "\n")[[1]] - + #drop empty lines (especially leading newline) cmd.split <- if(length(emptyPos <- which(cmd.split == "")) > 0L) {cmd.split[-1*emptyPos]} else {cmd.split} - + #Create a version of the command with no constraint specifications. - #This is useful for constraint specs that use the params on the LHS and RHS. Example: v1 ~~ conB*v1 + #This is useful for constraint specs that use the params on the LHS and RHS. Example: v1 ~~ conB*v1 cmd.noconstraints <- paste0(gsub("\\s*\\([^\\)]+\\)\\s*", "", cmd.split, perl=TRUE), collapse=" ") - + cmd.tojoin <- c() #will store all chunks divided by newlines, which will be joined at the end. - + #iterate over each newline segment for (n in 1:length(cmd.split)) { #in principle, now that we respect newlines, parens should only be of length 1, since Mplus syntax dictates newlines for each use of parentheses for constraints if ((parens <- gregexpr("(? 0) { #match parentheses, but not start() - #the syntax chunk after all parentheses have been matched + #the syntax chunk after all parentheses have been matched cmd.expand <- c() - + for (p in 1:length(parens)) { #string within the constraint parentheses constraints <- substr(cmd.split[n], attr(parens, "capture.start")[p], attr(parens, "capture.start")[p] + attr(parens, "capture.length")[p] - 1) - + #Divide constraints on spaces to determine number of constraints to parse. Use trimSpace to avoid problem of user including leading/trailing spaces within parentheses. con.split <- strsplit(trimSpace(constraints), "\\s+", perl=TRUE)[[1]] - + #if Mplus uses a purely numeric constraint, then add ".con" prefix to be consistent with R naming. con.split <- sapply(con.split, function(x) { if (! suppressWarnings(is.na(as.numeric(x)))) { make.names(paste0(".con", x)) } else { x } }) - + #determine the parameters that precede the parentheses (either first character for p == 1 or character after preceding parentheses) prestrStart <- ifelse(p > 1, attr(parens, "capture.start")[p-1] + attr(parens, "capture.length")[p-1] + 1, 1) - + #obtain the parameters that precede the parentheses, divide into arguments on spaces #use trimSpace here because first char after prestrStart for p > 1 will probably be a space precmd.split <- strsplit(trimSpace(substr(cmd.split[n], prestrStart, parens[p] - 1)), "\\s+", perl=TRUE)[[1]] - + #peel off any potential LHS arguments, such as F1 BY precmdLHSOp <- which(tolower(precmd.split) %in% c("by", "with", "on")) if (any(precmdLHSOp)) { @@ -179,38 +179,38 @@ parseConstraints <- function(cmd) { rhs <- precmd.split[(precmdLHSOp+1):length(precmd.split)] } else { lhsop <- "" - rhs <- precmd.split + rhs <- precmd.split } - + if (length(con.split) > 1L) { #several constraints listed within parentheses. Example: F1 BY X1 X2 X3 X4 (C2 C3 C4) #thus, backwards match the constraints to parameters - - #restrict parameters to backwards match to be of the same length as number of constraints + + #restrict parameters to backwards match to be of the same length as number of constraints rhs.backmatch <- rhs[(length(rhs)-length(con.split)+1):length(rhs)] - + rhs.expand <- c() - + #check that no mean or scale markers are part of the rhs param to expand if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs.backmatch[1L], perl=TRUE))[1L] > 0) { preMark <- substr(rhs.backmatch[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1) rhs.backmatch[1L] <- substr(rhs.backmatch[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs.backmatch[1L])) } else { preMark <- "" } - + if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs.backmatch[length(rhs.backmatch)], perl=TRUE))[1L] > 0) { postMark <- substr(rhs.backmatch[length(rhs.backmatch)], postMark.match[1L], nchar(rhs.backmatch[length(rhs.backmatch)])) rhs.backmatch[length(rhs.backmatch)] <- substr(rhs.backmatch[length(rhs.backmatch)], 1, postMark.match[1L] - 1) } else { postMark <- "" } - - + + #pre-multiply each parameter with each corresponding constraint for (i in 1:length(rhs.backmatch)) { - rhs.expand[i] <- paste0(con.split[i], "*", rhs.backmatch[i]) + rhs.expand[i] <- paste0(con.split[i], "*", rhs.backmatch[i]) } - + #join rhs as string and add back in mean/scale operator, if present rhs.expand <- paste0(preMark, paste(rhs.expand, collapse=" "), postMark) - + #if there were params that preceded the backwards match, then add these back to the syntax #append this syntax to the parsed command, cmd.expand if (length(rhs) - length(con.split) > 0L) { @@ -220,72 +220,72 @@ parseConstraints <- function(cmd) { } } else { #should be able to reduce redundancy with above - + #all parameters on the right hand side are to be equated #thus, pre-multiply each parameter by the constraint - + #check that no mean or scale markers are part of the rhs param to expand #DUPE CODE FROM ABOVE. Make Function?! if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs[1L], perl=TRUE))[1L] > 0) { preMark <- substr(rhs[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1) rhs[1L] <- substr(rhs[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs[1L])) } else { preMark <- "" } - + if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs[length(rhs)], perl=TRUE))[1L] > 0) { postMark <- substr(rhs[length(rhs)], postMark.match[1L], nchar(rhs[length(rhs)])) rhs[length(rhs)] <- substr(rhs[length(rhs)], 1, postMark.match[1L] - 1) } else { postMark <- "" } - - + + rhs.expand <- c() for (i in 1:length(rhs)) { rhs.expand[i] <- paste0(con.split[1L], "*", rhs[i]) } - + #join rhs as string rhs.expand <- paste0(preMark, paste(rhs.expand, collapse=" "), postMark) - + cmd.expand <- c(cmd.expand, paste0(lhsop, rhs.expand)) - + } } - + cmd.tojoin[n] <- paste(cmd.expand, collapse=" ") } else { cmd.tojoin[n] <- cmd.split[n] } #no parens } - + #eliminate newlines in this function so that they don't mess up \\s+ splits downstream toReturn <- paste(cmd.tojoin, collapse=" ") attr(toReturn, "noConstraints") <- cmd.noconstraints - + return(toReturn) - + } expandGrowthCmd <- function(cmd) { #can assume that any spaces between tscore and variable were stripped by parseFixStart - + #verify that this is not a random slope if (any(tolower(strsplit(cmd, "\\s+", perl=TRUE)[[1]]) %in% c("on", "at"))) { stop("lavaan does not support random slopes or individually varying growth model time scores") } - + cmd.split <- strsplit(cmd, "\\s*\\|\\s*", perl=TRUE)[[1]] if (!length(cmd.split) == 2) stop("Unknown growth syntax: ", cmd) - + lhs <- cmd.split[1] lhs.split <- strsplit(lhs, "\\s+", perl=TRUE)[[1]] - + rhs <- cmd.split[2] rhs.split <- strsplit(rhs, "(\\*|\\s+)", perl=TRUE)[[1]] - + if (length(rhs.split) %% 2 != 0) stop("Number of variables and number of tscores does not match: ", rhs) tscores <- as.numeric(rhs.split[1:length(rhs.split) %% 2 != 0]) #pre-multipliers - + vars <- rhs.split[1:length(rhs.split) %% 2 == 0] - + cmd.expand <- c() - + for (p in 0:(length(lhs.split)-1)) { if (p == 0) { #intercept @@ -294,9 +294,9 @@ expandGrowthCmd <- function(cmd) { cmd.expand <- c(cmd.expand, paste(lhs.split[(p+1)], "=~", paste(tscores^p, "*", vars, sep="", collapse=" + "))) } } - + return(cmd.expand) - + } #function to wrap long lines at a certain width, splitting on + symbols to be consistent with R syntax @@ -305,72 +305,72 @@ wrapAfterPlus <- function(cmd, width=90, exdent=5) { if (nchar(line) > width) { split <- c() spos <- 1L - + plusMatch <- gregexpr("+", line, fixed=TRUE)[[1]] mpos <- 1L - + if (plusMatch[1L] > 0L) { #split after plus symbol charsRemain <- nchar(line) while(charsRemain > 0L) { toProcess <- substr(line, nchar(line) - charsRemain + 1, nchar(line)) offset <- nchar(line) - charsRemain + 1 - + if (nchar(remainder <- substr(line, offset, nchar(line))) <= (width - exdent)) { #remainder of line fits within width -- no need to continue wrapping split[spos] <- remainder charsRemain <- 0 } else { - + wrapAt <- which(plusMatch < (width + offset - exdent)) wrapAt <- wrapAt[length(wrapAt)] #at the final + - + split[spos] <- substr(line, offset, plusMatch[wrapAt]) charsRemain <- charsRemain - nchar(split[spos]) spos <- spos + 1 } } - + #remove leading and trailing chars split <- trimSpace(split) - + #handle exdent split <- sapply(1:length(split), function(x) { if (x > 1) paste0(paste(rep(" ", exdent), collapse=""), split[x]) else split[x] }) - + return(split) } else { return(strwrap(line, width=width, exdent=exdent)) #convention strwrap when no + present - } + } } else { return(line) } }) - + #bind together multi-line expansions into single vector return(unname(do.call(c, result))) } mplus2lavaan.constraintSyntax <- function(syntax) { #should probably pass in model syntax along with some tracking of which parameter labels are defined. - + #convert MODEL CONSTRAINT section to lavaan model syntax syntax <- paste(lapply(trimSpace(strsplit(syntax, "\n")), function(x) { if (length(x) == 0L && is.character(x)) "" else x}), collapse="\n") - - #replace ! with # for comment lines. Also strip newline and replace with semicolon + + #replace ! with # for comment lines. Also strip newline and replace with semicolon syntax <- gsub("(\\s*)!(.+)\n", "\\1#\\2;", syntax, perl=TRUE) - - #split into vector of strings + + #split into vector of strings #need to peel off leading or trailing newlines -- leads to parsing confusion downstream otherwise - syntax.split <- gsub("(^\n|\n$)", "", unlist( strsplit(syntax, ";") ), perl=TRUE) - + syntax.split <- gsub("(^\n|\n$)", "", unlist( strsplit(syntax, ";") ), perl=TRUE) + constraint.out <- c() - + #TODO: Handle PLOT and LOOP syntax for model constraints. #TODO: Handle DO loop convention - + #first parse new parameters defined in MODEL CONSTRAINT into a vector new.parameters <- c() #parameters that are defined in constraint section if (length(new.con.lines <- grep("^\\s*NEW\\s*\\([^\\)]+\\)", syntax.split, perl=TRUE, ignore.case=TRUE)) > 0L) { @@ -382,10 +382,10 @@ mplus2lavaan.constraintSyntax <- function(syntax) { new.con <- expandCmd(new.con) #allow for hyphen expansion new.parameters <- c(new.parameters, strsplit(trimSpace(new.con), "\\s+", perl=TRUE)[[1L]]) } - + syntax.split <- syntax.split[-1L * new.con.lines] #drop out these lines parameters.undefined <- new.parameters #to be used below to handle ambiguity of equation versus definition - + } for (cmd in syntax.split) { @@ -396,14 +396,14 @@ mplus2lavaan.constraintSyntax <- function(syntax) { } else { #constraint proper cmd <- gsub("**", "^", cmd, fixed=TRUE) #handle exponent - + #lower case the math operations supported by Mplus to be consistent with R #match all math operators, then lower case each and rejoin string maths <- gregexpr("(SQRT|LOG|LOG10|EXP|ABS|SIN|COS|TAN|ASIN|ACOS|ATAN)\\s*\\(", cmd, perl=TRUE)[[1L]] if (maths[1L] > 0) { maths.replace <- c() ep <- 1 - + for (i in 1:length(maths)) { operator <- tolower(substr(cmd, attr(maths, "capture.start")[i], attr(maths, "capture.start")[i] + attr(maths, "capture.length")[i] - 1)) maths.replace[ep] <- joinRegexExpand(cmd, operator, maths, i, matchLength="capture.length") #only match operator, not opening ( @@ -411,12 +411,12 @@ mplus2lavaan.constraintSyntax <- function(syntax) { } cmd <- paste(maths.replace, collapse="") } - + #equating some lhs and rhs: could reflect definition of new parameter if ((equals <- regexpr("=", cmd, fixed=TRUE))[1L] > 0) { lhs <- trimSpace(substr(cmd, 1, equals - 1)) rhs <- trimSpace(substr(cmd, equals + attr(equals, "match.length"), nchar(cmd))) - + #possibility of lhs or rhs containing the single variable to be equated if (regexpr("\\s+", lhs, perl=TRUE)[1L] > 0L) { def <- rhs @@ -424,22 +424,22 @@ mplus2lavaan.constraintSyntax <- function(syntax) { } else if (regexpr("\\s+", rhs, perl=TRUE)[1L] > 0L) { def <- lhs body <- rhs - } else { + } else { #warning("Can't figure out which side of constraint defines a parameter") #this would occur for simple rel5 = rel2 sort of syntax def <- lhs body <- rhs } - + #must decide whether this is a new parameter (:=) or equation of exising labels (==) #alternatively, could be zero, as in 0 = x + y #this is tricky, because mplus doesn't differentiate definition from equation #consequently, could confuse the issue as in ex5.20 #NEW(rel2 rel5 stan3 stan6); - #rel2 = lam2**2*vf1/(lam2**2*vf1 + ve2); - #rel5 = lam5**2*vf2/(lam5**2*vf2 + ve5); + #rel2 = lam2**2*vf1/(lam2**2*vf1 + ve2); + #rel5 = lam5**2*vf2/(lam5**2*vf2 + ve5); #rel5 = rel2; - + #for now, only define a new constraint if it's not already defined #otherwise equate if (def %in% new.parameters && def %in% parameters.undefined) { @@ -448,43 +448,43 @@ mplus2lavaan.constraintSyntax <- function(syntax) { } else { constraint.out <- c(constraint.out, paste(def, "==", body)) } - + } else { #inequality constraints -- paste as is constraint.out <- c(constraint.out, cmd) } - + } - + } - + wrap <- paste(wrapAfterPlus(constraint.out, width=90, exdent=5), collapse="\n") return(wrap) - + } mplus2lavaan.modelSyntax <- function(syntax) { - #initial strip of leading/trailing whitespace, which can interfere with splitting on spaces + #initial strip of leading/trailing whitespace, which can interfere with splitting on spaces #strsplit generates character(0) for empty strings, which causes problems in paste because paste actually includes it as a literal #example: paste(list(character(0), "asdf", character(0)), collapse=" ") #thus, use lapply to convert these to empty strings first syntax <- paste(lapply(trimSpace(strsplit(syntax, "\n")), function(x) { if (length(x) == 0L && is.character(x)) "" else x}), collapse="\n") - - #replace ! with # for comment lines. Also strip newline and replace with semicolon + + #replace ! with # for comment lines. Also strip newline and replace with semicolon syntax <- gsub("(\\s*)!(.+)\n*", "\\1#\\2;", syntax, perl=TRUE) - + #new direction: retain newlines in parsed syntax until after constraints have been parsed - + #delete newlines #syntax <- gsub("\n", "", syntax, fixed=TRUE) - + # replace semicolons with newlines prior to split (divide into commands) #syntax <- gsub(";", "\n", syntax, fixed=TRUE) - - #split into vector of strings + + #split into vector of strings #syntax.split <- unlist( strsplit(syntax, "\n") ) syntax.split <- trimSpace(unlist( strsplit(syntax, ";") )) - + #format of parTable to mimic. # 'data.frame': 34 obs. of 12 variables: # $ id : int 1 2 3 4 5 6 7 8 9 10 ... @@ -499,10 +499,10 @@ mplus2lavaan.modelSyntax <- function(syntax) { # $ label : chr "" "" "" "" ... # $ eq.id : int 0 0 0 0 0 0 0 0 0 0 ... # $ unco : int 0 1 2 0 3 4 5 0 6 7 ... - + #vector of lavaan syntax lavaan.out <- c() - + for (cmd in syntax.split) { if (grepl("^\\s*#", cmd, perl=TRUE)) { #comment line lavaan.out <- c(lavaan.out, gsub("\n", "", cmd, fixed=TRUE)) #drop any newlines (otherwise done by parseConstraints) @@ -511,42 +511,42 @@ mplus2lavaan.modelSyntax <- function(syntax) { } else { #hyphen expansion cmd <- expandCmd(cmd) - + #blow up on growth syntax for now # if (grepl("|", cmd, fixed=TRUE)) stop("Growth modeling syntax using | not supported at the moment.") - + #parse fixed parameters and starting values cmd <- parseFixStart(cmd) - + #parse any constraints here (avoid weird logic below) cmd <- parseConstraints(cmd) if ((op <- regexpr("\\s+(by|on|with|pwith)\\s+", cmd, ignore.case=TRUE, perl=TRUE))[1L] > 0) { #regressions, factors, covariances - + lhs <- substr(cmd, 1, op - 1) #using op takes match.start which will omit spaces before operator rhs <- substr(cmd, op + attr(op, "match.length"), nchar(cmd)) operator <- tolower(substr(cmd, attr(op, "capture.start"), attr(op, "capture.start") + attr(op, "capture.length") - 1)) - + if (operator == "by") { lav.operator <- "=~" } else if (operator == "with" || operator == "pwith") { lav.operator <- "~~" } else if (operator == "on") { lav.operator <- "~" } - + #handle parameter combinations lhs.split <- strsplit(lhs, "\\s+")[[1]] #trimSpace( - + #handle pwith syntax if (operator == "pwith") { #TODO: Figure out if pwith can be paired with constraints? - + rhs.split <- strsplit(rhs, "\\s+")[[1]] #trimSpace( if (length(lhs.split) != length(rhs.split)) { browser(); stop("PWITH command does not have the same number of arguments on the left and right sides.")} - - cmd <- sapply(1:length(lhs.split), function(i) paste(lhs.split[i], lav.operator, rhs.split[i])) + + cmd <- sapply(1:length(lhs.split), function(i) paste(lhs.split[i], lav.operator, rhs.split[i])) } else { - + #insert plus signs on the rhs - rhs <- gsub("\\s+", " + ", rhs, perl=TRUE) - + rhs <- gsub("\\s+", " + ", rhs, perl=TRUE) + if (length(lhs.split) > 1L) { #expand using possible combinations cmd <- sapply(lhs.split, function(larg) { @@ -556,23 +556,23 @@ mplus2lavaan.modelSyntax <- function(syntax) { } else { cmd <- paste(lhs, lav.operator, rhs) } - + } } else if ((means.scales <- regexpr("^\\s*([\\[\\{])([^\\]\\}]+)[\\]\\}]\\s*$", cmd, ignore.case=TRUE, perl=TRUE))[1L] > 0) { #intercepts/means or scales #first capture is the operator: [ or { operator <- substr(cmd, attr(means.scales, "capture.start")[1L], attr(means.scales, "capture.start")[1L] + attr(means.scales, "capture.length")[1L] - 1) - + params <- substr(cmd, attr(means.scales, "capture.start")[2L], attr(means.scales, "capture.start")[2L] + attr(means.scales, "capture.length")[2L] - 1) - + #obtain parameters with no constraint specification for LHS params.noconstraints <- sub("^\\s*[\\[\\{]([^\\]\\}]+)[\\]\\}]\\s*$", "\\1", attr(cmd, "noConstraints"), perl=TRUE) - + means.scales.split <- strsplit(params, "\\s+")[[1]] #trimSpace( means.scales.noConstraints.split <- strsplit(params.noconstraints, "\\s+")[[1]] #trimSpace( - + if (operator == "[") { #Tricky syntax shift (and corresponding kludge). For means, need to put constraint on RHS as pre-multiplier of 1 (e.g., x1 ~ 5*1). - #But parseConstraints returns constraints multiplied by parameters + #But parseConstraints returns constraints multiplied by parameters cmd <- sapply(means.scales.split, function(v) { #shift pre-multiplier if ((premult <- regexpr("([^\\*]+)\\*([^\\*]+)", v, perl=TRUE))[1L] > 0) { @@ -583,7 +583,7 @@ mplus2lavaan.modelSyntax <- function(syntax) { paste(v, "~ 1") } }) - + } else if (operator == "{"){ #only include constraints on RHS cmd <- sapply(1:length(means.scales.split), function(v) paste(means.scales.noConstraints.split[v], "~*~", means.scales.split[v])) @@ -595,29 +595,29 @@ mplus2lavaan.modelSyntax <- function(syntax) { #cat("assuming vars: ", cmd, "\n") vars.lhs <- strsplit(attr(cmd, "noConstraints"), "\\s+")[[1]] #trimSpace( vars.rhs <- strsplit(cmd, "\\s+")[[1]] #trimSpace( - + cmd <- sapply(1:length(vars.lhs), function(v) paste(vars.lhs[v], "~~", vars.rhs[v])) } - + #handle threshold substitution: $ -> | cmd <- gsub("$", "|", cmd, fixed=TRUE) - + lavaan.out <- c(lavaan.out, cmd) - + } } - + #for now, include a final trimSpace call since some arguments have leading/trailing space stripped. wrap <- paste(wrapAfterPlus(lavaan.out, width=90, exdent=5), collapse="\n") #trimSpace( return(wrap) - + } mplus2lavaan <- function(inpfile, run=TRUE) { stopifnot(length(inpfile) == 1L) stopifnot(grepl("\\.inp$", inpfile)) if (!file.exists(inpfile)) { stop("Could not find file: ", inpfile) } - + #for future consideration. For now, require a .inp file # if (length(inpfile) == 1L && grepl("\\.inp$", inpfile)) { # if (!file.exists(inpfile)) { stop("Could not find file: ", inpfile) } @@ -626,34 +626,34 @@ mplus2lavaan <- function(inpfile, run=TRUE) { # #assume that inpfile itself is syntax (e.g., in a character vector) # inpfile.text <- inpfile # } - + inpfile.text <- scan(inpfile, what="character", sep="\n", strip.white=FALSE, blank.lines.skip=FALSE, quiet=TRUE) sections <- divideInputIntoSections(inpfile.text, inpfile) - + mplus.inp <- list() - + mplus.inp$title <- trimSpace(paste(sections$title, collapse=" ")) mplus.inp$data <- divideIntoFields(sections$data, required="file") mplus.inp$variable <- divideIntoFields(sections$variable, required="names") mplus.inp$analysis <- divideIntoFields(sections$analysis) - + meanstructure <- "default" #lavaan default if(!is.null(mplus.inp$analysis$model)) { if (tolower(mplus.inp$analysis$model) == "nomeanstructure") { meanstructure=FALSE } #explicitly disable mean structure } - + information <- "default" #lavaan default if(!is.null(mplus.inp$analysis$information)) { information <- tolower(mplus.inp$analysis$information) } - - + + estimator <- "default" if (!is.null(est <- mplus.inp$analysis$estimator)) { #no memory of what this is up to.... if (toupper(est) == "MUML") warning("Mplus does not support MUML estimator. Using default instead.") estimator <- est - + #march 2013: handle case where categorical data are specified, but ML-based estimator requested. #use WLSMV instead if (!is.null(mplus.inp$variable$categorical) && toupper(substr(mplus.inp$analysis$estimator, 1, 2)) == "ML") { @@ -661,25 +661,25 @@ mplus2lavaan <- function(inpfile, run=TRUE) { estimator <- "WLSMV" } } - + #expand hyphens in variable names and split into vector that will be the names for read.table mplus.inp$variable$names <- strsplit(expandCmd(mplus.inp$variable$names), "\\s+", perl=TRUE)[[1]] - + #expand hyphens in categorical declaration if (!is.null(mplus.inp$variable$categorical)) mplus.inp$variable$categorical <- strsplit(expandCmd(mplus.inp$variable$categorical), "\\s+", perl=TRUE)[[1]] - + #convert mplus syntax to lavaan syntax mplus.inp$model <- mplus2lavaan.modelSyntax(sections$model) - + #handle model constraint if ("model.constraint" %in% names(sections)) { mplus.inp$model.constraint <- mplus2lavaan.constraintSyntax(sections$model.constraint) mplus.inp$model <- paste(mplus.inp$model, mplus.inp$model.constraint, sep="\n") } - + #read mplus data (and handle missing spec) mplus.inp$data <- readMplusInputData(mplus.inp, inpfile) - + #handle bootstrapping specification se="default" bootstrap <- 1000L @@ -690,52 +690,52 @@ mplus2lavaan <- function(inpfile, run=TRUE) { if ((boot.match <- regexpr("\\((\\w+)\\)", mplus.inp$analysis$bootstrap, perl=TRUE)) > 0L) { boot.type <- tolower(substr(mplus.inp$analysis$bootstrap, attr(boot.match, "capture.start"), attr(boot.match, "capture.start") + attr(boot.match, "capture.length") - 1L)) } - + if (boot.type == "residual") test <- "Bollen.Stine" - + se <- "bootstrap" - + if ((nboot.match <- regexpr("^\\s*(\\d+)", mplus.inp$analysis$bootstrap, perl=TRUE)) > 0L) { bootstrap <- as.numeric(substr(mplus.inp$analysis$bootstrap, attr(nboot.match, "capture.start"), attr(nboot.match, "capture.start") + attr(nboot.match, "capture.length") - 1L)) - } + } } - + if (run) { fit <- sem(mplus.inp$model, data=mplus.inp$data, meanstructure=meanstructure, mimic="Mplus", estimator=estimator, test=test, se=se, bootstrap=bootstrap, information=information) fit@external <- list(mplus.inp=mplus.inp) } else { fit <- mplus.inp #just return the syntax outside of a lavaan object } - + return(fit) } divideIntoFields <- function(section.text, required) { - + if (is.null(section.text)) { return(NULL) } - + #The parser breaks down when there is a line with a trailing comment because then splitting on semicolon will combine it with the following line #Thus, trim off trailing comments before initial split section.text <- gsub("\\s*!.*$", "", section.text, perl=TRUE) section.split <- strsplit(paste(section.text, collapse=" "), ";", fixed=TRUE)[[1]] #split on semicolons section.divide <- list() - + for (cmd in section.split) { if (grepl("^\\s*!.*", cmd, perl=TRUE)) next #skip comment lines if (grepl("^\\s+$", cmd, perl=TRUE)) next #skip blank lines - + #mplus is apparently tolerant of specifications that don't include IS/ARE/= #example: usevariables x1-x10; #thus, split on spaces and assume that first element is lhs, drop second element if IS/ARE/=, and assume remainder is rhs - + #but if user uses equals sign, then spaces will not always be present (e.g., usevariables=x1-x10) if ( (leadingEquals <- regexpr("^\\s*[A-Za-z]+[A-Za-z_-]*\\s*(=)", cmd[1L], perl=TRUE))[1L] > 0) { cmdName <- trimSpace(substr(cmd[1L], 1, attr(leadingEquals, "capture.start") - 1)) cmdArgs <- trimSpace(substr(cmd[1L], attr(leadingEquals, "capture.start") + 1, nchar(cmd[1L]))) } else { cmd.spacesplit <- strsplit(trimSpace(cmd[1L]), "\\s+", perl=TRUE)[[1L]] - + if (length(cmd.spacesplit) < 2L) { #for future: make room for this function to prase things like just TECH13 (no rhs) } else { @@ -746,33 +746,33 @@ divideIntoFields <- function(section.text, required) { cmdArgs <- paste(cmd.spacesplit[2L:length(cmd.spacesplit)], collapse=" ") #is/are not used, so just join rhs } } - + } - + section.divide[[make.names(tolower(cmdName))]] <- cmdArgs - + } - + if (!missing(required)) { stopifnot(all(required %in% names(section.divide))) } return(section.divide) } #helper function splitFilePath <- function(abspath) { - #function to split path into path and filename + #function to split path into path and filename #code adapted from R.utils filePath command if (!is.character(abspath)) stop("Path not a character string") if (nchar(abspath) < 1 || is.na(abspath)) stop("Path is missing or of zero length") - + components <- strsplit(abspath, split="[\\/]")[[1]] lcom <- length(components) - + stopifnot(lcom > 0) - + #the file is the last element in the list. In the case of length == 1, this will extract the only element. relFilename <- components[lcom] absolute <- FALSE - + if (lcom == 1) { dirpart <- NA_character_ } @@ -780,24 +780,24 @@ splitFilePath <- function(abspath) { #drop the file from the list (the last element) components <- components[-lcom] dirpart <- do.call("file.path", as.list(components)) - + #if path begins with C:, /, //, or \\, then treat as absolute if (grepl("^([A-Z]{1}:|/|//|\\\\)+.*$", dirpart, perl=TRUE)) absolute <- TRUE } - + return(list(directory=dirpart, filename=relFilename, absolute=absolute)) } readMplusInputData <- function(mplus.inp, inpfile) { - + #handle issue of mplus2lavaan being called with an absolute path, whereas mplus has only a local data file inpfile.split <- splitFilePath(inpfile) datfile.split <- splitFilePath(mplus.inp$data$file) - + #if inp file target directory is non-empty, but mplus data is without directory, then append #inp file directory to mplus data. This ensures that R need not be in the working directory #to read the dat file. But if mplus data has an absolute directory, don't append - + #if mplus data directory is present and absolute, or if no directory in input file, just use filename as is if (!is.na(datfile.split$directory) && datfile.split$absolute) datFile <- mplus.inp$data$file #just use mplus data filename if it has absolute path @@ -805,16 +805,16 @@ readMplusInputData <- function(mplus.inp, inpfile) { datFile <- mplus.inp$data$file #just use mplus data filename if inp file is missing path (working dir) else datFile <- file.path(inpfile.split$directory, mplus.inp$data$file) #dat file path is relative or absent, and inp file directory is present - + if (!file.exists(datFile)) { warning("Cannot find data file: ", datFile) return(NULL) } - + #handle missing is/are: missList <- NULL if (!is.null(missSpec <- mplus.inp$variable$missing)) { - + expandMissVec <- function(missStr) { #sub-function to obtain a vector of all missing values within a set of parentheses missSplit <- strsplit(missStr, "\\s+")[[1L]] @@ -832,7 +832,7 @@ readMplusInputData <- function(mplus.inp, inpfile) { } return(as.numeric(missVals)) } - + if (missSpec == "." || missSpec=="*") { #case 1: MISSING ARE|=|IS .; na.strings <- missSpec } else if ((allMatch <- regexpr("\\s*ALL\\s*\\(([^\\)]+)\\)", missSpec, perl=TRUE))[1L] > -1L) { #case 2: use of ALL with parens @@ -842,12 +842,12 @@ readMplusInputData <- function(mplus.inp, inpfile) { #process each element missBlocks <- gregexpr("(?:(\\w+)\\s+\\(([^\\)]+)\\))+", missSpec, perl=TRUE)[[1]] missList <- list() - + if (missBlocks[1L] > -1L) { for (i in 1:length(missBlocks)) { vname <- substr(missSpec, attr(missBlocks, "capture.start")[i,1L], attr(missBlocks, "capture.start")[i,1L] + attr(missBlocks, "capture.length")[i,1L] - 1L) vmiss <- substr(missSpec, attr(missBlocks, "capture.start")[i,2L], attr(missBlocks, "capture.start")[i,2L] + attr(missBlocks, "capture.length")[i,2L] - 1L) - + vnameHyphen <- regexpr("(\\w+)-(\\w+)", vname, perl=TRUE)[1L] if (vnameHyphen > -1L) { #lookup against variable names @@ -858,13 +858,13 @@ readMplusInputData <- function(mplus.inp, inpfile) { if (vstart > vend) { vstart.orig <- vstart; vstart <- vend; vend <- vstart.orig } vname <- mplus.inp$variable$names[vstart:vend] } - + missVals <- expandMissVec(vmiss) - + for (j in 1:length(vname)) { missList[[ vname[j] ]] <- missVals } - + } } else { stop("I don't understand this missing specification: ", missSpec) } } @@ -877,43 +877,43 @@ readMplusInputData <- function(mplus.inp, inpfile) { dat[which(dat[,vmiss] %in% missList[[vmiss]]), vmiss] <- NA return(dat[,vmiss]) }) - + names(dat) <- mplus.inp$variable$names #loses these from the lapply - + } else { dat <- read.table(datFile, header=FALSE, col.names=mplus.inp$variable$names, na.strings=na.strings, colClasses="numeric") } - - + + #TODO: support covariance/mean+cov inputs - + #store categorical variables as ordered factors if (!is.null(mplus.inp$variable$categorical)) { - dat[,c(mplus.inp$variable$categorical)] <- lapply(dat[,c(mplus.inp$variable$categorical), drop=FALSE], ordered) + dat[,c(mplus.inp$variable$categorical)] <- lapply(dat[,c(mplus.inp$variable$categorical), drop=FALSE], ordered) } - + return(dat) } divideInputIntoSections <- function(inpfile.text, filename) { inputHeaders <- grep("^\\s*(title:|data.*:|variable:|define:|analysis:|model.*:|output:|savedata:|plot:|montecarlo:)", inpfile.text, ignore.case=TRUE, perl=TRUE) - + stopifnot(length(inputHeaders) > 0L) - + mplus.sections <- list() - + for (h in 1:length(inputHeaders)) { sectionEnd <- ifelse(h < length(inputHeaders), inputHeaders[h+1] - 1, length(inpfile.text)) section <- inpfile.text[inputHeaders[h]:sectionEnd] sectionName <- trimSpace(sub("^([^:]+):.*$", "\\1", section[1L], perl=TRUE)) #obtain text before the colon - + #dump section name from input syntax section[1L] <- sub("^[^:]+:(.*)$", "\\1", section[1L], perl=TRUE) - + mplus.sections[[make.names(tolower(sectionName))]] <- section } - + return(mplus.sections) } diff --git a/R/ctr_pairwise_fit.R b/R/ctr_pairwise_fit.R index 3fbb3eed..99072140 100644 --- a/R/ctr_pairwise_fit.R +++ b/R/ctr_pairwise_fit.R @@ -1,4 +1,4 @@ -# This code is written by YR (using lavaan components), but based on +# This code is written by YR (using lavaan components), but based on # research code written by Mariska Barendse (Groningen/Amsterdam, NL) # # September 2013 @@ -28,14 +28,14 @@ lavTablesFitCp <- function(object, alpha = 0.05) { - lavdata <- object@Data + lavdata <- object@Data if(!all(lavdata@ov$type == "ordered")) { - return(list(G2=as.numeric(NA), df=as.numeric(NA), + return(list(G2=as.numeric(NA), df=as.numeric(NA), p.value=as.numeric(NA), p.value.Bonferroni=as.numeric(NA))) } - TF <- lavTables(object, dimension = 2L, type = "table", + TF <- lavTables(object, dimension = 2L, type = "table", statistic = "G2", p.value = TRUE) # Bonferonni adjusted p-value @@ -47,7 +47,7 @@ lavTablesFitCp <- function(object, alpha = 0.05) { # find largest G2 max.idx <- which(TF$G2 == max(TF$G2)) - extra <- list(G2=unname(TF$G2[max.idx]), df=unname(TF$df[max.idx]), + extra <- list(G2=unname(TF$G2[max.idx]), df=unname(TF$df[max.idx]), lhs=TF$lhs[max.idx], rhs=TF$rhs[max.idx], group=TF$group[max.idx], @@ -122,7 +122,7 @@ lavTablesFitCf <- function(object) { attr(CF, "DF") <- DF attr(CF, "rpat.observed") <- sapply(lavdata@Rp, "[[", "npatterns") attr(CF, "rpat.total") <- sapply(lavdata@Rp, "[[", "total.patterns") - attr(CF, "rpat.empty") <- sapply(lavdata@Rp, "[[", "empty.patterns") + attr(CF, "rpat.empty") <- sapply(lavdata@Rp, "[[", "empty.patterns") class(CF) <- c("lavaan.tables.fit.Cf", "numeric") diff --git a/R/ctr_pairwise_table.R b/R/ctr_pairwise_table.R index e8482e0a..49f5f823 100644 --- a/R/ctr_pairwise_table.R +++ b/R/ctr_pairwise_table.R @@ -8,10 +8,10 @@ # data : matrix or data frame containing the data. The rows correspond to # different observations and the columns to different observed categorical # (ordinal or nominal) variables. No continuous variables or covariates -# should be contained in data. If the variables contained in the data are -# distinguished into indicators of exogenous latent variables (lv) and -# indicators of endogenous latent variables, those for exogenous lv should -# be presented first (in the first columns of data) followed by the +# should be contained in data. If the variables contained in the data are +# distinguished into indicators of exogenous latent variables (lv) and +# indicators of endogenous latent variables, those for exogenous lv should +# be presented first (in the first columns of data) followed by the # indicators for endogenous lv. # var.levels: NULL or vector or list, specifies the levels (response categories) # for each categorical variable contained in data. @@ -20,30 +20,30 @@ # defined. # If vector, that implies that all variables have the same levels as # given in the vector. -# If list, the components of the list are vectors, as many as the +# If list, the components of the list are vectors, as many as the # number of variables in data. Each vector gives the levels of # the corresponding categorical variable in data. # no.x : NULL or integer, gives the number of indicators for exogenous lv. # The default value is NULL indicating that data contains only -# indicators of exogenous latent variables. +# indicators of exogenous latent variables. # perc : TRUE/FALSE. If FALSE the observed frequencies are reported, otherwise # the observed percentages are given. # na.exclude : TRUE/FALSE. If TRUE, listwise deletion is applied to data. -# Otherwise, cases with missing values are preserved and and an +# Otherwise, cases with missing values are preserved and and an # extra level with label NA is included in the tables. # The output of the function: -# It is a list of three components: $pairTables, $VarLevels and $Ncases_del. +# It is a list of three components: $pairTables, $VarLevels and $Ncases_del. # pairTables : a list of so many tables as the number of variable pairs formed -# by data. If there are indicators of both exogenous and endogenous -# variables, then first all the matrices referring to pairs of -# indicators of exogenous lv are reported, followed by all the +# by data. If there are indicators of both exogenous and endogenous +# variables, then first all the matrices referring to pairs of +# indicators of exogenous lv are reported, followed by all the # matrices referring to pairs of indicators of endogenous lv, which -# in turn folowed by all the matrices of pairs: one indicator of an +# in turn folowed by all the matrices of pairs: one indicator of an # exogenous - one indicator of an endogenous lv. # VarLevels : a list of as many vectors as the number of variables in the data. # Each vector gives the levels/ response categories of each variable -# Ncases_del : An integer reporting the number of cases deleted by data because +# Ncases_del : An integer reporting the number of cases deleted by data because # of missing values (listwise deletion) when na.exclude=TRUE. @@ -61,7 +61,7 @@ pairwiseTables <- function(data, var.levels=NULL, no.x=NULL, if(no.var<2) { stop("there are less than 2 variables") } - + # no.x < no.var ? if(no.x > no.var) { stop("number of indicators for exogenous latent variables is larger than the total number of variables in data") @@ -145,35 +145,35 @@ pairwiseTables <- function(data, var.levels=NULL, no.x=NULL, for(i in 1:no.pairs ) { res[[i]] <- table( data[, pairs.index[,i] ], useNA="ifany" ) } - } else { + } else { no.y <- no.var - no.x pairs.xixj.index <- utils::combn(no.x,2) # row 1 gives i index, row 2 j index, j runs faster than i pairs.yiyj.index <- utils::combn(no.y,2) pairs.xiyj.index <- expand.grid(1:no.y, 1:no.x) pairs.xiyj.index <- rbind( pairs.xiyj.index[,2], pairs.xiyj.index[,1] ) # row 1 gives i index, row 2 j index, j runs faster than i - + no.pairs.xixj <- dim(pairs.xixj.index)[2] no.pairs.yiyj <- dim(pairs.yiyj.index)[2] no.pairs.xiyj <- dim(pairs.xiyj.index)[2] - no.all.pairs <- no.pairs.xixj + no.pairs.yiyj + no.pairs.xiyj - + no.all.pairs <- no.pairs.xixj + no.pairs.yiyj + no.pairs.xiyj + data.x <- data[,1:no.x] data.y <- data[,(no.x+1):no.var] - + res <- vector("list", no.all.pairs) for(i in 1:no.pairs.xixj) { res[[i]] <- table(data.x[,pairs.xixj.index[,i]], useNA="ifany" ) } - - j <- 0 + + j <- 0 for(i in (no.pairs.xixj+1):(no.pairs.xixj+no.pairs.yiyj) ) { j <- j+1 res[[i]] <- table(data.y[,pairs.yiyj.index[,j]], useNA="ifany" ) } - + j <-0 - for(i in (no.pairs.xixj+no.pairs.yiyj+1):no.all.pairs ) { - j <- j+1 + for(i in (no.pairs.xixj+no.pairs.yiyj+1):no.all.pairs ) { + j <- j+1 res[[i]] <- table(cbind(data.x[,pairs.xiyj.index[1,j], drop=FALSE], data.y[,pairs.xiyj.index[2,j], drop=FALSE]), useNA="ifany" ) @@ -192,6 +192,6 @@ pairwiseTables <- function(data, var.levels=NULL, no.x=NULL, } else { Ncases_deleted <- 0 } - + list(pairTables=res, VarLevels=var.levels, Ncases_del= Ncases_deleted) } diff --git a/R/ctr_pml_plrt.R b/R/ctr_pml_plrt.R index 09e4e462..99e3e061 100644 --- a/R/ctr_pml_plrt.R +++ b/R/ctr_pml_plrt.R @@ -19,7 +19,7 @@ ctr_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, if(is.null(x)) { - # compute 'fx' = objective function value + # compute 'fx' = objective function value # (NOTE: since 0.5-18, NOT divided by N!!) fx <- lav_model_objective(lavmodel = lavmodel, lavsamplestats = lavsamplestats, @@ -56,28 +56,28 @@ ctr_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, # we also need a `saturated model', but where the moments are based # on the model-implied sample statistics under H0 - ModelSat2 <- + ModelSat2 <- lav_partable_unrestricted(lavobject = NULL, lavdata = lavdata, lavoptions = lavoptions, lavpta = lavpta, lavsamplestats = NULL, sample.cov = computeSigmaHat(lavmodel), - sample.mean = computeMuHat(lavmodel), + sample.mean = computeMuHat(lavmodel), sample.th = computeTH(lavmodel), sample.th.idx = lavsamplestats@th.idx) Options2 <- Options Options2$optim.method <- "none" Options2$optim.force.converged <- TRUE - fittedSat2 <- lavaan(ModelSat2, + fittedSat2 <- lavaan(ModelSat2, slotOptions = Options2, slotSampleStats = lavsamplestats, slotData = lavdata, slotCache = lavcache) # the code below was contributed by Myrsini Katsikatsou (Jan 2015) -# for now, only a single group is supported: +# for now, only a single group is supported: # g = 1L @@ -85,7 +85,7 @@ ctr_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, # First define the number of non-redundant elements of the (fitted) # covariance/correlation matrix of the underlying variables. -#nvar <- lavmodel@nvar[[g]] +#nvar <- lavmodel@nvar[[g]] #dSat <- nvar*(nvar-1)/2 #if(length(lavmodel@num.idx[[g]]) > 0L) { # dSat <- dSat + length(lavmodel@num.idx[[g]]) @@ -159,7 +159,7 @@ if(lavmodel@eq.constraints) { } } } else { - Inv_of_InvH_to_psipsi_attheta0 <- + Inv_of_InvH_to_psipsi_attheta0 <- solve(InvH_to_psipsi_attheta0) #[H^psipsi(theta0)]^(-1) } @@ -173,7 +173,7 @@ var_tww <- 2* sum(diag(H0tmp_prod2)) #variance of the first quadratic quantity # using the estimates of SEM parameters derived under the fitted model # which is the model of the null hypothesis. We also need to compute the # vcov matrix of these estimates (estimates of polychoric correlations) -# as well as the related hessian and variability matrix. +# as well as the related hessian and variability matrix. tmp.options <- fittedSat2@Options tmp.options$se <- lavoptions$se VCOV.Sat2 <- lav_model_vcov(lavmodel = fittedSat2@Model, @@ -222,7 +222,7 @@ for(g in 1:lavsamplestats@ngroups) { # for now, we can assume that computeDelta will always return # the thresholds first, then the correlations # - # later, we should add a (working) add.labels = TRUE option to + # later, we should add a (working) add.labels = TRUE option to # computeDelta #th.names <- lavobject@pta$vnames$th[[g]] #ov.names <- lavobject@pta$vnames$ov[[g]] @@ -257,7 +257,7 @@ for(g in 1:lavsamplestats@ngroups) { par.idx <- match(PARLABEL, NAMES) if(any(is.na(par.idx))) { - warning("lavaan WARNING: [ctr_pml_plrt] mismatch between DELTA labels and PAR labels!\n", "PARLABEL:\n", paste(PARLABEL, collapse = " "), + warning("lavaan WARNING: [ctr_pml_plrt] mismatch between DELTA labels and PAR labels!\n", "PARLABEL:\n", paste(PARLABEL, collapse = " "), "\nDELTA LABELS:\n", paste(NAMES, collapse = " ")) } @@ -294,10 +294,10 @@ if(asym_mean_PLRTH0Sat == 0) { scaling.factor <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat/2) ) FSA_PLRT_SEM <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat/2) )* PLRTH0Sat adjusted_df <- (asym_mean_PLRTH0Sat*asym_mean_PLRTH0Sat) / (asym_var_PLRTH0Sat/2) - # In some very few cases (simulations show very few cases in small + # In some very few cases (simulations show very few cases in small # sample sizes) the adjusted_df is a negative number, we should then # print a warning like: "The adjusted df is computed to be a negative number - # and for this the first and second moment adjusted PLRT is not computed." + # and for this the first and second moment adjusted PLRT is not computed." if(scaling.factor > 0) { pvalue <- 1-pchisq(FSA_PLRT_SEM, df=adjusted_df ) } else { @@ -306,7 +306,7 @@ if(asym_mean_PLRTH0Sat == 0) { } list(PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group, - stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, + stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, scaling.factor = scaling.factor) } ############################################################################ @@ -325,13 +325,13 @@ ctr_pml_aic_bic <- function(lavobject) { logPL <- lavobject@optim$logl nsize <- lavobject@SampleStats@ntotal - # inverted observed unit information + # inverted observed unit information H.inv <- lavTech(lavobject, "inverted.information.observed") # first order unit information J <- lavTech(lavobject, "information.first.order") - # trace (J %*% H.inv) = sum (J * t(H.inv)) + # trace (J %*% H.inv) = sum (J * t(H.inv)) dimTheta <- sum(J * H.inv) diff --git a/R/ctr_pml_plrt2.R b/R/ctr_pml_plrt2.R index ab192471..e6c1d45e 100644 --- a/R/ctr_pml_plrt2.R +++ b/R/ctr_pml_plrt2.R @@ -19,7 +19,7 @@ ctr_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, if(is.null(x)) { - # compute 'fx' = objective function value + # compute 'fx' = objective function value # (NOTE: since 0.5-18, NOT divided by N!!) fx <- lav_model_objective(lavmodel = lavmodel, lavsamplestats = lavsamplestats, @@ -56,28 +56,28 @@ ctr_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, # we also need a `saturated model', but where the moments are based # on the model-implied sample statistics under H0 - ModelSat2 <- + ModelSat2 <- lav_partable_unrestricted(lavobject = NULL, lavdata = lavdata, lavoptions = lavoptions, lavpta = lavpta, lavsamplestats = NULL, sample.cov = computeSigmaHat(lavmodel), - sample.mean = computeMuHat(lavmodel), + sample.mean = computeMuHat(lavmodel), sample.th = computeTH(lavmodel), sample.th.idx = lavsamplestats@th.idx) Options2 <- Options Options2$optim.method <- "none" Options2$optim.force.converged <- TRUE - fittedSat2 <- lavaan(ModelSat2, + fittedSat2 <- lavaan(ModelSat2, slotOptions = Options2, slotSampleStats = lavsamplestats, slotData = lavdata, slotCache = lavcache) # the code below was contributed by Myrsini Katsikatsou (Jan 2015) -# for now, only a single group is supported: +# for now, only a single group is supported: # g = 1L @@ -99,8 +99,8 @@ ctr_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, # inverted observed information ('H.inv') if(is.null(VCOV)) { - H0.inv <- lav_model_information_observed(lavmodel = lavmodel, - lavsamplestats = lavsamplestats, lavdata = lavdata, + H0.inv <- lav_model_information_observed(lavmodel = lavmodel, + lavsamplestats = lavsamplestats, lavdata = lavdata, lavcache = lavcache, augmented = TRUE, inverted = TRUE) } else { H0.inv <- attr(VCOV, "E.inv") @@ -110,7 +110,7 @@ if(is.null(VCOV)) { if(is.null(VCOV)) { J0 <- lav_model_information_firstorder(lavmodel = lavmodel, lavsamplestats = lavsamplestats, lavdata = lavdata, - lavcache = lavcache)[,] + lavcache = lavcache)[,] } else { # we do not get J, but J.group, FIXME? J0 <- lav_model_information_firstorder(lavmodel = lavmodel, @@ -145,7 +145,7 @@ H_at_vartheta0 <- solve(attr(VCOV.Sat2, "E.inv")) # should always work # H1tmp_prod1 <- H1.inv %*% J1 H1tmp_prod1 <- InvG_at_vartheta0 %*% H_at_vartheta0 H1tmp_prod2 <- H1tmp_prod1 %*% H1tmp_prod1 -E_tzz <- sum(diag(H1tmp_prod1)) +E_tzz <- sum(diag(H1tmp_prod1)) var_tzz <- 2* sum(diag(H1tmp_prod2)) @@ -166,7 +166,7 @@ for(g in 1:lavsamplestats@ngroups) { # for now, we can assume that computeDelta will always return # the thresholds first, then the correlations # - # later, we should add a (working) add.labels = TRUE option to + # later, we should add a (working) add.labels = TRUE option to # computeDelta th.names <- lavobject@pta$vnames$th[[g]] ov.names <- lavobject@pta$vnames$ov[[g]] @@ -183,7 +183,7 @@ for(g in 1:lavsamplestats@ngroups) { drhodpsi_mat <- do.call(rbind, drhodpsi_MAT) # tmp_prod <- ( t(drhodpsi_mat) %*% H_at_vartheta0 %*% -# drhodpsi_mat %*% InvG_attheta0 %*% +# drhodpsi_mat %*% InvG_attheta0 %*% # H_attheta0 %*% InvG_attheta0 ) tmp_prod <- ( t(drhodpsi_mat) %*% H_at_vartheta0 %*% drhodpsi_mat %*% H0.inv %*% J0 %*% G0.inv ) @@ -204,7 +204,7 @@ adjusted_df <- (asym_mean_PLRTH0Sat*asym_mean_PLRTH0Sat) / (asym_var_PLRTH0Sat/ pvalue <- 1-pchisq(FSA_PLRT_SEM, df=adjusted_df ) list(PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group, - stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, + stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, scaling.factor = scaling.factor) } ############################################################################ diff --git a/R/ctr_pml_plrt_nested.R b/R/ctr_pml_plrt_nested.R index 2d451634..bf2c301a 100644 --- a/R/ctr_pml_plrt_nested.R +++ b/R/ctr_pml_plrt_nested.R @@ -5,19 +5,19 @@ # a) H0 states that some parameters are equal to 0 # b) H0 states that some parameters are equal to some others. #Note that for the latter I haven't checked if it is ok when equality constraints -#are imposed on parameters that refer to different groups in a multi-group +#are imposed on parameters that refer to different groups in a multi-group #analysis. All the code below has been developed for a single-group analysis. # Let fit_objH0 and fit_objH1 be the outputs of lavaan() function when we fit # a model under the null hypothesis and under the alternative, respectively. # The argument equalConstr is logical (T/F) and it is TRUE if equality constraints -# are imposed on subsets of the parameters. +# are imposed on subsets of the parameters. # The main idea of the code below is that we consider the parameter vector # under the alternative H1 evaluated at the values derived under H0 and for these # values we should evaluate the Hessian, the variability matrix (denoted by J) # and Godambe matrix. - + ctr_pml_plrt_nested <- function(fit_objH0, fit_objH1) { # sanity check, perhaps we misordered H0 and H1 in the function call?? @@ -33,14 +33,14 @@ ctr_pml_plrt_nested <- function(fit_objH0, fit_objH1) { } else { equalConstr = FALSE } - + nsize <- fit_objH0@SampleStats@ntotal PLRT <- 2 * (fit_objH1@optim$logl - fit_objH0@optim$logl) # create a new object 'objH1_h0': the object 'H1', but where # the parameter values are from H0 objH1_h0 <- lav_test_diff_m10(m1 = fit_objH1, m0 = fit_objH0, test = FALSE) - + # EqMat #EqMat <- lav_test_diff_A(m1 = fit_objH1, m0 = fit_objH0) EqMat <- fit_objH0@Model@ceq.JAC @@ -49,7 +49,7 @@ ctr_pml_plrt_nested <- function(fit_objH0, fit_objH1) { # -- if we do this, there is no need to use MASS::ginv later #JAC0 <- fit_objH0@Model@ceq.JAC #JAC1 <- fit_objH1@Model@ceq.JAC - #unique.idx <- which(apply(JAC0, 1, function(x) { + #unique.idx <- which(apply(JAC0, 1, function(x) { # !any(apply(JAC1, 1, function(y) { all(x == y) })) })) #if(length(unique.idx) > 0L) { # EqMat <- EqMat[unique.idx,,drop = FALSE] @@ -59,14 +59,14 @@ ctr_pml_plrt_nested <- function(fit_objH0, fit_objH1) { Hes.theta0 <- lavTech(objH1_h0, "information.observed") # handle possible constraints in H1 (and therefore also in objH1_h0) - Inv.Hes.theta0 <- + Inv.Hes.theta0 <- lav_model_information_augment_invert(lavmodel = objH1_h0@Model, information = Hes.theta0, inverted = TRUE) # the estimated variability matrix is given (=unit information first order) J.theta0 <- lavTech(objH1_h0, "first.order") - + # the Inverse of the G matrix Inv.G <- Inv.Hes.theta0 %*% J.theta0 %*% Inv.Hes.theta0 @@ -111,7 +111,7 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { MY.x.el.idx <- MY.x.el.idx2 #MY.m.el.idx2 <- fit_objH1@Model@m.free.idx - # MY.m.el.idx2 gives the POSITION index of the free parameters within each + # MY.m.el.idx2 gives the POSITION index of the free parameters within each # parameter matrix under H1 model. # The index numbering restarts from 1 when we move to a new parameter matrix. # Within each matrix the index numbering "moves" columnwise. @@ -120,7 +120,7 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # MY.x.el.idx2 ENUMERATES the free parameters within each parameter matrix. # The numbering continues as we move from one parameter matrix to the next one. - # In the case of the symmetric matrices, Theta and Psi,in some functions below + # In the case of the symmetric matrices, Theta and Psi,in some functions below # we need to give as input MY.m.el.idx2 and MY.x.el.idx2 after # we have eliminated the information about the redundant parameters # (those placed above the main diagonal). @@ -145,7 +145,7 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # MY.m.el.idx[[2]] <- MY.m.el.idx[[2]][MY.m.el.idx[[2]] %in% tmp_keep] # MY.x.el.idx[[2]] <- unique( MY.x.el.idx2[[2]] ) # } - + #below the commands to find the row-column indices of the Hessian that correspond to #the parameters to be tested equal to 0 #tmp.ind contains these indices @@ -161,7 +161,7 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # YR: use partable to find which parameters are restricted in H0 # (this should work in multiple groups too) - #h0.par.idx <- which( PT.H1.extended$free[PT.H1.extended$user < 2] > 0 & + #h0.par.idx <- which( PT.H1.extended$free[PT.H1.extended$user < 2] > 0 & # !(PT.H0.extended$free[PT.H0.extended$user < 2] > 0) ) #tmp.ind <- PT.H1.extended$free[ h0.par.idx ] #print(tmp.ind) @@ -194,10 +194,10 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # where g(theta) is the function that represents the equality constraints. g(theta) is # an rx1 vector where r are the equality constraints. In the null hypothesis # we test H0: g(theta)=0. The matrix of derivatives is of dimension: - # nrows= number of free non-redundant parameters under H0, namely + # nrows= number of free non-redundant parameters under H0, namely # NparH0 <- fit_objH0[[1]]@optim$npar , and ncols= number of free non-redundant # parameters under H1, namely NparH1 <- fit_objH0[[1]]@optim$npar. - # The matrix of derivatives of g(theta) is composed of 0's, 1's, -1's, and + # The matrix of derivatives of g(theta) is composed of 0's, 1's, -1's, and # in the rows that refer to odd number of parameters that are equal there is one -2. # The 1's, -1's (and possibly -2) are the contrast coefficients of the parameters. # The sum of the rows should be equal to 0. @@ -223,11 +223,11 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # Compute the sum of the eigenvalues and the sum of the squared eigenvalues # so that the adjustment to PLRT can be applied. - # Here a couple of functions (e.g. MYgetHessian) which are modifications of - # lavaan functions (e.g. getHessian) are needed. These are defined in the end of the file. + # Here a couple of functions (e.g. MYgetHessian) which are modifications of + # lavaan functions (e.g. getHessian) are needed. These are defined in the end of the file. #the quantity below follows the same logic as getHessian of lavaan 0.5-18 - #and it actually gives N*Hessian. That's why the command following the command below. + #and it actually gives N*Hessian. That's why the command following the command below. # NHes.theta0 <- MYgetHessian (object = obj@Model, # samplestats = obj@SampleStats , # X = obj@Data@X , @@ -282,13 +282,13 @@ ctr_pml_plrt_nested2 <- function (fit_objH0, fit_objH1) { # library(lavaan) # To run an example for the functions below the following input is needed. -# obj <- fit.objH0[[i]] -# object <- obj@Model -# samplestats = obj@SampleStats -# X = obj@Data@X -# estimator = "PML" +# obj <- fit.objH0[[i]] +# object <- obj@Model +# samplestats = obj@SampleStats +# X = obj@Data@X +# estimator = "PML" # lavcache = obj@Cache -# MY.m.el.idx = MY.m.el.idx +# MY.m.el.idx = MY.m.el.idx # MY.x.el.idx = MY.x.el.idx # MY.m.el.idx2 = MY.m.el.idx2 # input for MYx2GLIST # MY.x.el.idx2 = MY.x.el.idx2 # input for MYx2GLIST @@ -300,7 +300,7 @@ MYgetHessian <- function (object, samplestats , X , MY.m.el.idx, MY.x.el.idx, MY.m.el.idx2, MY.x.el.idx2, # input for MYx2GLIST Npar, #Npar is the number of parameters under H1 - equalConstr ) { # takes TRUE/ FALSE + equalConstr ) { # takes TRUE/ FALSE if(equalConstr){ #!!! added line } Hessian <- matrix(0, Npar, Npar) # @@ -396,7 +396,7 @@ MYgetModelParameters <- function (object, GLIST = NULL, N, #N the number of par #the difference are the input arguments MY.m.el.idx, MY.x.el.idx #used in lavaan:::computeDelta MYcomputeGradient <- function (object, GLIST, samplestats = NULL, X = NULL, - lavcache = NULL, estimator = "PML", + lavcache = NULL, estimator = "PML", MY.m.el.idx, MY.x.el.idx, equalConstr ) { if(equalConstr){ #added line } @@ -409,7 +409,7 @@ MYcomputeGradient <- function (object, GLIST, samplestats = NULL, X = NULL, Mu.hat <- computeMuHat(object, GLIST = GLIST) TH <- computeTH(object, GLIST = GLIST) g<-1 - d1 <- pml_deriv1(Sigma.hat = Sigma.hat[[g]], Mu.hat = Mu.hat[[g]], + d1 <- pml_deriv1(Sigma.hat = Sigma.hat[[g]], Mu.hat = Mu.hat[[g]], TH = TH[[g]], th.idx = th.idx[[g]], num.idx = num.idx[[g]], X = X[[g]], lavcache = lavcache[[g]]) @@ -417,7 +417,7 @@ MYcomputeGradient <- function (object, GLIST, samplestats = NULL, X = NULL, # Delta <- lavaan:::computeDelta (lavmodel= object, GLIST. = GLIST) # } else { Delta <- computeDelta (lavmodel= object, GLIST. = GLIST, - m.el.idx. = MY.m.el.idx , + m.el.idx. = MY.m.el.idx , x.el.idx. = MY.x.el.idx) # } @@ -452,7 +452,7 @@ MYgetVariability <- function (object, MY.m.el.idx, MY.x.el.idx, equalConstr ) { lavdata = object@Data, estimator = "PML", MY.m.el.idx=MY.m.el.idx, - MY.x.el.idx= MY.x.el.idx, + MY.x.el.idx= MY.x.el.idx, equalConstr = equalConstr) if(equalConstr){ #added lines } @@ -474,13 +474,13 @@ MYgetVariability <- function (object, MY.m.el.idx, MY.x.el.idx, equalConstr ) { ############################################################################## # example -# obj <- fit.objH0[[i]] -# object <- obj@Model -# samplestats = obj@SampleStats -# X = obj@Data@X -# estimator = "PML" +# obj <- fit.objH0[[i]] +# object <- obj@Model +# samplestats = obj@SampleStats +# X = obj@Data@X +# estimator = "PML" # lavcache = obj@Cache -# MY.m.el.idx = MY.m.el.idx +# MY.m.el.idx = MY.m.el.idx # MY.x.el.idx = MY.x.el.idx # MY.m.el.idx2 = MY.m.el.idx2 # input for MYx2GLIST # MY.x.el.idx2 = MY.x.el.idx2 # input for MYx2GLIST @@ -490,7 +490,7 @@ MYgetVariability <- function (object, MY.m.el.idx, MY.x.el.idx, equalConstr ) { MYNvcov.first.order <- function (lavmodel, lavsamplestats = NULL, lavdata = NULL, lavcache = NULL, - estimator = "PML", + estimator = "PML", MY.m.el.idx, MY.x.el.idx, equalConstr ) { #equalConstr takes TRUE/FALSE if(equalConstr){ #added lines @@ -510,8 +510,8 @@ MYNvcov.first.order <- function (lavmodel, lavsamplestats = NULL, TH <- computeTH(lavmodel) g <-1 - SC <- pml_deriv1(Sigma.hat = Sigma.hat[[g]], TH = TH[[g]], - Mu.hat = Mu.hat[[g]], th.idx = lavmodel@th.idx[[g]], + SC <- pml_deriv1(Sigma.hat = Sigma.hat[[g]], TH = TH[[g]], + Mu.hat = Mu.hat[[g]], th.idx = lavmodel@th.idx[[g]], num.idx = lavmodel@num.idx[[g]], X = lavdata@X[[g]], lavcache = lavcache, scores = TRUE, negative = FALSE) diff --git a/R/ctr_pml_utils.R b/R/ctr_pml_utils.R index bba5d78f..3a8e1e9f 100644 --- a/R/ctr_pml_utils.R +++ b/R/ctr_pml_utils.R @@ -1,33 +1,33 @@ # contributed by Myrsini Katsikatsou (March 2016) -#the function pc_lik_PL_with_cov gives the value of the bivariate likelihood +#the function pc_lik_PL_with_cov gives the value of the bivariate likelihood #for a specific pair of ordinal variables casewise when covariates are present and estimator=="PML" -#(the bivariate likelihood is essentially the bivariate probability of the +#(the bivariate likelihood is essentially the bivariate probability of the # observed response pattern of two ordinal variables) # Input arguments: -# Y1 is a vector, includes the observed values for the first variable for all cases/units, +# Y1 is a vector, includes the observed values for the first variable for all cases/units, # Y1 is ordinal # Y2 similar to Y1 # Rho is the polychoric correlation of Y1 and Y2 -# th.y1 is the vector of the thresholds for Y1* excluding the first and +# th.y1 is the vector of the thresholds for Y1* excluding the first and # the last thresholds which are -Inf and Inf # th.y2 is similar to th.y1 -# eXo is the data for the covariates in a matrix format where nrows= no of cases, +# eXo is the data for the covariates in a matrix format where nrows= no of cases, # ncols= no of covariates # PI.y1 is a vector, includes the regression coefficients of the covariates # for the first variable, Y1, the length of the vector is the no of covariates; # to obtain this vector apply the function lavaan:::computePI()[row_correspondin_to_Y1, ] # PI.y2 is similar to PI.y2 -# missing.ind is of "character" value, taking the values listwise, pairwise, available_cases; +# missing.ind is of "character" value, taking the values listwise, pairwise, available_cases; # to obtain a value use lavdata@missing # Output: # It is a vector, length= no of cases, giving the bivariate likelihood for each case. -pc_lik_PL_with_cov <- function(Y1, Y2, Rho, - th.y1, th.y2, - eXo, - PI.y1, PI.y2, +pc_lik_PL_with_cov <- function(Y1, Y2, Rho, + th.y1, th.y2, + eXo, + PI.y1, PI.y2, missing.ind ) { th.y1 <- c(-100, th.y1, 100) th.y2 <- c(-100, th.y2, 100) @@ -39,7 +39,7 @@ pc_lik_PL_with_cov <- function(Y1, Y2, Rho, th.y2.upper <- th.y2[Y2 +1L] - pred.y2 th.y2.lower <- th.y2[Y2 ] - pred.y2 - if (missing.ind=="listwise") { #I guess this is the default which + if (missing.ind=="listwise") { #I guess this is the default which #also handles the case of complete data biv_prob <- pbivnorm(th.y1.upper, th.y2.upper, rho= Rho) - pbivnorm(th.y1.lower, th.y2.upper, rho= Rho) - @@ -66,36 +66,36 @@ pc_lik_PL_with_cov <- function(Y1, Y2, Rho, #lik <- numeric( length(Y1) ) lik <- rep(as.numeric(NA), length(Y1)) lik[CP.idx] <- biv_prob - } + } lik } ################################################################# -# The function uni_lik gives the value of the univariate likelihood for a -# specific ordinal variable, casewise (which is essentially the probability for +# The function uni_lik gives the value of the univariate likelihood for a +# specific ordinal variable, casewise (which is essentially the probability for # the observed response category for each case). # The input arguments are explained before the function pc_lik_PL_with_cov above. -# Output: +# Output: # It is a vector, length= no of cases, giving the univariate likelihoods for each case. -uni_lik <- function(Y1, th.y1, eXo=NULL, PI.y1=NULL) { +uni_lik <- function(Y1, th.y1, eXo=NULL, PI.y1=NULL) { th.y1 <- c(-100, th.y1, 100) if(!is.null(eXo)) { pred.y1 <- c( eXo %*% PI.y1 ) } - + if(is.null(eXo)){ - th.y1.upper <- th.y1[Y1 +1L] - th.y1.lower <- th.y1[Y1 ] + th.y1.upper <- th.y1[Y1 +1L] + th.y1.lower <- th.y1[Y1 ] } else { th.y1.upper <- th.y1[Y1 +1L] - pred.y1 th.y1.lower <- th.y1[Y1 ] - pred.y1 } - + uni_lik <- pnorm(th.y1.upper) - pnorm(th.y1.lower) - + uni_lik[is.na(uni_lik)] <- 0 } @@ -104,26 +104,26 @@ uni_lik <- function(Y1, th.y1, eXo=NULL, PI.y1=NULL) { # The function lav_tables_univariate_freq_cell computes the univariate (one-way) frequency tables. -# The function closely folows the "logic" of the lavaan function +# The function closely folows the "logic" of the lavaan function # lav_tables_pairwise_freq_cell. -# The output is either a list or a data.frame depending on the value the logical +# The output is either a list or a data.frame depending on the value the logical # input argument as.data.frame. Either way, the same information is contained which is: # a) the observed (univariate) frequencies f_ia, i=1,...,p (variables), # a=1,...,ci (response categories), with a index running faster than i index. -# b) an index vector with the name varb which indicates which variable each frequency refers to. -# c) an index vector with the name group which indicates which group each frequency +# b) an index vector with the name varb which indicates which variable each frequency refers to. +# c) an index vector with the name group which indicates which group each frequency # refers to when multi-group analysis. -# d) an index vector with the name level which indicates which level within +# d) an index vector with the name level which indicates which level within # each ordinal variable each frequency refers to. -# e) a vector nobs which gives how many cases where considered to compute the -# corresponding frequency. Since we use the available data for each variable -# when missing=="available_cases" we expect these numbers to differ when +# e) a vector nobs which gives how many cases where considered to compute the +# corresponding frequency. Since we use the available data for each variable +# when missing=="available_cases" we expect these numbers to differ when # missing values are present. -# f) an index vector with the name id indexing each univariate table, -# 1 goes to first variable in the first group, 2 to 2nd variable in the second +# f) an index vector with the name id indexing each univariate table, +# 1 goes to first variable in the first group, 2 to 2nd variable in the second # group and so on. The last table has the index equal to (no of groups)*(no of variables). -lav_tables_univariate_freq_cell <- function(lavdata = NULL, +lav_tables_univariate_freq_cell <- function(lavdata = NULL, as.data.frame. = TRUE) { # shortcuts @@ -138,13 +138,13 @@ lav_tables_univariate_freq_cell <- function(lavdata = NULL, # do we have any categorical variables? if(length(cat.idx) == 0L) { stop("lavaan ERROR: no categorical variables are found") - } + } # univariate tables - univariate.tables <- vartable$name[cat.idx] - univariate.tables <- rbind(univariate.tables, + univariate.tables <- vartable$name[cat.idx] + univariate.tables <- rbind(univariate.tables, seq_len(length(univariate.tables)), - deparse.level = 0 ) + deparse.level = 0 ) ntables <- ncol(univariate.tables) # for each group, for each pairwise table, collect information @@ -153,18 +153,18 @@ lav_tables_univariate_freq_cell <- function(lavdata = NULL, UNI_TABLES[[g]] <- apply(univariate.tables, MARGIN=2, FUN=function(x) { idx1 <- which(vartable$name == x[1]) - id <- (g-1)*ntables + as.numeric(x[2]) + id <- (g-1)*ntables + as.numeric(x[2]) ncell <- vartable$nlev[idx1] # compute one-way observed frequencies Y1 <- X[[g]][,idx1] UNI_FREQ <- tabulate(Y1, nbins = max(Y1, na.rm=TRUE) ) - + list( id = rep.int(id, ncell), varb = rep.int(x[1], ncell), group = rep.int(g, ncell), nobs = rep.int(sum(UNI_FREQ), ncell), - level = seq_len(ncell), + level = seq_len(ncell), obs.freq = UNI_FREQ ) }) @@ -173,7 +173,7 @@ lav_tables_univariate_freq_cell <- function(lavdata = NULL, if(as.data.frame.) { for(g in 1:ngroups) { UNI_TABLE <- UNI_TABLES[[g]] - UNI_TABLE <- lapply(UNI_TABLE, as.data.frame, + UNI_TABLE <- lapply(UNI_TABLE, as.data.frame, stringsAsFactors=FALSE) if(g == 1) { out <- do.call(rbind, UNI_TABLE) @@ -182,7 +182,7 @@ lav_tables_univariate_freq_cell <- function(lavdata = NULL, } } if(g == 1) { - # remove group column + # remove group column out$group <- NULL } } else { @@ -201,13 +201,13 @@ lav_tables_univariate_freq_cell <- function(lavdata = NULL, # The function univariateExpProbVec gives the model-based univariate probabilities -# for all ordinal indicators and for all of their response categories, i.e. pi(xi=a), where +# for all ordinal indicators and for all of their response categories, i.e. pi(xi=a), where # a=1,...,ci and i=1,...,p with a index running faster than i index. # Input arguments: -# TH is a vector giving the thresholds for all variables, tau_ia, with a running +# TH is a vector giving the thresholds for all variables, tau_ia, with a running # faster than i (the first and the last thresholds which are -Inf and Inf are # not included). TH can be given by the lavaan function computeTH . -# th.idx is a vector of same length as TH which gives the value of the i index, +# th.idx is a vector of same length as TH which gives the value of the i index, # namely which variable each thresholds refers to. This can be obtained by # lavmodel@th.idx . # Output: @@ -229,23 +229,23 @@ univariateExpProbVec <- function(TH=TH, th.idx=th.idx){ # The function pc_cor_scores_PL_with_cov computes the derivatives of a bivariate # log-likelihood of two ordinal variables casewise with respect to thresholds, -# slopes (reduced-form regression coefficients for the covariates), and polychoric correlation. +# slopes (reduced-form regression coefficients for the covariates), and polychoric correlation. # The function dbinorm of lavaan is used. -# The function gives the right result for both listwise and pairwise deletion, +# The function gives the right result for both listwise and pairwise deletion, # and the case of complete data. # Input arguments are explained before the function pc_lik_PL_with_cov defined above. # The only difference is that PI.y1 and PI.y2 are (accidentally) renamed here as sl.y1 and sl.y2 # Output: # It is a list containing the following -# a) the derivatives w.r.t. the thresholds of the first variable casewise. +# a) the derivatives w.r.t. the thresholds of the first variable casewise. # This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 1. -# b) the derivatives w.r.t. the thresholds of the second variable casewise. +# b) the derivatives w.r.t. the thresholds of the second variable casewise. # This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 2. # c) the derivatives w.r.t slopes for variable 1. This is a matrix, where # nrows=no of cases, ncols= no of covariates. -# d) the derivatives w.r.t slopes for variable 2. This is a matrix, where +# d) the derivatives w.r.t slopes for variable 2. This is a matrix, where # nrows=no of cases, ncols= no of covariates. -# e) the derivative w.r.t the polychoric correlation of the two variables. +# e) the derivative w.r.t the polychoric correlation of the two variables. # This is a vector of length= no of cases. @@ -255,12 +255,12 @@ pc_cor_scores_PL_with_cov <- function(Y1, Y2, eXo, Rho, missing.ind) { nth.y1 <- length(th.y1) nth.y2 <- length(th.y2) - + start.th.y1 <- th.y1 start.th.y2 <- th.y2 - + Nobs <- length(Y1) - + R <- sqrt(1 - Rho*Rho) th.y1 <- c(-100, th.y1, 100) th.y2 <- c(-100, th.y2, 100) @@ -275,7 +275,7 @@ pc_cor_scores_PL_with_cov <- function(Y1, Y2, eXo, Rho, # lik, i.e. the bivariate probability case-wise lik <- pc_lik_PL_with_cov(Y1=Y1, Y2=Y2, Rho=Rho, - th.y1= start.th.y1, + th.y1= start.th.y1, th.y2= start.th.y2, eXo=eXo, PI.y1=sl.y1, @@ -290,13 +290,13 @@ pc_cor_scores_PL_with_cov <- function(Y1, Y2, eXo, Rho, #derivarive bivariate prob w.r.t. tau^xi_(ci-1), y1.Z2 <- (-1)*( dnorm(th.y1.z2) * ( pnorm( (th.y2.z1- Rho*th.y1.z2)/R) - pnorm( (th.y2.z2- Rho*th.y1.z2)/R) ) ) - - + + #allocate the derivatives at the right column casewise idx.y1.z1 <- matrix(1:nth.y1, nrow=Nobs, ncol=nth.y1, byrow=TRUE) == Y1 idx.y1.z2 <- matrix(1:nth.y1, nrow=Nobs, ncol=nth.y1, byrow=TRUE) == (Y1-1L) der.table.y1 <- idx.y1.z1* y1.Z1 + idx.y1.z2* y1.Z2 - + #der of pl w.r.t. th.y1 dx.th.tilde.y1 <- der.table.y1/lik dx.th.tilde.y1[is.na(dx.th.tilde.y1)]<-0 @@ -327,9 +327,9 @@ pc_cor_scores_PL_with_cov <- function(Y1, Y2, eXo, Rho, dbinorm(th.y1.z2, th.y2.z2, Rho) ) #der of pl w.r.t. rho dx.rho <- dbivprob.wrt.rho/lik - dx.rho[is.na(dx.rho)] <- 0 - - + dx.rho[is.na(dx.rho)] <- 0 + + #der of pl w.r.t. slopes (also referred to PI obtained by computePI function) row.sums.y1 <- rowSums(dx.th.tilde.y1) row.sums.y2 <- rowSums(dx.th.tilde.y2) @@ -347,18 +347,18 @@ pc_cor_scores_PL_with_cov <- function(Y1, Y2, eXo, Rho, ############################################################### -# The function uni_scores gives, casewise, the derivative of a univariate -# log-likelihood w.r.t. thresholds and slopes if present weighted by the +# The function uni_scores gives, casewise, the derivative of a univariate +# log-likelihood w.r.t. thresholds and slopes if present weighted by the # casewise uni-weights as those defined in AC-PL (essentially the number of missing values per case). # The function closely follows the "logic" of the function pc_cor_scores_PL_with_cov defined above. -# Input arguments are as before plus: weights.casewise given by +# Input arguments are as before plus: weights.casewise given by # lavcavhe$uniweights.casewise . # Output: # A list including the following: -# a) the derivatives w.r.t. the thresholds of the variable. This is a matrix, +# a) the derivatives w.r.t. the thresholds of the variable. This is a matrix, # nrows=no of cases, ncols= no of thresholds of variable 1. # b) the derivatives w.r.t slopes for the variable. If covariates are present, -# this is a matrix, nrows=no of cases, ncols= no of covariates. +# this is a matrix, nrows=no of cases, ncols= no of covariates. # Otherwise it takes the value NULL. @@ -370,8 +370,8 @@ uni_scores <- function(Y1, th.y1, eXo=NULL, sl.y1=NULL, th.y1 <- c(-100, th.y1, 100) if(is.null(eXo)){ - th.y1.z1 <- th.y1[Y1 +1L] - th.y1.z2 <- th.y1[Y1 ] + th.y1.z1 <- th.y1[Y1 +1L] + th.y1.z2 <- th.y1[Y1 ] } else { pred.y1 <- c( eXo %*% sl.y1 ) th.y1.z1 <- th.y1[Y1 +1L] - pred.y1 @@ -379,32 +379,32 @@ uni_scores <- function(Y1, th.y1, eXo=NULL, sl.y1=NULL, } # lik, i.e. the univariate probability case-wise - lik <- uni_lik( #Y1 = X[,i], + lik <- uni_lik( #Y1 = X[,i], Y1 = Y1, - #th.y1 = TH[th.idx==i], + #th.y1 = TH[th.idx==i], th.y1 = th.y1, - eXo = eXo, - #PI.y1 = PI[i,]) + eXo = eXo, + #PI.y1 = PI[i,]) PI.y1 = sl.y1) #w.r.t. th.y1 #derivarive of the univariate prob w.r.t. to the upper limit threshold - y1.Z1 <- dnorm(th.y1.z1) + y1.Z1 <- dnorm(th.y1.z1) #derivarive of the univariate prob w.r.t. to the lower limit threshold - y1.Z2 <- (-1)* dnorm(th.y1.z2) - + y1.Z2 <- (-1)* dnorm(th.y1.z2) + #allocate the derivatives at the right column casewise idx.y1.z1 <- matrix(1:nth.y1, nrow=Nobs, ncol=nth.y1, byrow=TRUE) == Y1 idx.y1.z2 <- matrix(1:nth.y1, nrow=Nobs, ncol=nth.y1, byrow=TRUE) == (Y1-1L) der.table.y1 <- idx.y1.z1* y1.Z1 + idx.y1.z2* y1.Z2 - + #der of pl w.r.t. th.y1 dx.th.tilde.y1 <- der.table.y1* (weights.casewise/lik) dx.th.tilde.y1[is.na(dx.th.tilde.y1)]<-0 #der of pl w.r.t. slopes (also referred to PI obtained by computePI function) dx.sl.y1 <- NULL - if(!is.null(eXo)) { + if(!is.null(eXo)) { row.sums.y1 <- rowSums(dx.th.tilde.y1) dx.sl.y1 <- (-1)*eXo*row.sums.y1 } diff --git a/R/lav_binorm.R b/R/lav_binorm.R index 7f67e088..c86eee73 100644 --- a/R/lav_binorm.R +++ b/R/lav_binorm.R @@ -2,7 +2,7 @@ # YR # TODO: better handling of rho=1.0 -# density of a bivariate standard normal +# density of a bivariate standard normal dbinorm <- function(u, v, rho) { # dirty hack to handle extreme large values for rho # note that u, v, and rho are vectorized! @@ -75,12 +75,12 @@ pbinorm2 <- function(upper.x=NULL, upper.y=NULL, rho=0.0, lower.x <- rep(lower.x, N) if(length(lower.y) == 1L) lower.y <- rep(lower.y, N) - } + } upper.only <- all(lower.x == -Inf & lower.y == -Inf) if(upper.only) { upper.x[upper.x == +Inf] <- exp(10) # better pnorm? - upper.y[upper.y == +Inf] <- exp(10) + upper.y[upper.y == +Inf] <- exp(10) upper.x[upper.x == -Inf] <- -exp(10) upper.y[upper.y == -Inf] <- -exp(10) res <- pbivnorm(upper.x, upper.y, rho=rho) @@ -88,9 +88,9 @@ pbinorm2 <- function(upper.x=NULL, upper.y=NULL, rho=0.0, # pbivnorm does not handle -Inf well... lower.x[lower.x == -Inf] <- -exp(10) lower.y[lower.y == -Inf] <- -exp(10) - res <- pbivnorm(upper.x, upper.y, rho=rho) - - pbivnorm(lower.x, upper.y, rho=rho) - - pbivnorm(upper.x, lower.y, rho=rho) + + res <- pbivnorm(upper.x, upper.y, rho=rho) - + pbivnorm(lower.x, upper.y, rho=rho) - + pbivnorm(upper.x, lower.y, rho=rho) + pbivnorm(lower.x, lower.y, rho=rho) } @@ -109,14 +109,14 @@ pbinorm2 <- function(upper.x=NULL, upper.y=NULL, rho=0.0, # # corr=matrix(c(1,rho,rho,1),2L,2L)) # # # MNORMT -# biv.nt.prob(df=0, +# biv.nt.prob(df=0, # lower=c(lower.x, lower.y), # upper=c(upper.x, upper.y), # mean=c(0,0), # S=matrix(c(1,rho,rho,1),2L,2L)) # # # PBIVNORM -# +# # } # # N <- length(upper.x) @@ -125,7 +125,7 @@ pbinorm2 <- function(upper.x=NULL, upper.y=NULL, rho=0.0, # if(length(rho) == 1L) # rho <- rep(rho, N) # if(length(lower.x) == 1L) -# lower.x <- rep(lower.x, N) +# lower.x <- rep(lower.x, N) # if(length(lower.y) == 1L) # lower.y <- rep(lower.y, N) # } @@ -135,10 +135,10 @@ pbinorm2 <- function(upper.x=NULL, upper.y=NULL, rho=0.0, # # biv.nt.prob does allow abs(rho) > 1 # stopifnot(all(abs(rho) <= 1)) # -# # vectorize (this would be faster if the loop is in the fortran code!) +# # vectorize (this would be faster if the loop is in the fortran code!) # res <- sapply(seq_len(N), function(i) # p2_i(lower.x[i], lower.y[i], -# upper.x[i], upper.y[i], +# upper.x[i], upper.y[i], # rho[i])) # res #} diff --git a/R/lav_bootstrap.R b/R/lav_bootstrap.R index 3d343727..811ab504 100644 --- a/R/lav_bootstrap.R +++ b/R/lav_bootstrap.R @@ -3,12 +3,12 @@ # free parameters for each bootstrap sample # # return COEF matrix of size R x npar (R = number of bootstrap samples) -# +# # Ed. 9 mar 2012 # # Notes: - faulty runs are simply ignored (with a warning) # - default R=1000 -# +# # Updates: - now we have a separate @data slot, we only need to transform once # for the bollen.stine bootstrap (13 dec 2011) # - bug fix: we need to 'update' the fixed.x variances/covariances @@ -19,10 +19,10 @@ -bootstrapLavaan <- function(object, - R = 1000L, +bootstrapLavaan <- function(object, + R = 1000L, type = "ordinary", - verbose = FALSE, + verbose = FALSE, FUN = "coef", warn = -1L, return.boot = FALSE, @@ -43,7 +43,7 @@ bootstrapLavaan <- function(object, # check if options$se is not bootstrap, otherwise, we get an infinite loop if(object@Options$se == "bootstrap") stop("lavaan ERROR: se == \"bootstrap\"; please refit model with another option for \"se\"") - + # check if options$test is not bollen.stine if(object@Options$test == "bollen.stine") stop("lavaan ERROR: test == \"bollen.stine\"; please refit model with another option for \"test\"") @@ -53,7 +53,7 @@ bootstrapLavaan <- function(object, stop("lavaan ERROR: this function is not (yet) available if conditional.x = TRUE") } - lavoptions. <- list(parallel = parallel, ncpus = ncpus, cl = cl, + lavoptions. <- list(parallel = parallel, ncpus = ncpus, cl = cl, iseed = iseed) bootstrap.internal(object = object, @@ -184,7 +184,7 @@ bootstrap.internal <- function(object = NULL, # if yuan, transform data here if(type == "yuan") { - # page numbers refer to Yuan et al, 2007 + # page numbers refer to Yuan et al, 2007 # Define a function to find appropriate value of a # (p. 272); code supplied 16 jun 2016 by Cheng & Wu search.a <- function(F0, d, p) { @@ -245,7 +245,7 @@ bootstrap.internal <- function(object = NULL, S.inv.sqrt <- lav_matrix_symmetric_sqrt(lavsamplestats@icov[[g]]) X <- lavdata@X[[g]] - X <- X %*% S.inv.sqrt %*% S.a.sqrt + X <- X %*% S.inv.sqrt %*% S.a.sqrt # transformed data dataX[[g]] <- X @@ -292,7 +292,7 @@ bootstrap.internal <- function(object = NULL, group.w.free = lavoptions$group.w.free, #missing.h1 = (FUN != "coef"), # not if fixed.x, otherwise starting values fails! missing.h1 = TRUE, - verbose = FALSE), silent=TRUE) + verbose = FALSE), silent=TRUE) if(inherits(bootSampleStats, "try-error")) { if(verbose) { cat(" FAILED: creating sample statistics\n") @@ -310,7 +310,7 @@ bootstrap.internal <- function(object = NULL, ### FIXME ##### #if(lavmodel@fixed.x && length(vnames(partable, "ov.x")) > 0L) { # for(g in 1:lavsamplestats@ngroups) { - # + # # } #} if(lavmodel@fixed.x && length(vnames(lavpartable, "ov.x")) > 0L) { @@ -329,17 +329,17 @@ bootstrap.internal <- function(object = NULL, if(verbose) cat(" FAILED: no convergence\n") options(old_options) return(NULL) - } - + } + # extract information we need if(is.null(object)) { # internal use only! if(FUN == "coef") { out <- fit.boot@optim$x - } else if(FUN == "test") { + } else if(FUN == "test") { out <- fit.boot@test[[1L]]$stat - } else if(FUN == "coeftest") { + } else if(FUN == "coeftest") { out <- c(fit.boot@optim$x, fit.boot@test[[1L]]$stat) - } + } } else { # general use out <- try(FUN(fit.boot, ...), silent=TRUE) } @@ -347,8 +347,8 @@ bootstrap.internal <- function(object = NULL, if(verbose) cat(" FAILED: applying FUN to fit.boot\n") options(old_options) return(NULL) - } - if(verbose) cat(" OK -- niter = ", + } + if(verbose) cat(" OK -- niter = ", sprintf("%3d", fit.boot@optim$iterations), " fx = ", sprintf("%13.9f", fit.boot@optim$fx), "\n") out @@ -399,7 +399,7 @@ bootstrap.internal <- function(object = NULL, # NOT DONE YET if(return.boot) { # mimic output boot function - } + } # restore options options(old_options) diff --git a/R/lav_bootstrap_lrt.R b/R/lav_bootstrap_lrt.R index 37ab9524..94899e3c 100644 --- a/R/lav_bootstrap_lrt.R +++ b/R/lav_bootstrap_lrt.R @@ -1,19 +1,19 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, type = "bollen.stine", verbose = FALSE, - return.LRT = FALSE, + return.LRT = FALSE, double.bootstrap = "no", - double.bootstrap.R = 500L, - double.bootstrap.alpha = 0.05, - warn = -1L, - parallel = c("no", "multicore", "snow"), - ncpus = 1L, - cl = NULL, + double.bootstrap.R = 500L, + double.bootstrap.alpha = 0.05, + warn = -1L, + parallel = c("no", "multicore", "snow"), + ncpus = 1L, + cl = NULL, iseed = NULL) { # checks type <- tolower(type) - stopifnot(inherits(h0, "lavaan"), - inherits(h1, "lavaan"), + stopifnot(inherits(h0, "lavaan"), + inherits(h1, "lavaan"), type %in% c("bollen.stine", "parametric", "yuan", "nonparametric", "ordinary"), double.bootstrap %in% c("no", "FDB", "standard")) @@ -28,7 +28,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, # prepare LRT <- rep(as.numeric(NA), R) - if((h1@optim$fx - h0@optim$fx) > (.Machine$double.eps * 10)) { + if((h1@optim$fx - h0@optim$fx) > (.Machine$double.eps * 10)) { # restricted fit should not be better! cat(" ... h0@optim$fx = ", h0@optim$fx, "h1@optim$fx = ", h1@optim$fx, "h0 should not be better!\n") @@ -37,31 +37,31 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, } LRT.original <- abs(anova(h0, h1)$`Chisq diff`[2L]) # abs only needed because df may be the same for both models! - - + + if(double.bootstrap == "FDB") { LRT.2 <- numeric(R) } else if(double.bootstrap == "standard") { plugin.pvalues <- numeric(R) } - - + + # prepare for parallel processing if(missing(parallel)) parallel <- "no" parallel <- match.arg(parallel) have_mc <- have_snow <- FALSE if(parallel != "no" && ncpus > 1L) { - if(parallel == "multicore") + if(parallel == "multicore") have_mc <- .Platform$OS.type != "windows" - else if(parallel == "snow") + else if(parallel == "snow") have_snow <- TRUE - if(!have_mc && !have_snow) + if(!have_mc && !have_snow) ncpus <- 1L } #data data <- h0@Data - + #Compute covariance matrix and additional mean vector if(type == "bollen.stine" || type == "parametric" || type == "yuan") { Sigma.hat <- computeSigmaHat(lavmodel = h0@Model) @@ -77,7 +77,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, } else { dataX <- data@X } - + #Bollen-Stine data transformation if(type == "bollen.stine") { for(g in 1:h0@Data@ngroups) { @@ -91,7 +91,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, X <- X %*% S.inv.sqrt %*% sigma.sqrt # add model based mean - if (h0@Model@meanstructure) + if (h0@Model@meanstructure) X <- scale(X, center = (-1 * Mu.hat[[g]]), scale = FALSE) # transformed data @@ -101,7 +101,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, # Yuan et al data transformation if(type == "yuan") { - # page numbers refer to Yuan et al, 2007 + # page numbers refer to Yuan et al, 2007 # Define a function to find appropriate value of a # (p. 272) g.a <- function(a, Sigmahat, Sigmahat.inv, S, tau.hat, p){ @@ -114,7 +114,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, (Sigmahat.inv - chol2inv(chol(S.a))))) res } - + # Now use g.a within each group for(g in 1:h0@Data@ngroups) { S <- h0@SampleStats@cov[[g]] @@ -147,7 +147,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, S.inv.sqrt <- lav_matrix_symmetric_sqrt(h0@SampleStats@icov[[g]]) X <- data@X[[g]] - X <- X %*% S.inv.sqrt %*% S.a.sqrt + X <- X %*% S.inv.sqrt %*% S.a.sqrt # transformed data dataX[[g]] <- X @@ -160,14 +160,14 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, # take a bootstrap sample for each group for(g in 1:h0@Data@ngroups) { stopifnot(h0@SampleStats@nobs[[g]] > 1L) - boot.idx <- sample(x = h0@SampleStats@nobs[[g]], + boot.idx <- sample(x = h0@SampleStats@nobs[[g]], size = h0@SampleStats@nobs[[g]], replace = TRUE) dataX[[g]] <- dataX[[g]][boot.idx,,drop=FALSE] } } else { # parametric! for(g in 1:h0@Data@ngroups) { - dataX[[g]] <- MASS::mvrnorm(n = h0@SampleStats@nobs[[g]], - mu = Mu.hat[[g]], + dataX[[g]] <- MASS::mvrnorm(n = h0@SampleStats@nobs[[g]], + mu = Mu.hat[[g]], Sigma = Sigma.hat[[g]]) } } @@ -177,13 +177,13 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, #Get sample statistics bootSampleStats <- try(lav_samplestats_from_data( - lavdata = NULL, + lavdata = NULL, DataX = dataX, DataOv = data@ov, DataOvnames = data@ov.names, missing = h0@Options$missing, - rescale = (h0@Options$estimator == "ML" && - h0@Options$likelihood =="normal"), + rescale = (h0@Options$estimator == "ML" && + h0@Options$likelihood =="normal"), estimator = h0@Options$estimator, mimic = h0@Options$mimic, meanstructure = h0@Options$meanstructure, @@ -207,16 +207,16 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, #Fit h0 model fit.h0 <- lavaan(slotOptions = h0@Options, - slotParTable = h0@ParTable, - slotSampleStats = bootSampleStats, + slotParTable = h0@ParTable, + slotSampleStats = bootSampleStats, slotData = data) if (!fit.h0@optim$converged) { if (verbose) cat(" FAILED: no convergence\n") options(old_options) return(NULL) } - if (verbose) - cat(" ok -- niter = ", fit.h0@optim$iterations, + if (verbose) + cat(" ok -- niter = ", fit.h0@optim$iterations, " fx = ", fit.h0@optim$fx, "\n") if (verbose) cat(" ... ... model h1: ") @@ -225,20 +225,20 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, h1@Options$test <- "standard" #Fit h1 model - fit.h1 <- lavaan(slotOptions = h1@Options, - slotParTable = h1@ParTable, - slotSampleStats = bootSampleStats, + fit.h1 <- lavaan(slotOptions = h1@Options, + slotParTable = h1@ParTable, + slotSampleStats = bootSampleStats, slotData = data) if (!fit.h1@optim$converged) { - if (verbose) - cat(" FAILED: no convergence -- niter = ", fit.h1@optim$iterations, + if (verbose) + cat(" FAILED: no convergence -- niter = ", fit.h1@optim$iterations, " fx = ", fit.h1@optim$fx,"\n") options(old_options) return(NULL) } - if (verbose) - cat(" ok -- niter = ", fit.h1@optim$iterations, + if (verbose) + cat(" ok -- niter = ", fit.h1@optim$iterations, " fx = ", fit.h1@optim$fx, "\n") # store LRT @@ -253,42 +253,42 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, if (verbose) cat(" ... ... LRT = ", lrt.boot, "\n") } - + #double bootstrap if (double.bootstrap == "standard") { if (verbose) cat(" ... ... calibrating p.value - ") - plugin.pvalue <- bootstrapLRT(h0 = fit.h0, h1 = fit.h1, - R = double.bootstrap.R, - type = type, - verbose = FALSE, + plugin.pvalue <- bootstrapLRT(h0 = fit.h0, h1 = fit.h1, + R = double.bootstrap.R, + type = type, + verbose = FALSE, return.LRT = FALSE, #FALSE - warn = warn, - parallel = parallel, + warn = warn, + parallel = parallel, ncpus = ncpus, cl = cl, double.bootstrap = "no") if (verbose) cat(sprintf("%5.3f", plugin.pvalue), "\n") attr(lrt.boot, "plugin.pvalue") <- plugin.pvalue } else if (double.bootstrap == "FDB") { #Fast double bootstrap - plugin.pvalue <- bootstrapLRT(h0 = fit.h0, h1 = fit.h1, - R = 1L, - type = type, - verbose = FALSE, - warn = warn, + plugin.pvalue <- bootstrapLRT(h0 = fit.h0, h1 = fit.h1, + R = 1L, + type = type, + verbose = FALSE, + warn = warn, return.LRT = TRUE, #TRUE - parallel = parallel, + parallel = parallel, ncpus = ncpus, cl = cl, - double.bootstrap = "no") + double.bootstrap = "no") LRT.2 <- attr(plugin.pvalue, "LRT") if (verbose) cat(" ... ... LRT2 = ", LRT.2, "\n") attr(lrt.boot, "LRT.2") <- LRT.2 - } + } lrt.boot } - + #Parallel processing RR <- sum(R) res <- if (ncpus > 1L && (have_mc || have_snow)) { @@ -298,9 +298,9 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, else if (have_snow) { if (is.null(cl)) { cl <- parallel::makePSOCKcluster(rep("localhost", ncpus)) # - if (RNGkind()[1L] == "L'Ecuyer-CMRG") - parallel::clusterSetRNGStream(cl, iseed = iseed) # - res <- parallel::parLapply(cl, seq_len(RR), fn) # + if (RNGkind()[1L] == "L'Ecuyer-CMRG") + parallel::clusterSetRNGStream(cl, iseed = iseed) # + res <- parallel::parLapply(cl, seq_len(RR), fn) # parallel::stopCluster(cl) # res } @@ -312,7 +312,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, for (b in seq_len(RR)) { if (!is.null(res[[b]])) { LRT[b] <- res[[b]] - if (double.bootstrap == "standard") { + if (double.bootstrap == "standard") { plugin.pvalues[b] <- attr(res[[b]], "plugin.pvalue") } else if (double.bootstrap == "FDB") { LRT.2[b] <- attr(res[[b]], "LRT.2") @@ -325,29 +325,29 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, #Error handling if (length(error.idx) > 0L) { - warning("lavaan WARNING: only ", (R - length(error.idx)), + warning("lavaan WARNING: only ", (R - length(error.idx)), " bootstrap draws were successful") LRT <- LRT[-error.idx] if(length(LRT) == 0) LRT <- as.numeric(NA) - if (double.bootstrap == "standard") { + if (double.bootstrap == "standard") { plugin.pvalues <- plugin.pvalues[-error.idx] attr(LRT, "error.idx") <- error.idx } - if (double.bootstrap == "FDB") { + if (double.bootstrap == "FDB") { LRT.2 <- LRT.2[-error.idx] attr(LRT.2, "error.idx") <- error.idx } } else { - if (verbose) - cat("Number of successful bootstrap draws:", (R - + if (verbose) + cat("Number of successful bootstrap draws:", (R - length(error.idx)), "\n") } pvalue <- sum(LRT > LRT.original) / length(LRT) - if (return.LRT) { + if (return.LRT) { attr(pvalue, "LRT.original") <- LRT.original attr(pvalue, "LRT") <- LRT } @@ -362,7 +362,7 @@ bootstrapLRT <- function (h0 = NULL, h1 = NULL, R = 1000L, attr(pvalue, "LRT.original") <- LRT.original attr(pvalue, "LRT") <- LRT attr(pvalue, "LRT2") <- LRT.2 - } + } } else if (double.bootstrap == "standard") { adj.alpha <- quantile(plugin.pvalues, double.bootstrap.alpha, na.rm=TRUE) diff --git a/R/lav_cfa_1fac.R b/R/lav_cfa_1fac.R index cd3dd894..f808e132 100644 --- a/R/lav_cfa_1fac.R +++ b/R/lav_cfa_1fac.R @@ -1,10 +1,10 @@ -# special functions for the one-factor model +# special functions for the one-factor model # YR 24 June 2018 # 1-factor model with (only) three indicators: # no iterations needed; can be solved analytically -# denote s11, s22, s33 the diagonal elements, and +# denote s11, s22, s33 the diagonal elements, and # s21, s31, s32 the off-diagonal elements # under the 1-factor model; typically, either psi == 1, or l1 == 1 @@ -27,10 +27,10 @@ # # (note: all eigenvalues are positive) -lav_cfa_1fac_3ind <- function(sample.cov, std.lv = FALSE, +lav_cfa_1fac_3ind <- function(sample.cov, std.lv = FALSE, warn.neg.triad = TRUE) { - - # check sample cov + + # check sample cov stopifnot(is.matrix(sample.cov)) nRow <- NROW(sample.cov); nCol <- NCOL(sample.cov) stopifnot(nRow == 3L, nCol == 3L) @@ -44,48 +44,77 @@ lav_cfa_1fac_3ind <- function(sample.cov, std.lv = FALSE, warning("lavaan WARNING: product of the three covariances is negative!") } - # solution + # first, we assume l1 = 1 + psi <- (s21*s31)/s32 + l1 <- 1 + l2 <- s32/s31 # l2 <- s21/psi + l3 <- s32/s21 # l3 <- s31/psi + theta1 <- s11 - psi + theta2 <- s22 - l2*l2*psi + theta3 <- s33 - l3*l3*psi + lambda <- c(l1, l2, l3) + theta <- c(theta1, theta2, theta3) + + # std.lv? if(std.lv) { + # we allow for negative psi + lambda <- lambda * sign(psi) * sqrt(abs(psi)) psi <- 1 - l1.square <- (s21*s31)/s32 - l2.square <- (s21*s32)/s31 - l3.square <- (s31*s32)/s21 - theta1 <- s11 - l1.square - theta2 <- s22 - l2.square - theta3 <- s33 - l3.square - l1 <- sign(l1.square) * sqrt( abs(l1.square) ) - l2 <- sign(l2.square) * sqrt( abs(l2.square) ) - l3 <- sign(l3.square) * sqrt( abs(l3.square) ) - } else { - psi <- (s21*s31)/s32 - l1 <- 1 - l2 <- s32/s31 # l2 <- s21/psi - l3 <- s32/s21 # l3 <- s31/psi - theta1 <- s11 - psi - theta2 <- s22 - l2*l2*psi - theta3 <- s33 - l3*l3*psi } - - list(lambda = c(l1,l2,l3), psi = psi, theta = c(theta1, theta2, theta3)) + + list(lambda = lambda, theta = theta, psi = psi) } # FABIN (Hagglund, 1982) -# 1-factor only (in this case fabin2 == fabin3) -lav_cfa_1fac_fabin <- function(S) { +# 1-factor only +lav_cfa_1fac_fabin <- function(S, lambda.only = FALSE, method = "fabin3", + std.lv = FALSE, extra = NULL) { nvar <- NCOL(S) - if(nvar < 3) { - return( rep(1, nvar) ) + + # catch nvar < 4 + if(nvar < 4L) { + lav_cfa_1fac_3ind(sample.cov = S, std.lv = std.lv, + warn.neg.triad = FALSE) } - out <- numeric( nvar ); out[1L] <- 1.0 + # 1. lambda + lambda <- numeric( nvar ); lambda[1L] <- 1.0 for(i in 2:nvar) { idx3 <- (1:nvar)[-c(i, 1L)] s23 <- S[i, idx3] S31 <- S13 <- S[idx3, 1L] - out[i] <- ( s23 / S31 ) + if(method == "fabin3") { + S33 <- S[idx3,idx3] + tmp <- solve(S33, S31) # GaussJordanPivot is slighty more efficient + lambda[i] <- sum(s23 * tmp) / sum(S13 * tmp) + } else { + lambda[i] <- sum(s23 * S31) / sum(S13^2) + } + } + + if(lambda.only) { + return(list(lambda = lambda, psi = as.numeric(NA), + theta = rep(as.numeric(NA), nvar)) + ) + } + + # 2. theta + D <- tcrossprod(lambda) / sum(lambda^2) + theta <- solve(diag(nvar) - D*D, diag(S - (D %*% S %*% D))) + + # 3. psi + S1 <- S - diag(theta) + l2 <- sum(lambda^2) + psi <- sum(colSums(as.numeric(lambda) * S1) * lambda) / (l2 * l2) + + # std.lv? + if(std.lv) { + # we allow for negative psi + lambda <- lambda * sign(psi) * sqrt(abs(psi)) + psi <- 1 } - out + list(lambda = lambda, theta = theta, psi = psi) } diff --git a/R/lav_constraints.R b/R/lav_constraints.R index cc9584b3..dc02f5c8 100644 --- a/R/lav_constraints.R +++ b/R/lav_constraints.R @@ -116,8 +116,8 @@ lav_constraints_parse <- function(partable = NULL, constraints = NULL, ceq.only.flag <- ceq.flag && !cin.flag cin.only.flag <- cin.flag && !ceq.flag - ceq.linear.only.flag <- ( ceq.linear.flag && - !ceq.nonlinear.flag && + ceq.linear.only.flag <- ( ceq.linear.flag && + !ceq.nonlinear.flag && !cin.flag ) # additional info if ceq.linear.flag @@ -125,15 +125,15 @@ lav_constraints_parse <- function(partable = NULL, constraints = NULL, ## NEW: 18 nov 2014: handle general *linear* constraints ## ## see Nocedal & Wright (2006) 15.3 - ## - from x to x.red: + ## - from x to x.red: ## x.red <- MASS::ginv(Q2) %*% (x - Q1 %*% solve(t(R)) %*% b) ## or - ## x.red <- as.numeric((x - b %*% qr.coef(QR,diag(npar))) %*% Q2) - ## + ## x.red <- as.numeric((x - b %*% qr.coef(QR,diag(npar))) %*% Q2) + ## ## - from x.red to x - ## x <- as.numeric(Q1 %*% solve(t(R)) %*% b + Q2 %*% x.red) + ## x <- as.numeric(Q1 %*% solve(t(R)) %*% b + Q2 %*% x.red) ## or - ## x <- as.numeric(b %*% qr.coef(QR, diag(npar))) + + ## x <- as.numeric(b %*% qr.coef(QR, diag(npar))) + ## as.numeric(Q2 %*% x.red) ## ## we write eq.constraints.K = Q2 @@ -202,10 +202,10 @@ lav_constraints_parse <- function(partable = NULL, constraints = NULL, OUT } -lav_constraints_linear_idx <- function(func = NULL, npar = NULL) { +lav_constraints_linear_idx <- function(func = NULL, npar = NULL) { if(is.null(func) || is.null(body(func))) return(integer(0L)) - + # seed 1: rnorm A0 <- lav_func_jacobian_complex(func = func, x = rnorm(npar)) @@ -217,8 +217,8 @@ lav_constraints_linear_idx <- function(func = NULL, npar = NULL) { which(linear) } -lav_constraints_nonlinear_idx <- function(func = NULL, npar = NULL) { - +lav_constraints_nonlinear_idx <- function(func = NULL, npar = NULL) { + if(is.null(func) || is.null(body(func))) return(integer(0L)) # seed 1: rnorm @@ -242,7 +242,7 @@ lav_constraints_check_linear <- function(model) { A.ceq <- t(lav_func_jacobian_complex(func=model@ceq.function, x=rnorm(model@nx.free))) if(!is.null(body(model@cin.function))) A.cin <- t(lav_func_jacobian_complex(func=model@cin.function, x=rnorm(model@nx.free))) - A0 <- cbind(A.ceq, A.cin) + A0 <- cbind(A.ceq, A.cin) # seed 2: rnorm A.ceq <- A.cin <- matrix(0, model@nx.free, 0) @@ -290,7 +290,7 @@ lav_constraints_R2K <- function(lavmodel = NULL, R = NULL) { K[idx2, idx1] <- 1 } - # remove redundant columns + # remove redundant columns neg.idx <- which(colSums(R) < 0) K <- K[,-neg.idx] @@ -298,7 +298,7 @@ lav_constraints_R2K <- function(lavmodel = NULL, R = NULL) { } lav_constraints_lambda_pre <- function(lavobject = NULL, method = "Don") { - + # compute factor 'pre' so that pre %*% g = lambda method <- tolower(method) diff --git a/R/lav_cor.R b/R/lav_cor.R index 2538fda6..abb9b2b2 100644 --- a/R/lav_cor.R +++ b/R/lav_cor.R @@ -1,19 +1,19 @@ -# user-visible routine to +# user-visible routine to # compute polychoric/polyserial/... correlations # # YR 17 Sept 2013 -# +# # - YR 26 Nov 2013: big change - make it a wrapper around lavaan() # estimator = "none" means two.step (starting values) -lavCor <- function(object, +lavCor <- function(object, # lav.data options - ordered = NULL, - group = NULL, + ordered = NULL, + group = NULL, missing = "listwise", - ov.names.x = NULL, + ov.names.x = NULL, # lavaan options - se = "none", + se = "none", estimator = "two.step", # other options (for lavaan) ..., @@ -48,7 +48,7 @@ lavCor <- function(object, if(!is.null(group)) { NAMES <- NAMES[- match(group, NAMES)] } - lav.data <- lavData(data = object, group = group, + lav.data <- lavData(data = object, group = group, ov.names = NAMES, ordered = ordered, ov.names.x = ov.names.x, lavoptions = list(missing = missing)) @@ -69,13 +69,13 @@ lavCor <- function(object, # extract partable options from dots dots <- list(...) - meanstructure <- FALSE + meanstructure <- FALSE fixed.x <- FALSE mimic <- "lavaan" conditional.x <- FALSE if(!is.null(dots$meanstructure)) { meanstructure <- dots$meanstructure - } + } if(categorical) { meanstructure <- TRUE } @@ -90,7 +90,7 @@ lavCor <- function(object, } # generate partable for unrestricted model - PT.un <- + PT.un <- lav_partable_unrestricted(lavobject = NULL, lavdata = lav.data, lavoptions = list(meanstructure = meanstructure, @@ -101,7 +101,7 @@ lavCor <- function(object, sample.mean = NULL, sample.th = NULL) - + FIT <- lavaan(slotParTable = PT.un, slotData = lav.data, model.type = "unrestricted", missing = missing, @@ -153,7 +153,7 @@ lav_cor_output <- function(object, output = "cor") { } } else if(output %in% c("sampstat")) { out <- inspect(object, "sampstat") - } else if(output %in% c("parameterEstimates", "pe", + } else if(output %in% c("parameterEstimates", "pe", "parameterestimates", "est")) { #out <- parameterEstimates(object) out <- standardizedSolution(object) diff --git a/R/lav_data.R b/R/lav_data.R index c9fc5ae6..45c0ca61 100644 --- a/R/lav_data.R +++ b/R/lav_data.R @@ -26,10 +26,10 @@ lavData <- function(data = NULL, # data.frame sample.cov = NULL, # sample covariance(s) sample.mean = NULL, # sample mean vector(s) sample.nobs = NULL, # sample nobs - + lavoptions = lavOptions(), # lavoptions allow.single.case = FALSE # for newdata in predict - ) + ) { # get info from lavoptions @@ -57,7 +57,7 @@ lavData <- function(data = NULL, # data.frame if(is.null(missing) || missing == "default") { missing <- "listwise" } - + # warn? warn <- lavoptions$warn if(is.null(warn)) { @@ -72,7 +72,7 @@ lavData <- function(data = NULL, # data.frame # 1) full data if(!is.null(data)) { - + # catch lavaan/lavData objects if(inherits(data, "lavData")) { return(data) @@ -80,7 +80,7 @@ lavData <- function(data = NULL, # data.frame return(data@Data) } - # catch matrix + # catch matrix if(!is.data.frame(data)) { # is it a matrix? if(is.matrix(data)) { @@ -89,7 +89,7 @@ lavData <- function(data = NULL, # data.frame if(data[2,1] == data[1,2] && warn) { # not perfect... warning("lavaan WARNING: data argument looks like a covariance matrix; please use the sample.cov argument instead") } - } + } # or perhaps it is a data matrix? ### FIXME, we should avoid as.data.frame() and handle ### data matrices directly @@ -115,14 +115,14 @@ lavData <- function(data = NULL, # data.frame allow.single.case = allow.single.case) sample.cov <- NULL # not needed, but just in case } - - + + # 2) sample moments if(is.null(data) && !is.null(sample.cov)) { # for now: no levels!! nlevels <- 1L - + # we also need the number of observations (per group) if(is.null(sample.nobs)) stop("lavaan ERROR: please specify number of observations") @@ -147,7 +147,7 @@ lavData <- function(data = NULL, # data.frame } else { # FIXME!!!! # check if they match - } + } } } else { ngroups <- 1L; group.label <- character(0) @@ -158,7 +158,7 @@ lavData <- function(data = NULL, # data.frame # get ov.names if (is.null(ov.names)) { - ov.names <- lapply(sample.cov, row.names) + ov.names <- lapply(sample.cov, row.names) } else if (!is.list(ov.names)) { # duplicate ov.names for each group tmp <- ov.names; ov.names <- vector("list", length = ngroups) @@ -195,7 +195,7 @@ lavData <- function(data = NULL, # data.frame # construct lavData object lavData <- new("lavData", data.type = "moment", - ngroups = ngroups, + ngroups = ngroups, group = character(0L), nlevels = 1L, # for now cluster = character(0L), @@ -203,7 +203,7 @@ lavData <- function(data = NULL, # data.frame level.label = character(0L), nobs = as.list(sample.nobs), norig = as.list(sample.nobs), - ov.names = ov.names, + ov.names = ov.names, ov.names.x = ov.names.x, ov.names.l = ov.names.l, ordered = as.character(ordered), @@ -238,7 +238,7 @@ lavData <- function(data = NULL, # data.frame cluster <- paste0("cluster", seq_len(nlevels - 1L)) } } - + # default level.labels if(length(level.label) == 0L) { level.label <- c("within", cluster) @@ -283,7 +283,7 @@ lavData <- function(data = NULL, # data.frame sample.nobs <- as.list(sample.nobs) if(length(sample.nobs) != ngroups) { stop("lavaan ERROR: length(sample.nobs) = ", - length(sample.nobs), + length(sample.nobs), " but syntax implies ngroups = ", ngroups) } } @@ -336,7 +336,7 @@ lavData <- function(data = NULL, # data.frame level.label = level.label, nobs = sample.nobs, norig = sample.nobs, - ov.names = ov.names, + ov.names = ov.names, ov.names.x = ov.names.x, ov.names.l = ov.names.l, ordered = as.character(ordered), @@ -363,7 +363,7 @@ lav_data_full <- function(data = NULL, # data.frame cluster = NULL, group.label = NULL, # custom group labels? level.label = NULL, - ov.names = NULL, # variables needed + ov.names = NULL, # variables needed # in model ordered = NULL, # ordered variables sampling.weights = NULL, # sampling weights @@ -380,15 +380,15 @@ lav_data_full <- function(data = NULL, # data.frame if(!(group %in% names(data))) { stop("lavaan ERROR: grouping variable ", sQuote(group), " not found;\n ", - "variable names found in data frame are:\n ", + "variable names found in data frame are:\n ", paste(names(data), collapse=" ")) } - # note: by default, we use the order as in the data; + # note: by default, we use the order as in the data; # not as in levels(data[,group]) if(length(group.label) == 0L) { group.label <- unique(as.character(data[[group]])) if(warn && any(is.na(group.label))) { - warning("lavaan WARNING: group variable ", sQuote(group), + warning("lavaan WARNING: group variable ", sQuote(group), " contains missing values\n", sep="") } group.label <- group.label[!is.na(group.label)] @@ -399,7 +399,7 @@ lav_data_full <- function(data = NULL, # data.frame idx <- match(group.label, LABEL) if(warn && any(is.na(idx))) { warning("lavaan WARNING: some group.labels do not appear ", - "in the grouping variable: ", + "in the grouping variable: ", paste(group.label[which(is.na(idx))], collapse=" ")) } group.label <- group.label[!is.na(idx)] @@ -421,7 +421,7 @@ lav_data_full <- function(data = NULL, # data.frame if(!is.null(sampling.weights)) { if(is.character(sampling.weights)) { if(!(sampling.weights %in% names(data))) { - stop("lavaan ERROR: sampling weights variable ", + stop("lavaan ERROR: sampling weights variable ", sQuote(sampling.weights), " not found;\n ", "variable names found in data frame are:\n ", @@ -444,11 +444,11 @@ lav_data_full <- function(data = NULL, # data.frame # cluster variable in data? if(!all(cluster %in% names(data))) { # which one did we not find? - not.ok <- which(!cluster %in% names(data)) + not.ok <- which(!cluster %in% names(data)) stop("lavaan ERROR: cluster variable(s) ", sQuote(cluster[not.ok]), " not found;\n ", - "variable names found in data frame are:\n ", + "variable names found in data frame are:\n ", paste(names(data), collapse = " ")) } # default level.labels @@ -546,7 +546,7 @@ lav_data_full <- function(data = NULL, # data.frame # add this interaction term to the data.frame, unless # it already exists if(is.null(data[[ ov.int.names[iv] ]])) { - data[[ ov.int.names[iv] ]] <- + data[[ ov.int.names[iv] ]] <- data[[NAMES[1L]]] * data[[NAMES[2L]]] } } @@ -566,7 +566,7 @@ lav_data_full <- function(data = NULL, # data.frame # here, we know for sure all ov.names exist in the data.frame # create varTable # FIXME: should we add the 'group'/'cluster' variable (no for now) - ov <- lav_dataframe_vartable(frame = data, ov.names = ov.names, + ov <- lav_dataframe_vartable(frame = data, ov.names = ov.names, ov.names.x = ov.names.x, ordered = ordered, as.data.frame. = FALSE) @@ -586,7 +586,7 @@ lav_data_full <- function(data = NULL, # data.frame } # check for ordered exogenous variables if("ordered" %in% ov$type[ov$name %in% unlist(ov.names.x)]) { - f.names <- ov$name[ov$type == "ordered" & + f.names <- ov$name[ov$type == "ordered" & ov$name %in% unlist(ov.names.x)] if(warn && any(f.names %in% unlist(ov.names.x))) warning(paste("lavaan WARNING: exogenous variable(s) declared as ordered in data:", paste(f.names, collapse=" "))) @@ -638,8 +638,8 @@ lav_data_full <- function(data = NULL, # data.frame warning("lavaan WARNING: all observed variables are exogenous; model may not be identified") } - # prepare empty lists - + # prepare empty lists + # group-based case.idx <- vector("list", length = ngroups) Mp <- vector("list", length = ngroups) @@ -656,7 +656,7 @@ lav_data_full <- function(data = NULL, # data.frame # extract variables in correct order ov.idx <- ov$idx[match(ov.names[[g]], ov$name)] - exo.idx <- ov$idx[match(ov.names.x[[g]], ov$name)] + exo.idx <- ov$idx[match(ov.names.x[[g]], ov$name)] all.idx <- unique(c(ov.idx, exo.idx)) # extract cases per group @@ -678,7 +678,7 @@ lav_data_full <- function(data = NULL, # data.frame norig[[g]] <- length(which(data[[group]] == group.label[g])) if(warn && (nobs[[g]] < norig[[g]])) { warning("lavaan WARNING: ", (nobs[[g]] - norig[[g]]), - " cases were deleted in group ", group.label[g], + " cases were deleted in group ", group.label[g], " due to missing values in ", "\n\t\t exogenous variable(s), while fixed.x = TRUE.") } @@ -744,7 +744,7 @@ lav_data_full <- function(data = NULL, # data.frame } } - ## FIXME: + ## FIXME: ## - why also in X? (for samplestats, for now) if(length(exo.idx) > 0L) { eXo[[g]] <- data.matrix(data[case.idx[[g]], exo.idx, drop = FALSE]) @@ -757,8 +757,8 @@ lav_data_full <- function(data = NULL, # data.frame if(std.ov) { num.idx <- which(ov.names[[g]] %in% ov$name & ov$type == "numeric") if(length(num.idx) > 0L) { - X[[g]][,num.idx] <- - scale(X[[g]][,num.idx,drop = FALSE])[,,drop = FALSE] + X[[g]][,num.idx] <- + scale(X[[g]][,num.idx,drop = FALSE])[,,drop = FALSE] # three copies are made!!!!! } if(length(exo.idx) > 0L) { @@ -769,7 +769,7 @@ lav_data_full <- function(data = NULL, # data.frame # missing data if(missing != "listwise") { # get missing patterns - Mp[[g]] <- lav_data_missing_patterns(X[[g]], + Mp[[g]] <- lav_data_missing_patterns(X[[g]], sort.freq = TRUE, coverage = TRUE) # checking! if(length(Mp[[g]]$empty.idx) > 0L) { @@ -792,7 +792,7 @@ lav_data_full <- function(data = NULL, # data.frame } # warn if we have a small number of observations (but NO error!) - if( !allow.single.case && warn && + if( !allow.single.case && warn && nobs[[g]] < (nvar <- length(ov.idx)) ) { txt <- "" if(ngroups > 1L) txt <- paste(" in group ", g, sep="") @@ -810,7 +810,7 @@ lav_data_full <- function(data = NULL, # data.frame ov.names.l = ov.names.l[[g]]) } - } # groups, at first level + } # groups, at first level if(is.null(sampling.weights)) { sampling.weights <- character(0L) @@ -844,7 +844,7 @@ lav_data_full <- function(data = NULL, # data.frame Rp = Rp, Lp = Lp ) - lavData + lavData } # get missing patterns @@ -885,7 +885,7 @@ lav_data_missing_patterns <- function(Y, sort.freq = FALSE, coverage = FALSE) { pat.npatterns <- length(pat.id) # case idx per pattern - pat.case.idx <- lapply(seq_len(pat.npatterns), + pat.case.idx <- lapply(seq_len(pat.npatterns), function(p) which(case.id == pat.id[p])) # unique pattern frequencies @@ -926,7 +926,7 @@ lav_data_resp_patterns <- function(Y) { ntotal <- nrow(Y); nvar <- ncol(Y) - # identify, label and sort response patterns + # identify, label and sort response patterns id <- apply(Y, MARGIN = 1, paste, collapse = "") # sort patterns (from high occurence to low occurence) @@ -972,7 +972,7 @@ lav_data_cluster_patterns <- function(Y = NULL, clus = NULL, cluster = NULL, if(haveData) { stopifnot(ncol(clus) == (nlevels - 1L), nrow(Y) == nrow(clus)) } - + cluster.size <- vector("list", length = nlevels) cluster.id <- vector("list", length = nlevels) cluster.idx <- vector("list", length = nlevels) @@ -1004,7 +1004,7 @@ lav_data_cluster_patterns <- function(Y = NULL, clus = NULL, cluster = NULL, nclusters[[l]] <- length(cluster.size[[l]]) cluster.sizes[[l]] <- unique(cluster.size[[l]]) ncluster.sizes[[l]] <- length(cluster.sizes[[l]]) - cluster.size.ns[[l]] <- as.integer(table(factor(cluster.size[[l]], + cluster.size.ns[[l]] <- as.integer(table(factor(cluster.size[[l]], levels = as.character(cluster.sizes[[l]])))) } else { cluster.id[[l]] <- integer(0L) @@ -1018,10 +1018,10 @@ lav_data_cluster_patterns <- function(Y = NULL, clus = NULL, cluster = NULL, # index of ov.names for this level ov.idx[[l]] <- match(ov.names.l[[l]], ov.names) - - both.idx[[l]] <- which( ov.names %in% ov.names.l[[1]] & + + both.idx[[l]] <- which( ov.names %in% ov.names.l[[1]] & ov.names %in% ov.names.l[[2]]) - within.idx[[l]] <- which( ov.names %in% ov.names.l[[1]] & + within.idx[[l]] <- which( ov.names %in% ov.names.l[[1]] & !ov.names %in% ov.names.l[[2]]) between.idx[[l]] <- which(!ov.names %in% ov.names.l[[1]] & ov.names %in% ov.names.l[[2]]) @@ -1035,14 +1035,14 @@ lav_data_cluster_patterns <- function(Y = NULL, clus = NULL, cluster = NULL, ov.names %in% ov.names.l[[2]] ] } - out <- list(cluster = cluster, # clus = clus, + out <- list(cluster = cluster, # clus = clus, # per level nclusters = nclusters, cluster.size = cluster.size, cluster.id = cluster.id, cluster.idx = cluster.idx, cluster.sizes = cluster.sizes, - ncluster.sizes = ncluster.sizes, + ncluster.sizes = ncluster.sizes, cluster.size.ns = cluster.size.ns, - ov.idx = ov.idx, both.idx = both.idx, within.idx = within.idx, + ov.idx = ov.idx, both.idx = both.idx, within.idx = within.idx, between.idx = between.idx, both.names = both.names, within.names = within.names, between.names = between.names) @@ -1086,7 +1086,7 @@ lav_data_print_short <- function(object) { (lavdata@nlevels > 1L) ) { #cat("\n") for(l in 2:lavdata@nlevels) { - t0.txt <- sprintf(" %-40s", + t0.txt <- sprintf(" %-40s", paste("Number of clusters [", lavdata@cluster[l-1], "]", sep = "")) t1.txt <- sprintf(" %10i", lavdata@Lp[[1]]$nclusters[[l]]) @@ -1115,10 +1115,10 @@ lav_data_print_short <- function(object) { (lavdata@nlevels > 1L) ) { #cat("\n") for(l in 2:lavdata@nlevels) { - t0.txt <- sprintf(" %-40s", + t0.txt <- sprintf(" %-40s", paste("Number of clusters [", lavdata@cluster[l-1], "]", sep = "")) - t1.txt <- sprintf(" %10i", + t1.txt <- sprintf(" %10i", lavdata@Lp[[g]]$nclusters[[l]]) #t2.txt <- ifelse(listwise, # sprintf(" %10i", lavdata@norig[[1L]]), "") diff --git a/R/lav_dataframe.R b/R/lav_dataframe.R index 966db974..58825971 100644 --- a/R/lav_dataframe.R +++ b/R/lav_dataframe.R @@ -4,14 +4,14 @@ # this is to replace sapply(frame, function(x) class(x)[1]) # try (in R3.0.0): # N <- 100000 -# frame <- data.frame(a=factor(sample(1:5, size=N, replace=TRUE)), +# frame <- data.frame(a=factor(sample(1:5, size=N, replace=TRUE)), # b=factor(sample(1:5, size=N, replace=TRUE)), # c=rnorm(N)) # system.time(replicate(1000, sapply(frame, function(x) class(x)[1]))) -# # user system elapsed +# # user system elapsed # # 1.223 0.000 1.222 # system.time(replicate(1000, lav_dataframe_check_vartype(frame))) -# # user system elapsed +# # user system elapsed # # 0.093 0.000 0.093 lav_dataframe_check_vartype <- function(frame = NULL, ov.names = character(0)) { if(missing(ov.names)) { @@ -48,7 +48,7 @@ lav_dataframe_check_ordered <- function(frame = NULL, ov.names = character(0)) { # construct vartable, but allow 'ordered/factor' argument to intervene # we do NOT change the data.frame -lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, +lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, ov.names.x = NULL, ordered = NULL, factor = NULL, @@ -73,7 +73,7 @@ lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, nlev <- integer(nvar); lnam <- character(nvar) for(i in seq_len(nvar)) { x <- frame[[var.idx[i]]] - + type.x <- class(x)[1L] # correct for matrix with 1 column @@ -98,7 +98,7 @@ lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, type.x <- "ordered" lev <- sort(unique(x)) # we assume integers! nlev[i] <- length(lev) - lnam[i] <- paste(lev, collapse="|") + lnam[i] <- paste(lev, collapse="|") user[i] <- 1L } else if(!is.null(factor) && var.names[i] %in% factor) { type.x <- "factor" @@ -113,9 +113,9 @@ lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, type[i] <- type.x nobs[i] <- sum(!is.na(x)) - mean[i] <- ifelse(type.x == "numeric", mean(x, na.rm=TRUE), + mean[i] <- ifelse(type.x == "numeric", mean(x, na.rm=TRUE), as.numeric(NA)) - var[i] <- ifelse(type.x == "numeric", var(x, na.rm=TRUE), + var[i] <- ifelse(type.x == "numeric", var(x, na.rm=TRUE), as.numeric(NA)) } diff --git a/R/lav_export.R b/R/lav_export.R index 93831585..8d3453a1 100644 --- a/R/lav_export.R +++ b/R/lav_export.R @@ -1,7 +1,7 @@ # export `lavaan' lav model description to third-party software -# +# -lavExport <- function(object, target="lavaan", prefix="sem", +lavExport <- function(object, target="lavaan", prefix="sem", dir.name="lavExport", export=TRUE) { stopifnot(inherits(object, "lavaan")) @@ -27,11 +27,11 @@ lavExport <- function(object, target="lavaan", prefix="sem", footer <- "" out <- paste(header, syntax, footer, sep="") } else if(target == "mplus") { - header <- lav_mplus_header(data.file=data.file, + header <- lav_mplus_header(data.file=data.file, group.label=object@Data@group.label, ov.names=vnames(object@ParTable, "ov"), ov.ord.names=vnames(object@ParTable, "ov.ord"), - estimator=lav_mplus_estimator(object), + estimator=lav_mplus_estimator(object), data.type=object@Data@data.type, nobs=object@Data@nobs[[1L]] ) @@ -49,7 +49,7 @@ lavExport <- function(object, target="lavaan", prefix="sem", } else { stop("lavaan ERROR: target", target, "has not been implemented yet") } - + # export to file? if(export) { dir.create(path=dir.name) @@ -116,7 +116,7 @@ lav2check <- function(lav) { # lav$label <- paste("p",as.character(lav$eq.id), sep="") # lav$label[lav$label == "p0"] <- "" #} - + lav } @@ -137,13 +137,13 @@ lav2lavaan <- lav2lav <- function(lav) { lav2 <- ifelse(lav$free != 0L, ifelse(lav$label == "", paste(lav$lhs, lav$op, lav$rhs, sep=""), - paste(lav$lhs, lav$op, lav$label, "*", lav$rhs, + paste(lav$lhs, lav$op, lav$label, "*", lav$rhs, sep="") ), ifelse(lav$label == "", - paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, + paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, sep=""), - paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, + paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, "+", lav$label, "*", lav$rhs, sep="") ) ) diff --git a/R/lav_export_bugs.R b/R/lav_export_bugs.R index 4d2bcc58..e910e8e3 100644 --- a/R/lav_export_bugs.R +++ b/R/lav_export_bugs.R @@ -3,14 +3,14 @@ # we assume that N1, N2, ... are in data lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { - # get parameter table attributes + # get parameter table attributes pta <- lav_partable_attributes(partable = partable, pta = pta) vnames <- pta$vnames; nblocks <- pta$nblocks nvar <- pta$nvar; nfac <- pta$nfac - + # sanity check partable <- lav2check(partable) - + # tabs t1 <- paste(rep(" ", 2L), collapse="") t2 <- paste(rep(" ", 4L), collapse="") @@ -49,7 +49,7 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { partable$lhs == partable$rhs & partable$lhs == ov.names.nox[i]) if(length(theta.free.idx) != 1L) { - stop("lavaan ERROR: parameter for residual variance ", + stop("lavaan ERROR: parameter for residual variance ", ov.names.nox[i], " not found") } else { theta.idx <- partable$free[ theta.free.idx ] @@ -74,7 +74,7 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { if(length(int.idx) == 1L) { # fixed or free? if(partable$free[int.idx] == 0L) { - TXT <- paste(TXT, + TXT <- paste(TXT, partable$ustart[int.idx], sep="") } else { TXT <- paste(TXT, @@ -92,12 +92,12 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { # fixed or free? if(partable$free[j] == 0L) { TXT <- paste(TXT, " + ", - partable$ustart[j], "*eta", g, "[i,", + partable$ustart[j], "*eta", g, "[i,", match(partable$lhs[j], lv.names) , "]", sep="") } else { TXT <- paste(TXT, " + ", - "theta[", partable$free[j], "]*eta", g, "[i,", + "theta[", partable$free[j], "]*eta", g, "[i,", match(partable$lhs[j], lv.names) , "]", sep="") } @@ -150,7 +150,7 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { } TXT <- paste(TXT, "\n", t2, # dnorm for now - "eta", g, "[i,", lv.y.idx[j], "] ~ dnorm(mu.eta", g, "[i,", + "eta", g, "[i,", lv.y.idx[j], "] ~ dnorm(mu.eta", g, "[i,", lv.y.idx[j], "], itheta[", theta.idx, "])", sep="") } for(j in 1:ny) { @@ -183,15 +183,15 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { for(p in 1:np) { TXT <- paste(TXT, " + ", "theta[", partable$free[rhs.idx[p]], - "]*eta", g, "[i,", - match(partable$rhs[rhs.idx[p]], lv.names), + "]*eta", g, "[i,", + match(partable$rhs[rhs.idx[p]], lv.names), "]", sep="") } } } - - # exogenous lv -- FIXME: we assume the lv.x array is continous - # (eg 3,4,5, but NOT 3,5,6) + + # exogenous lv -- FIXME: we assume the lv.x array is continous + # (eg 3,4,5, but NOT 3,5,6) # var(lv.x) = PHI (lisrel style) lv.x <- vnames$lv.x[[g]] if(length(lv.x) > 0L) { @@ -200,8 +200,8 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { lv.x.idx <- match(lv.x, lv.names); nx <- length(lv.x.idx) TXT <- paste(TXT, "\n", t2, # dmnorm for now - "eta", g, "[i,", min(lv.x.idx), ":", max(lv.x.idx), - "] ~ dmnorm(mu.eta", g, "[i,", min(lv.x.idx), ":", + "eta", g, "[i,", min(lv.x.idx), ":", max(lv.x.idx), + "] ~ dmnorm(mu.eta", g, "[i,", min(lv.x.idx), ":", max(lv.x.idx), "], iphi", g, "[1:", nx, ",1:", nx, "])", sep="") for(j in 1:nx) { TXT <- paste(TXT, "\n", t2, @@ -237,7 +237,7 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { # variance # 1. lv.x + lv.x (skip -> multivariate) # 2. lv.y + lv.y - # 3. observed + observed + # 3. observed + observed # 4. else -> fix (upgrade to latent?) if(lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) { # lv.x: move to multivariate... (dwish) @@ -260,7 +260,7 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { # covariance # 1. lv.x + lv.x (skip -> multivariate) # 2. lv.y + lv.y - # 3. observed + observed + # 3. observed + observed # 4. else -> fix (upgrade to latent?) if(lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) { # exo lv covariance @@ -295,10 +295,10 @@ lav2bugs <- function(partable, pta = NULL, as.function.=FALSE) { nx <- length(vnames$lv.x[[g]]) if(length(nx) > 0L) { TXT <- paste(TXT, "\n", t1, - "iphi", g, "[1:", nx, ",1:", nx, "] ~ dwish(R", g, "[1:", + "iphi", g, "[1:", nx, ",1:", nx, "] ~ dwish(R", g, "[1:", nx, ",1:", nx, "], 5)", sep="") TXT <- paste(TXT, "\n", t1, - "phi", g, "[1:", nx, ",1:", nx, "] <- inverse(iphi", g, "[1:", + "phi", g, "[1:", nx, ",1:", nx, "] <- inverse(iphi", g, "[1:", nx, ",1:", nx, "])", sep="") for(idx in lv.phi.idx) { TXT <- paste(TXT, "\n", t1, diff --git a/R/lav_export_mplus.R b/R/lav_export_mplus.R index 34a0d584..45a4e8ec 100644 --- a/R/lav_export_mplus.R +++ b/R/lav_export_mplus.R @@ -14,7 +14,7 @@ lav2mplus <- function(lav, group.label=NULL) { # replace them by an underscore '_' lav$lhs <- gsub("\\.", "_", lav$lhs) lav$rhs <- gsub("\\.", "_", lav$rhs) - + # remove contraints (:=, <, >, ==) here con.idx <- which(lav$op %in% c(":=", "<",">","==")) if(length(con.idx) > 0L) { @@ -37,7 +37,7 @@ lav2mplus <- function(lav, group.label=NULL) { # end of line lav$eol <- rep(";", length(lav$lhs)) lav$ustart <- ifelse(is.na(lav$ustart), "", lav$ustart) - lav$rhs2 <- ifelse(lav$free == 0L, + lav$rhs2 <- ifelse(lav$free == 0L, paste("@",lav$ustart,sep=""), paste("*",lav$ustart,sep="")) lav$plabel <- gsub("\\.", "", lav$plabel) @@ -60,7 +60,7 @@ lav2mplus <- function(lav, group.label=NULL) { lav$rhs[var.idx] <- "" # scaling factors - scal.idx <- which(lav$op == "~*~") + scal.idx <- which(lav$op == "~*~") lav$op[scal.idx] <- "" lav$rhs2[scal.idx] <- paste(lav$rhs2[scal.idx],"}",sep="") lav$lhs[scal.idx] <- "{" @@ -86,7 +86,7 @@ lav2mplus <- function(lav, group.label=NULL) { lav2 <- paste(lav$lhs, lav$op, lav$rhs, lav$rhs2, lav$plabel, lav$eol, sep="") - + body <- paste(" ", lav2, collapse="\n") body @@ -131,15 +131,15 @@ lav2mplus <- function(lav, group.label=NULL) { if(length(eq.idx) > 0L) { lav$op[eq.idx] <- "=" } - con <- paste(gsub("\\.","",lav$lhs[con.idx]), " ", - lav$op[con.idx], " ", + con <- paste(gsub("\\.","",lav$lhs[con.idx]), " ", + lav$op[con.idx], " ", gsub("\\.","",lav$rhs[con.idx]), ";", sep="") con2 <- paste(" ", con, collapse="\n") - constraints <- paste(constraints, con2, sep="\n") + constraints <- paste(constraints, con2, sep="\n") } else { constraints <- "" } - + out <- paste(header, body, constraints, footer, sep="") class(out) <- c("lavaan.character", "character") out @@ -178,7 +178,7 @@ lav_mplus_estimator <- function(object) { } lav_mplus_header <- function(data.file=NULL, group.label="", ov.names="", - ov.ord.names="", estimator="ML", + ov.ord.names="", estimator="ML", data.type="full", nobs=NULL) { # replace '.' by '_' in all variable names @@ -191,12 +191,12 @@ lav_mplus_header <- function(data.file=NULL, group.label="", ov.names="", # TITLE command c.TITLE <- "TITLE:\n" - c.TITLE <- paste(c.TITLE, + c.TITLE <- paste(c.TITLE, " [This syntax is autogenerated by lavExport]\n") # DATA command c.DATA <- "DATA:\n" - ngroups <- length(data.file) + ngroups <- length(data.file) if(ngroups == 1L) { c.DATA <- paste(c.DATA, " file is ", data.file, ";\n", sep="") @@ -215,7 +215,7 @@ lav_mplus_header <- function(data.file=NULL, group.label="", ov.names="", } else { stop("lavaan ERROR: data.type must be full or moment") } - + # VARIABLE command c.VARIABLE <- "VARIABLE:\n" c.VARIABLE <- paste(c.VARIABLE, " names are", sep="") diff --git a/R/lav_fiml.R b/R/lav_fiml.R index c1500f8a..3fb96590 100644 --- a/R/lav_fiml.R +++ b/R/lav_fiml.R @@ -23,8 +23,8 @@ derivative.FIML <- function(Sigma.hat, Mu.hat, M) { dx.Mu[var.idx, 1] <- ( dx.Mu[var.idx, 1] + nobs/ntotal * -2 * t(t(MX - Mu) %*% Sigma.inv) ) - dx.Sigma[var.idx, var.idx] <- - ( dx.Sigma[var.idx, var.idx] - nobs/ntotal * 2 * + dx.Sigma[var.idx, var.idx] <- + ( dx.Sigma[var.idx, var.idx] - nobs/ntotal * 2 * # in the 'textbook' formula's, the Sigma.inv below is often # replaced by [0.5 * D'(Sigma.inv %x% Sigma.inv) D] # but we do not use the 'vecs' notation here, and @@ -32,7 +32,7 @@ derivative.FIML <- function(Sigma.hat, Mu.hat, M) { (Sigma.inv %*% (TT - Sigma.hat[var.idx,var.idx]) %*% Sigma.inv ) ) } - + # compensate for symmetry diag(dx.Sigma) <- diag(dx.Sigma)/2 @@ -47,8 +47,8 @@ derivative.FIML <- function(Sigma.hat, Mu.hat, M) { # Sigma <- cov(X2); Mu <- colMeans(X2) # logl of the MVM, no constants, factor 0.5, factor -1 -# summary statistics version -logl.MVN.complete <- function(Sigma, Mu, +# summary statistics version +logl.MVN.complete <- function(Sigma, Mu, X=NULL, data.cov=NULL, data.mean=NULL) { if(is.null(data.cov)) { @@ -64,7 +64,7 @@ logl.MVN.complete <- function(Sigma, Mu, diff <- as.matrix(data.mean - Mu) TT <- data.cov + tcrossprod(diff) - logl <- Sigma.log.det + sum(TT * Sigma.inv) # - S.log.det - nvar + logl <- Sigma.log.det + sum(TT * Sigma.inv) # - S.log.det - nvar logl <- 0.5 * logl logl @@ -146,7 +146,7 @@ hessian.MVN.saturated <- function(Sigma=NULL, Mu=NULL, # # # compute numerical approximation of the Hessian # H <- numDeriv::hessian(func=objective.function, x=param2x(Sigma,Mu)) - # + # #} else { Sigma.inv <- inv.chol(Sigma, logdet=FALSE) diff --git a/R/lav_fit.R b/R/lav_fit.R index 34c722ca..fb306c1d 100644 --- a/R/lav_fit.R +++ b/R/lav_fit.R @@ -1,7 +1,7 @@ lav_model_fit <- function(lavpartable = NULL, - lavmodel = NULL, - x = NULL, - VCOV = NULL, + lavmodel = NULL, + x = NULL, + VCOV = NULL, TEST = NULL) { stopifnot(is.list(lavpartable), class(lavmodel) == "lavModel") @@ -26,7 +26,7 @@ lav_model_fit <- function(lavpartable = NULL, est <- lav_model_get_parameters(lavmodel = lavmodel, type = "user") # did we compute standard errors? - se <- lav_model_vcov_se(lavmodel = lavmodel, lavpartable = lavpartable, + se <- lav_model_vcov_se(lavmodel = lavmodel, lavpartable = lavpartable, VCOV = VCOV, BOOT = attr(VCOV, "BOOT.COEF")) # did we compute test statistics diff --git a/R/lav_fit_measures.R b/R/lav_fit_measures.R index 691bb13e..9296a83b 100644 --- a/R/lav_fit_measures.R +++ b/R/lav_fit_measures.R @@ -139,7 +139,7 @@ lav_fit_measures <- function(object, fit.measures="all", fit.logl <- c("logl", "unrestricted.logl", "aic", "bic", "ntotal", "bic2") } - if(scaled && object@Options$test %in% + if(scaled && object@Options$test %in% c("yuan.bentler", "yuan.bentler.mplus")) { fit.logl <- c(fit.logl, "scaling.factor.h1", "scaling.factor.h0") } @@ -310,7 +310,7 @@ lav_fit_measures <- function(object, fit.measures="all", object@loglik$loglik) ) fit.indep@test[[1]]$pvalue <- 1 - pchisq(fit.indep@test[[1]]$stat, fit.indep@test[[1]]$df) - } + } X2.null <- fit.indep@test[[1]]$stat df.null <- fit.indep@test[[1]]$df @@ -373,7 +373,7 @@ lav_fit_measures <- function(object, fit.measures="all", } if("cfi.robust" %in% fit.measures) { - if(TEST[[2]]$test %in% + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # see Brosseau-Liard & Savalei MBR 2014, equation 15 @@ -428,7 +428,7 @@ lav_fit_measures <- function(object, fit.measures="all", } if("rni.robust" %in% fit.measures) { - if(TEST[[2]]$test %in% + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # see Brosseau-Liard & Savalei MBR 2014, equation 15 @@ -505,7 +505,7 @@ lav_fit_measures <- function(object, fit.measures="all", if("tli.robust" %in% fit.measures || "nnfi.robust" %in% fit.measures) { - if(TEST[[2]]$test %in% + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # see Brosseau-Liard & Savalei MBR 2014, equation 16 @@ -685,7 +685,7 @@ lav_fit_measures <- function(object, fit.measures="all", logl.H0 <- out$loglik AIC <- out$AIC BIC <- out$BIC - BIC2 <- out$BIC2 + BIC2 <- out$BIC2 } if("logl" %in% fit.measures) { @@ -705,7 +705,7 @@ lav_fit_measures <- function(object, fit.measures="all", } # scaling factor for MLR - if(object@Options$test %in% + if(object@Options$test %in% c("yuan.bentler", "yuan.bentler.mplus")) { indices["scaling.factor.h1"] <- TEST[[2]]$scaling.factor.h1 @@ -777,7 +777,7 @@ lav_fit_measures <- function(object, fit.measures="all", indices["rmsea"] <- RMSEA if(scaled) { indices["rmsea.scaled"] <- RMSEA.scaled - if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { indices["rmsea.robust"] <- RMSEA.robust } else { @@ -839,7 +839,7 @@ lav_fit_measures <- function(object, fit.measures="all", indices["rmsea.ci.lower.scaled"] <- sqrt( lambda.l/(N*df2) ) } - if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # robust XX2 <- X2.scaled @@ -919,7 +919,7 @@ lav_fit_measures <- function(object, fit.measures="all", sqrt( lambda.u/(N*df2) ) } - if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # robust XX2 <- X2.scaled @@ -984,7 +984,7 @@ lav_fit_measures <- function(object, fit.measures="all", 1 - pchisq(XX2, df=df2, ncp=(N*df2*0.05^2)) } - if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", + if(TEST[[2]]$test %in% c("satorra.bentler", "yuan.bentler.mplus", "yuan.bentler")) { # robust XX2 <- X2.scaled @@ -1159,7 +1159,7 @@ lav_fit_measures <- function(object, fit.measures="all", } # multilevel version - if(any(c("srmr_within", "srmr_between", "srmr") %in% fit.measures) && + if(any(c("srmr_within", "srmr_between", "srmr") %in% fit.measures) && object@Data@nlevels > 1L) { nlevels <- object@Data@nlevels > 1L @@ -1181,7 +1181,7 @@ lav_fit_measures <- function(object, fit.measures="all", # force pd for between # S.between <- lav_matrix_symmetric_force_pd(S.between) Sigma.between <- lav_matrix_symmetric_force_pd(Sigma.between) - + # Bollen approach: simply using cov2cor ('residual correlations') S.within.cor <- cov2cor(S.within) S.between.cor <- cov2cor(S.between) @@ -1200,16 +1200,16 @@ lav_fit_measures <- function(object, fit.measures="all", nvar.between <- NCOL(S.between) pstar.within <- nvar.within*(nvar.within+1)/2 pstar.between <- nvar.between*(nvar.between+1)/2 - + # SRMR - SRMR.within[g] <- sqrt( sum(lav_matrix_vech(R.within.cor)^2) / + SRMR.within[g] <- sqrt( sum(lav_matrix_vech(R.within.cor)^2) / pstar.within ) SRMR.between[g] <- sqrt( sum(lav_matrix_vech(R.between.cor)^2) / pstar.between ) } if(G > 1) { - SRMR_WITHIN <- as.numeric( (unlist(object@SampleStats@nobs) %*% + SRMR_WITHIN <- as.numeric( (unlist(object@SampleStats@nobs) %*% SRMR.within) / object@SampleStats@ntotal ) SRMR_BETWEEN <- as.numeric( (unlist(object@SampleStats@nobs) %*% SRMR.between) / object@SampleStats@ntotal ) diff --git a/R/lav_fsr.R b/R/lav_fsr.R index 732dfdda..e6e027d8 100644 --- a/R/lav_fsr.R +++ b/R/lav_fsr.R @@ -23,7 +23,7 @@ lav_fsr_croon_correction <- function(FS.COV, LVINFO, fs.method = "bartlett") { if(nfac > 1L) { for(j in (i+1):nfac) { - + A.x <- LVINFO[[g]][[j]]$fsm lambda.x <- LVINFO[[g]][[j]]$lambda @@ -37,7 +37,7 @@ lav_fsr_croon_correction <- function(FS.COV, LVINFO, fs.method = "bartlett") { } } # nfac > 1L } # i - } + } # correct variances for(i in 1:nfac) { diff --git a/R/lav_func_deriv.R b/R/lav_func_deriv.R index 0e99abc8..32147dd2 100644 --- a/R/lav_func_deriv.R +++ b/R/lav_func_deriv.R @@ -7,9 +7,9 @@ # YR 17 July 2012 -lav_func_gradient_complex <- function(func, x, - h = .Machine$double.eps, ... , - check.scalar = TRUE, +lav_func_gradient_complex <- function(func, x, + h = .Machine$double.eps, ... , + check.scalar = TRUE, fallback.simple = TRUE) { # check current point, see if it is a scalar function @@ -48,8 +48,8 @@ lav_func_gradient_complex <- function(func, x, } # as a backup, if func() is not happy about non-numeric arguments -lav_func_gradient_simple <- function(func, x, - h = sqrt(.Machine$double.eps), ... , +lav_func_gradient_simple <- function(func, x, + h = sqrt(.Machine$double.eps), ... , check.scalar = TRUE) { # check current point, see if it is a scalar function @@ -78,7 +78,7 @@ lav_func_gradient_simple <- function(func, x, dx } -lav_func_jacobian_complex <- function(func, x, +lav_func_jacobian_complex <- function(func, x, h = .Machine$double.eps, ... , fallback.simple = TRUE) { @@ -110,7 +110,7 @@ lav_func_jacobian_complex <- function(func, x, dx } -lav_func_jacobian_simple <- function(func, x, +lav_func_jacobian_simple <- function(func, x, h = sqrt(.Machine$double.eps), ...) { f0 <- func(x, ...) @@ -134,8 +134,8 @@ lav_func_jacobian_simple <- function(func, x, } # this is based on the Ridout (2009) paper, and the code snippet for 'h4' -lav_func_hessian_complex <- function(func, x, - h = .Machine$double.eps, ... , +lav_func_hessian_complex <- function(func, x, + h = .Machine$double.eps, ... , check.scalar = TRUE) { # check current point, see if it is a scalar function @@ -166,10 +166,10 @@ lav_func_hessian_complex <- function(func, x, delta <- delta1 } H[i,j] <- H[j,i] <- - Im(func(x + delta*1i*(seq.int(nvar) == i)*x + + Im(func(x + delta*1i*(seq.int(nvar) == i)*x + delta*(seq.int(nvar) == j)*x, ...) - - func(x + delta*1i*(seq.int(nvar) == i)*x - - delta*(seq.int(nvar) == j)*x, ...)) / + func(x + delta*1i*(seq.int(nvar) == i)*x - + delta*(seq.int(nvar) == j)*x, ...)) / (2*delta*delta*x[i]*x[j]) } } diff --git a/R/lav_h1_logl.R b/R/lav_h1_logl.R index 1890826b..13df8f04 100644 --- a/R/lav_h1_logl.R +++ b/R/lav_h1_logl.R @@ -30,7 +30,7 @@ lav_h1_logl <- function(lavdata = NULL, } } - if(logl.ok) { + if(logl.ok) { for(g in seq_len(ngroups) ) { if(lavdata@nlevels > 1L) { OUT <- lav_mvnorm_cluster_em_sat(YLp = lavsamplestats@YLp[[g]], @@ -54,7 +54,7 @@ lav_h1_logl <- function(lavdata = NULL, lav_mvnorm_h1_loglik_samplestats( sample.cov.logdet = lavsamplestats@res.cov.log.det[[g]], - sample.nvar = + sample.nvar = NCOL(lavsamplestats@res.cov[[g]]), sample.nobs = lavsamplestats@nobs[[g]]) } else { diff --git a/R/lav_integrate.R b/R/lav_integrate.R index dbbb38d1..a12733f2 100644 --- a/R/lav_integrate.R +++ b/R/lav_integrate.R @@ -11,7 +11,7 @@ lav_integration_gaussian_product <- function(mus = NULL, sds = NULL, vars = NULL # variance product var.prod <- 1/sum(1/vars) - + # mean product mu.prod <- sum(mus/vars)*var.prod @@ -27,11 +27,11 @@ lav_integration_gaussian_product <- function(mus = NULL, sds = NULL, vars = NULL # return list: x = nodes, w = quadrature weights # -# As noted by Wilf (1962, chapter 2, ex 9), the nodes are given by +# As noted by Wilf (1962, chapter 2, ex 9), the nodes are given by # the eigenvalues of the Jacobi matrix; weights are given by the squares of the # first components of the (normalized) eigenvectors, multiplied by sqrt(pi) # -# (This is NOT identical to Golub & Welsch, 1968: as they used a specific +# (This is NOT identical to Golub & Welsch, 1968: as they used a specific # method tailored for tridiagonal symmetric matrices) # # TODO: look at https://github.com/ajt60gaibb/FastGaussQuadrature.jl/blob/master/src/gausshermite.jl diff --git a/R/lav_lavaanList_inspect.R b/R/lav_lavaanList_inspect.R index a45f5bc9..167fa297 100644 --- a/R/lav_lavaanList_inspect.R +++ b/R/lav_lavaanList_inspect.R @@ -9,11 +9,11 @@ inspect.lavaanList <- function(object, what = "free", ...) { } # the `tech' version: no labels, full matrices, ... for further processing -lavTech.lavaanList <- function(object, +lavTech.lavaanList <- function(object, what = "free", add.labels = FALSE, add.class = FALSE, - list.by.group = FALSE, + list.by.group = FALSE, drop.list.single.group = FALSE) { lavListInspect(object = object, what = what, @@ -70,19 +70,19 @@ lavListInspect <- function(object, #### model matrices, with different contents #### if(what == "free") { - lav_lavaanList_inspect_modelmatrices(object, what = "free", + lav_lavaanList_inspect_modelmatrices(object, what = "free", type = "free", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "partable" || what == "user") { - lav_lavaanList_inspect_modelmatrices(object, what = "free", + lav_lavaanList_inspect_modelmatrices(object, what = "free", type="partable", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "start" || what == "starting.values") { lav_lavaanList_inspect_modelmatrices(object, what = "start", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) @@ -118,7 +118,7 @@ lavListInspect <- function(object, object@Model@fixed.x } else if(what == "parameterization") { object@Model@parameterization - + # options } else if(what == "options" || what == "lavoptions") { object@Options @@ -184,7 +184,7 @@ lav_lavaanList_inspect_modelmatrices <- function(object, what = "free", x.user.idx <- object@Model@x.user.idx[[mm]] START <- lav_lavaanList_inspect_start(object) GLIST[[mm]][m.user.idx] <- START[x.user.idx] - } + } # class if(add.class) { @@ -209,7 +209,7 @@ lav_lavaanList_inspect_modelmatrices <- function(object, what = "free", LABEL <- names(ID) for(con in 1:nrow(CON)) { # lhs - LHS.labels <- all.vars(as.formula(paste("~",CON[con,"lhs"]))) + LHS.labels <- all.vars(as.formula(paste("~",CON[con,"lhs"]))) if(length(LHS.labels) > 0L) { # par id @@ -241,7 +241,7 @@ lav_lavaanList_inspect_modelmatrices <- function(object, what = "free", # add this info at the top #GLIST <- c(constraints = list(CON), GLIST) #no, not a good idea, it does not work with list.by.group - + # add it as a 'header' attribute? attr(CON, "header") <- "Note: model contains equality constraints:" con.flag <- TRUE diff --git a/R/lav_lavaanList_methods.R b/R/lav_lavaanList_methods.R index 14c33847..f4e17ace 100644 --- a/R/lav_lavaanList_methods.R +++ b/R/lav_lavaanList_methods.R @@ -23,7 +23,7 @@ function(object, header = TRUE, estimates = TRUE, print = TRUE, nd = 3L) { - lav_lavaanList_summary(object, + lav_lavaanList_summary(object, header = header, estimates = estimates, print = print, nd = nd) }) @@ -42,7 +42,7 @@ lav_lavaanList_summary <- function(object, if(header) { output$header <- lav_lavaanList_short_summary(object, print = print) - + #if(print) { # # show only basic information # lav_lavaanList_short_summary(object) @@ -50,22 +50,22 @@ lav_lavaanList_summary <- function(object, } if(estimates && "partable" %in% object@meta$store.slots) { - pe <- parameterEstimates(object, se = FALSE, - remove.system.eq = TRUE, remove.eq = TRUE, + pe <- parameterEstimates(object, se = FALSE, + remove.system.eq = TRUE, remove.eq = TRUE, remove.ineq = TRUE, remove.def = FALSE, - # zstat = FALSE, pvalue = FALSE, ci = FALSE, + # zstat = FALSE, pvalue = FALSE, ci = FALSE, standardized = FALSE, add.attributes = print) - + # scenario 1: simulation if(!is.null(object@meta$lavSimulate)) { pe$est.true <- object@meta$est.true nel <- length(pe$est.true) - # EST + # EST EST <- lav_lavaanList_partable(object, what = "est", type = "all") AVE <- rowMeans(EST, na.rm = TRUE) - + # remove things like equality constraints if(length(AVE) > nel) { AVE <- AVE[seq_len(nel)] @@ -109,7 +109,7 @@ lav_lavaanList_summary <- function(object, # between-imputation variance #B.var <- apply(EST, 1L, var) - est1 <- rowMeans(EST, na.rm = TRUE) + est1 <- rowMeans(EST, na.rm = TRUE) est2 <- rowMeans(EST^2, na.rm = TRUE) B.var <- (est2 - est1*est1) * m/(m-1) @@ -167,11 +167,11 @@ lav_lavaanList_summary <- function(object, setMethod("coef", "lavaanList", function(object, type = "free", labels = TRUE) { - lav_lavaanList_partable(object = object, what = "est", type = type, + lav_lavaanList_partable(object = object, what = "est", type = type, labels = labels) }) -lav_lavaanList_partable <- function(object, what = "est", +lav_lavaanList_partable <- function(object, what = "est", type = "free", labels = TRUE) { if("partable" %in% object@meta$store.slots) { diff --git a/R/lav_lavaanList_multipleGroups.R b/R/lav_lavaanList_multipleGroups.R index e6edde5f..3b91abaa 100644 --- a/R/lav_lavaanList_multipleGroups.R +++ b/R/lav_lavaanList_multipleGroups.R @@ -1,8 +1,8 @@ -# lavMultipleGroups: fit the *same* model, on (typically a small number of) +# lavMultipleGroups: fit the *same* model, on (typically a small number of) # groups/sets # YR - 11 July 2016 -lavMultipleGroups <- +lavMultipleGroups <- function(model = NULL, dataList = NULL, ndat = length(dataList), @@ -20,7 +20,7 @@ lavMultipleGroups <- dotdotdot <- list() # fit multiple times - fit <- do.call("lavaanList", args = c(list(model = model, + fit <- do.call("lavaanList", args = c(list(model = model, dataList = dataList, ndat = ndat, cmd = cmd, store.slots = store.slots, FUN = FUN, show.progress = show.progress, diff --git a/R/lav_lavaanList_multipleImputation.R b/R/lav_lavaanList_multipleImputation.R index b10c0b93..30820e14 100644 --- a/R/lav_lavaanList_multipleImputation.R +++ b/R/lav_lavaanList_multipleImputation.R @@ -1,7 +1,7 @@ # lavMultipleImputation: fit the *same* model, on a set of imputed datasets # YR - 11 July 2016 -lavMultipleImputation <- +lavMultipleImputation <- function(model = NULL, dataList = NULL, ndat = length(dataList), @@ -19,7 +19,7 @@ lavMultipleImputation <- dotdotdot <- list() # fit multiple times - fit <- do.call("lavaanList", args = c(list(model = model, + fit <- do.call("lavaanList", args = c(list(model = model, dataList = dataList, ndat = ndat, cmd = cmd, store.slots = store.slots, FUN = FUN, show.progress = show.progress, diff --git a/R/lav_lavaanList_simulate.R b/R/lav_lavaanList_simulate.R index b8ebfac3..551f06e6 100644 --- a/R/lav_lavaanList_simulate.R +++ b/R/lav_lavaanList_simulate.R @@ -5,7 +5,7 @@ lavSimulate <- function(pop.model = NULL, # population model model = NULL, # user model dataFunction = simulateData, dataFunction.args = list(model = pop.model, - sample.nobs = 1000L), + sample.nobs = 1000L), ndat = 1000L, cmd = "sem", cmd.pop = "sem", @@ -29,13 +29,13 @@ lavSimulate <- function(pop.model = NULL, # population model dotdotdot.pop$sample.cov <- NULL # 'fit' population model without data, to get 'true' parameters - fit.pop <- do.call(cmd.pop, + fit.pop <- do.call(cmd.pop, args = c(list(model = pop.model), dotdotdot.pop)) # check model object if(is.null(model)) { model <- fit.pop@ParTable - } + } # per default, use 'true' values as starting values if(is.null(dotdotdot$start)) { @@ -46,7 +46,7 @@ lavSimulate <- function(pop.model = NULL, # population model # dotdotdot$warn <- FALSE # generate simulations - fit <- do.call("lavaanList", args = c(list(model = model, + fit <- do.call("lavaanList", args = c(list(model = model, dataFunction = dataFunction, dataFunction.args = dataFunction.args, ndat = ndat, cmd = cmd, @@ -59,10 +59,10 @@ lavSimulate <- function(pop.model = NULL, # population model fit@meta$lavSimulate <- TRUE # NOTE!!! - # if the model != pop.model, we may need to 'reorder' the + # if the model != pop.model, we may need to 'reorder' the # 'true' parameters, so they correspond to the 'model' parameters - p2.id <- lav_partable_map_id_p1_in_p2(p1 = fit@ParTable, - p2 = fit.pop@ParTable, + p2.id <- lav_partable_map_id_p1_in_p2(p1 = fit@ParTable, + p2 = fit.pop@ParTable, stopifnotfound = FALSE) est1 <- fit@ParTable$est na.idx <- which(is.na(p2.id)) diff --git a/R/lav_matrix.R b/R/lav_matrix.R index b2a7e28e..fc578a35 100644 --- a/R/lav_matrix.R +++ b/R/lav_matrix.R @@ -4,7 +4,7 @@ # vec operator # -# the vec operator (for 'vectorization') transforms a matrix into +# the vec operator (for 'vectorization') transforms a matrix into # a vector by stacking the *columns* of the matrix one underneath the other # # M&N book: page 30 @@ -17,7 +17,7 @@ lav_matrix_vec <- function(A) { # vecr operator # -# the vecr operator ransforms a matrix into +# the vecr operator ransforms a matrix into # a vector by stacking the *rows* of the matrix one underneath the other lav_matrix_vecr <- function(A) { @@ -29,10 +29,10 @@ lav_matrix_vecr <- function(A) { } -# vech -# -# the vech operator (for 'half vectorization') transforms a *symmetric* matrix -# into a vector by stacking the *columns* of the matrix one underneath the +# vech +# +# the vech operator (for 'half vectorization') transforms a *symmetric* matrix +# into a vector by stacking the *columns* of the matrix one underneath the # other, but eliminating all supradiagonal elements # # see Henderson & Searle, 1979 @@ -45,7 +45,7 @@ lav_matrix_vech <- function(S, diagonal = TRUE) { } -# the vechr operator transforms a *symmetric* matrix +# the vechr operator transforms a *symmetric* matrix # into a vector by stacking the *rows* of the matrix one after the # other, but eliminating all supradiagonal elements lav_matrix_vechr <- function(S, diagonal = TRUE) { @@ -53,7 +53,7 @@ lav_matrix_vechr <- function(S, diagonal = TRUE) { } -# the vechu operator transforms a *symmetric* matrix +# the vechu operator transforms a *symmetric* matrix # into a vector by stacking the *columns* of the matrix one after the # other, but eliminating all infradiagonal elements lav_matrix_vechu <- function(S, diagonal = TRUE) { @@ -61,7 +61,7 @@ lav_matrix_vechu <- function(S, diagonal = TRUE) { } -# the vechru operator transforms a *symmetric* matrix +# the vechru operator transforms a *symmetric* matrix # into a vector by stacking the *rows* of the matrix one after the # other, but eliminating all infradiagonal elements # @@ -73,7 +73,7 @@ lav_matrix_vechru <- function(S, diagonal = TRUE) { -# return the *vector* indices of the lower triangular elements of a +# return the *vector* indices of the lower triangular elements of a # symmetric matrix of size 'n' lav_matrix_vech_idx <- function(n = 1L, diagonal = TRUE) { # FIXME: is there a way to avoid creating ROW/COL matrices? @@ -83,7 +83,7 @@ lav_matrix_vech_idx <- function(n = 1L, diagonal = TRUE) { if(diagonal) which(ROW >= COL) else which(ROW > COL) } -# return the *row* indices of the lower triangular elements of a +# return the *row* indices of the lower triangular elements of a # symmetric matrix of size 'n' lav_matrix_vech_row_idx <- function(n = 1L, diagonal = TRUE) { n <- as.integer(n) @@ -94,7 +94,7 @@ lav_matrix_vech_row_idx <- function(n = 1L, diagonal = TRUE) { } } -# return the *col* indices of the lower triangular elements of a +# return the *col* indices of the lower triangular elements of a # symmetric matrix of size 'n' lav_matrix_vech_col_idx <- function(n = 1L, diagonal = TRUE) { n <- as.integer(n) @@ -105,9 +105,9 @@ lav_matrix_vech_col_idx <- function(n = 1L, diagonal = TRUE) { } - -# return the *vector* indices of the lower triangular elements of a + +# return the *vector* indices of the lower triangular elements of a # symmetric matrix of size 'n' -- ROW-WISE lav_matrix_vechr_idx <- function(n = 1L, diagonal = TRUE) { n <- as.integer(n) @@ -117,7 +117,7 @@ lav_matrix_vechr_idx <- function(n = 1L, diagonal = TRUE) { if(diagonal) tmp[ROW <= COL] else tmp[ROW < COL] } -# return the *vector* indices of the upper triangular elements of a +# return the *vector* indices of the upper triangular elements of a # symmetric matrix of size 'n' -- COLUMN-WISE lav_matrix_vechu_idx <- function(n = 1L, diagonal = TRUE) { n <- as.integer(n) @@ -126,7 +126,7 @@ lav_matrix_vechu_idx <- function(n = 1L, diagonal = TRUE) { if(diagonal) which(ROW <= COL) else which(ROW < COL) } -# return the *vector* indices of the upper triangular elements of a +# return the *vector* indices of the upper triangular elements of a # symmetric matrix of size 'n' -- ROW-WISE # # FIXME!! make this more efficient (without creating 3 n*n matrices!) @@ -142,10 +142,10 @@ lav_matrix_vechru_idx <- function(n = 1L, diagonal = TRUE) { # vech.reverse and vechru.reverse (aka `upper2full') # -# given the output of vech(S) --or vechru(S) which is identical-- +# given the output of vech(S) --or vechru(S) which is identical-- # reconstruct S -lav_matrix_vech_reverse <- lav_matrix_vechru_reverse <- -lav_matrix_upper2full <- +lav_matrix_vech_reverse <- lav_matrix_vechru_reverse <- +lav_matrix_upper2full <- function(x, diagonal = TRUE) { # guess dimensions if(diagonal) { @@ -158,7 +158,7 @@ function(x, diagonal = TRUE) { S[lav_matrix_vech_idx( p, diagonal = diagonal)] <- x S[lav_matrix_vechru_idx(p, diagonal = diagonal)] <- x - attr(S, "dim") <- c(p, p) + attr(S, "dim") <- c(p, p) S } @@ -167,7 +167,7 @@ function(x, diagonal = TRUE) { # # given the output of vechr(S) --or vechu(S) which is identical-- # reconstruct S -lav_matrix_vechr_reverse <- lav_matrix_vechu_reverse <- +lav_matrix_vechr_reverse <- lav_matrix_vechu_reverse <- lav_matrix_lower2full <- function(x, diagonal = TRUE) { # guess dimensions if(diagonal) { @@ -213,17 +213,17 @@ lav_matrix_antidiag_idx <- function(n = 1L) { # return the *vector* indices of 'idx' elements in a vech() matrix # # eg if n = 4 and type == "and" and idx = c(2,4) -# we create matrix A = +# we create matrix A = # [,1] [,2] [,3] [,4] # [1,] FALSE FALSE FALSE FALSE # [2,] FALSE TRUE FALSE TRUE # [3,] FALSE FALSE FALSE FALSE # [4,] FALSE TRUE FALSE TRUE -# +# # and the result is c(5,7,10) # # eg if n = 4 and type == "or" and idx = c(2,4) -# we create matrix A = +# we create matrix A = # [,1] [,2] [,3] [,4] # [1,] FALSE TRUE FALSE TRUE # [2,] TRUE TRUE TRUE TRUE @@ -249,9 +249,9 @@ lav_matrix_vech_which_idx <- function(n = 1L, diagonal = TRUE, # similar to lav_matrix_vech_which_idx(), but # - only 'type = and' # - order of idx matters! -lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, +lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, idx = integer(0L)) { - if (length(idx) == 0L) + if (length(idx) == 0L) return(integer(0L)) n <- as.integer(n) pstar <- n*(n+1)/2 @@ -293,7 +293,7 @@ lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, r3 <- seq.int(from = 2*n+1, by = n, length.out = n-1) # is there a more elegant way to do this? - rr <- unlist(lapply((n-1):1, + rr <- unlist(lapply((n-1):1, function(x) { c(rbind(r1[1:x], r2[1:x]), r3[n-x]) })) idx <- c(1L, cumsum(rr) + 1L) @@ -317,7 +317,7 @@ lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, if(n > 255L) { stop("n is too large") } - + nstar <- n * (n+1)/2 n2 <- n * n # THIS is the real bottleneck: allocating an ocean of zeroes... @@ -355,7 +355,7 @@ lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, idx <- (1:n2) + (lav_matrix_vec(tmp)-1L) * n2 - x[idx] <- 1.0 + x[idx] <- 1.0 attr(x, "dim") <- c(n2, nstar) x @@ -407,7 +407,7 @@ lav_matrix_duplication_pre <- function(A = matrix(0,0,0)) { OUT <- A[idx1, , drop = FALSE] + A[idx2 , , drop = FALSE] u <- which(idx1 %in% idx2); OUT[u,] <- OUT[u,] / 2.0 - + OUT } @@ -480,7 +480,7 @@ lav_matrix_duplication_pre_post <- function(A = matrix(0,0,0)) { OUT } -# create the generalized inverse of the duplication matrix (D^+_n): +# create the generalized inverse of the duplication matrix (D^+_n): # it removes the duplicated elements in vec(S) to create vech(S) # # D^+ %*% vec(S) == vech(S) @@ -597,7 +597,7 @@ lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0,0,0)) { # dimension n <- sqrt(n2) - + idx1 <- lav_matrix_vech_idx(n); idx2 <- lav_matrix_vechru_idx(n) OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2 OUT <- (OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]) / 2 @@ -607,7 +607,7 @@ lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0,0,0)) { -# create the commutation matrix (K_mn) +# create the commutation matrix (K_mn) # the mn x mx commutation matrix is a permutation matrix which # transforms vec(A) into vec(A') # @@ -618,7 +618,7 @@ lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0,0,0)) { # # note: K_mn is a permutation matrix, so it is orthogonal: t(K_mn) = K_mn^-1 # K_nm %*% K_mn == I_mn -# +# # it is called the 'commutation' matrix because it enables us to interchange # ('commute') the two matrices of a Kronecker product, eg # K_pm (A %x% B) K_nq == (B %x% A) @@ -637,7 +637,7 @@ lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0,0,0)) { if ((n < 1L) | (round(n) != n)) { stop("n must be a positive integer") } - + p <- m*n x <- numeric( p*p ) @@ -671,7 +671,7 @@ lav_matrix_commutation_pre <- function(A = matrix(0,0,0)) { row.idx <- rep(1:n, each = n) + (0:(n-1L))*n OUT <- A[row.idx, , drop = FALSE] - OUT + OUT } # compute K_mn %*% A without explicitly computing K @@ -713,7 +713,7 @@ lav_matrix_kronecker_square <- function(A, check = TRUE) { # break up in n*n pieces, and rearrange dim(out) <- c(n,n,n,n) out <- aperm(out, perm = c(3,1,4,2)) - + # reshape again, to form n2 x n2 matrix dim(out) <- c(n2, n2) @@ -723,22 +723,22 @@ lav_matrix_kronecker_square <- function(A, check = TRUE) { # (simplified) faster kronecker product for symmetric matrices # note: not faster, but the logic extends to vech versions lav_matrix_kronecker_symmetric <- function(S, check = TRUE) { - + dimS <- dim(S); n <- dimS[1L]; n2 <- n*n if(check) { stopifnot(dimS[2L] == n) } - + # all possible combinations out <- tcrossprod(as.vector(S)) - + # break up in n*(n*n) pieces, and rearrange - dim(out) <- c(n,n*n,n) + dim(out) <- c(n,n*n,n) out <- aperm(out, perm = c(3L,2L,1L)) - + # reshape again, to form n2 x n2 matrix dim(out) <- c(n2, n2) - + out } @@ -794,7 +794,7 @@ lav_matrix_symmetric_sqrt <- function(S = matrix(0,0,0)) { # decomposition P = HVH', where H is a p* x (p* - q) matrix of full column rank, # and V is a (p* - q) x (p* - q) diagonal matrix. It is obvious that H'A = 0; # hence, H is the desired orthogonal complement. This method of constructing an -# orthogonal complement was proposed by Heinz Neudecker (1990, pers. comm.). +# orthogonal complement was proposed by Heinz Neudecker (1990, pers. comm.). # # update YR 21 okt 2014: # - note that A %*% solve(t(A) %*% A) %*% t(A) == tcrossprod(qr.Q(qr(A))) @@ -840,7 +840,7 @@ lav_matrix_bdiag <- function(...) { trows <- sum(nrows) tcols <- sum(ncols) x <- numeric(trows * tcols) - + for(m in seq_len(nmat)) { if(m > 1L) { rcoffset <- trows*ccols[m-1] + crows[m-1] @@ -849,7 +849,7 @@ lav_matrix_bdiag <- function(...) { } m.idx <- ( rep((0:(ncols[m] - 1L))*trows, each=nrows[m]) + rep(1:nrows[m], ncols[m]) + rcoffset ) - x[m.idx] <- mlist[[m]] + x[m.idx] <- mlist[[m]] } attr(x, "dim") <- c(trows, tcols) @@ -898,13 +898,13 @@ lav_matrix_trace <- function(..., check = TRUE) { # below is the logic; to be coded inline # DIAG <- numeric( NROW(A) ) # for(i in seq_len(NROW(A))) { - # DIAG[i] <- sum( rep(A[i,], times = NCOL(B)) * - # as.vector(B) * + # DIAG[i] <- sum( rep(A[i,], times = NCOL(B)) * + # as.vector(B) * # rep(C[,i], each=NROW(B)) ) # } # out <- sum(DIAG) - # FIXME: + # FIXME: # dimension check is automatic B2 <- B %*% C @@ -1019,13 +1019,13 @@ lav_matrix_orthogonal_complement2 <- function(A, if(nfree) { R <- out$R - + # remove all-zero rows zero.idx <- which(apply(R, 1, function(x) { all(abs(x) < tol) })) if(length(zero.idx) > 0) { R <- R[-zero.idx,, drop = FALSE] } - + FREE <- R[, -out$pivot, drop = FALSE] I <- diag( nfree ) N <- rbind(-FREE, I) @@ -1039,7 +1039,7 @@ lav_matrix_orthogonal_complement2 <- function(A, # inverse of a non-singular (not necessarily positive-definite) symmetric matrix # FIXME: error handling? -lav_matrix_symmetric_inverse <- function(S, logdet = FALSE, +lav_matrix_symmetric_inverse <- function(S, logdet = FALSE, Sinv.method = "eigen") { P <- NCOL(S) @@ -1069,7 +1069,7 @@ lav_matrix_symmetric_inverse <- function(S, logdet = FALSE, } else if(Sinv.method == "eigen") { EV <- eigen(S, symmetric = TRUE) # V %*% diag(1/d) %*% V^{-1}, where V^{-1} = V^T - S.inv <- + S.inv <- tcrossprod(EV$vector / rep(EV$values, each = length(EV$values)), EV$vector) if(logdet) { @@ -1143,7 +1143,7 @@ lav_matrix_inverse_update <- function(A.inv, rm.idx = integer(0L)) { # - only removal for now! # lav_matrix_symmetric_inverse_update <- function(S.inv, rm.idx = integer(0L), - logdet = FALSE, + logdet = FALSE, S.logdet = NULL) { ndel <- length(rm.idx) @@ -1179,7 +1179,7 @@ lav_matrix_symmetric_inverse_update <- function(S.inv, rm.idx = integer(0L), # erase all col/rows... } else if(ndel == NCOL(S.inv)) { out <- matrix(0,0,0) - } + } else { stop("lavaan ERROR: column indices exceed number of columns in S.inv") @@ -1247,7 +1247,7 @@ lav_matrix_symmetric_det_update <- function(det.S, S.inv, rm.idx = integer(0L)){ # update log determinant of S, after removing 1 or more rows (and corresponding # colums) from S, a symmetric matrix # -lav_matrix_symmetric_logdet_update <- function(S.logdet, S.inv, +lav_matrix_symmetric_logdet_update <- function(S.logdet, S.inv, rm.idx = integer(0L)) { ndel <- length(rm.idx) @@ -1284,7 +1284,7 @@ lav_matrix_symmetric_force_pd <- function(S, tol = 1e-06) { # eigen decomposition S.eigen <- eigen(S, symmetric = TRUE) - + # eigen values ev <- S.eigen$values @@ -1308,7 +1308,7 @@ lav_matrix_cov <- function(Y, ybar = NULL) { } # transform a matrix to match a given target mean/covariance -lav_matrix_transform_mean_cov <- function(Y, +lav_matrix_transform_mean_cov <- function(Y, target.mean = numeric( NCOL(Y) ), target.cov = diag( NCOL(Y) )) { @@ -1319,13 +1319,13 @@ lav_matrix_transform_mean_cov <- function(Y, S.inv <- solve(S) S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv) target.cov.sqrt <- lav_matrix_symmetric_sqrt(target.cov) - + # transform cov X <- Y %*% S.inv.sqrt %*% target.cov.sqrt # shift mean xbar <- colMeans(X) X <- t( t(X) - xbar + target.mean ) - + X } diff --git a/R/lav_model.R b/R/lav_model.R index 06e7b73b..3b78295e 100644 --- a/R/lav_model.R +++ b/R/lav_model.R @@ -9,7 +9,7 @@ # construct MATRIX lavoptions$representation of the model lav_model <- function(lavpartable = NULL, lavoptions = NULL, - th.idx = list(), + th.idx = list(), cov.x = list(), mean.x = list()) { # for conditional.x only # (not really needed, @@ -17,20 +17,20 @@ lav_model <- function(lavpartable = NULL, # handle bare-minimum partables lavpartable <- lav_partable_complete(lavpartable) - + # global info from user model nblocks <- lav_partable_nblocks(lavpartable) ngroups <- lav_partable_ngroups(lavpartable) meanstructure <- any(lavpartable$op == "~1") categorical <- any(lavpartable$op == "|") - if(categorical) { + if(categorical) { meanstructure <- TRUE # handle th.idx if length(th.idx) != nblocks if(nblocks != length(th.idx)) { th.idx <- rep(th.idx, each = nblocks) } - + } group.w.free <- any(lavpartable$lhs == "group" & lavpartable$op == "%") multilevel <- FALSE @@ -66,12 +66,12 @@ lav_model <- function(lavpartable = NULL, if(lavoptions$debug) print(REP) # FIXME: check for non-existing parameters - bad.idx <- which(REP$mat == "" & + bad.idx <- which(REP$mat == "" & !lavpartable$op %in% c("==","<",">",":=")) if(length(bad.idx) > 0L) { - - label <- paste(lavpartable$lhs[bad.idx[1]], + + label <- paste(lavpartable$lhs[bad.idx[1]], lavpartable$op[bad.idx[1]], lavpartable$rhs[bad.idx[1]], sep = " ") stop("lavaan ERROR: parameter is not defined: ", label) @@ -140,7 +140,7 @@ lav_model <- function(lavpartable = NULL, dimNames[[offset]] <- mmDimNames[[mm]] # select elements for this matrix - idx <- which(lavpartable$block == g & REP$mat == mmNames[mm]) + idx <- which(lavpartable$block == g & REP$mat == mmNames[mm]) # create empty `pattern' matrix # FIXME: one day, we may want to use sparse matrices... @@ -161,7 +161,7 @@ lav_model <- function(lavpartable = NULL, # 2. if equality constraints, unconstrained free parameters # -> to be used in lav_model_gradient #if(CON$ceq.linear.only.flag) { - # tmp[ cbind(REP$row[idx], + # tmp[ cbind(REP$row[idx], # REP$col[idx]) ] <- lavpartable$unco[idx] # if(mmSymmetric[mm]) { # # NOTE: we assume everything is in the UPPER tri! @@ -181,7 +181,7 @@ lav_model <- function(lavpartable = NULL, } m.user.idx[[offset]] <- which(tmp > 0) x.user.idx[[offset]] <- tmp[which(tmp > 0)] - + # 4. now assign starting/fixed values # create empty matrix # FIXME: again, we may want to use sparse matrices here... @@ -206,7 +206,7 @@ lav_model <- function(lavpartable = NULL, } # representation specific stuff - if(lavoptions$representation == "LISREL" && mmNames[mm] == "lambda") { + if(lavoptions$representation == "LISREL" && mmNames[mm] == "lambda") { ov.dummy.names.nox <- attr(REP, "ov.dummy.names.nox")[[g]] ov.dummy.names.x <- attr(REP, "ov.dummy.names.x")[[g]] ov.dummy.names <- c(ov.dummy.names.nox, ov.dummy.names.x) @@ -231,7 +231,7 @@ lav_model <- function(lavpartable = NULL, # only categorical values are listed in the lavpartable # but all remaining values should be 1.0 idx <- which(tmp[,1L] == 0.0) - tmp[idx,1L] <- 1.0 + tmp[idx,1L] <- 1.0 } # assign matrix to GLIST @@ -240,7 +240,7 @@ lav_model <- function(lavpartable = NULL, } # g # fixed.x parameters? - #fixed.x <- any(lavpartable$exo > 0L & lavpartable$free == 0L) + #fixed.x <- any(lavpartable$exo > 0L & lavpartable$free == 0L) #if(categorical) { # fixed.x <- TRUE #} @@ -262,10 +262,10 @@ lav_model <- function(lavpartable = NULL, # which free parameters are observed variances? ov.names <- vnames(lavpartable, "ov") - x.free.var.idx <- lavpartable$free[ lavpartable$free & + x.free.var.idx <- lavpartable$free[ lavpartable$free & #!duplicated(lavpartable$free) & lavpartable$lhs %in% ov.names & - lavpartable$op == "~~" & + lavpartable$op == "~~" & lavpartable$lhs == lavpartable$rhs ] Model <- new("lavModel", diff --git a/R/lav_model_compute.R b/R/lav_model_compute.R index 0f040262..496035ef 100644 --- a/R/lav_model_compute.R +++ b/R/lav_model_compute.R @@ -1,4 +1,4 @@ -computeSigmaHat <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE, +computeSigmaHat <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE, delta = TRUE, debug = FALSE) { # state or final? @@ -19,7 +19,7 @@ computeSigmaHat <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE, MLIST <- GLIST[mm.in.group] if(representation == "LISREL") { - Sigma.hat[[g]] <- computeSigmaHat.LISREL(MLIST = MLIST, + Sigma.hat[[g]] <- computeSigmaHat.LISREL(MLIST = MLIST, delta = delta) } else { stop("only representation LISREL has been implemented for now") @@ -54,9 +54,9 @@ computeSigmaHat <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE, ## only if conditional.x = TRUE ## compute the (larger) unconditional 'joint' covariance matrix (y,x) ## -## Sigma (Joint ) = [ (S11, S12), +## Sigma (Joint ) = [ (S11, S12), ## (S21, S22) ] where -## S11 = Sigma.res + PI %*% cov.x %*% t(PI) +## S11 = Sigma.res + PI %*% cov.x %*% t(PI) ## S12 = PI %*% cov.x ## S21 = cov.x %*% t(PI) ## S22 = cov.x @@ -219,7 +219,7 @@ computeTH <- function(lavmodel = NULL, GLIST = NULL) { TH[[g]] <- numeric(0L) next } - + # which mm belong to group g? mm.in.group <- 1:nmat[g] + cumsum(c(0,nmat))[g] @@ -350,7 +350,7 @@ computeVY <- function(lavmodel = NULL, GLIST = NULL, diagonal.only = FALSE) { } # V(ETA): latent variances variances/covariances -computeVETA <- function(lavmodel = NULL, GLIST = NULL, +computeVETA <- function(lavmodel = NULL, GLIST = NULL, remove.dummy.lv = FALSE) { # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST @@ -411,7 +411,7 @@ computeVETAx <- function(lavmodel = NULL, GLIST = NULL) { if(representation == "LISREL") { lv.idx <- c(lavmodel@ov.y.dummy.lv.idx[[g]], lavmodel@ov.x.dummy.lv.idx[[g]]) - ETA.g <- computeVETAx.LISREL(MLIST = MLIST, + ETA.g <- computeVETAx.LISREL(MLIST = MLIST, lv.dummy.idx = lv.idx) } else { stop("only representation LISREL has been implemented for now") @@ -424,7 +424,7 @@ computeVETAx <- function(lavmodel = NULL, GLIST = NULL) { } # COV: observed+latent variances variances/covariances -computeCOV <- function(lavmodel = NULL, GLIST = NULL, +computeCOV <- function(lavmodel = NULL, GLIST = NULL, remove.dummy.lv = FALSE) { # state or final? @@ -452,7 +452,7 @@ computeCOV <- function(lavmodel = NULL, GLIST = NULL, lavmodel@ov.x.dummy.lv.idx[[g]]) if(!is.null(lv.idx)) { # offset for ov - lambda.names <- + lambda.names <- lavmodel@dimNames[[which(names(GLIST) == "lambda")[g]]][[1L]] lv.idx <- lv.idx + length(lambda.names) COV.g <- COV.g[-lv.idx, -lv.idx, drop=FALSE] @@ -470,9 +470,9 @@ computeCOV <- function(lavmodel = NULL, GLIST = NULL, # E(ETA): expectation (means) of latent variables (return vector) -computeEETA <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, +computeEETA <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, remove.dummy.lv = FALSE) { - + # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST @@ -490,7 +490,7 @@ computeEETA <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, MLIST <- GLIST[ mm.in.group ] if(representation == "LISREL") { - EETA.g <- computeEETA.LISREL(MLIST, + EETA.g <- computeEETA.LISREL(MLIST, mean.x=lavsamplestats@mean.x[[g]], sample.mean=lavsamplestats@mean[[g]], ov.y.dummy.lv.idx=lavmodel@ov.y.dummy.lv.idx[[g]], @@ -517,9 +517,9 @@ computeEETA <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, # E(ETA|x_i): conditional expectation (means) of latent variables # for a given value of x_i (instead of E(x_i)) -computeEETAx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, +computeEETAx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, eXo = NULL, nobs = NULL, remove.dummy.lv = FALSE) { - + # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST @@ -543,7 +543,7 @@ computeEETAx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, } if(representation == "LISREL") { - EETAx.g <- computeEETAx.LISREL(MLIST, + EETAx.g <- computeEETAx.LISREL(MLIST, eXo=EXO, N=nobs[[g]], sample.mean=lavsamplestats@mean[[g]], ov.y.dummy.lv.idx=lavmodel@ov.y.dummy.lv.idx[[g]], @@ -570,9 +570,9 @@ computeEETAx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, } # return 'regular' LAMBDA -computeLAMBDA <- function(lavmodel = NULL, GLIST = NULL, +computeLAMBDA <- function(lavmodel = NULL, GLIST = NULL, remove.dummy.lv = FALSE) { - + # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST @@ -643,7 +643,7 @@ computeTHETA <- function(lavmodel = NULL, GLIST = NULL) { # E(Y): expectation (mean) of observed variables # returns vector 1 x nvar computeEY <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL) { - + # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST @@ -661,7 +661,7 @@ computeEY <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL) { MLIST <- GLIST[ mm.in.group ] if(representation == "LISREL") { - EY.g <- computeEY.LISREL(MLIST = MLIST, + EY.g <- computeEY.LISREL(MLIST = MLIST, mean.x=lavsamplestats@mean.x[[g]], sample.mean=lavsamplestats@mean[[g]], ov.y.dummy.ov.idx=lavmodel@ov.y.dummy.ov.idx[[g]], @@ -681,9 +681,9 @@ computeEY <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL) { # E(Y | ETA, x_i): conditional expectation (means) of observed variables # for a given value of x_i AND eta_i -computeYHAT <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, +computeYHAT <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, eXo = NULL, nobs = NULL, ETA = NULL, duplicate = FALSE) { - + # state or final? if(is.null(GLIST)) GLIST <- lavmodel@GLIST diff --git a/R/lav_model_estimate.R b/R/lav_model_estimate.R index a0e7525a..052d81af 100644 --- a/R/lav_model_estimate.R +++ b/R/lav_model_estimate.R @@ -38,7 +38,7 @@ lav_model_estimate <- function(lavmodel = NULL, # rescale parameters as if the data was standardized # new in 0.6-2 # - # FIXME: this works well, as long as the variances of the + # FIXME: this works well, as long as the variances of the # latent variables (which we do not know) are more or less # equal to 1.0 (eg std.lv = TRUE) # @@ -62,7 +62,7 @@ lav_model_estimate <- function(lavmodel = NULL, } if(lavoptions$std.lv) { - parscale <- lav_standardize_all(lavobject = NULL, + parscale <- lav_standardize_all(lavobject = NULL, est = rep(1, length(lavpartable$lhs)), est.std = rep(1, length(lavpartable$lhs)), cov.std = FALSE, ov.var = OV.VAR, @@ -116,7 +116,7 @@ lav_model_estimate <- function(lavmodel = NULL, # length(lavmodel@x.free.var.idx) > 0L) { # # transforming variances using atan (or another sigmoid function?) # # FIXME: better approach? - # #start.x[lavmodel@x.free.var.idx] <- + # #start.x[lavmodel@x.free.var.idx] <- # # atan(start.x[lavmodel@x.free.var.idx]) # start.x[lavmodel@x.free.var.idx] <- # sqrt(start.x[lavmodel@x.free.var.idx]) # assuming positive var @@ -128,7 +128,7 @@ lav_model_estimate <- function(lavmodel = NULL, cat("start.x = ", start.x, "\n") } - + # bounds? (new in 0.6-2) if(is.null(lavpartable$lower)) { lower <- -Inf @@ -140,7 +140,7 @@ lav_model_estimate <- function(lavmodel = NULL, lowerb <- lower lowerb[lower == -Inf] <- -999999 - + # pack l.pack <- as.numeric( (lowerb - lavmodel@eq.constraints.k0) %*% lavmodel@eq.constraints.K ) @@ -166,14 +166,14 @@ lav_model_estimate <- function(lavmodel = NULL, upper[!(upper %in% not.inf.val)] <- Inf } } - + # function to be minimized objective_function <- function(x, verbose = FALSE, infToMax = FALSE) { - # 3. standard deviations to variances + # 3. standard deviations to variances # WARNING: x is still packed here! #if(lavoptions$optim.var.transform == "sqrt" && # length(lavmodel@x.free.var.idx) > 0L) { @@ -195,9 +195,9 @@ lav_model_estimate <- function(lavmodel = NULL, # update GLIST (change `state') and make a COPY! GLIST <- lav_model_x2GLIST(lavmodel, x = x) - fx <- lav_model_objective(lavmodel = lavmodel, - GLIST = GLIST, - lavsamplestats = lavsamplestats, + fx <- lav_model_objective(lavmodel = lavmodel, + GLIST = GLIST, + lavsamplestats = lavsamplestats, lavdata = lavdata, lavcache = lavcache, verbose = verbose, @@ -210,8 +210,8 @@ lav_model_estimate <- function(lavmodel = NULL, - if(debug || verbose) { - cat("Objective function = ", sprintf("%18.16f", fx), "\n", sep="") + if(debug || verbose) { + cat("Objective function = ", sprintf("%18.16f", fx), "\n", sep="") } if(debug) { #cat("Current unconstrained parameter values =\n") @@ -256,12 +256,12 @@ lav_model_estimate <- function(lavmodel = NULL, # update GLIST (change `state') and make a COPY! GLIST <- lav_model_x2GLIST(lavmodel, x = x) - dx <- lav_model_gradient(lavmodel = lavmodel, - GLIST = GLIST, + dx <- lav_model_gradient(lavmodel = lavmodel, + GLIST = GLIST, lavsamplestats = lavsamplestats, lavdata = lavdata, lavcache = lavcache, - type = "free", + type = "free", group.weight = group.weight, ### check me!! verbose = verbose, forcePD = TRUE) @@ -285,7 +285,7 @@ lav_model_estimate <- function(lavmodel = NULL, # x.var.sign <- sign(x.var) # x.var <- abs(x.var) # x.sd <- sqrt(x.var) - # dx[lavmodel@x.free.var.idx] <- + # dx[lavmodel@x.free.var.idx] <- # ( 2 * x.var.sign * dx[lavmodel@x.free.var.idx] * x.sd ) #} @@ -310,7 +310,7 @@ lav_model_estimate <- function(lavmodel = NULL, npar <- length(x) h <- 10e-6 dx <- numeric( npar ) - + ## FIXME: call lav_model_objective directly!! for(i in 1:npar) { x.left <- x.left2 <- x.right <- x.right2 <- x @@ -328,11 +328,11 @@ lav_model_estimate <- function(lavmodel = NULL, if(debug) { cat("Gradient function (numerical) =\n"); print(dx); cat("\n") - } + } dx } - + # check if the initial values produce a positive definite Sigma # to begin with -- but only for estimator="ML" @@ -341,7 +341,7 @@ lav_model_estimate <- function(lavmodel = NULL, Sigma.hat <- computeSigmaHat(lavmodel, extra=TRUE, debug=lavoptions$debug) for(g in 1:ngroups) { if(!attr(Sigma.hat[[g]], "po")) { - group.txt <- ifelse(ngroups > 1, + group.txt <- ifelse(ngroups > 1, paste(" in group ",g,".",sep=""), ".") if(debug) print(Sigma.hat[[g]]) stop("lavaan ERROR: initial model-implied matrix (Sigma) is not positive definite;\n check your model and/or starting parameters", group.txt) @@ -409,7 +409,7 @@ lav_model_estimate <- function(lavmodel = NULL, #OPTIMIZER <- "L-BFGS-B" # trouble with Inf values for fx! } else { OPTIMIZER <- toupper(lavoptions$optim.method) - stopifnot(OPTIMIZER %in% c("NLMINB0", "NLMINB1", "NLMINB2", + stopifnot(OPTIMIZER %in% c("NLMINB0", "NLMINB1", "NLMINB2", "NLMINB", "BFGS", "L-BFGS-B", "NONE")) if(OPTIMIZER == "NLMINB1") { OPTIMIZER <- "NLMINB" @@ -425,7 +425,7 @@ lav_model_estimate <- function(lavmodel = NULL, optim.out <- optim(par=start.x, fn=objective_function, method="Nelder-Mead", - #control=list(maxit=10L, + #control=list(maxit=10L, # parscale=SCALE, # trace=trace), hessian=FALSE, @@ -434,7 +434,7 @@ lav_model_estimate <- function(lavmodel = NULL, start.x <- optim.out$par } - + if(OPTIMIZER == "NLMINB0") { if(verbose) cat("Quasi-Newton steps using NLMINB0 (no analytic gradient):\n") @@ -451,7 +451,7 @@ lav_model_estimate <- function(lavmodel = NULL, x.tol=1.5e-8, xf.tol=2.2e-14) control.nlminb <- modifyList(control.nlminb, lavoptions$control) - control <- control.nlminb[c("eval.max", "iter.max", "trace", + control <- control.nlminb[c("eval.max", "iter.max", "trace", "step.min", "step.max", "abs.tol", "rel.tol", "x.tol", "xf.tol")] #cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n") @@ -462,7 +462,7 @@ lav_model_estimate <- function(lavmodel = NULL, upper=upper, control=control, scale=SCALE, - verbose=verbose) + verbose=verbose) if(verbose) { cat("convergence status (0=ok): ", optim.out$convergence, "\n") cat("nlminb message says: ", optim.out$message, "\n") @@ -494,7 +494,7 @@ lav_model_estimate <- function(lavmodel = NULL, x.tol=1.5e-8, xf.tol=2.2e-14) control.nlminb <- modifyList(control.nlminb, lavoptions$control) - control <- control.nlminb[c("eval.max", "iter.max", "trace", + control <- control.nlminb[c("eval.max", "iter.max", "trace", "step.min", "step.max", "abs.tol", "rel.tol", "x.tol", "xf.tol")] #cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n") @@ -505,7 +505,7 @@ lav_model_estimate <- function(lavmodel = NULL, upper=upper, control=control, scale=SCALE, - verbose=verbose) + verbose=verbose) if(verbose) { cat("convergence status (0=ok): ", optim.out$convergence, "\n") cat("nlminb message says: ", optim.out$message, "\n") @@ -527,7 +527,7 @@ lav_model_estimate <- function(lavmodel = NULL, # (but WLS works!) # - BB.ML works too - control.bfgs <- list(trace=0L, fnscale=1, + control.bfgs <- list(trace=0L, fnscale=1, parscale=SCALE, ## or not? ndeps=1e-3, maxit=10000, @@ -574,8 +574,8 @@ lav_model_estimate <- function(lavmodel = NULL, factr=1e7, pgtol=0) control.lbfgsb <- modifyList(control.lbfgsb, lavoptions$control) - control <- control.lbfgsb[c("trace", "fnscale", "parscale", - "ndeps", "maxit", "REPORT", "lmm", + control <- control.lbfgsb[c("trace", "fnscale", "parscale", + "ndeps", "maxit", "REPORT", "lmm", "factr", "pgtol")] optim.out <- optim(par=start.x, fn=objective_function, @@ -661,7 +661,7 @@ lav_model_estimate <- function(lavmodel = NULL, fx <- objective_function(x) # to get "fx.group" attribute # transform back - # 3. + # 3. #if(lavoptions$optim.var.transform == "sqrt" && # length(lavmodel@x.free.var.idx) > 0L) { # #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx]) diff --git a/R/lav_model_gradient.R b/R/lav_model_gradient.R index e1f24a1c..30c31e18 100644 --- a/R/lav_model_gradient.R +++ b/R/lav_model_gradient.R @@ -1,13 +1,13 @@ # model gradient -lav_model_gradient <- function(lavmodel = NULL, - GLIST = NULL, - lavsamplestats = NULL, +lav_model_gradient <- function(lavmodel = NULL, + GLIST = NULL, + lavsamplestats = NULL, lavdata = NULL, lavcache = NULL, - type = "free", - verbose = FALSE, - forcePD = TRUE, + type = "free", + verbose = FALSE, + forcePD = TRUE, group.weight = TRUE, Delta = NULL, m.el.idx = NULL, @@ -66,10 +66,10 @@ lav_model_gradient <- function(lavmodel = NULL, if(meanstructure) { #if(conditional.x) { # Mu.hat <- computeMuHat(lavmodel = lavmodel, GLIST = GLIST) - #} else { + #} else { Mu.hat <- computeMuHat(lavmodel = lavmodel, GLIST = GLIST) #} - } + } if(categorical) { TH <- computeTH(lavmodel = lavmodel, GLIST = GLIST) @@ -99,20 +99,20 @@ lav_model_gradient <- function(lavmodel = NULL, # - PML/FML/MML: custom # 1. ML approach - if( (estimator == "ML" || estimator == "REML") && + if( (estimator == "ML" || estimator == "REML") && lavdata@nlevels == 1L && !lavmodel@conditional.x ) { if(meanstructure) { Omega <- computeOmega(Sigma.hat=Sigma.hat, Mu.hat=Mu.hat, - lavsamplestats=lavsamplestats, - estimator=estimator, - meanstructure=TRUE, + lavsamplestats=lavsamplestats, + estimator=estimator, + meanstructure=TRUE, conditional.x = conditional.x) Omega.mu <- attr(Omega, "mu") } else { Omega <- computeOmega(Sigma.hat=Sigma.hat, Mu.hat=NULL, - lavsamplestats=lavsamplestats, + lavsamplestats=lavsamplestats, estimator=estimator, meanstructure=FALSE, conditional.x = conditional.x) @@ -121,14 +121,14 @@ lav_model_gradient <- function(lavmodel = NULL, # compute DX (for all elements in every model matrix) DX <- vector("list", length=length(GLIST)) - + for(g in 1:lavmodel@nblocks) { # which mm belong to group g? mm.in.group <- 1:nmat[g] + cumsum(c(0,nmat))[g] mm.names <- names( GLIST[mm.in.group] ) if(representation == "LISREL") { - DX.group <- derivative.F.LISREL(GLIST[mm.in.group], + DX.group <- derivative.F.LISREL(GLIST[mm.in.group], Omega[[g]], Omega.mu[[g]]) @@ -139,7 +139,7 @@ lav_model_gradient <- function(lavmodel = NULL, } # only save what we need - DX[mm.in.group] <- DX.group[ mm.names ] + DX[mm.in.group] <- DX.group[ mm.names ] } else { stop("only representation LISREL has been implemented for now") } @@ -172,7 +172,7 @@ lav_model_gradient <- function(lavmodel = NULL, dx <- DX # handle equality constraints ### FIXME!!!! TODO!!!! - } + } } else # ML @@ -191,8 +191,8 @@ lav_model_gradient <- function(lavmodel = NULL, #diff <- as.matrix(lavsamplestats@WLS.obs[[g]] - WLS.est[[g]]) #group.dx <- -1 * ( t(Delta[[g]]) %*% lavsamplestats@WLS.V[[g]] %*% diff) # 0.5-17: use crossprod twice; treat DWLS/ULS special - if(estimator == "WLS" || - estimator == "GLS" || + if(estimator == "WLS" || + estimator == "GLS" || estimator == "NTRLS") { # full weight matrix diff <- lavsamplestats@WLS.obs[[g]] - WLS.est[[g]] @@ -200,7 +200,7 @@ lav_model_gradient <- function(lavmodel = NULL, # full weight matrix if(estimator == "GLS" || estimator == "WLS") { WLS.V <- lavsamplestats@WLS.V[[g]] - group.dx <- -1 * crossprod(Delta[[g]], + group.dx <- -1 * crossprod(Delta[[g]], crossprod(WLS.V, diff)) } else if(estimator == "NTRLS") { stopifnot(!conditional.x) @@ -237,7 +237,7 @@ lav_model_gradient <- function(lavmodel = NULL, group.dx <- as.numeric( -1 * crossprod(Delta[[g]], POST) ) } - } else + } else if(estimator == "DWLS" || estimator == "ULS") { # diagonal weight matrix @@ -258,9 +258,9 @@ lav_model_gradient <- function(lavmodel = NULL, # nothing to do } else { # make a GLIST - dx <- lav_model_x2GLIST(lavmodel = lavmodel, x = dx, + dx <- lav_model_x2GLIST(lavmodel = lavmodel, x = dx, type = "custom", setDelta = FALSE, - m.el.idx = m.el.idx, + m.el.idx = m.el.idx, x.el.idx = x.el.idx) } @@ -289,12 +289,12 @@ lav_model_gradient <- function(lavmodel = NULL, Sigma.inv <- attr(Sigma, "inv") nvar <- NROW(Sigma) S <- lavsamplestats@res.cov[[g]] - + # beta OBS <- t( cbind(lavsamplestats@res.int[[g]], lavsamplestats@res.slopes[[g]]) ) EST <- t( cbind(Mu.g, PI.g) ) - #obs.beta <- c(lavsamplestats@res.int[[g]], + #obs.beta <- c(lavsamplestats@res.int[[g]], # lav_matrix_vec(lavsamplestats@res.slopes[[g]])) #est.beta <- c(Mu.g, lav_matrix_vec(PI.g)) #beta.COV <- C3 %x% Sigma.inv @@ -311,10 +311,10 @@ lav_model_gradient <- function(lavmodel = NULL, #POST.beta <- 2 * beta.COV %*% (obs.beta - est.beta) d.BETA <- C3 %*% (OBS - EST) %*% Sigma.inv # NOTE: the vecr here, unlike lav_mvreg_dlogl_beta - # this is because DELTA has used vec(t(BETA)), + # this is because DELTA has used vec(t(BETA)), # instead of vec(BETA) #POST.beta <- 2 * lav_matrix_vecr(d.BETA) - # NOT any longer, since 0.6-1!!! + # NOT any longer, since 0.6-1!!! POST.beta <- 2 * lav_matrix_vec(d.BETA) #POST.sigma1 <- lav_matrix_duplication_pre( @@ -322,7 +322,7 @@ lav_model_gradient <- function(lavmodel = NULL, # Sigma #POST.sigma2 <- lav_matrix_duplication_pre( - # matrix( lav_matrix_vec( + # matrix( lav_matrix_vec( # Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)), ncol = 1L)) W.tilde <- S + t(OBS - EST) %*% C3 %*% (OBS - EST) d.SIGMA <- (Sigma.inv - Sigma.inv %*% W.tilde %*% Sigma.inv) @@ -350,9 +350,9 @@ lav_model_gradient <- function(lavmodel = NULL, # nothing to do } else { # make a GLIST - dx <- lav_model_x2GLIST(lavmodel = lavmodel, x = dx, + dx <- lav_model_x2GLIST(lavmodel = lavmodel, x = dx, type = "custom", setDelta = FALSE, - m.el.idx = m.el.idx, + m.el.idx = m.el.idx, x.el.idx = x.el.idx) } } # ML + conditional.x @@ -391,7 +391,7 @@ lav_model_gradient <- function(lavmodel = NULL, #cat("dx1 (numerical) = \n"); print( zapsmall(dx1) ) #cat("dx (analytic) = \n"); print( zapsmall(dx ) ) - + } # ML + two-level else if(estimator == "PML" || estimator == "FML" || @@ -411,7 +411,7 @@ lav_model_gradient <- function(lavmodel = NULL, #print(TH[[g]]) #cat("*****\n") - # compute partial derivative of logLik with respect to + # compute partial derivative of logLik with respect to # thresholds/means, slopes, variances, correlations if(estimator == "PML") { @@ -442,7 +442,7 @@ lav_model_gradient <- function(lavmodel = NULL, } # not conditional.x # chain rule (fmin) - group.dx <- + group.dx <- as.numeric(t(d1) %*% Delta[[g]]) } # PML @@ -456,11 +456,11 @@ lav_model_gradient <- function(lavmodel = NULL, lavcache = lavcache[[g]]) # chain rule (fmin) - group.dx <- + group.dx <- as.numeric(t(d1) %*% Delta[[g]])/lavsamplestats@nobs[[g]] } else if(estimator == "MML") { - group.dx <- + group.dx <- lav_model_gradient_mml(lavmodel = lavmodel, GLIST = GLIST, THETA = THETA[[g]], @@ -487,7 +487,7 @@ lav_model_gradient <- function(lavmodel = NULL, # group.w.free for ML - if(lavmodel@group.w.free && + if(lavmodel@group.w.free && estimator %in% c("ML","MML","FML","PML","REML")) { #est.prop <- unlist( computeGW(lavmodel = lavmodel, GLIST = GLIST) ) #obs.prop <- unlist(lavsamplestats@group.w) @@ -503,7 +503,7 @@ lav_model_gradient <- function(lavmodel = NULL, # remove last element (fixed LAST group to zero) # dx.GW <- dx.GW[-length(dx.GW)] - + # fill in in dx gw.mat.idx <- which(names(lavmodel@GLIST) == "gw") gw.x.idx <- unlist( lavmodel@x.free.idx[gw.mat.idx] ) @@ -523,7 +523,7 @@ lav_model_gradient <- function(lavmodel = NULL, # # # state or final? # if(is.null(GLIST)) GLIST <- lavmodel@GLIST -# +# # compute.moments <- function(x) { # GLIST <- lav_model_x2GLIST(lavmodel = NULL, x=x, type="free") # Sigma.hat <- computeSigmaHat(lavmodel = NULL, GLIST = GLIST) @@ -531,7 +531,7 @@ lav_model_gradient <- function(lavmodel = NULL, # if(lavmodel@meanstructure) { # Mu.hat <- computeMuHat(lavmodel = NULL, GLIST=GLIST) # out <- c(Mu.hat[[g]], S.vec) -# } else { +# } else { # out <- S.vec # } # out @@ -547,7 +547,7 @@ lav_model_gradient <- function(lavmodel = NULL, ### FIXME: should we here also: ### - weight for groups? (no, for now) ### - handle equality constraints? (yes, for now) -computeDelta <- function(lavmodel = NULL, GLIST. = NULL, +computeDelta <- function(lavmodel = NULL, GLIST. = NULL, m.el.idx. = NULL, x.el.idx. = NULL) { representation <- lavmodel@representation @@ -574,7 +574,7 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, # type = "free" or something else? type <- "nonfree" m.el.idx <- m.el.idx.; x.el.idx <- x.el.idx. - if(is.null(m.el.idx) && is.null(x.el.idx)) + if(is.null(m.el.idx) && is.null(x.el.idx)) type <- "free" # number of rows in DELTA.group @@ -617,12 +617,12 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, m.el.idx[[mm]] <- m.el.idx[[mm]][!dix] x.el.idx[[mm]] <- x.el.idx[[mm]][!dix] } - } + } } } else { ## FIXME: this does *not* take into account symmetric ## matrices; hence NCOL will be too large, and empty - ## columns will be added + ## columns will be added ## this is ugly, but it doesn't hurt ## alternative could be: ## NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x))))) @@ -642,7 +642,7 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, # which mm belong to group g? mm.in.group <- 1:nmat[g] + cumsum(c(0,nmat))[g] - # label rows of Delta.group --- FIXME!!! + # label rows of Delta.group --- FIXME!!! #if(categorical) { # # 1. th (means interleaved?) # # 2. pi @@ -656,7 +656,7 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, # if theta, do some preparation if(parameterization == "theta") { - sigma.hat <- computeSigmaHat.LISREL(MLIST=GLIST[mm.in.group], + sigma.hat <- computeSigmaHat.LISREL(MLIST=GLIST[mm.in.group], delta=FALSE) dsigma <- diag(sigma.hat) # dcor/dcov for sigma @@ -682,17 +682,17 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, if(categorical && parameterization == "theta") { DELTA <- R %*% DELTA } - + if(categorical) { # reorder: first variances (of numeric), then covariances cov.idx <- lav_matrix_vech_idx(nvar[g]) covd.idx <- lav_matrix_vech_idx(nvar[g], diagonal = FALSE) - var.idx <- which(is.na(match(cov.idx, + var.idx <- which(is.na(match(cov.idx, covd.idx)))[num.idx[[g]]] cor.idx <- match(covd.idx, cov.idx) - - DELTA <- rbind(DELTA[var.idx,,drop=FALSE], + + DELTA <- rbind(DELTA[var.idx,,drop=FALSE], DELTA[cor.idx,,drop=FALSE]) } @@ -724,7 +724,7 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, idx=m.el.idx[[mm]], MLIST=GLIST[ mm.in.group ]) DELTA <- rbind(DELTA.mu, DELTA) } - } + } else if(categorical) { DELTA.th <- derivative.th.LISREL(m=mname, @@ -734,22 +734,22 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, delta = TRUE) if(parameterization == "theta") { # dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma)) - dDelta.dx <- - ( dxSigma[theta.var.idx,,drop=FALSE] * + dDelta.dx <- + ( dxSigma[theta.var.idx,,drop=FALSE] * -0.5 / (dsigma*sqrt(dsigma)) ) - dth.dDelta <- + dth.dDelta <- derivative.th.LISREL(m = "delta", idx = 1:nvar[g], MLIST = GLIST[ mm.in.group ], th.idx = th.idx[[g]]) # add dth.dDelta %*% dDelta.dx no.num.idx <- which(th.idx[[g]] > 0) - DELTA.th[no.num.idx,] <- + DELTA.th[no.num.idx,] <- DELTA.th[no.num.idx,,drop=FALSE] + (dth.dDelta %*% dDelta.dx)[no.num.idx,,drop=FALSE] } if(conditional.x && lavmodel@nexo[g] > 0L) { - DELTA.pi <- + DELTA.pi <- derivative.pi.LISREL(m=mname, idx=m.el.idx[[mm]], MLIST=GLIST[ mm.in.group ]) @@ -759,11 +759,11 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, idx = 1:nvar[g], MLIST = GLIST[ mm.in.group ]) # add dpi.dDelta %*% dDelta.dx - no.num.idx <- + no.num.idx <- which(!seq.int(1L,nvar[g]) %in% num.idx[[g]]) no.num.idx <- rep(seq.int(0,nexo[g]-1) * nvar[g], each=length(no.num.idx)) + no.num.idx - DELTA.pi[no.num.idx,] <- + DELTA.pi[no.num.idx,] <- DELTA.pi[no.num.idx,,drop=FALSE] + (dpi.dDelta %*% dDelta.dx)[no.num.idx,,drop=FALSE] } @@ -791,7 +791,7 @@ computeDelta <- function(lavmodel = NULL, GLIST. = NULL, #if(type == "free" && lavmodel@eq.constraints) { # Delta.group <- Delta.group %*% lavmodel@eq.constraints.K #} - + #Delta.eq <- Delta.group # save(Delta.eq, file=paste0("delta_NO_EQ",g,".Rdata")) @@ -876,7 +876,7 @@ computeDeltaDx <- function(lavmodel = NULL, GLIST = NULL, target = "lambda") { DELTA <- derivative.tau.LISREL(m=mname, idx=m.el.idx[[mm]], MLIST=GLIST[ mm.in.group ]) } else if(target == "theta") { - DELTA <- derivative.theta.LISREL(m=mname, + DELTA <- derivative.theta.LISREL(m=mname, idx=m.el.idx[[mm]], MLIST=GLIST[ mm.in.group ]) } else if(target == "gamma") { DELTA <- derivative.gamma.LISREL(m=mname, @@ -916,8 +916,8 @@ computeDeltaDx <- function(lavmodel = NULL, GLIST = NULL, target = "lambda") { Delta } -computeOmega <- function(Sigma.hat=NULL, Mu.hat=NULL, - lavsamplestats=NULL, estimator="ML", +computeOmega <- function(Sigma.hat=NULL, Mu.hat=NULL, + lavsamplestats=NULL, estimator="ML", meanstructure=FALSE, conditional.x = FALSE) { # nblocks @@ -953,7 +953,7 @@ computeOmega <- function(Sigma.hat=NULL, Mu.hat=NULL, } # Browne 1995 eq 4.55 Omega.mu[[g]] <- t(t(diff) %*% Sigma.hat.inv) - Omega[[g]] <- + Omega[[g]] <- ( Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*% Sigma.hat.inv ) } else { @@ -962,7 +962,7 @@ computeOmega <- function(Sigma.hat=NULL, Mu.hat=NULL, } else { W.tilde <- lavsamplestats@cov[[g]] } - Omega[[g]] <- + Omega[[g]] <- ( Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*% Sigma.hat.inv ) } @@ -1044,7 +1044,7 @@ lav_model_gradient_DD <- function(lavmodel, GLIST = NULL, group = 1L) { # fix Delta's... mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0,lavmodel@nmat))[group] MLIST <- GLIST[ mm.in.group ] - + DD <- list() nvar <- lavmodel@nvar nfac <- ncol(MLIST$lambda) - length(lv.dummy.idx) @@ -1077,7 +1077,7 @@ lav_model_gradient_DD <- function(lavmodel, GLIST = NULL, group = 1L) { beta.idx <- rep(nr*((1:nc) - 1L), times=length(lv.dummy.idx)) + rep(lv.dummy.idx, each=nc) #l.idx <- inr*((1:nc) - 1L) + rep(ov.dummy.idx, each=nc) ## FIXME - # l.idx <- rep(nr*((1:nc) - 1L), each=length(ov.dummy.idx)) + rep(ov.dummy.idx, times=nc) + # l.idx <- rep(nr*((1:nc) - 1L), each=length(ov.dummy.idx)) + rep(ov.dummy.idx, times=nc) l.idx <- rep(nr*((1:nc) - 1L), times=length(ov.dummy.idx)) + rep(ov.dummy.idx, each=nc) DD$lambda[match(l.idx, lambda.idx),] <- Delta.beta[beta.idx,,drop=FALSE] } @@ -1104,7 +1104,7 @@ lav_model_gradient_DD <- function(lavmodel, GLIST = NULL, group = 1L) { nr <- nc <- nrow(MLIST$beta) lv.idx <- 1:nfac # MUST BE ROWWISE! - beta.idx <- rep(nr*((1:nfac) - 1L), times=nfac) + rep(lv.idx, each=nfac) + beta.idx <- rep(nr*((1:nfac) - 1L), times=nfac) + rep(lv.idx, each=nfac) DD$beta <- Delta.beta[beta.idx,,drop=FALSE] } diff --git a/R/lav_model_gradient_mml.R b/R/lav_model_gradient_mml.R index 1c5e259b..a69b5360 100644 --- a/R/lav_model_gradient_mml.R +++ b/R/lav_model_gradient_mml.R @@ -8,7 +8,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, sample.mean.x = NULL, lavcache = NULL) { - if(lavmodel@link == "logit") + if(lavmodel@link == "logit") stop("logit link not implemented yet; use probit") # shortcut @@ -117,7 +117,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, tmp[cbind(i, i)] <- 1 IB.inv <- solve(tmp) } - + # fix GAMMA GAMMA <- MLIST$gamma if(is.null(GAMMA)) { @@ -198,7 +198,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, TH = TH, THETA = THETA, num.idx = num.idx, th.idx = th.idx, link = lavmodel@link, log. = TRUE) - + # if log, fy is just the sum of log.fy.var log.fy <- apply(log.fy.var, 1L, sum) @@ -216,7 +216,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, PRE <- matrix(0, nobs, nvar) if(length(num.idx) > 0L) { tmp <- X[,num.idx,drop=FALSE] - yhat[,num.idx,drop=FALSE] - theta.var <- diag(THETA)[num.idx] + theta.var <- diag(THETA)[num.idx] PRE[,num.idx] <- sweep(tmp, MARGIN=2, STATS=1/theta.var, FUN="*") } @@ -246,10 +246,10 @@ lav_model_gradient_mml <- function(lavmodel = NULL, (dth %*% DD$tau[which(th.idx==p),,drop=FALSE]) } } - + if(length(num.idx) > 0L) { # THETA (num only) - dsigma2 <- sweep(0.5*PRE[,num.idx]*PRE[,num.idx], MARGIN=2, + dsigma2 <- sweep(0.5*PRE[,num.idx]*PRE[,num.idx], MARGIN=2, STATS=1/(2*theta.var), FUN="-") dFYp.q <- dFYp.q + (dsigma2 %*% DD$theta) @@ -267,7 +267,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, #dlambda <- sweep(PRE, MARGIN=1, STATS=eta, FUN="*") } dFYp.q <- dFYp.q + (dlambda %*% DD$lambda) - + # PSI #if(nrow(ksi) == 1L) { dpsi <- PRE %*% kronecker(LAMBDA[,,drop=FALSE], ksi) @@ -313,7 +313,7 @@ lav_model_gradient_mml <- function(lavmodel = NULL, dFYp <- 1/lik * dFYp dx <- apply(dFYp, 2, sum) - + # integration #dx <- apply(as.numeric(GH$w) * dLdx, 2, sum) diff --git a/R/lav_model_gradient_pml.R b/R/lav_model_gradient_pml.R index 04ca4958..565a2857 100644 --- a/R/lav_model_gradient_pml.R +++ b/R/lav_model_gradient_pml.R @@ -9,8 +9,8 @@ fml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor eXo = NULL, # external covariates lavcache = NULL, # housekeeping stuff scores = FALSE, # return case-wise scores - negative = TRUE) { - stop("not implemented") + negative = TRUE) { + stop("not implemented") } # the first derivative of the pairwise logLik function with respect to the @@ -97,7 +97,7 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor var.idx <- unlist( lapply(var.idx, function(x){c(x,x[1])}) ) tmp.varwise <- split(tmp, var.idx) - tmp1 <- unlist( lapply(tmp.varwise, + tmp1 <- unlist( lapply(tmp.varwise, function(x){ c(x[-length(x)]) } ) ) tmp2 <- unlist( lapply(tmp.varwise, function(x){ c(x[-1]) } ) ) @@ -117,7 +117,7 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor # scores or gradient? if(scores) { - SCORES <- matrix(0, nrow(X), GRAD.size) # we will sum up over all pairs + SCORES <- matrix(0, nrow(X), GRAD.size) # we will sum up over all pairs } else { GRAD <- matrix(0, pstar, GRAD.size) # each pair is a row } @@ -160,12 +160,12 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor # MU1 + MU2 SCORES[, c(i,j)] <- SCORES[, c(i,j)] + SC[, c(1,2)] # VAR1 + COV_12 + VAR2 - var.idx <- ( nvar + + var.idx <- ( nvar + lav_matrix_vech_match_idx(nvar, idx = c(i,j)) ) SCORES[, var.idx] <- SCORES[, var.idx] + SC[, c(3,4,5)] } else { # mixed ordered/continuous # MU - mu.idx <- c(th.idx_i, th.idx_j) + mu.idx <- c(th.idx_i, th.idx_j) SCORES[, mu.idx] <- SCORES[, mu.idx] + (-1)*SC[, c(1,2)] # VAR+COV var.idx <- c(var.idx_i, cor.idx, var.idx_j) @@ -209,7 +209,7 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor if(scores) { - # MU + # MU SCORES[, th.idx_i] <- ( SCORES[, th.idx_i] + -1 * SC.COR.UNI$dx.mu.y1 ) # TH @@ -224,17 +224,17 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor } else { - # MU - GRAD[pstar.idx, th.idx_i] <- + # MU + GRAD[pstar.idx, th.idx_i] <- -1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE) # TH GRAD[pstar.idx, th.idx_j] <- colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE) # VAR - GRAD[pstar.idx, var.idx_i] <- + GRAD[pstar.idx, var.idx_i] <- sum(SC.COR.UNI$dx.var.y1, na.rm = TRUE) # COR - GRAD[pstar.idx, cor.idx] <- + GRAD[pstar.idx, cor.idx] <- sum(SC.COR.UNI$dx.rho, na.rm = TRUE) } # grad only @@ -254,7 +254,7 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor if(scores) { - # MU + # MU SCORES[, th.idx_j] <- ( SCORES[, th.idx_j] + -1 * SC.COR.UNI$dx.mu.y1 ) # TH @@ -269,7 +269,7 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor } else { - # MU + # MU GRAD[pstar.idx, th.idx_j] <- -1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE) # TH @@ -325,49 +325,49 @@ pml_deriv1 <- function(Sigma.hat = NULL, # model-based var/cov/cor # NO VAR # RHO SCORES[,cor.idx] <- SCORES[,cor.idx] + SC.COR.UNI$dx.rho - + } else { # TH if(length(th.idx_i) > 1L) { - GRAD[pstar.idx, th.idx_i] <- + GRAD[pstar.idx, th.idx_i] <- colSums(SC.COR.UNI$dx.th.y1, na.rm = TRUE) } else { - GRAD[pstar.idx, th.idx_i] <- + GRAD[pstar.idx, th.idx_i] <- sum(SC.COR.UNI$dx.th.y1, na.rm = TRUE) } if(length(th.idx_j) > 1L) { - GRAD[pstar.idx, th.idx_j] <- + GRAD[pstar.idx, th.idx_j] <- colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE) } else { - GRAD[pstar.idx, th.idx_j] <- + GRAD[pstar.idx, th.idx_j] <- sum(SC.COR.UNI$dx.th.y2, na.rm = TRUE) } - + # SL if(nexo > 0L) { if(length(sl.idx_i) > 1L) { - GRAD[pstar.idx, sl.idx_i] <- + GRAD[pstar.idx, sl.idx_i] <- colSums(SC.COR.UNI$dx.sl.y1, na.rm = TRUE) } else { - GRAD[pstar.idx, sl.idx_i] <- + GRAD[pstar.idx, sl.idx_i] <- sum(SC.COR.UNI$dx.sl.y1, na.rm = TRUE) } if(length(sl.idx_j) > 1L) { - GRAD[pstar.idx, sl.idx_j] <- + GRAD[pstar.idx, sl.idx_j] <- colSums(SC.COR.UNI$dx.sl.y2, na.rm = TRUE) } else { - GRAD[pstar.idx, sl.idx_j] <- + GRAD[pstar.idx, sl.idx_j] <- sum(SC.COR.UNI$dx.sl.y2, na.rm = TRUE) } } # NO VAR # RHO - GRAD[pstar.idx, cor.idx] <- + GRAD[pstar.idx, cor.idx] <- sum(SC.COR.UNI$dx.rho, na.rm = TRUE) } - #GRAD2 <- numDeriv::grad(func = pc_logl_x, + #GRAD2 <- numDeriv::grad(func = pc_logl_x, # x = c(Sigma.hat[i,j], # TH[ th.idx == i ], # TH[ th.idx == j]), @@ -522,16 +522,16 @@ grad_tau_rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj, # in all.thres belongs to, it is of the form (1,1,1..., 2,2,2,..., p,p,p,...) # The output of the function: -# it is a list of vectors keeping track of the indices +# it is a list of vectors keeping track of the indices # of thresholds, of variables, and of pairs, and two T/F vectors indicating # if the threshold index corresponds to the last threshold of a variable; all # these for all pairs of variables. All are needed for the # computation of expected probabilities, der.L.to.rho, and der.L.to.tau # all duplications of indices are done as follows: within each pair of variables, -# xi-xj, if for example we want to duplicate the indices of the thresholds, -# tau^xi_a and tau^xj_b, then index a runs faster than b, i.e. for each b we -# take all different tau^xi's, and then we proceed to the next b and do the +# xi-xj, if for example we want to duplicate the indices of the thresholds, +# tau^xi_a and tau^xj_b, then index a runs faster than b, i.e. for each b we +# take all different tau^xi's, and then we proceed to the next b and do the # same. In other words if it was tabulated we fill the table columnwise. # All pairs xi-xj are taken with index j running faster than i. @@ -762,7 +762,7 @@ LongVecTH.Rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj) { # The function pairwiseExpProbVec # input: ind.vec - the output of function LongVecInd -# th.rho.vec - the output of function LongVecTH.Rho +# th.rho.vec - the output of function LongVecTH.Rho # output: it gives the elements of pairwiseTablesExpected()$pi.tables # table-wise and column-wise within each table. In other words if # pi^xixj_ab is the expected probability for the pair of variables xi-xj @@ -818,7 +818,7 @@ pairwiseExpProbVec <- function(ind.vec, th.rho.vec) { # derLtoRho # input: ind.vec - the output of function LongVecInd -# th.rho.vec - the output of function LongVecTH.Rho +# th.rho.vec - the output of function LongVecTH.Rho # n.xixj - a vector with the observed frequency for every combination # of categories and every pair. The frequencies are given in # the same order as the expected probabilities in the output of @@ -868,7 +868,7 @@ derLtoRho <- function(ind.vec, th.rho.vec, n.xixj, pi.xixj, no.x) { # derLtoTau # input: ind.vec - the output of function LongVecInd -# th.rho.vec - the output of function LongVecTH.Rho +# th.rho.vec - the output of function LongVecTH.Rho # n.xixj - a vector with the observed frequency for every combination # of categories and every pair. The frequencies are given in # the same order as the expected probabilities in the output of diff --git a/R/lav_model_h1_information.R b/R/lav_model_h1_information.R index 4f1932ec..3c0d51c0 100644 --- a/R/lav_model_h1_information.R +++ b/R/lav_model_h1_information.R @@ -143,7 +143,7 @@ lav_model_h1_information_expected <- function(lavobject = NULL, } if(structured) { - A1[[g]] <- + A1[[g]] <- lav_mvnorm_missing_information_expected( Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]], @@ -301,7 +301,7 @@ lav_model_h1_information_observed <- function(lavobject = NULL, } else { structured <- TRUE } - + # 1. WLS.V (=A1) for GLS/WLS if(lavmodel@estimator == "GLS" || lavmodel@estimator == "WLS") { A1 <- lavsamplestats@WLS.V @@ -316,7 +316,7 @@ lav_model_h1_information_observed <- function(lavobject = NULL, # 3a. ML single level else if(lavmodel@estimator == "ML" && lavdata@nlevels == 1L) { A1 <- vector("list", length=lavsamplestats@ngroups) - + # structured? compute model-implied statistics if(structured && length(lavimplied) == 0L) { lavimplied <- lav_model_implied(lavmodel) @@ -337,7 +337,7 @@ lav_model_h1_information_observed <- function(lavobject = NULL, } if(structured) { - A1[[g]] <- + A1[[g]] <- lav_mvnorm_missing_information_observed_samplestats( Yp = lavsamplestats@missing[[g]], #wt = WT, ? @@ -593,7 +593,7 @@ lav_model_h1_information_firstorder <- function(lavobject = NULL, } else { MEAN <- lavsamplestats@missing.h1[[g]]$mu } - + B1[[g]] <- lav_mvnorm_missing_information_firstorder( Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]], wt = WT, diff --git a/R/lav_model_hessian.R b/R/lav_model_hessian.R index ee0f8658..906998c2 100644 --- a/R/lav_model_hessian.R +++ b/R/lav_model_hessian.R @@ -18,45 +18,45 @@ lav_model_hessian <- function(lavmodel = NULL, x.left[j] <- x[j] - h.j; x.left2[j] <- x[j] - 2*h.j x.right[j] <- x[j] + h.j; x.right2[j] <- x[j] + 2*h.j - g.left <- - lav_model_gradient(lavmodel = lavmodel, - GLIST = lav_model_x2GLIST(lavmodel = - lavmodel, x.left), - lavsamplestats = lavsamplestats, - lavdata = lavdata, + g.left <- + lav_model_gradient(lavmodel = lavmodel, + GLIST = lav_model_x2GLIST(lavmodel = + lavmodel, x.left), + lavsamplestats = lavsamplestats, + lavdata = lavdata, lavcache = lavcache, - type = "free", + type = "free", group.weight = group.weight) - g.left2 <- + g.left2 <- lav_model_gradient(lavmodel = lavmodel, GLIST = lav_model_x2GLIST(lavmodel = lavmodel, x.left2), - lavsamplestats = lavsamplestats, - lavdata = lavdata, + lavsamplestats = lavsamplestats, + lavdata = lavdata, lavcache = lavcache, - type = "free", + type = "free", group.weight = group.weight) - g.right <- + g.right <- lav_model_gradient(lavmodel = lavmodel, GLIST = lav_model_x2GLIST(lavmodel = lavmodel, x.right), - lavsamplestats = lavsamplestats, - lavdata = lavdata, + lavsamplestats = lavsamplestats, + lavdata = lavdata, lavcache = lavcache, - type = "free", + type = "free", group.weight = group.weight) - g.right2 <- + g.right2 <- lav_model_gradient(lavmodel = lavmodel, GLIST = lav_model_x2GLIST(lavmodel = lavmodel, x.right2), - lavsamplestats = lavsamplestats, - lavdata = lavdata, + lavsamplestats = lavsamplestats, + lavdata = lavdata, lavcache = lavcache, - type = "free", + type = "free", group.weight = group.weight) - + Hessian[,j] <- (g.left2 - 8*g.left + 8*g.right - g.right2)/(12*h.j) } diff --git a/R/lav_model_implied.R b/R/lav_model_implied.R index 8a1fe9e0..72a93012 100644 --- a/R/lav_model_implied.R +++ b/R/lav_model_implied.R @@ -26,7 +26,7 @@ lav_model_implied <- function(lavmodel = NULL, GLIST = NULL) { } else { TH <- vector("list", length = lavmodel@nblocks) } - + if(lavmodel@group.w.free) { w.idx <- which(names(lavmodel@GLIST) == "gw") GW <- unname(GLIST[ w.idx ]) diff --git a/R/lav_model_information.R b/R/lav_model_information.R index 8889e3aa..ba72f76e 100644 --- a/R/lav_model_information.R +++ b/R/lav_model_information.R @@ -1,7 +1,7 @@ # here, we compute various versions of the `information' matrix # NOTE: # 1) we ALWAYS compute the UNIT information (not the total information) -# +# # 2) by default, we ignore the constraints (we deal with this when we # take the inverse later on) @@ -48,7 +48,7 @@ lav_model_information <- function(lavmodel = NULL, E <- lav_model_information_expected(lavmodel = lavmodel, lavsamplestats = lavsamplestats, lavdata = lavdata, lavimplied = lavimplied, lavh1 = lavh1, - lavcache = lavcache, lavoptions = lavoptions, extra = extra, + lavcache = lavcache, lavoptions = lavoptions, extra = extra, augmented = augmented, inverted = inverted, use.ginv = use.ginv) } else if(information == "first.order") { E <- lav_model_information_firstorder(lavmodel = lavmodel, @@ -124,7 +124,7 @@ lav_model_information_expected <- function(lavmodel = NULL, } Lp <- lavdata@Lp[[g]] - Info.g <- + Info.g <- lav_mvnorm_cluster_information_expected_delta(Lp = Lp, Delta = Delta[[g]], Mu.W = Mu.W, @@ -141,7 +141,7 @@ lav_model_information_expected <- function(lavmodel = NULL, Info.group[[g]] <- fg * crossprod(Delta2) } else { # full weight matrix - Info.group[[g]] <- + Info.group[[g]] <- fg * ( crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]] ) } } @@ -157,7 +157,7 @@ lav_model_information_expected <- function(lavmodel = NULL, # 5. augmented information? if(augmented) { - Information <- + Information <- lav_model_information_augment_invert(lavmodel = lavmodel, information = Information, inverted = inverted, @@ -174,8 +174,8 @@ lav_model_information_expected <- function(lavmodel = NULL, } # only for Mplus MLM -lav_model_information_expected_MLM <- function(lavmodel = NULL, - lavsamplestats = NULL, +lav_model_information_expected_MLM <- function(lavmodel = NULL, + lavsamplestats = NULL, Delta = NULL, extra = FALSE, augmented = FALSE, @@ -261,10 +261,10 @@ lav_model_information_observed <- function(lavmodel = NULL, # observed.information: # - "hessian": second derivative of objective function - # - "h1": observed information matrix of saturated (h1) model, + # - "h1": observed information matrix of saturated (h1) model, # pre- and post-multiplied by the jacobian of the model # parameters (Delta), usually evaluated at the structured - # sample statistics (but this depends on the h1.information + # sample statistics (but this depends on the h1.information # option) if(!is.null(lavoptions) && !is.null(lavoptions$observed.information) && @@ -285,7 +285,7 @@ lav_model_information_observed <- function(lavmodel = NULL, # NOTE! What is the relationship between the Hessian of the objective # function, and the `information' matrix (unit or total) - + # 1. in lavaan, we ALWAYS minimize, so the Hessian is already pos def # 2. currently, all estimators give unit information, except MML and PML # so, no need to divide by N @@ -314,7 +314,7 @@ lav_model_information_observed <- function(lavmodel = NULL, Delta <- computeDelta(lavmodel = lavmodel) # 2. H1 information - + A1 <- lav_model_h1_information_observed(lavmodel = lavmodel, lavsamplestats = lavsamplestats, lavdata = lavdata, @@ -407,8 +407,8 @@ lav_model_information_firstorder <- function(lavmodel = NULL, for(g in 1:lavsamplestats@ngroups) { # unweighted (needed in lav_test?) - B0.group[[g]] <- t(Delta[[g]]) %*% B1[[g]] %*% Delta[[g]] - + B0.group[[g]] <- t(Delta[[g]]) %*% B1[[g]] %*% Delta[[g]] + fg <- lavsamplestats@nobs[[g]]/lavsamplestats@ntotal # compute information for this group Info.group[[g]] <- fg * B0.group[[g]] @@ -473,7 +473,7 @@ lav_model_information_augment_invert <- function(lavmodel = NULL, lambda <- lambda[-inactive.idx] } if(nrow(H) > 0L) { - is.augmented <- TRUE + is.augmented <- TRUE H0 <- matrix(0,nrow(H),nrow(H)) H10 <- matrix(0, ncol(information), nrow(H)) DL <- 2*diag(lambda, nrow(H), nrow(H)) @@ -481,12 +481,12 @@ lav_model_information_augment_invert <- function(lavmodel = NULL, E3 <- rbind( cbind( information, H10, t(H)), cbind( t(H10), DL, H0), cbind( H, H0, H0) ) - information <- E3 + information <- E3 } } if(check.pd) { - eigvals <- eigen(information, symmetric = TRUE, + eigvals <- eigen(information, symmetric = TRUE, only.values = TRUE)$values if(any(eigvals < -1 * .Machine$double.eps^(3/4))) { warning("lavaan WARNING: matrix based on first order outer product of the derivatives is not positive definite; the model may not be identified") @@ -498,10 +498,10 @@ lav_model_information_augment_invert <- function(lavmodel = NULL, # note: default tol in MASS::ginv is sqrt(.Machine$double.eps) # which seems a bit too conservative # from 0.5-20, we changed this to .Machine$double.eps^(3/4) - information <- - try( MASS::ginv(information, - tol = .Machine$double.eps^(3/4))[1:npar, - 1:npar, + information <- + try( MASS::ginv(information, + tol = .Machine$double.eps^(3/4))[1:npar, + 1:npar, drop = FALSE], silent = TRUE ) } else { @@ -531,10 +531,10 @@ lav_model_information_expected_2l <- function(lavmodel = NULL, # Delta.sigma.j' W.j Delta.sigma.j + # (nj-1) Delta.sigma.w' W.w Delta.sigma.w # - # where + # where # - sigma.j = sigma.w + n.j * sigma.b # - W.w = 1/2 * D'(sigma.w.inv %x% sigma.w.inv) D # - W.j = 1/2 * D'(sigma.j.inv %x% sigma.j.inv) D - - + + } diff --git a/R/lav_model_lik.R b/R/lav_model_lik.R index fc8d5dc6..2f93fbd4 100644 --- a/R/lav_model_lik.R +++ b/R/lav_model_lik.R @@ -51,7 +51,7 @@ lav_model_lik_mml <- function(lavmodel = NULL, # cholesky? #if(is.null(lavmodel@control$cholesky)) { - CHOLESKY <- TRUE + CHOLESKY <- TRUE #} else { # CHOLESKY <- as.logical(lavmodel@control$cholesky) #if(nfac > 1L && !CHOLESKY) { @@ -79,7 +79,7 @@ lav_model_lik_mml <- function(lavmodel = NULL, ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]) } else { - EETA <- computeEETA.LISREL(MLIST = MLIST, + EETA <- computeEETA.LISREL(MLIST = MLIST, mean.x = sample.mean.x, sample.mean = sample.mean, ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], @@ -99,11 +99,11 @@ lav_model_lik_mml <- function(lavmodel = NULL, # current value(s) for ETA #eta <- matrix(0, nrow = 1, ncol = ncol(MLIST$lambda)) - + # non-dummy elements -> quadrature points #eta[1L, -lv.dummy.idx] <- GH$x[q,,drop=FALSE] XQ <- GH$x[q,,drop=FALSE] - + # rescale/unwhiten if(CHOLESKY) { # un-orthogonalize @@ -149,7 +149,7 @@ lav_model_lik_mml <- function(lavmodel = NULL, ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]]) } - + # compute fy.var, for this node (eta): P(Y_i = y_i | eta_i, x_i) log.fy.var <- lav_predict_fy_internal(X = X, yhat = yhat, TH = TH, THETA = THETA, diff --git a/R/lav_model_loglik.R b/R/lav_model_loglik.R index 00ffd0ed..6e72ef2f 100644 --- a/R/lav_model_loglik.R +++ b/R/lav_model_loglik.R @@ -30,7 +30,7 @@ lav_model_loglik <- function(lavdata = NULL, logl.ok <- FALSE } } - + # lavsamplestats filled in? (not if no data...) if(length(lavsamplestats@ntotal) == 0L) { logl.ok <- FALSE @@ -123,7 +123,7 @@ lav_model_loglik <- function(lavdata = NULL, # BIC2 N.star <- (lavsamplestats@ntotal + 2) / 24 - BIC2 <- (-2 * logl) + (npar * log(N.star)) + BIC2 <- (-2 * logl) + (npar * log(N.star)) } else { AIC <- BIC <- BIC2 <- as.numeric(NA) } diff --git a/R/lav_model_objective.R b/R/lav_model_objective.R index 8f337f22..615cfd62 100644 --- a/R/lav_model_objective.R +++ b/R/lav_model_objective.R @@ -38,7 +38,7 @@ lav_model_objective <- function(lavmodel = NULL, Mu.hat <- computeMuHat(lavmodel = lavmodel, GLIST = GLIST) } if(debug) print(WLS.est) - } else if(estimator %in% c("ML", "PML", "FML", "REML") && + } else if(estimator %in% c("ML", "PML", "FML", "REML") && lavdata@nlevels == 1L) { # compute moments for all groups #if(conditional.x) { @@ -46,7 +46,7 @@ lav_model_objective <- function(lavmodel = NULL, # GLIST = GLIST, lavsamplestats = lavsamplestats, # extra = (estimator %in% c("ML", "REML","NTRLS"))) #} else { - Sigma.hat <- computeSigmaHat(lavmodel = lavmodel, GLIST = GLIST, + Sigma.hat <- computeSigmaHat(lavmodel = lavmodel, GLIST = GLIST, extra = (estimator %in% c("ML", "REML","NTRLS"))) #} @@ -57,7 +57,7 @@ lav_model_objective <- function(lavmodel = NULL, # ridge? if( lavsamplestats@ridge > 0.0 ) { for(g in 1:lavsamplestats@ngroups) { - diag(Sigma.hat[[g]]) <- diag(Sigma.hat[[g]]) + + diag(Sigma.hat[[g]]) <- diag(Sigma.hat[[g]]) + lavsamplestats@ridge } } @@ -88,7 +88,7 @@ lav_model_objective <- function(lavmodel = NULL, THETA <- computeTHETA(lavmodel = lavmodel, GLIST = GLIST) GW <- computeGW( lavmodel = lavmodel, GLIST = GLIST) } - + fx <- 0.0 fx.group <- numeric( lavsamplestats@ngroups ) logl.group <- rep(as.numeric(NA), lavsamplestats@ngroups) @@ -112,7 +112,7 @@ lav_model_objective <- function(lavmodel = NULL, # group = g) group.fx <- 0 } else { - stop("this estimator: `", estimator, + stop("this estimator: `", estimator, "' can not be used with incomplete data and the missing=\"ml\" option") } } else if(estimator == "ML" || estimator == "Bayes") { @@ -137,15 +137,15 @@ lav_model_objective <- function(lavmodel = NULL, mean.x = lavsamplestats@mean.x[[g]]) } else { group.fx <- estimator.ML( - Sigma.hat = Sigma.hat[[g]], + Sigma.hat = Sigma.hat[[g]], Mu.hat = Mu.hat[[g]], - data.cov = lavsamplestats@cov[[g]], - data.mean = lavsamplestats@mean[[g]], + data.cov = lavsamplestats@cov[[g]], + data.mean = lavsamplestats@mean[[g]], data.cov.log.det = lavsamplestats@cov.log.det[[g]], meanstructure = meanstructure) } - } else if(estimator == "GLS" || - estimator == "WLS" || + } else if(estimator == "GLS" || + estimator == "WLS" || estimator == "NTRLS") { # full weight matrix if(estimator == "GLS" || estimator == "WLS") { @@ -176,7 +176,7 @@ lav_model_objective <- function(lavmodel = NULL, } else if(estimator == "DWLS" || estimator == "ULS") { # diagonal weight matrix group.fx <- estimator.DWLS(WLS.est = WLS.est[[g]], - WLS.obs = lavsamplestats@WLS.obs[[g]], + WLS.obs = lavsamplestats@WLS.obs[[g]], WLS.VD = lavsamplestats@WLS.VD[[g]]) attr(group.fx, "WLS.est") <- WLS.est[[g]] @@ -187,7 +187,7 @@ lav_model_objective <- function(lavmodel = NULL, # GLIST = GLIST, # Lp = lavdata@Lp[[g]], # lavsamplestats = lavsamplestats, - # group = g) + # group = g) group.fx <- 0 # for now attr(group.fx, "logl") <- 0 } else if(conditional.x) { @@ -214,7 +214,7 @@ lav_model_objective <- function(lavmodel = NULL, missing = lavdata@missing) } logl.group[g] <- attr(group.fx, "logl") - } else if(estimator == "FML") { + } else if(estimator == "FML") { # Full maximum likelihood (underlying multivariate normal) group.fx <- estimator.FML(Sigma.hat = Sigma.hat[[g]], TH = TH[[g]], @@ -223,7 +223,7 @@ lav_model_objective <- function(lavmodel = NULL, X = lavdata@X[[g]], lavcache = lavcache[[g]]) - } else if(estimator == "MML") { + } else if(estimator == "MML") { # marginal maximum likelihood group.fx <- estimator.MML(lavmodel= lavmodel, GLIST = GLIST, @@ -254,7 +254,7 @@ lav_model_objective <- function(lavmodel = NULL, if(lavdata@nlevels == 1L) { group.fx <- 0.5 * group.fx ## FIXME } - } else if(estimator == "PML" || estimator == "FML" || + } else if(estimator == "PML" || estimator == "FML" || estimator == "MML") { # do nothing } else { @@ -297,7 +297,7 @@ lav_model_objective <- function(lavmodel = NULL, # # deriv is here -2 * (obs.prop - est.prop) #fx.w <- sum(obs.prop * log(obs.prop/est.prop) ) # } - + # poisson kernel obs.freq <- unlist(lavsamplestats@group.w) * lavsamplestats@ntotal est.freq <- exp(unlist(GW)) diff --git a/R/lav_model_utils.R b/R/lav_model_utils.R index 2ddf1697..7a368a17 100644 --- a/R/lav_model_utils.R +++ b/R/lav_model_utils.R @@ -3,7 +3,7 @@ # initial version: YR 25/03/2009: `methods' for the Model class # - YR 14 Jan 2014: rename object -> lavmodel, all functions as lav_model_* -lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL, +lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL, type = "free", extra = TRUE) { # type == "free": only non-redundant free parameters (x) @@ -25,7 +25,7 @@ lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL, if(type == "free") { m.idx <- lavmodel@m.free.idx[[mm]] x.idx <- lavmodel@x.free.idx[[mm]] - #} else if(type == "unco") { + #} else if(type == "unco") { # m.idx <- lavmodel@m.unco.idx[[mm]] # x.idx <- lavmodel@x.unco.idx[[mm]] } else if(type == "user") { @@ -36,10 +36,10 @@ lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL, } if(type == "user" && extra && sum(lavmodel@x.def.idx, - lavmodel@x.ceq.idx, + lavmodel@x.ceq.idx, lavmodel@x.cin.idx) > 0L) { # we need 'free' x - x.free <- lav_model_get_parameters(lavmodel = lavmodel, GLIST = GLIST, + x.free <- lav_model_get_parameters(lavmodel = lavmodel, GLIST = GLIST, type = "free") if(length(lavmodel@x.def.idx) > 0L) { x[lavmodel@x.def.idx] <- lavmodel@def.function(x.free) @@ -75,7 +75,7 @@ lav_model_set_parameters <- function(lavmodel = NULL, x = NULL) { if(lavmodel@estimator %in% c("WLS","DWLS","ULS","PML")) { if(lavmodel@parameterization == "delta") { - tmp[mm.in.group] <- + tmp[mm.in.group] <- setResidualElements.LISREL(MLIST = tmp[mm.in.group], num.idx = lavmodel@num.idx[[g]], ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], @@ -106,7 +106,7 @@ lav_model_set_parameters <- function(lavmodel = NULL, x = NULL) { # create a standalone GLIST, filled with (new) x values # (avoiding a copy of lavmodel) -lav_model_x2GLIST <- function(lavmodel = NULL, x = NULL, +lav_model_x2GLIST <- function(lavmodel = NULL, x = NULL, type = "free", setDelta = TRUE, m.el.idx = NULL, x.el.idx = NULL) { @@ -144,7 +144,7 @@ lav_model_x2GLIST <- function(lavmodel = NULL, x = NULL, } # theta parameterization: delta must be reset! - if(lavmodel@categorical && setDelta && + if(lavmodel@categorical && setDelta && lavmodel@parameterization == "theta") { nmat <- lavmodel@nmat for(g in 1:lavmodel@nblocks) { diff --git a/R/lav_model_vcov.R b/R/lav_model_vcov.R index 12850d86..c5b0d58a 100644 --- a/R/lav_model_vcov.R +++ b/R/lav_model_vcov.R @@ -1,11 +1,11 @@ # bootstrap based NVCOV -lav_model_nvcov_bootstrap <- function(lavmodel = NULL, - lavsamplestats = NULL, - lavoptions = NULL, +lav_model_nvcov_bootstrap <- function(lavmodel = NULL, + lavsamplestats = NULL, + lavoptions = NULL, lavimplied = NULL, lavh1 = NULL, lavdata = NULL, - lavcache = NULL, + lavcache = NULL, lavpartable = NULL) { # number of bootstrap draws @@ -14,18 +14,18 @@ lav_model_nvcov_bootstrap <- function(lavmodel = NULL, } else { R <- 1000L } - + boot.type <- "ordinary" if(lavoptions$test == "bollen.stine") boot.type <- "bollen.stine" TEST <- NULL COEF <- bootstrap.internal(object = NULL, - lavmodel. = lavmodel, - lavsamplestats. = lavsamplestats, - lavpartable. = lavpartable, - lavoptions. = lavoptions, + lavmodel. = lavmodel, + lavsamplestats. = lavsamplestats, + lavpartable. = lavpartable, + lavoptions. = lavoptions, lavdata. = lavdata, - R = R, + R = R, verbose = lavoptions$verbose, type = boot.type, FUN = ifelse(boot.type == "bollen.stine", @@ -44,15 +44,15 @@ lav_model_nvcov_bootstrap <- function(lavmodel = NULL, # save COEF and TEST (if any) attr(NVarCov, "BOOT.COEF") <- COEF attr(NVarCov, "BOOT.TEST") <- TEST - + NVarCov } # robust `sem' NVCOV (see Browne, 1984, bentler & dijkstra 1985) -lav_model_nvcov_robust_sem <- function(lavmodel = NULL, +lav_model_nvcov_robust_sem <- function(lavmodel = NULL, lavsamplestats = NULL, - lavdata = NULL, + lavdata = NULL, lavcache = NULL, lavimplied = NULL, lavh1 = NULL, @@ -62,12 +62,12 @@ lav_model_nvcov_robust_sem <- function(lavmodel = NULL, # compute inverse of the expected(!) information matrix if(lavmodel@estimator == "ML" && lavoptions$mimic == "Mplus") { # YR - 11 aug 2010 - what Mplus seems to do is (see Muthen apx 4 eq102) - # - A1 is not based on Sigma.hat and Mu.hat, + # - A1 is not based on Sigma.hat and Mu.hat, # but on lavsamplestats@cov and lavsamplestats@mean... ('unstructured') # - Gamma is not identical to what is used for WLS; closer to EQS # - N/N-1 bug in G11 for NVarCov (but not test statistic) # - we divide by N-1! (just like EQS) - E.inv <- lav_model_information_expected_MLM(lavmodel = lavmodel, + E.inv <- lav_model_information_expected_MLM(lavmodel = lavmodel, lavsamplestats = lavsamplestats, extra = TRUE, augmented = TRUE, @@ -87,7 +87,7 @@ lav_model_nvcov_robust_sem <- function(lavmodel = NULL, } # check if E.inv is ok - if(inherits(E.inv, "try-error")) { + if(inherits(E.inv, "try-error")) { return(E.inv) } @@ -96,9 +96,9 @@ lav_model_nvcov_robust_sem <- function(lavmodel = NULL, # Gamma Gamma <- lavsamplestats@NACOV - if(lavmodel@estimator == "ML" && + if(lavmodel@estimator == "ML" && lavoptions$mimic == "Mplus" && !lavsamplestats@NACOV.user) { - # 'fix' G11 part of Gamma (NOTE: this is NOT needed for SB test + # 'fix' G11 part of Gamma (NOTE: this is NOT needed for SB test # statistic for(g in 1:lavsamplestats@ngroups) { gg1 <- (lavsamplestats@nobs[[g]]-1)/lavsamplestats@nobs[[g]] @@ -111,7 +111,7 @@ lav_model_nvcov_robust_sem <- function(lavmodel = NULL, Gamma[[g]][1:nvar, 1:nvar] <- G11 * gg1 } # g } - + tDVGVD <- matrix(0, ncol=ncol(E.inv), nrow=nrow(E.inv)) for(g in 1:lavsamplestats@ngroups) { @@ -146,12 +146,12 @@ lav_model_nvcov_robust_sem <- function(lavmodel = NULL, } lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL, - lavsamplestats = NULL, + lavsamplestats = NULL, lavdata = NULL, lavoptions = NULL, lavimplied = NULL, lavh1 = NULL, - lavcache = NULL, + lavcache = NULL, use.ginv = FALSE) { # sandwich estimator: A.inv %*% B %*% t(A.inv) @@ -177,7 +177,7 @@ lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL, } # outer product of case-wise scores - B0 <- + B0 <- lav_model_information_firstorder(lavmodel = lavmodel, lavsamplestats = lavsamplestats, lavdata = lavdata, @@ -200,10 +200,10 @@ lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL, NVarCov } -# two stage +# two stage # - two.stage: Gamma = I_1^{-1} # - robust.two.stage: Gamma = incomplete Gamma (I_1^{-1} J_1 I_1^{-1}) -# where I_1 and J_1 are based on the (saturated) model h1 +# where I_1 and J_1 are based on the (saturated) model h1 # (either unstructured, or structured) # # references: @@ -211,7 +211,7 @@ lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL, # - Savalei \& Bentler (2009) eq (6) for se = "two.stage" # - Savalei \& Falk (2014) eq (3) for se = "robust.two.stage" # - Yuan \& Bentler (2000) -lav_model_nvcov_two_stage <- function(lavmodel = NULL, +lav_model_nvcov_two_stage <- function(lavmodel = NULL, lavsamplestats = NULL, lavoptions = NULL, lavimplied = NULL, @@ -230,7 +230,7 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, # only works if: # - information is expected, # - or information is observed but with observed.information == "h1" - if(lavoptions$information == "observed" && + if(lavoptions$information == "observed" && lavoptions$observed.information != "h1") { stop("lavaan ERROR: two.stage + observed information currently only works with observed.information = ", dQuote("h1")) } @@ -239,7 +239,7 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, stop("lavaan ERROR: two.stage + sampling.weights is not supported yet") } # no fixed.x (yet) - if(!is.null(lavsamplestats@x.idx) && + if(!is.null(lavsamplestats@x.idx) && length(lavsamplestats@x.idx[[1]]) > 0L) { stop("lavaan ERROR: two.stage + fixed.x = TRUE is not supported yet") } @@ -285,7 +285,7 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, # t(Delta) * WLS.V %*% Gamma %*% WLS.V %*% Delta WD <- WLS.V[[g]] %*% Delta[[g]] - # to compute (incomplete) GAMMA, should we use + # to compute (incomplete) GAMMA, should we use # structured or unstructured mean/sigma? # # we use the same setting as to compute 'H' (the h1 information matrix) @@ -295,7 +295,7 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, SIGMA <- lavsamplestats@missing.h1[[g]]$sigma } else { MU <- lavimplied$mean[[g]] - SIGMA <- lavimplied$cov[[g]] + SIGMA <- lavimplied$cov[[g]] } # compute 'Gamma' (or Omega.beta) @@ -303,11 +303,11 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, # this is Savalei & Bentler (2009) if(lavoptions$information == "expected") { Info <- lav_mvnorm_missing_information_expected( - Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]], + Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]], Mu = MU, Sigma = SIGMA) } else { Info <- lav_mvnorm_missing_information_observed_samplestats( - Yp = lavsamplestats@missing[[g]], + Yp = lavsamplestats@missing[[g]], Mu = MU, Sigma = SIGMA) } Gamma[[g]] <- lav_matrix_symmetric_inverse(Info) @@ -315,13 +315,13 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, # NACOV is here incomplete Gamma # Savalei & Falk (2014) # - Gamma[[g]] <- lav_mvnorm_missing_h1_omega_sw(Y = - lavdata@X[[g]], Mp = lavdata@Mp[[g]], - Yp = lavsamplestats@missing[[g]], + Gamma[[g]] <- lav_mvnorm_missing_h1_omega_sw(Y = + lavdata@X[[g]], Mp = lavdata@Mp[[g]], + Yp = lavsamplestats@missing[[g]], Mu = MU, Sigma = SIGMA, information = lavoptions$information) } - + # compute tDVGVD <- tDVGVD + fg*fg/fg1 * crossprod(WD, Gamma[[g]] %*% WD) } # g @@ -332,7 +332,7 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, attr(NVarCov, "Delta") <- Delta attr(NVarCov, "Gamma") <- Gamma #if(lavoptions$h1.information.se == lavoptions$h1.information.test) { - attr(NVarCov, "E.inv") <- E.inv + attr(NVarCov, "E.inv") <- E.inv attr(NVarCov, "WLS.V") <- WLS.V #} @@ -341,11 +341,11 @@ lav_model_nvcov_two_stage <- function(lavmodel = NULL, -lav_model_vcov <- function(lavmodel = NULL, - lavsamplestats = NULL, - lavoptions = NULL, - lavdata = NULL, - lavpartable = NULL, +lav_model_vcov <- function(lavmodel = NULL, + lavsamplestats = NULL, + lavoptions = NULL, + lavdata = NULL, + lavpartable = NULL, lavcache = NULL, lavimplied = NULL, lavh1 = NULL, @@ -356,12 +356,12 @@ lav_model_vcov <- function(lavmodel = NULL, se <- lavoptions$se verbose <- lavoptions$verbose mimic <- lavoptions$mimic - + # special cases if(se == "none" || se == "external") return(matrix(0,0,0)) # some require meanstructure (for now) - #if(se %in% c("first.order", "robust.sem", "robust.huber.white") && + #if(se %in% c("first.order", "robust.sem", "robust.huber.white") && # !lavoptions$meanstructure) { # stop("se (", se, ") requires meanstructure (for now)") #} @@ -380,7 +380,7 @@ lav_model_vcov <- function(lavmodel = NULL, use.ginv = use.ginv) } else if(se == "first.order") { - NVarCov <- + NVarCov <- lav_model_information_firstorder(lavmodel = lavmodel, lavsamplestats = lavsamplestats, lavdata = lavdata, @@ -393,7 +393,7 @@ lav_model_vcov <- function(lavmodel = NULL, augmented = TRUE, inverted = TRUE, use.ginv = use.ginv) - + } else if(se == "robust.sem") { NVarCov <- lav_model_nvcov_robust_sem(lavmodel = lavmodel, @@ -443,7 +443,7 @@ lav_model_vcov <- function(lavmodel = NULL, if(! inherits(NVarCov, "try-error") ) { # denominator! - if(lavmodel@estimator %in% c("ML","PML","FML") && + if(lavmodel@estimator %in% c("ML","PML","FML") && likelihood == "normal") { if(lavdata@nlevels == 1L) { N <- lavsamplestats@ntotal @@ -495,7 +495,7 @@ lav_model_vcov_se <- function(lavmodel, lavpartable, VCOV = NULL, se[ which(lavpartable$free == 0L) ] <- 0.0 - # 3. defined parameters: + # 3. defined parameters: def.idx <- which(lavpartable$op == ":=") if(length(def.idx) > 0L) { if(!is.null(BOOT)) { diff --git a/R/lav_model_wls.R b/R/lav_model_wls.R index 217d6b67..8ca49ddb 100644 --- a/R/lav_model_wls.R +++ b/R/lav_model_wls.R @@ -1,5 +1,5 @@ # compute WLS.est (as a list per group) -lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, +lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, lavimplied = NULL) { nblocks <- lavmodel@nblocks @@ -32,7 +32,7 @@ lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, } else { wls.est <- c(lavimplied$th[[g]], diag(lavimplied$cov[[g]])[ num.idx[[g]] ], - lav_matrix_vech(lavimplied$cov[[g]], + lav_matrix_vech(lavimplied$cov[[g]], diagonal = FALSE) ) } @@ -44,8 +44,8 @@ lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, # cbind(res.int, res.slopes) is t(Beta) # so we need vecr if(meanstructure) { - wls.est <- c(lav_matrix_vecr( - cbind(lavimplied$res.int[[g]], + wls.est <- c(lav_matrix_vecr( + cbind(lavimplied$res.int[[g]], lavimplied$res.slopes[[g]]) ), lav_matrix_vech(lavimplied$res.cov[[g]]) ) @@ -56,9 +56,9 @@ lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, } } else { - + if(meanstructure) { - wls.est <- c(lavimplied$mean[[g]], + wls.est <- c(lavimplied$mean[[g]], lav_matrix_vech(lavimplied$cov[[g]])) } else { wls.est <- lav_matrix_vech(lavimplied$cov[[g]]) diff --git a/R/lav_modification.R b/R/lav_modification.R index 30042eae..b0d43447 100644 --- a/R/lav_modification.R +++ b/R/lav_modification.R @@ -1,19 +1,19 @@ # univariate modification indices # -modindices <- function(object, - standardized = TRUE, +modindices <- function(object, + standardized = TRUE, cov.std = TRUE, # power statistics? - power = FALSE, - delta = 0.1, - alpha = 0.05, + power = FALSE, + delta = 0.1, + alpha = 0.05, high.power = 0.75, # customize output - sort. = FALSE, - minimum.value = 0.0, + sort. = FALSE, + minimum.value = 0.0, maximum.number = nrow(LIST), free.remove = TRUE, na.remove = TRUE, @@ -28,7 +28,7 @@ modindices <- function(object, if(object@Options$estimator == "PML") { stop("lavaan WARNING: modification indices for estimator PML are not implemented yet.") } - + # sanity check if(power) { standardized <- TRUE @@ -70,15 +70,15 @@ modindices <- function(object, } else { warning("lavaan WARNING: list with extra parameters is empty; to release equality\n constraints, use lavTestScore()") } - LIST <- data.frame(lhs = character(0), op = character(0), - rhs = character(0), group = integer(0), - mi = numeric(0), epc = numeric(0), + LIST <- data.frame(lhs = character(0), op = character(0), + rhs = character(0), group = integer(0), + mi = numeric(0), epc = numeric(0), sepc.lv = numeric(0), sepc.all = numeric(0), sepc.nox = numeric(0)) return(LIST) } - - # partition + + # partition I11 <- information[extra.idx, extra.idx, drop = FALSE] I12 <- information[extra.idx, model.idx, drop = FALSE] I21 <- information[model.idx, extra.idx, drop = FALSE] @@ -107,8 +107,8 @@ modindices <- function(object, score <- -1 * score # due to gradient.logl } } else { - # total number of clusters (over groups) - N <- 0 + # total number of clusters (over groups) + N <- 0 for(g in 1:object@SampleStats@ngroups) { N <- N + object@Data@Lp[[g]]$nclusters[[2]] } @@ -130,7 +130,7 @@ modindices <- function(object, # OUT <- lavTestScore(object, warn = FALSE) # LIST$mi[ eq.idx ] <- OUT$uni$X2 #} - + # scaled? #if(length(object@test) > 1L) { # LIST$mi.scaled <- LIST$mi / object@test[[2]]$scaling.factor @@ -155,12 +155,12 @@ modindices <- function(object, EPC[ var.idx ] <- LIST$est[ var.idx ] } - # two problems: + # two problems: # - EPC of variances can be negative, and that is # perfectly legal - # - EPC (of variances) can be tiny (near-zero), and we should + # - EPC (of variances) can be tiny (near-zero), and we should # not divide by tiny variables - small.idx <- which(LIST$op == "~~" & + small.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs & abs(EPC) < sqrt( .Machine$double.eps ) ) if(length(small.idx) > 0L) { @@ -170,28 +170,28 @@ modindices <- function(object, # get the sign EPC.sign <- sign(LIST$epc) - LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object, - partable = LIST, + LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object, + partable = LIST, est = abs(EPC), cov.std = cov.std) if(length(small.idx) > 0L) { LIST$sepc.lv[small.idx] <- 0 } - LIST$sepc.all <- EPC.sign * lav_standardize_all(object, - partable = LIST, + LIST$sepc.all <- EPC.sign * lav_standardize_all(object, + partable = LIST, est = abs(EPC), cov.std = cov.std) if(length(small.idx) > 0L) { LIST$sepc.all[small.idx] <- 0 } - LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object, + LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object, partable = LIST, est = abs(EPC), cov.std = cov.std) if(length(small.idx) > 0L) { LIST$sepc.nox[small.idx] <- 0 } - + } # power? @@ -210,15 +210,15 @@ modindices <- function(object, TRUE, FALSE ) high.power <- LIST$power > high.power # FIXME: sepc.all or epc?? - #epc.high <- LIST$sepc.all > LIST$delta + #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 & + LIST$decision[ which( mi.significant & high.power & !epc.high)] <- "epc:nm" - LIST$decision[ which( mi.significant & high.power & + LIST$decision[ which( mi.significant & high.power & epc.high)] <- "*epc:m*" #LIST$decision[ which(mi.significant & high.power) ] <- "epc" @@ -256,9 +256,9 @@ modindices <- function(object, eq.idx <- which(LIST$op == "==") if(length(eq.idx) > 0L) { LIST <- LIST[-eq.idx,] - } + } - # remove even more columns + # remove even more columns LIST$user <- NULL # remove block/group/level is only single block @@ -267,13 +267,13 @@ modindices <- function(object, LIST$group <- NULL LIST$level <- NULL } - + # 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,] + LIST <- LIST[!is.na(LIST$mi) & LIST$mi > minimum.value,] } if(maximum.number < nrow(LIST)) { LIST <- LIST[seq_len(maximum.number),] @@ -293,7 +293,7 @@ modindices <- function(object, # add header # TODO: small explanation of the columns in the header? -# attr(LIST, "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") diff --git a/R/lav_mplus.R b/R/lav_mplus.R index ad79703f..97a2ba71 100644 --- a/R/lav_mplus.R +++ b/R/lav_mplus.R @@ -36,6 +36,6 @@ lavutils_mplus_readdifftest <- function(file="deriv.dat") { # just for fun, M1 # M1 <- (P1 - P1 %*% H %*% solve(t(H) %*% P1 %*% H) %*% t(H) %*% P1) %*% V1 - list(T1=T1, ngroups=ngroups, ndat=ndat, npar=npar, pstar=pstar, + list(T1=T1, ngroups=ngroups, ndat=ndat, npar=npar, pstar=pstar, Delta=Delta, P1=P1, V1=V1) } diff --git a/R/lav_muthen1984.R b/R/lav_muthen1984.R index 29d8deb9..29750169 100644 --- a/R/lav_muthen1984.R +++ b/R/lav_muthen1984.R @@ -1,20 +1,20 @@ # This function was written in January 2012 -- Yves Rosseel # First success: Friday 20 Jan 2012: the standard errors for -# thresholds and polychoric correlations (in an +# thresholds and polychoric correlations (in an # unrestricted/saturated model) are spot on! # Second success: Saturday 9 June 2012: support for mixed (ordinal + metric) -# variables; thanks to the delta method to get the ACOV +# variables; thanks to the delta method to get the ACOV # right (see H matrix) # Third success: Monday 2 July 2012: support for fixed.x covariates -# +# # Friday 13 July 2012: merge exo + non-exo code # Monday 16 July 2012: fixed sign numeric in WLS.W; I think we got it right now # YR 26 Nov 2015: move step1 + step2 to external functions # -muthen1984 <- function(Data = NULL, - ov.names = NULL, - ov.types = NULL, +muthen1984 <- function(Data = NULL, + ov.names = NULL, + ov.types = NULL, ov.levels = NULL, ov.names.x = character(0L), eXo = NULL, @@ -79,7 +79,7 @@ muthen1984 <- function(Data = NULL, VAR <- step1$VAR; SLOPES <- step1$SLOPES SC.TH <- step1$SC.TH; SC.SL <- step1$SC.SL; SC.VAR <- step1$SC.VAR th.start.idx <- step1$th.start.idx; th.end.idx <- step1$th.end.idx - + # rm SC.VAR columns from ordinal variables if(WLS.W && length(ord.idx) > 0L) { SC.VAR <- SC.VAR[,-ord.idx, drop=FALSE] @@ -102,10 +102,10 @@ muthen1984 <- function(Data = NULL, } # stage two -- correlations - + if(verbose) cat("\n\nSTEP 2: covariances/correlations:\n") COR <- lav_samplestats_step2(UNI = FIT, ov.names = ov.names, - zero.add = zero.add, + zero.add = zero.add, zero.keep.margins = zero.keep.margins, zero.cell.warn = zero.cell.warn, zero.cell.tables = zero.cell.tables, @@ -193,7 +193,7 @@ muthen1984 <- function(Data = NULL, H22[pstar.idx, pstar.idx] <- sqrt(VAR[i]) * sqrt(VAR[j]) } else if(ov.types[i] == "numeric" && ov.types[j] == "ordered") { SC.COR.UNI <- ps_cor_scores(rho=COR[i,j], - fit.y1=FIT[[i]], + fit.y1=FIT[[i]], fit.y2=FIT[[j]]) # RHO SC.COR[,pstar.idx] <- SC.COR.UNI$dx.rho @@ -218,7 +218,7 @@ muthen1984 <- function(Data = NULL, H22[pstar.idx, pstar.idx] <- sqrt(VAR[i]) } else if(ov.types[j] == "numeric" && ov.types[i] == "ordered") { SC.COR.UNI <- ps_cor_scores(rho=COR[i,j], - fit.y1=FIT[[j]], + fit.y1=FIT[[j]], fit.y2=FIT[[i]]) # RHO SC.COR[,pstar.idx] <- SC.COR.UNI$dx.rho @@ -243,16 +243,16 @@ muthen1984 <- function(Data = NULL, H22[pstar.idx, pstar.idx] <- sqrt(VAR[j]) } else if(ov.types[i] == "ordered" && ov.types[j] == "ordered") { # polychoric correlation - SC.COR.UNI <- pc_cor_scores(rho=COR[i,j], - fit.y1=FIT[[i]], + SC.COR.UNI <- pc_cor_scores(rho=COR[i,j], + fit.y1=FIT[[i]], fit.y2=FIT[[j]]) # RHO SC.COR[,pstar.idx] <- SC.COR.UNI$dx.rho # TH - A21[pstar.idx, th.idx_i] <- + A21[pstar.idx, th.idx_i] <- lav_crossprod2(SC.COR[,pstar.idx], SC.COR.UNI$dx.th.y1) - A21[pstar.idx, th.idx_j] <- + A21[pstar.idx, th.idx_j] <- lav_crossprod2(SC.COR[,pstar.idx], SC.COR.UNI$dx.th.y2) # SL if(nexo > 0L) { @@ -276,7 +276,7 @@ muthen1984 <- function(Data = NULL, } # A11 - # new approach (2 June 2012): A11 is just a 'sparse' version of + # new approach (2 June 2012): A11 is just a 'sparse' version of # (the left upper block of) INNER A11 <- matrix(0, A11.size, A11.size) for(i in 1:nvar) { @@ -338,7 +338,7 @@ muthen1984 <- function(Data = NULL, A11.inv <- MASS::ginv(A11) warning("lavaan WARNING: trouble constructing W matrix; used generalized inverse for A11 submatrix") } - + # invert da22 <- diag(A22) if(any(da22 == 0)) { @@ -393,7 +393,7 @@ muthen1984 <- function(Data = NULL, WLS.W[NUM.idx,] <- -WLS.W[NUM.idx,] WLS.W[,NUM.idx] <- -WLS.W[,NUM.idx] } - + out <- list(TH=TH, SLOPES=SLOPES, VAR=VAR, COR=COR, COV=COV, SC=SC, TH.NOX=TH.NOX,TH.NAMES=TH.NAMES, TH.IDX=TH.IDX, INNER=INNER, A11=A11, A12=A12, A21=A21, A22=A22, diff --git a/R/lav_mvnorm.R b/R/lav_mvnorm.R index 1759da33..debf0ffb 100644 --- a/R/lav_mvnorm.R +++ b/R/lav_mvnorm.R @@ -23,7 +23,7 @@ # YR 19 Jan 2017: added lav_mvnorm_inverted_information_expected # YR 04 Okt 2018: adding wt= argument, and missing meanstructure= -# 0. densities +# 0. densities lav_mvnorm_dmvnorm <- function(Y = NULL, wt = NULL, Mu = NULL, @@ -53,7 +53,7 @@ lav_mvnorm_dmvnorm <- function(Y = NULL, out <- -(P * LOG.2PI + DIST)/2 } else { if(is.null(Sigma.inv)) { - Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, + Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, logdet = TRUE, Sinv.method = Sinv.method) logdet <- attr(Sigma.inv, "logdet") } else { @@ -85,7 +85,7 @@ lav_mvnorm_dmvnorm <- function(Y = NULL, X <- Y[, x.idx, drop = FALSE] } else { X <- Y[x.idx] - } + } Mu.X <- x.mean; Sigma.X <- x.cov if(is.null(x.mean)) { @@ -96,8 +96,8 @@ lav_mvnorm_dmvnorm <- function(Y = NULL, } logl.X <- lav_mvnorm_dmvnorm(Y = X, wt = wt, Mu = Mu.X, Sigma = Sigma.X, - Sigma.inv = NULL, - Sinv.method = Sinv.method, + Sigma.inv = NULL, + Sinv.method = Sinv.method, x.idx = NULL, log = TRUE) # subtract logl.X @@ -189,7 +189,7 @@ lav_mvnorm_loglik_data <- function(Y = NULL, if(is.null(x.cov)) { Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE] } - loglik.x <- lav_mvnorm_loglik_data(Y = Y[, x.idx, drop = FALSE], + loglik.x <- lav_mvnorm_loglik_data(Y = Y[, x.idx, drop = FALSE], wt = wt, Mu = Mu.X, Sigma = Sigma.X, x.idx = NULL, casewise = casewise, Sinv.method = Sinv.method) @@ -250,7 +250,7 @@ lav_mvnorm_loglik_samplestats <- function(sample.mean = NULL, } sample.mean.x <- sample.mean[x.idx] sample.cov.x <- sample.cov[x.idx, x.idx, drop = FALSE] - loglik.x <- + loglik.x <- lav_mvnorm_loglik_samplestats(sample.mean = sample.mean.x, sample.cov = sample.cov.x, sample.nobs = sample.nobs, @@ -275,7 +275,7 @@ lav_mvnorm_loglik_data_z <- function(Y = NULL, } P <- NCOL(Y); LOG.2PI <- log(2 * pi) - + if(casewise) { DIST <- rowSums(Y * Y) loglik <- -(P * LOG.2PI + DIST)/2 @@ -316,7 +316,7 @@ lav_mvnorm_dlogl_dmu <- function(Y = NULL, Sinv.method = "eigen", Sigma.inv = NULL) { Mu <- as.numeric(Mu) - + if(is.null(Sigma.inv)) { # invert Sigma Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, logdet = FALSE, @@ -403,7 +403,7 @@ lav_mvnorm_dlogl_dvechSigma <- function(Y = NULL, } else { N <- NROW(Y) } - + Mu <- as.numeric(Mu) if(is.null(Sigma.inv)) { @@ -433,7 +433,7 @@ lav_mvnorm_dlogl_dvechSigma <- function(Y = NULL, dSigma[x.idx, x.idx] <- 0 } - dvechSigma <- as.numeric( lav_matrix_duplication_pre( + dvechSigma <- as.numeric( lav_matrix_duplication_pre( as.matrix(lav_matrix_vec(dSigma)) ) ) dvechSigma @@ -543,23 +543,23 @@ lav_mvnorm_scores_mu_vech_sigma <- function(Y = NULL, # vech(Sigma.inv) isigma <- lav_matrix_vech(Sigma.inv) - + # substract Mu Yc <- t( t(Y) - Mu ) # postmultiply with Sigma.inv Yc <- Yc %*% Sigma.inv - + # tcrossprod idx1 <- lav_matrix_vech_col_idx(P); idx2 <- lav_matrix_vech_row_idx(P) Z <- Yc[,idx1] * Yc[,idx2] - + # substract isigma from each row SC <- t( t(Z) - isigma ) # adjust for lav_matrix_duplication_pre (not vech!) SC[,lav_matrix_diagh_idx(P)] <- SC[,lav_matrix_diagh_idx(P)] / 2 - + out <- cbind(Yc, SC) # weights @@ -596,7 +596,7 @@ lav_mvnorm_logl_hessian_data <- function(Y = NULL, # observed information observed <- lav_mvnorm_information_observed_data(Y = Y, wt = wt, Mu = Mu, - Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, + Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, meanstructure = meanstructure) -N*observed @@ -618,10 +618,10 @@ lav_mvnorm_logl_hessian_samplestats <- # observed information observed <- lav_mvnorm_information_observed_samplestats(sample.mean = - sample.mean, sample.cov = sample.cov, Mu = Mu, Sigma = Sigma, + sample.mean, sample.cov = sample.cov, Mu = Mu, Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, meanstructure = meanstructure) - + -N*observed } @@ -712,15 +712,15 @@ lav_mvnorm_information_observed_samplestats <- } W.tilde <- sample.cov + tcrossprod(sample.mean - Mu) - + if(meanstructure) { I11 <- Sigma.inv - I21 <- lav_matrix_duplication_pre( (Sigma.inv %*% + I21 <- lav_matrix_duplication_pre( (Sigma.inv %*% (sample.mean - Mu)) %x% Sigma.inv ) I12 <- t(I21) } - + AAA <- Sigma.inv %*% (2*W.tilde - Sigma) %*% Sigma.inv I22 <- (1/2) * lav_matrix_duplication_pre_post(Sigma.inv %x% AAA) @@ -733,8 +733,8 @@ lav_mvnorm_information_observed_samplestats <- # fixed.x? if(!is.null(x.idx) && length(x.idx) > 0L) { - not.x <- eliminate.pstar.idx(nvar = length(sample.mean), - el.idx = x.idx, + not.x <- eliminate.pstar.idx(nvar = length(sample.mean), + el.idx = x.idx, meanstructure = meanstructure) out[, !not.x] <- 0 out[!not.x, ] <- 0 @@ -760,7 +760,7 @@ lav_mvnorm_information_firstorder <- function(Y = NULL, } if(meanstructure) { - SC <- lav_mvnorm_scores_mu_vech_sigma(Y = Y, wt = wt, + SC <- lav_mvnorm_scores_mu_vech_sigma(Y = Y, wt = wt, Mu = Mu, Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv) } else { @@ -789,7 +789,7 @@ lav_mvnorm_inverted_information_expected <- function(Y = NULL, # unused! meanstructure = TRUE) { if(!is.null(x.idx) && length(x.idx) > 0L) { - # cov(Y|X) = A - B C^{-1} B' + # cov(Y|X) = A - B C^{-1} B' # where A = cov(Y), B = cov(Y,X), C = cov(X) A <- Sigma[-x.idx, -x.idx, drop = FALSE] B <- Sigma[-x.idx, x.idx, drop = FALSE] diff --git a/R/lav_mvnorm_cluster.R b/R/lav_mvnorm_cluster.R index 4510ec3b..6c1d789d 100644 --- a/R/lav_mvnorm_cluster.R +++ b/R/lav_mvnorm_cluster.R @@ -29,7 +29,7 @@ lav_mvnorm_cluster_implied22l <- function(Lp = NULL, Mu.B <- implied$mean[[2]] } - # within/between.idx + # within/between.idx between.idx <- Lp$between.idx[[2]] within.idx <- Lp$within.idx[[2]] both.idx <- Lp$both.idx[[2]] @@ -57,7 +57,7 @@ lav_mvnorm_cluster_implied22l <- function(Lp = NULL, Mu.B.tilde[ ov.idx[[2]] ] <- Mu.B # add Mu.W[within.idx] to Mu.B - Mu.WB.tilde <- numeric( p.tilde) + Mu.WB.tilde <- numeric( p.tilde) Mu.WB.tilde[ within.idx ] <- Mu.W.tilde[ within.idx ] Mu.WB.tilde[ both.idx ] <- ( Mu.B.tilde[ both.idx ] + Mu.W.tilde[ both.idx ] ) @@ -91,7 +91,7 @@ lav_mvnorm_cluster_implied22l <- function(Lp = NULL, mu.b = mu.b) } -lav_mvnorm_cluster_2l2implied <- function(Lp, +lav_mvnorm_cluster_2l2implied <- function(Lp, sigma.w = NULL, sigma.b = NULL, sigma.zz = NULL, @@ -101,7 +101,7 @@ lav_mvnorm_cluster_2l2implied <- function(Lp, mu.w = NULL, mu.b = NULL) { - # between.idx + # between.idx between.idx <- Lp$between.idx[[2]] within.idx <- Lp$within.idx[[2]] @@ -154,7 +154,7 @@ lav_mvnorm_cluster_2l2implied <- function(Lp, list(Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B) } - + # Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics # (not yet reordered) @@ -173,7 +173,7 @@ lav_mvnorm_cluster_loglik_samplestats_2l <- function(YLp = NULL, out <- lav_mvnorm_cluster_implied22l(Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B) mu.y <- out$mu.y; mu.z <- out$mu.z - sigma.w <- out$sigma.w; sigma.b <- out$sigma.b + sigma.w <- out$sigma.w; sigma.b <- out$sigma.b sigma.zz <- out$sigma.zz; sigma.yz <- out$sigma.yz #if(length(x.idx) > 0L) { @@ -273,7 +273,7 @@ lav_mvnorm_cluster_loglik_samplestats_2l <- function(YLp = NULL, #sigma.j.logdet <- attr(sigma.j.inv, "logdet") #attr(sigma.j.inv, "logdet") <- NULL } - + # logdet -- between only L[clz] <- (sigma.zz.logdet + sigma.j.logdet) @@ -339,7 +339,7 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, out <- lav_mvnorm_cluster_implied22l(Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B) mu.y <- out$mu.y; mu.z <- out$mu.z - sigma.w <- out$sigma.w; sigma.b <- out$sigma.b + sigma.w <- out$sigma.w; sigma.b <- out$sigma.b sigma.zz <- out$sigma.zz; sigma.yz <- out$sigma.yz # Lp @@ -374,7 +374,7 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, if(length(between.idx) > 0L) { G.muz <- matrix(0, ncluster.sizes, length(mu.z)) - G.Sigma.zz <- matrix(0, ncluster.sizes, + G.Sigma.zz <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.zz))) G.Sigma.yz <- matrix(0, ncluster.sizes, length(lav_matrix_vec(sigma.yz))) @@ -459,18 +459,18 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, # level-1 d.mu.y <- colSums(G.muy * cluster.size.ns) - d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * + d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * cluster.size.ns)) - d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * + d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * cluster.size.ns)) # level-2 d.mu.z <- colSums(G.muz * cluster.size.ns) - d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.Sigma.zz * + d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.Sigma.zz * cluster.size.ns)) - d.sigma.yz <- matrix(colSums(G.Sigma.yz * cluster.size.ns), + d.sigma.yz <- matrix(colSums(G.Sigma.yz * cluster.size.ns), nrow(sigma.yz), ncol(sigma.yz)) - } # between.idx + } # between.idx else { # no level-2 variables @@ -488,7 +488,7 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, sigma.j <- (nj * sigma.b) + sigma.w sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j, logdet = FALSE, Sinv.method = Sinv.method) - # common part + # common part jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv # MU.Y @@ -507,9 +507,9 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, # level-1 d.mu.y <- colSums(G.muy * cluster.size.ns) - d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * + d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * cluster.size.ns)) - d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * + d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * cluster.size.ns)) # level-2 d.mu.z <- numeric(0L) @@ -525,7 +525,7 @@ lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, d.sigma.w <- d.sigma.w1 + d.sigma.w2 - # rearrange + # rearrange dout <- lav_mvnorm_cluster_2l2implied(Lp = Lp, sigma.w = d.sigma.w, sigma.b = d.sigma.b, sigma.yz = d.sigma.yz, sigma.zz = d.sigma.zz, @@ -555,7 +555,7 @@ lav_mvnorm_cluster_scores_2l <- function(Y1 = NULL, out <- lav_mvnorm_cluster_implied22l(Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B) mu.y <- out$mu.y; mu.z <- out$mu.z - sigma.w <- out$sigma.w; sigma.b <- out$sigma.b + sigma.w <- out$sigma.w; sigma.b <- out$sigma.b sigma.zz <- out$sigma.zz; sigma.yz <- out$sigma.yz # Lp @@ -682,7 +682,7 @@ lav_mvnorm_cluster_scores_2l <- function(Y1 = NULL, G.Sigma.yz[cl,] <- lav_matrix_vec(g.sigma.yz) } - } # between.idx + } # between.idx else { # no level-2 variables @@ -701,7 +701,7 @@ lav_mvnorm_cluster_scores_2l <- function(Y1 = NULL, sigma.j <- (nj * sigma.b) + sigma.w sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j, logdet = FALSE, Sinv.method = Sinv.method) - # common part + # common part jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv # MU.Y @@ -925,7 +925,7 @@ lav_mvnorm_cluster_information_expected <- function(Lp = NULL, I11.w <- Sigma.W.inv.tilde I22.w <- 0.5 * lav_matrix_duplication_pre_post(Sigma.W.inv.tilde %x% Sigma.W.inv.tilde) I.w <- lav_matrix_bdiag(I11.w, I22.w) - information.w <- (nobs - nclusters) * + information.w <- (nobs - nclusters) * ( t(Delta.W.tilde) %*% I.w %*% Delta.W.tilde ) # unit information @@ -944,9 +944,9 @@ lav_mvnorm_cluster_information_expected <- function(Lp = NULL, information.tilde[all.idx, ] <- 0 information.tilde[, all.idx] <- 0 } - + # remove redundant rows/cols - ok.idx <- c(ov.idx[[1]], + ok.idx <- c(ov.idx[[1]], w.idx + p.tilde, npar + ov.idx[[2]], npar + b.idx + p.tilde) @@ -957,7 +957,7 @@ lav_mvnorm_cluster_information_expected <- function(Lp = NULL, } -# expected information -- delta +# expected information -- delta # for non-saturated models only lav_mvnorm_cluster_information_expected_delta <- function(Lp = NULL, Delta = NULL, @@ -1128,7 +1128,7 @@ lav_mvnorm_cluster_information_observed <- function(Lp = NULL, x.idx.w <- which(ov.idx[[1]] %in% x.idx) if(length(x.idx.w) > 0L) { xw.idx <- c(x.idx.w, - nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)) + nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w)) } else { xw.idx <- integer(0L) } @@ -1457,7 +1457,7 @@ lav_mvnorm_cluster_em_h0 <- function(lavsamplestats = NULL, # add attributes if(i < max.iter) { - attr(x, "converged") <- TRUE + attr(x, "converged") <- TRUE } else { attr(x, "converged") <- FALSE } diff --git a/R/lav_mvnorm_h1.R b/R/lav_mvnorm_h1.R index 5a86c5f9..c4bb4471 100644 --- a/R/lav_mvnorm_h1.R +++ b/R/lav_mvnorm_h1.R @@ -1,5 +1,5 @@ # the multivariate normal distribution, unrestricted (h1) -# - everything is evalued under the MLEs: Mu = ybar, Sigma = S +# - everything is evalued under the MLEs: Mu = ybar, Sigma = S # 1) loglikelihood h1 (from raw data, or sample statistics) # 4) hessian h1 around MLEs @@ -38,8 +38,8 @@ lav_mvnorm_h1_loglik_data <- function(Y = NULL, } else { out <- stats::cov.wt(Y, wt = wt, method = "ML") if(casewise) { - loglik <- lav_mvnorm_loglik_data(Y, Mu = out$center, - Sigma = out$cov, casewise = TRUE, + loglik <- lav_mvnorm_loglik_data(Y, Mu = out$center, + Sigma = out$cov, casewise = TRUE, Sinv.method = Sinv.method) return(loglik * wt) } else { @@ -58,7 +58,7 @@ lav_mvnorm_h1_loglik_data <- function(Y = NULL, DIST <- rowSums((Yc %*% icS)^2) logdet <- -2 * sum(log(diag(icS))) } else { - sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, + sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, logdet = TRUE, Sinv.method = Sinv.method) logdet <- attr(sample.cov.inv, "logdet") # mahalanobis distance @@ -83,7 +83,7 @@ lav_mvnorm_h1_loglik_data <- function(Y = NULL, # fixed.x? if(!is.null(x.idx) && length(x.idx) > 0L) { loglik.x <- lav_mvnorm_h1_loglik_data(Y = Y[, x.idx, drop = FALSE], - wt = wt, x.idx = NULL, + wt = wt, x.idx = NULL, casewise = casewise, Sinv.method = Sinv.method) # subtract logl.X @@ -168,7 +168,7 @@ lav_mvnorm_h1_logl_hessian_data <- function(Y = NULL, x.idx = x.idx, Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv, meanstructure = meanstructure) - + -N*observed } @@ -185,11 +185,11 @@ lav_mvnorm_h1_logl_hessian_samplestats <- N <- sample.nobs # observed information - observed <- lav_mvnorm_h1_information_observed_samplestats(sample.mean = + observed <- lav_mvnorm_h1_information_observed_samplestats(sample.mean = sample.mean, sample.cov = sample.cov, x.idx = x.idx, - Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv, + Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv, meanstructure = meanstructure) - + -N*observed } @@ -218,12 +218,12 @@ lav_mvnorm_h1_information_expected <- function(Y = NULL, } # invert sample.cov - sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, + sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, logdet = FALSE, Sinv.method = Sinv.method) } I11 <- sample.cov.inv - I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% + I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% sample.cov.inv) if(meanstructure) { @@ -261,7 +261,7 @@ lav_mvnorm_h1_information_observed_data <- function(Y = NULL, # 5b-bis: observed information h1 from sample statistics lav_mvnorm_h1_information_observed_samplestats <- function(sample.mean = NULL, # unused! - sample.cov = NULL, + sample.cov = NULL, x.idx = NULL, Sinv.method = "eigen", sample.cov.inv = NULL, @@ -269,12 +269,12 @@ lav_mvnorm_h1_information_observed_samplestats <- if(is.null(sample.cov.inv)) { # invert sample.cov - sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, + sample.cov.inv <- lav_matrix_symmetric_inverse(S = sample.cov, logdet = FALSE, Sinv.method = Sinv.method) } I11 <- sample.cov.inv - I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% + I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% sample.cov.inv) if(meanstructure) { @@ -296,7 +296,7 @@ lav_mvnorm_h1_information_observed_samplestats <- } # 5c: unit first-order information h1 -# note: first order information h1 == A1 %*% Gamma %*% A1 +# note: first order information h1 == A1 %*% Gamma %*% A1 # (where A1 = obs/exp information h1) lav_mvnorm_h1_information_firstorder <- function(Y = NULL, wt = NULL, @@ -309,7 +309,7 @@ lav_mvnorm_h1_information_firstorder <- function(Y = NULL, if(!is.null(wt)) { out <- stats::cov.wt(Y, wt = wt, method = "ML") - res <- lav_mvnorm_information_firstorder(Y = Y, wt = wt, + res <- lav_mvnorm_information_firstorder(Y = Y, wt = wt, Mu = out$center, Sigma = out$cov, x.idx = x.idx, meanstructure = meanstructure) return( res ) @@ -351,7 +351,7 @@ lav_mvnorm_h1_information_firstorder <- function(Y = NULL, # 6a: (unit) inverted expected information (A1.inv = Gamma.NT) # 6b: (unit) inverted observed information (A1.inv = Gamma.NT) -lav_mvnorm_h1_inverted_information_expected <- +lav_mvnorm_h1_inverted_information_expected <- lav_mvnorm_h1_inverted_information_observed <- function(Y = NULL, sample.cov = NULL, x.idx = NULL) { @@ -396,8 +396,8 @@ lav_mvnorm_h1_inverted_information_firstorder <- function(Y = NULL, } # Gamma.NT - Gamma.NT <- - lav_mvnorm_h1_inverted_information_expected(Y = Y, + Gamma.NT <- + lav_mvnorm_h1_inverted_information_expected(Y = Y, sample.cov = sample.cov, x.idx = x.idx) if(!is.null(x.idx) && length(x.idx) > 0L) { @@ -421,8 +421,8 @@ lav_mvnorm_h1_acov_observed <- function(Y = NULL, x.idx = NULL) { N <- NROW(Y) - Gamma.NT <- - lav_mvnorm_h1_inverted_information_expected(Y = Y, + Gamma.NT <- + lav_mvnorm_h1_inverted_information_expected(Y = Y, sample.cov = sample.cov, x.idx = x.idx) @@ -439,8 +439,8 @@ lav_mvnorm_h1_acov_firstorder <- function(Y = NULL, N <- NROW(Y) J1.inv <- lav_mvnorm_h1_inverted_information_firstorder(Y = Y, - sample.cov = sample.cov, - x.idx = x.idx, Sinv.method = Sinv.method, + sample.cov = sample.cov, + x.idx = x.idx, Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv, Gamma = Gamma) (1/N) * J1.inv diff --git a/R/lav_mvnorm_missing.R b/R/lav_mvnorm_missing.R index a07f4f58..f5e1a24a 100644 --- a/R/lav_mvnorm_missing.R +++ b/R/lav_mvnorm_missing.R @@ -36,7 +36,7 @@ # 1a: input is raw data # - two strategies: 1) using missing patterns (pattern = TRUE) # 2) truly case per case (pattern = FALSE) -# depending on the sample size, missing patterns, etc... one can be +# depending on the sample size, missing patterns, etc... one can be # (much) faster than the other lav_mvnorm_missing_loglik_data <- function(Y = NULL, Mu = NULL, @@ -54,11 +54,11 @@ lav_mvnorm_missing_loglik_data <- function(Y = NULL, } if(pattern) { - llik <- lav_mvnorm_missing_llik_pattern(Y = Y, wt = wt, Mu = Mu, + llik <- lav_mvnorm_missing_llik_pattern(Y = Y, wt = wt, Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, log2pi = log2pi, minus.two = minus.two) } else { - llik <- lav_mvnorm_missing_llik_casewise(Y = Y, wt = wt, Mu = Mu, + llik <- lav_mvnorm_missing_llik_casewise(Y = Y, wt = wt, Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, log2pi = log2pi, minus.two = minus.two) } @@ -68,7 +68,7 @@ lav_mvnorm_missing_loglik_data <- function(Y = NULL, } else { loglik <- sum(llik, na.rm = TRUE) } - + loglik } @@ -85,7 +85,7 @@ lav_mvnorm_missing_loglik_samplestats <- function(Yp = NULL, if(!is.null(x.idx) && length(x.idx) > 0L) { #warning("lavaan WARNING: x.idx not supported yet (ignored)") - + } LOG.2PI <- log(2*pi); pat.N <- length(Yp); P <- length(Yp[[1]]$var.idx) @@ -191,7 +191,7 @@ lav_mvnorm_missing_llik_casewise <- function(Y = NULL, # constant P.LOG.2PI <- P.i * LOG.2PI - # complete cases first (only an advantage if we have mostly complete + # complete cases first (only an advantage if we have mostly complete # observations) other.idx <- seq_len(N) complete.idx <- which(P.i == P) @@ -294,13 +294,13 @@ lav_mvnorm_missing_llik_pattern <- function(Y = NULL, } if(Mp$freq[p] == 1L) { - DIST[case.idx] <- sum(sigma.inv * + DIST[case.idx] <- sum(sigma.inv * crossprod(Yc[case.idx, var.idx, drop = FALSE])) } else { DIST[case.idx] <- rowSums(Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv * Yc[case.idx, var.idx, drop = FALSE]) - } + } } # compute casewise loglikelihoods @@ -342,7 +342,7 @@ lav_mvnorm_missing_dlogl_dmu <- function(Y = NULL, colSums(SC, na.rm = TRUE) } -# 2abis: using samplestats +# 2abis: using samplestats lav_mvnorm_missing_dlogl_dmu_samplestats <- function(Yp = NULL, Mu = NULL, Sigma = NULL, @@ -390,7 +390,7 @@ lav_mvnorm_missing_dlogl_dmu_samplestats <- function(Yp = NULL, # 2b: derivative logl with respect to Sigma (full matrix, ignoring symmetry) lav_mvnorm_missing_dlogl_dSigma <- function(Y = NULL, Mp = NULL, - wt = NULL, + wt = NULL, Mu = NULL, Sigma = NULL, Sigma.inv = NULL, @@ -442,7 +442,7 @@ lav_mvnorm_missing_dlogl_dSigma <- function(Y = NULL, if(length(case.idx) > 1L) { if(!is.null(wt)) { - out <- stats::cov.wt(Y[case.idx, var.idx, drop = FALSE], + out <- stats::cov.wt(Y[case.idx, var.idx, drop = FALSE], wt = wt[Mp$case.idx[[p]]], method = "ML") SY <- out$cov MY <- out$center @@ -456,7 +456,7 @@ lav_mvnorm_missing_dlogl_dSigma <- function(Y = NULL, # dSigma for this pattern dSigma.pattern <- matrix(0, P, P) - dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - + dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - (sigma.inv %*% W.tilde %*% sigma.inv)) # update dSigma @@ -504,7 +504,7 @@ lav_mvnorm_missing_dlogl_dSigma_samplestats <- function(Yp = NULL, # dSigma for this pattern dSigma.pattern <- matrix(0, P, P) - dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - + dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - (sigma.inv %*% W.tilde %*% sigma.inv)) # update dSigma @@ -523,13 +523,13 @@ lav_mvnorm_missing_dlogl_dvechSigma <- function(Y = NULL, Sigma.inv = NULL, Sinv.method = "eigen") { - FULL <- lav_mvnorm_missing_dlogl_dSigma(Y = Y, wt = wt, Mu = Mu, + FULL <- lav_mvnorm_missing_dlogl_dSigma(Y = Y, wt = wt, Mu = Mu, Sigma = Sigma, Sigma.inv = Sigma.inv, Sinv.method = Sinv.method) as.numeric( lav_matrix_duplication_pre( as.matrix(lav_matrix_vec(FULL)) ) ) } # 2cbis: using samplestats -lav_mvnorm_missing_dlogl_dvechSigma_samplestats <- +lav_mvnorm_missing_dlogl_dvechSigma_samplestats <- function(Yp = NULL, Mu = NULL, Sigma = NULL, @@ -567,7 +567,7 @@ lav_mvnorm_missing_dlogl_dvechSigma_samplestats <- # dSigma for this pattern dSigma.pattern <- matrix(0, P, P) - dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - + dSigma.pattern[var.idx, var.idx] <- -(1/2) * (sigma.inv - (sigma.inv %*% W.tilde %*% sigma.inv)) # convert to vechSigma @@ -661,7 +661,7 @@ lav_mvnorm_missing_scores_vech_sigma <- function(Y = NULL, Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, logdet = FALSE, Sinv.method = Sinv.method) } - + # for the tcrossprod idx1 <- lav_matrix_vech_col_idx(P); idx2 <- lav_matrix_vech_row_idx(P) @@ -739,7 +739,7 @@ lav_mvnorm_missing_scores_mu_vech_sigma <- function(Y = NULL, Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, logdet = FALSE, Sinv.method = Sinv.method) } - + # for the tcrossprod idx1 <- lav_matrix_vech_col_idx(P); idx2 <- lav_matrix_vech_row_idx(P) @@ -869,8 +869,8 @@ lav_mvnorm_missing_logl_hessian_samplestats <- tmp21[var.idx,1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx]) W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) - AAA <- ( sigma.inv %*% - (2*W.tilde - Sigma[var.idx,var.idx,drop = FALSE]) %*% + AAA <- ( sigma.inv %*% + (2*W.tilde - Sigma[var.idx,var.idx,drop = FALSE]) %*% sigma.inv ) tmp22 <- matrix(0, P, P) tmp22[var.idx, var.idx] <- AAA @@ -893,7 +893,7 @@ lav_mvnorm_missing_logl_hessian_samplestats <- -# 5) Information +# 5) Information # 5a: expected unit information Mu and vech(Sigma) # (only useful under MCAR) @@ -950,7 +950,7 @@ lav_mvnorm_missing_information_expected <- function(Y = NULL, S2.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv) - if(!is.null(wt)) { + if(!is.null(wt)) { FREQ <- sum( wt[ Mp$case.idx[[p]] ] ) } else { FREQ <- Mp$freq[p] @@ -986,7 +986,7 @@ lav_mvnorm_missing_information_observed_data <- function(Y = NULL, # observed information observed <- lav_mvnorm_missing_logl_hessian_data(Y = Y, Mp = Mp, wt = wt, - Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, + Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv) -observed/N @@ -994,19 +994,19 @@ lav_mvnorm_missing_information_observed_data <- function(Y = NULL, # 5b-bis: unit observed information Mu and vech(Sigma) from samplestats lav_mvnorm_missing_information_observed_samplestats <- - function(Yp = NULL, + function(Yp = NULL, Mu = NULL, Sigma = NULL, Sinv.method = "eigen", Sigma.inv = NULL) { N <- sum(sapply(Yp, "[[", "freq")) # implicitly: removed empty cases! - + # observed information observed <- lav_mvnorm_missing_logl_hessian_samplestats(Yp = Yp, Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv) - + -observed/N } @@ -1031,8 +1031,8 @@ lav_mvnorm_missing_information_firstorder <- function(Y = NULL, N <- sum(Mp$freq) } - SC <- lav_mvnorm_missing_scores_mu_vech_sigma(Y = Y, Mp = Mp, wt = wt, - Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, + SC <- lav_mvnorm_missing_scores_mu_vech_sigma(Y = Y, Mp = Mp, wt = wt, + Mu = Mu, Sigma = Sigma, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv) lav_matrix_crossprod(SC)/N @@ -1055,7 +1055,7 @@ lav_mvnorm_missing_information_both <- function(Y = NULL, Sigma.inv <- lav_matrix_symmetric_inverse(S = Sigma, logdet = FALSE, Sinv.method = Sinv.method) } - + # for the tcrossprod idx1 <- lav_matrix_vech_col_idx(P); idx2 <- lav_matrix_vech_row_idx(P) @@ -1135,21 +1135,21 @@ lav_mvnorm_missing_information_both <- function(Y = NULL, I22 <- I22 + FREQ * S2.inv } else { pat.freq <- Yp[[p]]$freq - + tmp21 <- matrix(0,P,1) tmp21[var.idx,1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx]) - + W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) - AAA <- ( sigma.inv %*% + AAA <- ( sigma.inv %*% (2*W.tilde - Sigma[var.idx,var.idx,drop = FALSE]) %*% sigma.inv ) tmp22 <- matrix(0, P, P) tmp22[var.idx, var.idx] <- AAA - + i11 <- S.inv i21 <- lav_matrix_duplication_pre( tmp21 %x% S.inv ) i22 <- (1/2) * lav_matrix_duplication_pre_post(S.inv %x% tmp22) - + I11 <- I11 + pat.freq * i11 I21 <- I21 + pat.freq * i21 I22 <- I22 + pat.freq * i22 @@ -1360,7 +1360,7 @@ lav_mvnorm_missing_estep <- function(Y = NULL, if(!is.null(wt)) { WT <- wt[Mp$case.idx[[p]]] - T1 <- T1 + colSums(WT * O) + T1 <- T1 + colSums(WT * O) T2 <- T2 + crossprod(sqrt(WT) * O) } else { # complete pattern @@ -1413,7 +1413,7 @@ lav_mvnorm_missing_estep <- function(Y = NULL, T2.pat[!var.idx, !var.idx] <- T2.pat[!var.idx, !var.idx] + (T2.p11 * sum(WT)) } else { - T2.pat[!var.idx, !var.idx] <- + T2.pat[!var.idx, !var.idx] <- T2.pat[!var.idx, !var.idx] + (T2.p11 * Mp$freq[[p]]) } diff --git a/R/lav_mvnorm_missing_h1.R b/R/lav_mvnorm_missing_h1.R index b9076927..7023f3f2 100644 --- a/R/lav_mvnorm_missing_h1.R +++ b/R/lav_mvnorm_missing_h1.R @@ -50,7 +50,7 @@ lav_mvnorm_missing_h1_estimate_moments <- function(Y = NULL, #fx0 <- estimator.FIML(Sigma.hat=Sigma, Mu.hat=Mu, M=Yp) fx0 <- lav_mvnorm_missing_loglik_samplestats(Yp = Yp, Mu = Mu, Sigma = Sigma, - log2pi = FALSE, + log2pi = FALSE, minus.two = TRUE)/N cat(" EM iteration:", sprintf("%4d", 0), " fx = ", sprintf("%15.10f", fx0), @@ -76,7 +76,7 @@ lav_mvnorm_missing_h1_estimate_moments <- function(Y = NULL, tol <- 1e-6 # FIXME! if(any(ev$values < tol)) { #too.small <- which( ev$values < tol ) - #ev$values[too.small] <- tol + #ev$values[too.small] <- tol #ev$values <- ev$values + tol #Sigma <- ev$vectors %*% diag(ev$values) %*% t(ev$vectors) @@ -85,7 +85,7 @@ lav_mvnorm_missing_h1_estimate_moments <- function(Y = NULL, } # max absolute difference in parameter values - DELTA <- max(abs(c(Mu, lav_matrix_vech(Sigma)) - + DELTA <- max(abs(c(Mu, lav_matrix_vech(Sigma)) - c(Mu0, lav_matrix_vech(Sigma0)))) # report fx @@ -162,11 +162,11 @@ lav_mvnorm_missing_h1_omega_sw <- function(Y = NULL, # information matrices info <- lav_mvnorm_missing_information_both(Y = Y, Mp = Mp, Mu = Mu, - Sigma = Sigma, Sinv.method = Sinv.method, + Sigma = Sigma, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, information = information) A <- info$Abeta - A.inv <- lav_matrix_symmetric_inverse(S = A, logdet = FALSE, + A.inv <- lav_matrix_symmetric_inverse(S = A, logdet = FALSE, Sinv.method = Sinv.method) B <- info$Bbeta diff --git a/R/lav_mvreg.R b/R/lav_mvreg.R index 8110e5b8..e80e1749 100644 --- a/R/lav_mvreg.R +++ b/R/lav_mvreg.R @@ -12,7 +12,7 @@ # YR 24 Mar 2016: first version # YR 20 Jan 2017: removed added 'N' in many equations, to be consistent with # lav_mvnorm_* -# YR 18 Okt 2018: add 'information' functions, change arguments +# YR 18 Okt 2018: add 'information' functions, change arguments # (X -> eXo, Sigma -> res.cov, Beta -> res.int + res.slopes) # 1. loglikelihood @@ -118,7 +118,7 @@ lav_mvreg_loglik_samplestats <- function(sample.res.int = NULL, # tr(res.cov^{-1} %*% S) DIST1 <- sum(res.cov.inv * sample.res.cov) - # tr( res.cov^{-1} (B-beta)' X'X (B-beta) + # tr( res.cov^{-1} (B-beta)' X'X (B-beta) Diff <- sample.B - Beta DIST2 <- sum(res.cov.inv * crossprod(Diff, sample.xx) %*% Diff) @@ -272,7 +272,7 @@ lav_mvreg_scores_beta <- function(Y = NULL, # post-multiply with res.cov.inv RES <- RES %*% res.cov.inv - SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] * + SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] * RES[,rep(1:Q, each = P), drop = FALSE] SC.Beta @@ -295,24 +295,24 @@ lav_mvreg_scores_vech_sigma <- function(Y = NULL, if(is.null(Beta)) { Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) } - + # res.cov.inv if(is.null(res.cov.inv)) { # invert res.cov res.cov.inv <- lav_matrix_symmetric_inverse(S = res.cov, logdet = FALSE, Sinv.method = Sinv.method) - } - + } + # vech(res.cov.inv) isigma <- lav_matrix_vech(res.cov.inv) - + # substract X %*% Beta RES <- Y - X %*% Beta # postmultiply with res.cov.inv RES <- RES %*% res.cov.inv - - # tcrossprod + + # tcrossprod idx1 <- lav_matrix_vech_col_idx(Q) idx2 <- lav_matrix_vech_row_idx(Q) Z <- RES[,idx1] * RES[,idx2] @@ -349,11 +349,11 @@ lav_mvreg_scores_beta_vech_sigma <- function(Y = NULL, # invert res.cov res.cov.inv <- lav_matrix_symmetric_inverse(S = res.cov, logdet = FALSE, Sinv.method = Sinv.method) - } - + } + # vech(res.cov.inv) isigma <- lav_matrix_vech(res.cov.inv) - + # substract X %*% Beta RES <- Y - X %*% Beta @@ -362,8 +362,8 @@ lav_mvreg_scores_beta_vech_sigma <- function(Y = NULL, SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] * RES[,rep(1:Q, each = P), drop = FALSE] - - # tcrossprod + + # tcrossprod idx1 <- lav_matrix_vech_col_idx(Q) idx2 <- lav_matrix_vech_row_idx(Q) Z <- RES[,idx1] * RES[,idx2] @@ -394,8 +394,8 @@ lav_mvreg_logl_hessian_data <- function(Y = NULL, # observed information observed <- lav_mvreg_information_observed_data(Y = Y, eXo = eXo, - Beta = Beta, res.int = res.int, res.slopes = res.slopes, - res.cov = res.cov, res.cov.inv = res.cov.inv, + Beta = Beta, res.int = res.int, res.slopes = res.slopes, + res.cov = res.cov, res.cov.inv = res.cov.inv, Sinv.method = Sinv.method) # hessian @@ -423,9 +423,9 @@ lav_mvreg_logl_hessian_samplestats <- function( # information observed <- lav_mvreg_information_observed_samplestats( sample.res.int = sample.res.int, sample.res.slopes = sample.res.slopes, - sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x, - sample.cov.x = sample.cov.x, Beta = Beta, res.int = res.int, - res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method, + sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x, + sample.cov.x = sample.cov.x, Beta = Beta, res.int = res.int, + res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv) # hessian @@ -510,7 +510,7 @@ lav_mvreg_information_observed_data <- function(Y = NULL, lav_mvreg_information_observed_samplestats(sample.res.int = sample.res.int, sample.res.slopes = sample.res.slopes, sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x, sample.cov.x = sample.cov.x, - Beta = Beta, res.int = res.int, res.slopes = res.slopes, + Beta = Beta, res.int = res.int, res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv) } @@ -543,7 +543,7 @@ lav_mvreg_information_observed_samplestats <- sample.cov.x + tcrossprod(sample.mean.x)) ) # W.tilde = S + t(B - Beta) %*% (1/N)*X'X %*% (B - Beta) - W.tilde <- ( sample.res.cov + + W.tilde <- ( sample.res.cov + t(sample.B - Beta) %*% sample.xx %*% (sample.B - Beta) ) # res.cov.inv @@ -580,8 +580,8 @@ lav_mvreg_information_firstorder <- function(Y = NULL, N <- NROW(Y) # scores - SC <- lav_mvreg_scores_beta_vech_sigma(Y = Y, eXo = eXo, Beta = Beta, - res.int = res.int, res.slopes = res.slopes, res.cov = res.cov, + SC <- lav_mvreg_scores_beta_vech_sigma(Y = Y, eXo = eXo, Beta = Beta, + res.int = res.int, res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv) crossprod(SC)/N diff --git a/R/lav_nlminb_constr.R b/R/lav_nlminb_constr.R index bdc32836..d5f54b43 100644 --- a/R/lav_nlminb_constr.R +++ b/R/lav_nlminb_constr.R @@ -1,14 +1,14 @@ -# constrained optimization +# constrained optimization # - references: * Nocedal & Wright (2006) Chapter 17 # * Optimization with constraints by Madsen, Nielsen & Tingleff # * original papers: Powell, 1969 and Rockafeller, 1974 # - using 'nlminb' for the unconstrained subproblem # - convergence scheme is based on the auglag function in the alabama package -nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, +nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, ..., scale = 1, control = list(), lower = -Inf, upper = Inf, ceq = NULL, ceq.jac = NULL, - cin = NULL, cin.jac = NULL, + cin = NULL, cin.jac = NULL, control.outer = list()) { # we need a gradient @@ -56,7 +56,7 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, itmax = 100L, verbose = FALSE) control.outer <- modifyList(control.outer.default, control.outer) - + # construct augmented lagrangian function auglag <- function(x, ...) { @@ -77,7 +77,7 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, # jacobian JAC <- rbind(ceq.jac(x, ...), cin.jac(x, ...)) lambda.JAC <- lambda * JAC - + # handle inactive constraints if(ncin > 0L) { slack <- lambda/mu @@ -88,7 +88,7 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, con0 <- con0[-inactive.idx] } } - + if(nrow(JAC) > 0L) { ( gradient(x, ...) - colSums(lambda.JAC) + mu * as.numeric(t(JAC) %*% con0) ) @@ -132,14 +132,14 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, x.par <- start for (i in 1:control.outer$itmax) { x.old <- x.par - r.old <- r + r.old <- r ############################################################ - if(control.outer$verbose) { + if(control.outer$verbose) { cat("\nStarting inner optimization [",i,"]:\n") cat("lambda: ", lambda, "\n") cat("mu: ", mu, "\n") } - optim.out <- nlminb(start = x.par, objective = auglag, + optim.out <- nlminb(start = x.par, objective = auglag, gradient = fgrad, control = control, scale = scale, ...) ############################################################ @@ -178,12 +178,12 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, pconv <- max(abs(x.par - x.old)) if(pconv < control.outer$tol) { ilack <- ilack + 1L - } else { + } else { ilack <- 0L } - if( (is.finite(r) && is.finite(r.old) && - abs(r - r.old) < control.outer$tol && K < control.outer$tol) | + if( (is.finite(r) && is.finite(r.old) && + abs(r - r.old) < control.outer$tol && K < control.outer$tol) | ilack >= 3 ) break } @@ -205,12 +205,12 @@ nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, a$lambda <- lambda a$mu <- mu #a$value <- objective(a$start, ...) - #a$cin <- cin(a$start, ...) + #a$cin <- cin(a$start, ...) #a$ceq <- ceq(a$start, ...) a$evaluations <- c(feval, geval) a$iterations <- niter - #a$kkt1 <- max(abs(a$fgrad)) <= 0.01 * (1 + abs(a$value)) - #a$kkt2 <- any(eigen(a$hessian)$value * control.optim$objectivescale> 0) + #a$kkt1 <- max(abs(a$fgrad)) <= 0.01 * (1 + abs(a$value)) + #a$kkt2 <- any(eigen(a$hessian)$value * control.optim$objectivescale> 0) # jacobian of ceq and 'active' cin ceq0 <- ceq(a$par, ...); cin0 <- cin(a$par, ...); con0 <- c(ceq0, cin0) diff --git a/R/lav_object_generate.R b/R/lav_object_generate.R index d41fdeef..d6674697 100644 --- a/R/lav_object_generate.R +++ b/R/lav_object_generate.R @@ -4,8 +4,8 @@ # 3. model + extra parameters (for modindices/lavTestScore) -# 1. fit an 'independence' model -# note that for ML (and ULS and DWLS), the 'estimates' of the +# 1. fit an 'independence' model +# note that for ML (and ULS and DWLS), the 'estimates' of the # independence model are simply the observed variances # but for GLS and WLS, this is not the case!! lav_object_independence <- function(object, se = FALSE, verbose = FALSE, @@ -24,7 +24,7 @@ lav_object_independence <- function(object, se = FALSE, verbose = FALSE, } } else { ## FIXME: if test = scaled, we need it anyway? - lavoptions$se <- "none" + lavoptions$se <- "none" } # set baseline/h1 to FALSE @@ -33,7 +33,7 @@ lav_object_independence <- function(object, se = FALSE, verbose = FALSE, lavoptions$loglik <- TRUE # eg for multilevel lavoptions$implied <- TRUE #, needed for loglik lavoptions$check <- character(0L) - + # ALWAYS do.fit lavoptions$do.fit <- TRUE @@ -62,8 +62,8 @@ lav_object_independence <- function(object, se = FALSE, verbose = FALSE, lavsamplestats = object@SampleStats, lavoptions = object@Options) } - - FIT <- lavaan(lavpartable, + + FIT <- lavaan(lavpartable, slotOptions = lavoptions, slotSampleStats = object@SampleStats, slotData = object@Data, @@ -91,9 +91,9 @@ lav_object_unrestricted <- function(object, se = FALSE, verbose = FALSE, } } else { ## FIXME: if test = scaled, we need it anyway? - lavoptions$se <- "none" + lavoptions$se <- "none" } - + # ALWAYS do.fit lavoptions$do.fit <- TRUE @@ -137,7 +137,7 @@ lav_object_unrestricted <- function(object, se = FALSE, verbose = FALSE, lav_object_extended <- function(object, add = NULL, remove.duplicated = TRUE, all.free = FALSE, - verbose = FALSE, warn = FALSE, + verbose = FALSE, warn = FALSE, do.fit = FALSE) { # partable original model @@ -160,10 +160,10 @@ lav_object_extended <- function(object, add = NULL, } else { partable$block <- rep(1L, length(partable$lhs)) } - + # TDJ: Added to prevent error when lav_partable_merge() is called below. # Problematic if object@ParTable is missing one of the requested slots, - # which returns a NULL slot with a missing name. For example: + # which returns a NULL slot with a missing name. For example: # example(cfa) # lav_partable_independence(lavdata = fit@Data, lavpta = fit@pta, # lavoptions = lavInspect(fit, "options")) @@ -172,7 +172,7 @@ lav_object_extended <- function(object, add = NULL, if(length(empties)) { partable[empties] <- NULL } - + if(all.free) { partable$user <- rep(1L, length(partable$lhs)) non.free.idx <- which(partable$free == 0L & partable$op != "==" & @@ -181,11 +181,11 @@ lav_object_extended <- function(object, add = NULL, partable$free[ non.free.idx ] <- 1L partable$user[ non.free.idx ] <- 10L } - + # replace 'start' column, since lav_model will fill these in in GLIST partable$start <- parameterEstimates(object, remove.system.eq = FALSE, remove.def = FALSE, - remove.eq = FALSE, + remove.eq = FALSE, remove.ineq = FALSE)$est # add new parameters, extend model @@ -215,7 +215,7 @@ lav_object_extended <- function(object, add = NULL, } else { ADD$block <- rep(1L, length(ADD$lhs)) } - + remove.idx <- which(ADD$user == 0) if(length(remove.idx) > 0L) { ADD <- ADD[-remove.idx,] @@ -241,7 +241,7 @@ lav_object_extended <- function(object, add = NULL, # redo 'free' free.idx <- which(LIST$free > 0) LIST$free[free.idx] <- 1:length(free.idx) - + # adapt options lavoptions <- object@Options @@ -262,12 +262,12 @@ lav_object_extended <- function(object, add = NULL, } else { # old object -- for example 'usemmodelfit' in package 'pompom' - # add a few fields + # add a few fields lavoptions$h1 <- FALSE lavoptions$implied <- FALSE lavoptions$baseline <- FALSE lavoptions$loglik <- FALSE - + # add a few slots object@Data@weights <- vector("list", object@Data@ngroups) object@Model@estimator <- object@Options$estimator diff --git a/R/lav_object_inspect.R b/R/lav_object_inspect.R index e469a1ed..7c82f6b9 100644 --- a/R/lav_object_inspect.R +++ b/R/lav_object_inspect.R @@ -10,11 +10,11 @@ inspect.lavaan <- function(object, what = "free", ...) { } # the `tech' version: no labels, full matrices, ... for further processing -lavTech.lavaan <- function(object, +lavTech.lavaan <- function(object, what = "free", add.labels = FALSE, add.class = FALSE, - list.by.group = FALSE, + list.by.group = FALSE, drop.list.single.group = FALSE) { lavInspect.lavaan(object, what = what, @@ -45,61 +45,61 @@ lavInspect.lavaan <- function(object, #### model matrices, with different contents #### if(what == "free") { - lav_object_inspect_modelmatrices(object, what = "free", + lav_object_inspect_modelmatrices(object, what = "free", type = "free", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "impute" || what == "imputed") { # just to ease the transition for semTools! object@imputed } else if(what == "partable" || what == "user") { - lav_object_inspect_modelmatrices(object, what = "free", + lav_object_inspect_modelmatrices(object, what = "free", type="partable", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "se" || what == "std.err" || what == "standard.errors") { lav_object_inspect_modelmatrices(object, what = "se", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "start" || what == "starting.values") { lav_object_inspect_modelmatrices(object, what = "start", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "est" || what == "estimates" || what == "x") { lav_object_inspect_modelmatrices(object, what = "est", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, #list.by.group = FALSE, for semTools only drop.list.single.group = drop.list.single.group) } else if(what == "dx.free") { lav_object_inspect_modelmatrices(object, what = "dx.free", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "dx.all") { lav_object_inspect_modelmatrices(object, what = "dx.all", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "std" || what == "std.all" || what == "standardized") { lav_object_inspect_modelmatrices(object, what = "std.all", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "std.lv") { lav_object_inspect_modelmatrices(object, what = "std.lv", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) } else if(what == "std.nox") { lav_object_inspect_modelmatrices(object, what = "std.nox", add.labels = add.labels, add.class = add.class, - list.by.group = list.by.group, + list.by.group = list.by.group, drop.list.single.group = drop.list.single.group) @@ -132,7 +132,7 @@ lavInspect.lavaan <- function(object, what == "sample" || what == "samplestatistics") { lav_object_inspect_sampstat(object, h1 = FALSE, - add.labels = add.labels, add.class = add.class, + add.labels = add.labels, add.class = add.class, drop.list.single.group = drop.list.single.group) } else if(what == "h1" || what == "missing.h1" || what == "sampstat.h1") { lav_object_inspect_sampstat(object, h1 = TRUE, @@ -157,11 +157,11 @@ lavInspect.lavaan <- function(object, #### data + missingness #### } else if(what == "data") { - lav_object_inspect_data(object, + lav_object_inspect_data(object, drop.list.single.group = drop.list.single.group) } else if(what == "case.idx") { lav_object_inspect_case_idx(object, - drop.list.single.group = drop.list.single.group) + drop.list.single.group = drop.list.single.group) } else if(what == "ngroups") { object@Data@ngroups } else if(what == "group") { @@ -193,7 +193,7 @@ lavInspect.lavaan <- function(object, #### rsquare #### } else if(what == "rsquare" || what == "r-square" || what == "r2") { - lav_object_inspect_rsquare(object, + lav_object_inspect_rsquare(object, add.labels = add.labels, add.class = add.class, drop.list.single.group = drop.list.single.group) @@ -265,7 +265,7 @@ lavInspect.lavaan <- function(object, lav_object_inspect_theta(object, correlation.metric = TRUE, add.labels = add.labels, add.class = add.class, drop.list.single.group = drop.list.single.group) - + #### convergence, meanstructure, categorical #### @@ -286,7 +286,7 @@ lavInspect.lavaan <- function(object, } else if(what == "npar") { lav_object_inspect_npar(object, type = "free") } else if(what == "coef") { - # this breaks simsem and semTools -- 0.6-1 + # this breaks simsem and semTools -- 0.6-1 #lav_object_inspect_coef(object, type = "free", # add.labels = add.labels, add.class = add.class) lav_object_inspect_modelmatrices(object, what = "est", @@ -328,7 +328,7 @@ lavInspect.lavaan <- function(object, lav_object_inspect_information(object, information = "observed", augmented = FALSE, inverted = FALSE, add.labels = add.labels, add.class = add.class) - } else if(what == "information.first.order" || + } else if(what == "information.first.order" || what == "information.firstorder" || what == "first.order") { lav_object_inspect_information(object, information = "first.order", @@ -365,7 +365,7 @@ lavInspect.lavaan <- function(object, lav_object_inspect_information(object, information = "observed", augmented = TRUE, inverted = TRUE, add.labels = add.labels, add.class = add.class) - } else if(what == "inverted.information.first.order" || + } else if(what == "inverted.information.first.order" || what == "inverted.first.order") { lav_object_inspect_information(object, information = "first.order", augmented = TRUE, inverted = TRUE, @@ -474,7 +474,7 @@ lavInspect.lavaan <- function(object, # helper functions (mostly to deal with older 'object' that may have # been saved somewhere) lav_object_inspect_est <- function(object) { - + if(inherits(object, "lavaan")) { # from 0.5-19, they are in the partable if(!is.null(object@ParTable$est)) { @@ -499,7 +499,7 @@ lav_object_inspect_est <- function(object) { } lav_object_inspect_se <- function(object) { - + # from 0.5-19, they are in the partable if(!is.null(object@ParTable$se)) { OUT <- object@ParTable$se @@ -639,7 +639,7 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", m.user.idx <- object@Model@m.user.idx[[mm]] x.user.idx <- object@Model@x.user.idx[[mm]] GLIST[[mm]][m.user.idx] <- STD[x.user.idx] - } + } # class if(add.class) { @@ -664,7 +664,7 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", LABEL <- names(ID) for(con in 1:nrow(CON)) { # lhs - LHS.labels <- all.vars(as.formula(paste("~",CON[con,"lhs"]))) + LHS.labels <- all.vars(as.formula(paste("~",CON[con,"lhs"]))) if(length(LHS.labels) > 0L) { # par id @@ -696,7 +696,7 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", # add this info at the top #GLIST <- c(constraints = list(CON), GLIST) #no, not a good idea, it does not work with list.by.group - + # add it as a 'header' attribute? attr(CON, "header") <- "Note: model contains equality constraints:" con.flag <- TRUE @@ -710,7 +710,7 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", OUT <- vector("list", length = lavmodel@nblocks) for(b in seq_len(lavmodel@nblocks)) { - # which mm belong to this block? + # which mm belong to this block? mm.in.group <- 1:nmat[b] + cumsum(c(0,nmat))[b] mm.names <- names( GLIST[mm.in.group] ) @@ -720,10 +720,10 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", if(lavmodel@nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) - } else if(object@Data@nlevels > 1L && + } else if(object@Data@nlevels > 1L && length(object@Data@group.label) == 0L) { names(OUT) <- object@Data@level.label } @@ -750,7 +750,7 @@ lav_object_inspect_modelmatrices <- function(object, what = "free", # - fixme, should we export this function? # - since 0.5-21, conditional.x = TRUE returns residual sample statistics -# for ML, we have both joint and residual cov/var/...; but for +# for ML, we have both joint and residual cov/var/...; but for # categorical = TRUE, we only have residual cov/var...; so, we # only return residual in both cases, whenever residual # - since 0.6-1, we extract the values from the @h1 slot (if present) @@ -794,7 +794,7 @@ lav_object_inspect_sampstat <- function(object, h1 = FALSE, OUT[[b]]$cov <- lavsamplestats@cov[[b]] } if(add.labels && !is.null(OUT[[b]]$cov)) { - rownames(OUT[[b]]$cov) <- colnames(OUT[[b]]$cov) <- + rownames(OUT[[b]]$cov) <- colnames(OUT[[b]]$cov) <- ov.names[[b]] } if(add.class) { @@ -843,14 +843,14 @@ lav_object_inspect_sampstat <- function(object, h1 = FALSE, OUT[[b]]$res.cov <- lavsamplestats@res.cov[[b]] } if(add.labels) { - rownames(OUT[[b]]$res.cov) <- colnames(OUT[[b]]$res.cov) <- + rownames(OUT[[b]]$res.cov) <- colnames(OUT[[b]]$res.cov) <- ov.names.res[[b]] } if(add.class) { - class(OUT[[b]]$res.cov) <- + class(OUT[[b]]$res.cov) <- c("lavaan.matrix.symmetric", "matrix") } - + # intercepts if(object@Model@meanstructure) { if(h1) { @@ -909,12 +909,12 @@ lav_object_inspect_sampstat <- function(object, h1 = FALSE, colnames(OUT[[b]]$cov.x) <- ov.names.x[[b]] } if(add.class) { - class(OUT[[b]]$cov.x) <- + class(OUT[[b]]$cov.x) <- c("lavaan.matrix.symmetric", "matrix") } } - # mean.x + # mean.x if(object@Model@nexo > 0L) { OUT[[b]]$mean.x <- as.numeric(object@SampleStats@mean.x[[b]]) if(add.labels) { @@ -929,9 +929,9 @@ lav_object_inspect_sampstat <- function(object, h1 = FALSE, # stochastic weights if(object@Model@group.w.free) { - # to be consistent with the 'implied' values, + # to be consistent with the 'implied' values, # transform so group.w is the 'log(group.freq)' - OUT[[b]]$group.w <- + OUT[[b]]$group.w <- log(lavsamplestats@group.w[[b]] * lavsamplestats@ntotal) if(add.labels) { names(OUT[[b]]$group.w) <- "w" @@ -945,7 +945,7 @@ lav_object_inspect_sampstat <- function(object, h1 = FALSE, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1015,9 +1015,9 @@ lav_object_inspect_rsquare <- function(object, est.std.all=NULL, partable$rsquare[partable$rsquare > 1.0] <- as.numeric(NA) for(b in seq_len(nblocks)) { - ind.names <- partable$rhs[ which(partable$op == "=~" & + ind.names <- partable$rhs[ which(partable$op == "=~" & partable$block == b) ] - eqs.y.names <- partable$lhs[ which(partable$op == "~" & + eqs.y.names <- partable$lhs[ which(partable$op == "~" & partable$block == b) ] y.names <- unique( c(ind.names, eqs.y.names) ) @@ -1038,16 +1038,16 @@ lav_object_inspect_rsquare <- function(object, est.std.all=NULL, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) - } else if(object@Data@nlevels > 1L && + } else if(object@Data@nlevels > 1L && length(object@Data@group.label) == 0L) { names(OUT) <- object@Data@level.label } } - OUT + OUT } # model implied sample stats @@ -1164,7 +1164,7 @@ lav_object_inspect_implied <- function(object, } } - # mean.x + # mean.x if(object@Model@nexo > 0L) { OUT[[b]]$mean.x <- as.numeric(object@SampleStats@mean.x[[b]]) if(add.labels) { @@ -1174,7 +1174,7 @@ lav_object_inspect_implied <- function(object, class(OUT[[b]]$mean.x) <- c("lavaan.vector", "numeric") } } - + } # conditional.x @@ -1193,10 +1193,10 @@ lav_object_inspect_implied <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) - } else if(object@Data@nlevels > 1L && + } else if(object@Data@nlevels > 1L && length(object@Data@group.label) == 0L) { names(OUT) <- object@Data@level.label } @@ -1229,7 +1229,7 @@ lav_object_inspect_residuals <- function(object, h1 = TRUE, resList[[b]]$res.cov <- ( obsList[[b]]$res.cov - estList[[b]]$res.cov ) if(add.class) { - class(resList[[b]]$res.cov) <- + class(resList[[b]]$res.cov) <- c("lavaan.matrix.symmetric", "matrix") } } @@ -1261,7 +1261,7 @@ lav_object_inspect_residuals <- function(object, h1 = TRUE, resList[[b]]$cov.x <- ( obsList[[b]]$cov.x - estList[[b]]$cov.x ) if(add.class) { - class(resList[[b]]$cov.x) <- + class(resList[[b]]$cov.x) <- c("lavaan.matrix.symmetric", "matrix") } } @@ -1279,7 +1279,7 @@ lav_object_inspect_residuals <- function(object, h1 = TRUE, resList[[b]]$cov <- ( obsList[[b]]$cov - estList[[b]]$cov ) if(add.class) { - class(resList[[b]]$cov) <- + class(resList[[b]]$cov) <- c("lavaan.matrix.symmetric", "matrix") } } @@ -1303,7 +1303,7 @@ lav_object_inspect_residuals <- function(object, h1 = TRUE, # free group.w if(!is.null(estList[[b]]$group.w)) { - resList[[b]]$group.w <- ( obsList[[b]]$group.w - + resList[[b]]$group.w <- ( obsList[[b]]$group.w - estList[[b]]$group.w ) if(add.class) { class(resList[[b]]$group.w) <- @@ -1347,7 +1347,7 @@ lav_object_inspect_cov_lv <- function(object, correlation.metric = FALSE, } if(add.labels) { - colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- + colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- object@pta$vnames$lv[[b]] } @@ -1359,7 +1359,7 @@ lav_object_inspect_cov_lv <- function(object, correlation.metric = FALSE, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1375,7 +1375,7 @@ lav_object_inspect_mean_lv <- function(object, add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) { # compute lv means - OUT <- computeEETA(lavmodel = object@Model, + OUT <- computeEETA(lavmodel = object@Model, lavsamplestats = object@SampleStats, remove.dummy.lv = TRUE) @@ -1398,7 +1398,7 @@ lav_object_inspect_mean_lv <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1414,7 +1414,7 @@ lav_object_inspect_cov_all <- function(object, correlation.metric = FALSE, add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) { # compute extended model implied covariance matrix (both ov and lv) - OUT <- computeCOV(lavmodel = object@Model, + OUT <- computeCOV(lavmodel = object@Model, remove.dummy.lv = TRUE) # nblocks @@ -1441,7 +1441,7 @@ lav_object_inspect_cov_all <- function(object, correlation.metric = FALSE, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1468,14 +1468,14 @@ lav_object_inspect_cov_ov <- function(object, correlation.metric = FALSE, # cor + labels + class for(b in seq_len(nblocks)) { - + if(correlation.metric && nrow(OUT[[b]]) > 1L) { # note: cov2cor fails if matrix is empty! OUT[[b]] <- cov2cor(OUT[[b]]) } if(add.labels) { - colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- + colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- object@pta$vnames$ov.model[[b]] } if(add.class) { @@ -1486,7 +1486,7 @@ lav_object_inspect_cov_ov <- function(object, correlation.metric = FALSE, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1510,7 +1510,7 @@ lav_object_inspect_mean_ov <- function(object, # nblocks nblocks <- length(OUT) - + # make numeric OUT <- lapply(OUT, as.numeric) @@ -1527,7 +1527,7 @@ lav_object_inspect_mean_ov <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1572,7 +1572,7 @@ lav_object_inspect_th <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1592,7 +1592,7 @@ lav_object_inspect_vy <- function(object, # - 1.0 (or delta^2) if categorical # - if also Gamma, cov.x is used (only if categorical) - OUT <- computeVY(lavmodel = object@Model, GLIST = NULL, + OUT <- computeVY(lavmodel = object@Model, GLIST = NULL, diagonal.only = TRUE) # nblocks @@ -1615,7 +1615,7 @@ lav_object_inspect_vy <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1639,13 +1639,13 @@ lav_object_inspect_theta <- function(object, correlation.metric = FALSE, # labels + class for(b in seq_len(nblocks)) { - + if(correlation.metric && nrow(OUT[[b]]) > 0L) { OUT[[b]] <- cov2cor(OUT[[b]]) } if(add.labels && length(OUT[[b]]) > 0L) { - colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- + colnames(OUT[[b]]) <- rownames(OUT[[b]]) <- object@pta$vnames$ov.model[[b]] } @@ -1657,7 +1657,7 @@ lav_object_inspect_theta <- function(object, correlation.metric = FALSE, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1675,7 +1675,7 @@ lav_object_inspect_missing_coverage <- function(object, G <- object@Data@ngroups OUT <- vector("list", G) - + for(g in 1:G) { if(!is.null(object@Data@Mp[[g]])) { OUT[[g]] <- object@Data@Mp[[g]]$coverage @@ -1710,7 +1710,7 @@ lav_object_inspect_missing_patterns <- function(object, G <- object@Data@ngroups OUT <- vector("list", G) - + for(g in 1:G) { if(!is.null(object@Data@Mp[[g]])) { OUT[[g]] <- object@Data@Mp[[g]]$pat @@ -1742,7 +1742,7 @@ lav_object_inspect_missing_patterns <- function(object, lav_object_inspect_empty_idx <- function(object, drop.list.single.group = FALSE) { - + G <- object@Data@ngroups # get empty idx @@ -1755,7 +1755,7 @@ lav_object_inspect_empty_idx <- function(object, OUT[[g]] <- integer(0L) } } - + if(G == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { @@ -1790,7 +1790,7 @@ lav_object_inspect_wls_est <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1824,7 +1824,7 @@ lav_object_inspect_wls_obs <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1854,7 +1854,7 @@ lav_object_inspect_wls_v <- function(object, # if estimator == "DWLS" or "ULS", we only stored the diagonal # hence, we create a full matrix here if(object@Options$estimator %in% c("DWLS", "ULS")) { - OUT <- lapply(OUT, + OUT <- lapply(OUT, function(x) { nr = NROW(x); diag(x, nrow=nr, ncol=nr) }) } @@ -1873,7 +1873,7 @@ lav_object_inspect_wls_v <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] } else { - if(object@Data@nlevels == 1L && + if(object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) { names(OUT) <- unlist(object@Data@group.label) } else if(object@Data@nlevels > 1L && @@ -1900,7 +1900,7 @@ lav_object_inspect_sampstat_gamma <- function(object, if(nblocks == 1L && drop.list.single.group) { OUT <- OUT[[1]] - if(add.class) { + if(add.class) { class(OUT) <- c("lavaan.matrix.symmetric", "matrix") } } else { @@ -1963,7 +1963,7 @@ lav_object_inspect_gradient <- function(object, N <- lavdata@Lp[[1]]$nclusters[[1]] nclusters <- lavdata@Lp[[1]]$nclusters[[2]] dx <- dx * (2 * N) / nclusters - } else { + } else { for(g in seq_len(lavdata@ngroups)) { N <- lavdata@Lp[[g]]$nclusters[[1]] nclusters <- lavdata@Lp[[g]]$nclusters[[2]] @@ -2040,14 +2040,14 @@ lav_object_inspect_hessian <- function(object, OUT } -lav_object_inspect_information <- function(object, +lav_object_inspect_information <- function(object, information = "default", augmented = FALSE, inverted = FALSE, add.labels = FALSE, add.class = FALSE) { if(information != "default") { # override option object@Options$information <- information - } + } OUT <- lav_model_information(lavmodel = object@Model, lavsamplestats = object@SampleStats, @@ -2080,7 +2080,7 @@ lav_object_inspect_information <- function(object, } # only to provide a direct function to the old 'getVariability()' function -lav_object_inspect_firstorder <- function(object, +lav_object_inspect_firstorder <- function(object, add.labels = FALSE, add.class = FALSE) { B0 <- lav_model_information_firstorder(lavmodel = object@Model, @@ -2132,7 +2132,7 @@ lav_object_inspect_vcov <- function(object, standardized = FALSE, ) } } - + # strip attributes attr(OUT, "E.inv") <- NULL attr(OUT, "B0") <- NULL @@ -2159,18 +2159,18 @@ lav_object_inspect_vcov <- function(object, standardized = FALSE, x = object@optim$x, lavobject = object) } } else if(type == "std.nox") { - JAC <- + JAC <- try(lav_func_jacobian_complex(func = lav_standardize_all_nox_x, x = object@optim$x, lavobject = object), silent = TRUE) if(inherits(JAC, "try-error")) { # eg. pnorm() - JAC <- + JAC <- lav_func_jacobian_simple(func = lav_standardize_all_nox_x, x = object@optim$x, lavobject = object) } } # JAC contains *all* parameters in the parameter table - if(free.only) { + if(free.only) { free.idx <- which(object@ParTable$free > 0L) JAC <- JAC[free.idx,, drop = FALSE] } @@ -2216,7 +2216,7 @@ lav_object_inspect_vcov_def <- function(object, standardized = FALSE, if(standardized) { # compute VCOV for "free" parameters only - VCOV <- lav_object_inspect_vcov(object, + VCOV <- lav_object_inspect_vcov(object, standardized = TRUE, type = type, free.only = FALSE, add.labels = FALSE, add.class = FALSE) @@ -2241,9 +2241,9 @@ lav_object_inspect_vcov_def <- function(object, standardized = FALSE, VCOV <- lav_object_inspect_vcov(object, standardized = FALSE, type = type, free.only = TRUE, - add.labels = FALSE, + add.labels = FALSE, add.class = FALSE) - + # regular delta method JAC <- try(lav_func_jacobian_complex(func = lavmodel@def.function, x = x), silent=TRUE) @@ -2336,10 +2336,10 @@ lav_object_inspect_delta <- function(object, lavpartable <- object@ParTable lavpta <- object@pta - OUT <- lav_object_inspect_delta_internal(lavmodel = lavmodel, + OUT <- lav_object_inspect_delta_internal(lavmodel = lavmodel, lavdata = lavdata, lavpartable = lavpartable, lavpta = lavpta, - add.labels = add.labels, add.class = add.class, - drop.list.single.group = drop.list.single.group) + add.labels = add.labels, add.class = add.class, + drop.list.single.group = drop.list.single.group) OUT } @@ -2389,11 +2389,11 @@ lav_object_inspect_delta_internal <- function(lavmodel = NULL, lavdata = NULL, names.cov <- names.cor <- names.var <- character(0L) names.mu <- names.pi <- names.th <- character(0L) names.gw <- character(0L) - + # Sigma # - if continuous: vech(Sigma) # - if categorical: first numeric variances, then - #tmp <- apply(expand.grid(ov.names, ov.names), 1L, + #tmp <- apply(expand.grid(ov.names, ov.names), 1L, # paste, collapse = "~~") #if(categorical) { @@ -2405,7 +2405,7 @@ lav_object_inspect_delta_internal <- function(lavmodel = NULL, lavdata = NULL, # NOTE: in 0.6-1, we use the same order, but 'label' in row-wise # format (eg x1 ~~ x2 instead of x2 ~~ x1) - tmp <- matrix(apply(expand.grid(ov.names, ov.names), 1L, + tmp <- matrix(apply(expand.grid(ov.names, ov.names), 1L, paste, collapse = "~~"), nrow = nvar) if(categorical) { names.cor <- lav_matrix_vechru(tmp, diagonal = FALSE) @@ -2422,7 +2422,7 @@ lav_object_inspect_delta_internal <- function(lavmodel = NULL, lavdata = NULL, # Pi if(conditional.x && lavmodel@nexo[g] > 0L) { - names.pi <- apply(expand.grid(ov.names, ov.names.x), 1L, + names.pi <- apply(expand.grid(ov.names, ov.names.x), 1L, paste, collapse = "~") } @@ -2446,8 +2446,8 @@ lav_object_inspect_delta_internal <- function(lavmodel = NULL, lavdata = NULL, if(lavdata@nlevels == 1L) { rownames(OUT[[g]]) <- c(names.gw, - names.th, names.mu, - names.pi, + names.th, names.mu, + names.pi, names.cov, names.var, names.cor) # class if(add.class) { @@ -2506,8 +2506,8 @@ lav_object_inspect_zero_cell_tables <- function(object, # select tables with empty cells empty.id <- TABLE$id[which(TABLE$obs.freq == 0)] - - + + if(length(empty.id) == 0L) { # only when lavInspect() is used, give message if(add.class) { @@ -2523,7 +2523,7 @@ lav_object_inspect_zero_cell_tables <- function(object, OUT } -lav_object_inspect_coef <- function(object, type = "free", +lav_object_inspect_coef <- function(object, type = "free", add.labels = FALSE, add.class = FALSE) { if(type == "user" || type == "all") { @@ -2553,7 +2553,7 @@ lav_object_inspect_coef <- function(object, type = "free", lav_object_inspect_npar <- function(object, type = "free") { if(type == "free") { - npar <- sum(object@ParTable$free > 0L & + npar <- sum(object@ParTable$free > 0L & !duplicated(object@ParTable$free)) } else { npar <- length(object@ParTable$lhs) @@ -2562,7 +2562,7 @@ lav_object_inspect_npar <- function(object, type = "free") { npar } -lav_object_inspect_icc <- function(object, add.labels = FALSE, +lav_object_inspect_icc <- function(object, add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) { @@ -2617,10 +2617,10 @@ lav_object_inspect_icc <- function(object, add.labels = FALSE, } } - OUT + OUT } -lav_object_inspect_ranef <- function(object, add.labels = FALSE, +lav_object_inspect_ranef <- function(object, add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) { @@ -2678,5 +2678,5 @@ lav_object_inspect_ranef <- function(object, add.labels = FALSE, } } - OUT + OUT } diff --git a/R/lav_object_methods.R b/R/lav_object_methods.R index 2f3df20f..104d1acc 100644 --- a/R/lav_object_methods.R +++ b/R/lav_object_methods.R @@ -205,7 +205,7 @@ function(object, header = TRUE, std.nox = FALSE, modindices = FALSE, nd = 3L) { - + # this is to avoid partial matching of 'std' with std.nox standardized <- std || standardized @@ -251,7 +251,7 @@ function(object, header = TRUE, setMethod("coef", "lavaan", function(object, type="free", labels=TRUE) { - lav_object_inspect_coef(object = object, type = type, + lav_object_inspect_coef(object = object, type = type, add.labels = labels, add.class = TRUE) }) @@ -503,7 +503,7 @@ parameterEstimates <- parameterestimates <- function(object, # add se, zstat, pvalue if(se && object@Options$se != "none") { LIST$se <- lav_object_inspect_se(object) - # handle tiny SEs + # handle tiny SEs LIST$se <- ifelse(LIST$se < sqrt(.Machine$double.eps), 0, LIST$se) tmp.se <- ifelse(LIST$se < sqrt(.Machine$double.eps), NA, LIST$se) if(zstat) { @@ -901,7 +901,7 @@ function(object, ...) { if(object@optim$npar > 0L && !object@optim$converged) { warning("lavaan WARNING: model did not converge") } - + # new in 0.6-1: we use the @loglik slot (instead of fitMeasures) if(.hasSlot(object, "loglik")) { LOGL <- object@loglik @@ -953,7 +953,7 @@ function(object, model, add, ..., evaluate = TRUE) { call$model$se <- NULL } if (!is.null(call$slotParTable) && is.list(call$model)) call$slotParTable <- call$model - + if (length(extras) > 0) { ## check for call$slotOptions conflicts if (!is.null(call$slotOptions)) { @@ -970,10 +970,10 @@ function(object, model, add, ..., evaluate = TRUE) { call <- as.call(call) } } - + if (missing(add) && !evaluate) return(call) ## for any of the other 3 scenarios, we need the updated fit - + ## Check if "add" and "model" are both strings; combine them if (missing(add)) { ADD.already.in.parTable <- TRUE # because nothing to add @@ -985,7 +985,7 @@ function(object, model, add, ..., evaluate = TRUE) { } newfit <- eval(call, parent.frame()) if (ADD.already.in.parTable && evaluate) return(newfit) - + ## only remaining situations: "add" exists, but either "add" or "model" ## is a parameter table, so update the parameter table in the call if (!(mode(add) %in% c("list","character"))) { @@ -1000,7 +1000,7 @@ function(object, model, add, ..., evaluate = TRUE) { PT$est <- NULL PT$se <- NULL call$model <- PT - + if (evaluate) { eval(call, parent.frame()) } diff --git a/R/lav_object_post_check.R b/R/lav_object_post_check.R index 73daa988..10c914c0 100644 --- a/R/lav_object_post_check.R +++ b/R/lav_object_post_check.R @@ -38,7 +38,7 @@ lav_object_post_check <- function(object, verbose = FALSE) { if(any(eigvals < -1 * .Machine$double.eps^(3/4))) { warning( "lavaan WARNING: covariance matrix of latent variables\n", -" is not positive definite", txt.group, ";\n", +" is not positive definite", txt.group, ";\n", " use lavInspect(fit, \"cov.lv\") to investigate.") result.ok <- FALSE } @@ -59,7 +59,7 @@ lav_object_post_check <- function(object, verbose = FALSE) { only.values = TRUE)$values if(any(eigvals < -1 * .Machine$double.eps^(3/4))) { warning( -"lavaan WARNING: the covariance matrix of the residuals of the observed\n", +"lavaan WARNING: the covariance matrix of the residuals of the observed\n", " variables (theta) is not positive definite", txt.group, ";\n", " use lavInspect(fit, \"theta\") to investigate.") result.ok <- FALSE diff --git a/R/lav_object_print.R b/R/lav_object_print.R index d374c7d0..8a364142 100644 --- a/R/lav_object_print.R +++ b/R/lav_object_print.R @@ -3,9 +3,9 @@ # header lav_object_print_header <- function(object) { - cat(sprintf("lavaan %s ", + cat(sprintf("lavaan %s ", packageDescription("lavaan", fields="Version"))) - + # catch FAKE run FAKE <- FALSE if(object@Options$optim.method == "none") { diff --git a/R/lav_objective.R b/R/lav_objective.R index f719a48a..e4e3ebd9 100644 --- a/R/lav_objective.R +++ b/R/lav_objective.R @@ -1,5 +1,5 @@ # fitting function for standard ML -estimator.ML <- function(Sigma.hat=NULL, Mu.hat=NULL, +estimator.ML <- function(Sigma.hat=NULL, Mu.hat=NULL, data.cov=NULL, data.mean=NULL, data.cov.log.det=NULL, meanstructure=FALSE) { @@ -31,7 +31,7 @@ estimator.ML <- function(Sigma.hat=NULL, Mu.hat=NULL, # fitting function for standard ML estimator.ML_res <- function(Sigma.hat=NULL, Mu.hat=NULL, PI=NULL, res.cov=NULL, res.int=NULL, res.slopes=NULL, - res.cov.log.det=NULL, + res.cov.log.det=NULL, cov.x = NULL, mean.x = NULL) { if(!attr(Sigma.hat, "po")) return(Inf) @@ -67,7 +67,7 @@ estimator.REML <- function(Sigma.hat=NULL, Mu.hat=NULL, data.cov=NULL, data.mean=NULL, data.cov.log.det=NULL, meanstructure=FALSE, - group = 1L, lavmodel = NULL, + group = 1L, lavmodel = NULL, lavsamplestats = NULL, lavdata = NULL) { if(!attr(Sigma.hat, "po")) return(Inf) @@ -153,8 +153,8 @@ estimator.DWLS <- function(WLS.est = NULL, WLS.obs = NULL, WLS.VD = NULL) { fx } -# Full Information ML estimator (FIML) handling the missing values -estimator.FIML <- function(Sigma.hat = NULL, Mu.hat = NULL, Yp = NULL, +# Full Information ML estimator (FIML) handling the missing values +estimator.FIML <- function(Sigma.hat = NULL, Mu.hat = NULL, Yp = NULL, h1 = NULL, N = NULL) { if(is.null(N)) { @@ -183,7 +183,7 @@ estimator.FIML <- function(Sigma.hat = NULL, Mu.hat = NULL, Yp = NULL, # some changes: # - no distinction between x/y (ksi/eta) # - 29/03/2016: adapt for exogenous covariates -# - 21/09/2016: added code for missing = doubly.robust (contributed by +# - 21/09/2016: added code for missing = doubly.robust (contributed by # Myrsini Katsikatsou) estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor Mu.hat = NULL, # model-based means @@ -197,11 +197,11 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor missing = NULL) { # how to deal with missings? # YR 3 okt 2012 - # - the idea is to compute for each pair of variables, the model-based - # probability (or likelihood in mixed case) (that we observe the data - # for this pair under the model) + # - the idea is to compute for each pair of variables, the model-based + # probability (or likelihood in mixed case) (that we observe the data + # for this pair under the model) # - if we have exogenous variables + condidional.x, do this for each case - # - after taking logs, the sum over the cases gives the + # - after taking logs, the sum over the cases gives the # log probablity/likelihood for this pair # - the sum over all pairs gives the final PL based logl @@ -224,12 +224,12 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor Cor.hat <- cov2cor(Sigma.hat2) # to get correlations (rho!) cors <- lav_matrix_vech(Cor.hat, diagonal = FALSE) - if(length(cors) > 0L && (any(abs(cors) > 1) || + if(length(cors) > 0L && (any(abs(cors) > 1) || any(is.na(cors)))) { # question: what is the best approach here?? OUT <- +Inf attr(OUT, "logl") <- as.numeric(NA) - return(OUT) + return(OUT) } nvar <- nrow(Sigma.hat) @@ -249,7 +249,7 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor ##### 1) all ordered, no exogenous (fast!) ##### 2) mixed ordered + continuous, no exogenous ##### 3) mixed ordered + continuous, exogenous (conditional.x = TRUE) - + @@ -261,16 +261,16 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor # prepare for Myrsini's vectorization scheme LONG2 <- LongVecTH.Rho(no.x = nvar, all.thres = TH, - index.var.of.thres = th.idx, + index.var.of.thres = th.idx, rho.xixj = cors) # get expected probability per table, per pair - pairwisePI <- pairwiseExpProbVec(ind.vec = lavcache$LONG, + pairwisePI <- pairwiseExpProbVec(ind.vec = lavcache$LONG, th.rho.vec = LONG2) pairwisePI_orig <- pairwisePI # for doubly.robust # get frequency per table, per pair logl <- sum(lavcache$bifreq * log(pairwisePI)) - + # more convenient fit function prop <- lavcache$bifreq / lavcache$nobs freq <- lavcache$bifreq @@ -281,7 +281,7 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor freq <- freq[-zero.idx] prop <- prop[-zero.idx] pairwisePI <- pairwisePI[-zero.idx] - } + } ##Fmin <- sum( prop*log(prop/pairwisePI) ) Fmin <- sum( freq * log(prop/pairwisePI) ) # to avoid 'N' @@ -298,7 +298,7 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor uniprop <- unifreq / uninobs - # remove zero props + # remove zero props # uni.zero.idx <- which(uniprop == 0.0) uni.zero.idx <- which( (uniprop == 0.0) | !is.finite(uniprop) ) if(length(uni.zero.idx) > 0L) { @@ -316,36 +316,36 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor #SUM_{i,j} [ E_{Yi,Yj|y^o}(lnf(Yi,Yj))) ] #First compute the terms of the summand. Since the cells of - # pairwiseProbGivObs are zero for the pairs of variables that at least + # pairwiseProbGivObs are zero for the pairs of variables that at least #one of the variables is observed (hence not contributing to the summand) - #there is no need to construct an index vector for summing appropriately + #there is no need to construct an index vector for summing appropriately #within each individual. log_pairwisePI_orig <- log(pairwisePI_orig) pairwiseProbGivObs <- lavcache$pairwiseProbGivObs tmp_prod <- t(t(pairwiseProbGivObs)*log_pairwisePI_orig) - + SumElnfijCasewise <- apply(tmp_prod, 1, sum) SumElnfij <- sum(SumElnfijCasewise) logl <- logl + SumElnfij Fmin <- Fmin - SumElnfij - # COMPUTE THE THE SUM OF THE EXPECTED UNIVARIATE CONDITIONAL LIKELIHOODS + # COMPUTE THE THE SUM OF THE EXPECTED UNIVARIATE CONDITIONAL LIKELIHOODS # SUM_{i,j} [ E_{Yj|y^o}(lnf(Yj|yi))) ] #First compute the model-implied conditional univariate probabilities # p(y_i=a|y_j=b). Let ModProbY1Gy2 be the vector of these # probabilities. The order the probabilities - #are listed in the vector ModProbY1Gy2 is as follows: + #are listed in the vector ModProbY1Gy2 is as follows: # y1|y2, y1|y3, ..., y1|yp, y2|y1, y2|y3, ..., y2|yp, # ..., yp|y1, yp|y2, ..., yp|y(p-1). Within each pair of variables the - #index "a" which represents the response category of variable yi runs faster than + #index "a" which represents the response category of variable yi runs faster than #"b" which represents the response category of the given variable yj. #The computation of these probabilities are based on the model-implied #bivariate probabilities p(y_i=a,y_j=b). To do the appropriate summations #and divisions we need some index vectors to keep track of the index i, j, - #a, and b, as well as the pair index. These index vectors should be + #a, and b, as well as the pair index. These index vectors should be #computed once and stored in lavcache. About where in the lavaan code - #we will add the computations and how they will be done please see the + #we will add the computations and how they will be done please see the #file "new objects in lavcache for DR-PL.r" idx.pairs <- lavcache$idx.pairs @@ -372,14 +372,14 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor log_ModProbY1Gy2 <- log(ModProbY1Gy2) - #Let univariateProbGivObs be the matrix of the conditional univariate + #Let univariateProbGivObs be the matrix of the conditional univariate # probabilities Pr(y_i=a|y^o) that has been computed in advance and are - #fed to the DR-PL function. The rows represent different individuals, + #fed to the DR-PL function. The rows represent different individuals, #i.e. nrow=nobs, and the columns different probabilities. The columns - # are listed as follows: a runs faster than i. - - #Note that the number of columns of univariateProbGivObs is not the - #same with the length(log_ModProbY1Gy2), actually + # are listed as follows: a runs faster than i. + + #Note that the number of columns of univariateProbGivObs is not the + #same with the length(log_ModProbY1Gy2), actually #ncol(univariateProbGivObs) < length(log_ModProbY1Gy2). #For this we use the following commands in order to multiply correctly. @@ -391,14 +391,14 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor id.cases.with.missing <- which(uniweights.casewise > 0) no.cases.with.missing <- length(id.cases.with.missing) no.obs.casewise <- nvar - uniweights.casewise - idx.missing.var <- apply(X, 1, function(x) { - which(is.na(x)) + idx.missing.var <- apply(X, 1, function(x) { + which(is.na(x)) }) idx.observed.var <- lapply(idx.missing.var, function(x) { - c(1:nvar)[-x] + c(1:nvar)[-x] }) idx.cat.observed.var <- sapply(1:nobs, function(i) { - X[i, idx.observed.var[[i]]] + X[i, idx.observed.var[[i]]] }) ElnyiGivyjbCasewise <- sapply(1:no.cases.with.missing,function(i) { tmp.id.case <- id.cases.with.missing[i] @@ -424,7 +424,7 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor # for the Fmin function Fmin <- Fmin - ElnyiGivyjb - } #end of if (missing =="doubly.robust") + } #end of if (missing =="doubly.robust") ##### Case 2: @@ -452,8 +452,8 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor } else if(ov.types[i] == "numeric" && ov.types[j] == "ordered") { # polyserial correlation - logLIK <- ps_loglik_no_exo(Y1 = X[,i], Y2 = X[,j], - var.y1 = Sigma.hat[i,i], + logLIK <- ps_loglik_no_exo(Y1 = X[,i], Y2 = X[,j], + var.y1 = Sigma.hat[i,i], eta.y1 = rep(Mu.hat[i], N), th.y2 = TH[ th.idx == j ], rho = Cor.hat[i,j]) @@ -461,20 +461,20 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor } else if(ov.types[j] == "numeric" && ov.types[i] == "ordered") { # polyserial correlation - logLIK <- ps_loglik_no_exo(Y1 = X[,j], Y2 = X[,i], + logLIK <- ps_loglik_no_exo(Y1 = X[,j], Y2 = X[,i], var.y1 = Sigma.hat[j,j], eta.y1 = rep(Mu.hat[j], N), th.y2 = TH[ th.idx == i ], rho = Cor.hat[i,j]) logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE) - } else if(ov.types[i] == "ordered" && + } else if(ov.types[i] == "ordered" && ov.types[j] == "ordered") { # polychoric correlation - pairwisePI <- pc_PI(rho = Cor.hat[i,j], + pairwisePI <- pc_PI(rho = Cor.hat[i,j], th.y1 = TH[ th.idx == i ], th.y2 = TH[ th.idx == j ]) # avoid zeroes - pairwisePI[ pairwisePI < .Machine$double.eps] <- + pairwisePI[ pairwisePI < .Machine$double.eps] <- .Machine$double.eps # note: missing values are just not counted FREQ <- pc_freq(X[,i], X[,j]) @@ -511,37 +511,37 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor for(i in (j+1L):nvar) { pstar.idx <- PSTAR[i,j] # cat("pstar.idx =", pstar.idx, "i = ", i, " j = ", j, "\n") - if(ov.types[i] == "numeric" && + if(ov.types[i] == "numeric" && ov.types[j] == "numeric") { # ordinary pearson correlation LIK[,pstar.idx] <- pp_lik(Y1 = X[,i], Y2 = X[,j], - var.y1 = Sigma.hat[i,i], + var.y1 = Sigma.hat[i,i], eta.y1 = rep(Mu.hat[i], N), eta.y2 = rep(Mu.hat[j], N), var.y2 = Sigma.hat[j,j], eXo = eXo, rho = Cor.hat[i,j]) - } else if(ov.types[i] == "numeric" && + } else if(ov.types[i] == "numeric" && ov.types[j] == "ordered") { # polyserial correlation ### FIXME: th.y2 should go into ps_lik!!! - LIK[,pstar.idx] <- ps_lik(Y1 = X[,i], Y2 = X[,j], - var.y1 = Sigma.hat[i,i], + LIK[,pstar.idx] <- ps_lik(Y1 = X[,i], Y2 = X[,j], + var.y1 = Sigma.hat[i,i], eta.y1 = rep(Mu.hat[i], N), eXo = eXo, rho = Cor.hat[i,j]) - } else if(ov.types[j] == "numeric" && + } else if(ov.types[j] == "numeric" && ov.types[i] == "ordered") { # polyserial correlation ### FIXME: th.y1 should go into ps_lik!!! - LIK[,pstar.idx] <- ps_lik(Y1 = X[,j], Y2 = X[,i], + LIK[,pstar.idx] <- ps_lik(Y1 = X[,j], Y2 = X[,i], var.y1 = Sigma.hat[j,j], eta.y1 = rep(Mu.hat[j], N), eXo = eXo, rho = Cor.hat[i,j]) - } else if(ov.types[i] == "ordered" && + } else if(ov.types[i] == "ordered" && ov.types[j] == "ordered") { - LIK[,pstar.idx] <- + LIK[,pstar.idx] <- pc_lik_PL_with_cov(Y1 = X[,i], Y2 = X[,j], Rho = Sigma.hat[i,j], @@ -562,17 +562,17 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor attr(OUT, "logl") <- as.numeric(NA) return(OUT) } - + # loglikelihood LogLIK.cases <- log(LIK) - + # sum over cases LogLIK.pairs <- colSums(LogLIK.cases, na.rm = TRUE) # sum over pairs logl <- logl_pairs <- sum(LogLIK.pairs) - if(missing == "available.cases" && all(ov.types == "ordered") && + if(missing == "available.cases" && all(ov.types == "ordered") && nexo != 0L) { uni_LIK <- matrix(0, nrow(X), ncol(X)) @@ -611,7 +611,7 @@ estimator.PML <- function(Sigma.hat = NULL, # model-based var/cov/cor # function value as returned to the minimizer fx <- Fmin - # attach 'loglikelihood' + # attach 'loglikelihood' attr(fx, "logl") <- logl fx @@ -635,7 +635,7 @@ estimator.FML <- function(Sigma.hat = NULL, # model-based var/cov/cor cors <- Sigma.hat[lower.tri(Sigma.hat)] if(any(abs(cors) > 1)) { - return(+Inf) + return(+Inf) } nvar <- nrow(Sigma.hat) @@ -703,9 +703,9 @@ estimator.MML <- function(lavmodel = NULL, sample.mean.x = NULL, lavcache = NULL) { - # compute case-wise likelihoods + # compute case-wise likelihoods lik <- lav_model_lik_mml(lavmodel = lavmodel, THETA = THETA, TH = TH, - GLIST = GLIST, group = group, lavdata = lavdata, + GLIST = GLIST, group = group, lavdata = lavdata, sample.mean = sample.mean, sample.mean.x = sample.mean.x, lavcache = lavcache) @@ -728,7 +728,7 @@ estimator.2L <- function(lavmodel = NULL, # compute model-implied statistics for all blocks implied <- lav_model_implied(lavmodel, GLIST = GLIST) - + # here, we assume only 2!!! levels, at [[1]] and [[2]] Sigma.W <- implied$cov[[ (group-1)*2 + 1]] Mu.W <- implied$mean[[ (group-1)*2 + 1]] @@ -736,7 +736,7 @@ estimator.2L <- function(lavmodel = NULL, Mu.B <- implied$mean[[ (group-1)*2 + 2]] loglik <- lav_mvnorm_cluster_loglik_samplestats_2l(YLp = YLp, Lp = Lp, - Mu.W = Mu.W, Sigma.W = Sigma.W, + Mu.W = Mu.W, Sigma.W = Sigma.W, Mu.B = Mu.B, Sigma.B = Sigma.B, log2pi = FALSE, minus.two = TRUE) diff --git a/R/lav_ols.R b/R/lav_ols.R index 1bac365a..2f2e5ad5 100644 --- a/R/lav_ols.R +++ b/R/lav_ols.R @@ -1,12 +1,12 @@ # simple wrapper around lm.fit to get scores() -# +# # YR 25 June 2012 # # NOTES: - X should NOT already contain a column of 1's for the intercept! # - weights not used yet # wrapper function -lavOLS <- function(y, X = NULL, +lavOLS <- function(y, X = NULL, method = "none", start.values = NULL, control = list(), verbose = FALSE) { @@ -33,7 +33,7 @@ lavRefOLS <- setRefClass("lavOLS", contains = "lavML", # fields -fields = list(X = "matrix", nexo = "integer", +fields = list(X = "matrix", nexo = "integer", # housekeeping int.idx = "integer", slope.idx = "integer", var.idx = "integer", missing.values = "logical", missing.idx = "integer", @@ -66,7 +66,7 @@ initialize = function(y, X = NULL, ...) { .self$int.idx <- 1L .self$slope.idx <- seq_len(nexo) + 1L .self$var.idx <- 1L + nexo + 1L - + # set up for Optim .self$npar <- 1L + nexo + 1L # intercept + slopes + var start(); .self$theta <- theta.start @@ -98,7 +98,7 @@ lik = function(x) { if(!missing(x)) .self$theta <- x beta <- theta[-npar] # not the variance e.var <- theta[npar] # the variance of the error - if(nexo > 0L) + if(nexo > 0L) .self$yhat <- drop(X %*% beta) else .self$yhat <- rep(beta[1L], nobs) @@ -152,7 +152,7 @@ hessian = function(x) { } else { dx.beta.var <- -1/(e.var*e.var) * sum(y-yhat) } - # var - var + # var - var sq.e.var <- sqrt(e.var) sq.e.var6 <- sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var #dx2.var <- nobs/(2*e.var*e.var) - 1/sq.e.var6 * crossprod(y-yhat) diff --git a/R/lav_options.R b/R/lav_options.R index f1d4cbb8..e012dc1e 100644 --- a/R/lav_options.R +++ b/R/lav_options.R @@ -18,7 +18,7 @@ lavOptions <- function(x = NULL, default = NULL, mimic = "lavaan") { if(length(not.ok) > 0L) { # only warn if multiple options were requested if(length(x) > 1L) { - warning("lavaan WARNING: option `", x[not.ok], + warning("lavaan WARNING: option `", x[not.ok], "' not available") } x <- x[ -not.ok ] @@ -86,7 +86,7 @@ lav_options_default <- function(mimic = "lavaan") { cluster = NULL, level.label = NULL, - # sampling weights + # sampling weights sampling.weights = NULL, # estimation @@ -156,11 +156,11 @@ lav_options_default <- function(mimic = "lavaan") { opt } -# this function collects and checks the user-provided options/arguments, +# this function collects and checks the user-provided options/arguments, # and fills in the "default" values, or changes them in an attempt to # produce a consistent set of values... # -# returns a list with the named options +# returns a list with the named options lav_options_set <- function(opt = NULL) { if(opt$debug) { cat("lavaan DEBUG: lavaanOptions IN\n"); str(opt) } @@ -179,7 +179,7 @@ lav_options_set <- function(opt = NULL) { opt$group.label <- opt.old$group.label opt$group.partial <- opt.old$group.partial opt$cluster <- opt.old$cluster - + # do.fit implies se="none and test="none" (unless not default) if(!opt$do.fit) { @@ -224,7 +224,7 @@ lav_options_set <- function(opt = NULL) { "regressions", "residuals", "residual.covariances", "thresholds", "lv.variances", "lv.covariances"))) { - # nothing to do + # nothing to do } else { stop("lavaan ERROR: unknown value for `group.equal' argument: ", opt$group.equal, "\n") @@ -253,7 +253,7 @@ lav_options_set <- function(opt = NULL) { opt$representation <- "LISREL" } else if(opt$representation == "lisrel") { opt$representation <- "LISREL" - } else if(opt$representation == "eqs" || + } else if(opt$representation == "eqs" || opt$representation == "bentler-weeks") { opt$representation <- "EQS" } else { @@ -306,9 +306,9 @@ lav_options_set <- function(opt = NULL) { # missing if(opt$missing == "default") { if(opt$mimic == "Mplus" && !opt$categorical && - opt$estimator %in% c("default", "ml", "mlr")) { + opt$estimator %in% c("default", "ml", "mlr")) { # since version 5? - opt$missing <- "ml" + opt$missing <- "ml" # check later if this is ok } else { opt$missing <- "listwise" @@ -329,9 +329,9 @@ lav_options_set <- function(opt = NULL) { "uls", "ulsm", "ulsmv", "pml", "mml")) { stop("lavaan ERROR: missing=\"two.stage\" is not allowed for estimator MLM, MLMV, GLS, ULS, ULSM, ULSMV, DWLS, WLS, WLSM, WLSMV, PML, MML") } - } else if(opt$missing %in% c("robust.two.stage", "robust.twostage", + } else if(opt$missing %in% c("robust.two.stage", "robust.twostage", "robust.two-stage", "robust-two-stage", - "robust.two.step", "robust.twostep", + "robust.two.step", "robust.twostep", "robust-two-step")) { opt$missing <- "robust.two.stage" if(opt$categorical) { @@ -372,13 +372,13 @@ lav_options_set <- function(opt = NULL) { } } else if(opt$test %in% c("none", "standard")) { # nothing to do - } else if(opt$test == "satorra" || - opt$test == "sb" || + } else if(opt$test == "satorra" || + opt$test == "sb" || opt$test == "SB" || opt$test == "satorra.bentler" || opt$test == "satorra-bentler") { opt$test <- "satorra.bentler" - } else if(opt$test == "yuan" || + } else if(opt$test == "yuan" || opt$test == "yb" || opt$test == "YB" || opt$test == "yuan.bentler" || @@ -405,9 +405,9 @@ lav_options_set <- function(opt = NULL) { opt$test == "scale.shift" || opt$test == "scaled.shifted") { opt$test <- "scaled.shifted" - } else if(opt$test == "bootstrap" || + } else if(opt$test == "bootstrap" || opt$test == "boot" || - opt$test == "bollen.stine" || + opt$test == "bollen.stine" || opt$test == "bollen-stine") { opt$test <- "bollen.stine" } else { @@ -416,7 +416,7 @@ lav_options_set <- function(opt = NULL) { \"mean.var.adjusted\", \"scaled.shifted\", \"bollen.stine\", or \"bootstrap\"") } - + # check missing if(opt$missing == "ml" && opt$se == "robust.sem") { warning("lavaan WARNING: missing will be set to ", @@ -424,8 +424,8 @@ lav_options_set <- function(opt = NULL) { dQuote(opt$se) ) opt$missing <- "listwise" } - if(opt$missing == "ml" && - opt$test %in% c("satorra.bentler", + if(opt$missing == "ml" && + opt$test %in% c("satorra.bentler", "mean.var.adjusted", "scaled.shifted")) { warning("lavaan WARNING: missing will be set to ", dQuote("listwise"), " for test = ", @@ -444,7 +444,7 @@ lav_options_set <- function(opt = NULL) { } else { opt$se <- "robust.two.stage" } - } else if(opt$missing == "two.stage" && + } else if(opt$missing == "two.stage" && opt$se == "two.stage") { # nothing to do } else if(opt$missing == "robust.two.stage" && @@ -532,7 +532,7 @@ lav_options_set <- function(opt = NULL) { opt$estimator <- "ML" if(opt$se == "default") { opt$se <- "standard" - } else if(opt$se %in% c("bootstrap", "none", + } else if(opt$se %in% c("bootstrap", "none", "external", "standard", "robust.huber.white", "two.stage", "robust.two.stage", "robust.sem")) { # nothing to do @@ -555,18 +555,18 @@ lav_options_set <- function(opt = NULL) { opt$se <- "robust.sem" } } else { - stop("lavaan ERROR: unknown value for `se' argument when estimator is ML: ", + stop("lavaan ERROR: unknown value for `se' argument when estimator is ML: ", opt$se, "\n") } - } else if(opt$estimator == "mlm" || - opt$estimator == "mlmv" || + } else if(opt$estimator == "mlm" || + opt$estimator == "mlmv" || opt$estimator == "mlmvs") { est.orig <- opt$estimator if(opt$test != "none") { if(opt$estimator == "mlm") { opt$test <- "satorra.bentler" - } else if(opt$estimator == "mlmv") { + } else if(opt$estimator == "mlmv") { opt$test <- "scaled.shifted" } else if(opt$estimator == "mlmvs") { opt$test <- "mean.var.adjusted" @@ -580,7 +580,7 @@ lav_options_set <- function(opt = NULL) { if(opt$se != "none" && opt$se != "external") opt$se <- "robust.sem" #if(!(opt$information %in% c("expected", "default"))) { # warning("lavaan WARNING: information will be set to ", - # dQuote("expected"), " for estimator = ", + # dQuote("expected"), " for estimator = ", # dQuote(toupper(est.orig)) ) #} #opt$information <- "expected" @@ -594,7 +594,7 @@ lav_options_set <- function(opt = NULL) { } if(opt$se != "none" && opt$se != "external") { opt$se <- "standard" - opt$information <- "first.order" + opt$information <- "first.order" } } else if(opt$estimator == "mlr") { opt$estimator <- "ML" @@ -614,19 +614,19 @@ lav_options_set <- function(opt = NULL) { opt$estimator <- "GLS" if(opt$se == "default" || opt$se == "standard") { opt$se <- "standard" - } else if(opt$se == "none" || - opt$se == "bootstrap" || + } else if(opt$se == "none" || + opt$se == "bootstrap" || opt$se == "external") { # nothing to do } else { - stop("lavaan ERROR: invalid value for `se' argument when estimator is GLS: ", + stop("lavaan ERROR: invalid value for `se' argument when estimator is GLS: ", opt$se, "\n") } if(!opt$test %in% c("standard","none")) { - stop("lavaan ERROR: invalid value for `test' argument when estimator is GLS: ", + stop("lavaan ERROR: invalid value for `test' argument when estimator is GLS: ", opt$test, "\n") } - opt$missing <- "listwise" + opt$missing <- "listwise" } else if(opt$estimator == "ntrls") { opt$estimator <- "NTRLS" if(opt$se == "default" || opt$se == "standard") { @@ -648,8 +648,8 @@ lav_options_set <- function(opt = NULL) { opt$estimator <- "WLS" if(opt$se == "default" || opt$se == "standard") { opt$se <- "standard" - } else if(opt$se == "none" || - opt$se == "bootstrap" || + } else if(opt$se == "none" || + opt$se == "bootstrap" || opt$se == "external") { # nothing to do } else if(opt$se == "robust.sem") { @@ -657,11 +657,11 @@ lav_options_set <- function(opt = NULL) { } else if(opt$se == "robust") { opt$se <- "robust.sem" } else { - stop("lavaan ERROR: invalid value for `se' argument when estimator is WLS: ", + stop("lavaan ERROR: invalid value for `se' argument when estimator is WLS: ", opt$se, "\n") } if(!opt$test %in% c("standard","none")) { - stop("lavaan ERROR: invalid value for `test' argument when estimator is WLS: ", + stop("lavaan ERROR: invalid value for `test' argument when estimator is WLS: ", opt$test, "\n") } #opt$missing <- "listwise" @@ -669,8 +669,8 @@ lav_options_set <- function(opt = NULL) { opt$estimator <- "DWLS" if(opt$se == "default" || opt$se == "standard") { opt$se <- "standard" - } else if(opt$se == "none" || - opt$se == "bootstrap" || + } else if(opt$se == "none" || + opt$se == "bootstrap" || opt$se == "external") { # nothing to do } else if(opt$se == "robust.sem") { @@ -681,7 +681,7 @@ lav_options_set <- function(opt = NULL) { stop("lavaan ERROR: invalid value for `se' argument when estimator is DWLS: ", opt$se, "\n") } - if(!opt$test %in% c("standard","none","satorra.bentler", + if(!opt$test %in% c("standard","none","satorra.bentler", "mean.adjusted", "mean.var.adjusted","scaled.shifted")) { stop("lavaan ERROR: invalid value for `test' argument when estimator is DWLS: ", @@ -690,7 +690,7 @@ lav_options_set <- function(opt = NULL) { #opt$missing <- "listwise" } else if(opt$estimator == "wlsm") { opt$estimator <- "DWLS" - if(opt$se == "bootstrap") { + if(opt$se == "bootstrap") { stop("lavaan ERROR: use (D)WLS estimator for bootstrap") } if(opt$se != "none" && opt$se != "external") opt$se <- "robust.sem" @@ -731,8 +731,8 @@ lav_options_set <- function(opt = NULL) { opt$estimator <- "ULS" if(opt$se == "default" || opt$se == "standard") { opt$se <- "standard" - } else if(opt$se == "none" || - opt$se == "bootstrap" || + } else if(opt$se == "none" || + opt$se == "bootstrap" || opt$se == "external") { # nothing to do } else if(opt$se == "robust.sem") { @@ -740,7 +740,7 @@ lav_options_set <- function(opt = NULL) { } else if(opt$se == "robust") { opt$se <- "robust.sem" } else { - stop("lavaan ERROR: invalid value for `se' argument when estimator is ULS: ", + stop("lavaan ERROR: invalid value for `se' argument when estimator is ULS: ", opt$se, "\n") } if(!opt$test %in% c("standard","none", "satorra.bentler", @@ -824,7 +824,7 @@ lav_options_set <- function(opt = NULL) { } else if(opt$link %in% c("logit","probit")) { # nothing to do } else { - stop("lavaan ERROR: link must be `logit' or `probit'") + stop("lavaan ERROR: link must be `logit' or `probit'") } # check for parameterization if(opt$parameterization == "default") { @@ -876,15 +876,15 @@ lav_options_set <- function(opt = NULL) { opt$likelihood <- "normal" } else if(opt$likelihood == "default") { opt$likelihood <- "normal" - if(opt$mimic == "EQS" || - opt$mimic == "LISREL" || + if(opt$mimic == "EQS" || + opt$mimic == "LISREL" || opt$mimic == "AMOS") { opt$likelihood <- "wishart" } } else if(opt$likelihood == "wishart" || opt$likelihood == "normal") { # nothing to do } else { - stop("lavaan ERROR: invalid value for `likelihood' argument: ", + stop("lavaan ERROR: invalid value for `likelihood' argument: ", opt$likelihood, "\n") } @@ -902,8 +902,8 @@ lav_options_set <- function(opt = NULL) { # information if(opt$information == "default") { - if(opt$missing == "ml" || - opt$se == "robust.huber.white" || + if(opt$missing == "ml" || + opt$se == "robust.huber.white" || opt$se == "first.order") { #nchar(opt$constraints) > 0L) { opt$information <- "observed" @@ -956,7 +956,7 @@ lav_options_set <- function(opt = NULL) { } else { stop("lavaan ERROR: conditional.x must be TRUE, FALSE or \"default\"\n") } - + # if conditional.x, always use a meanstructure if(opt$conditional.x) { opt$meanstructure <- TRUE @@ -989,7 +989,7 @@ lav_options_set <- function(opt = NULL) { "means" %in% opt$group.equal) { opt$meanstructure <- TRUE } - #if(opt$se == "robust.huber.white" || + #if(opt$se == "robust.huber.white" || # opt$se == "robust.sem" || # opt$test == "satorra.bentler" || # opt$test == "mean.var.adjusted" || @@ -1021,7 +1021,7 @@ lav_options_set <- function(opt = NULL) { stop("lavaan ERROR: argument `zero.add' must be numeric or \"default\"") } - if(is.character(opt$zero.keep.margins) && + if(is.character(opt$zero.keep.margins) && opt$zero.keep.margins == "default") { if(opt$mimic %in% c("lavaan", "Mplus")) { opt$zero.keep.margins <- TRUE diff --git a/R/lav_partable.R b/R/lav_partable.R index 787a9d37..d8d52171 100644 --- a/R/lav_partable.R +++ b/R/lav_partable.R @@ -19,7 +19,7 @@ lavaanify <- lavParTable <- function( meanstructure = FALSE, int.ov.free = FALSE, int.lv.free = FALSE, - orthogonal = FALSE, + orthogonal = FALSE, std.lv = FALSE, conditional.x = FALSE, fixed.x = TRUE, @@ -43,7 +43,7 @@ lavaanify <- lavParTable <- function( group.w.free = FALSE, debug = FALSE, warn = TRUE, - + as.data.frame. = TRUE) { @@ -71,7 +71,7 @@ lavaanify <- lavParTable <- function( CON2 <- attr(FLAT2, "constraints"); rm(FLAT2) CON <- c(CON, CON2) } - + if(debug) { cat("[lavaan DEBUG]: FLAT (flattened user model):\n") print(FLAT) @@ -107,8 +107,8 @@ lavaanify <- lavParTable <- function( auto.cov.y = TRUE auto.th = TRUE auto.delta = TRUE - } else - + } else + if(model.type == "growth") { model.type = "growth" int.ov.free = FALSE @@ -118,7 +118,7 @@ lavaanify <- lavParTable <- function( auto.var = TRUE auto.cov.lv.x = TRUE auto.cov.y = TRUE - auto.th = TRUE + auto.th = TRUE auto.delta = TRUE } } @@ -135,14 +135,14 @@ lavaanify <- lavParTable <- function( # what are the block lhs labels? BLOCKS <- tolower(FLAT$lhs[FLAT$op == ":"]) BLOCK.lhs <- unique(BLOCKS) - + # block op == ":" indices BLOCK.op.idx <- which(FLAT$op == ":") # check for wrong spelled 'group' lhs if(length(grep("group", BLOCK.lhs)) > 1L) { warning("lavaan WARNING: ambiguous block identifiers for group:", - "\n\t\t ", paste(BLOCK.lhs[grep("group", BLOCK.lhs)], + "\n\t\t ", paste(BLOCK.lhs[grep("group", BLOCK.lhs)], collapse = ", ")) } @@ -205,8 +205,8 @@ lavaanify <- lavParTable <- function( varTable = varTable, group.equal = NULL, group.w.free = group.w.free, ngroups = 1L) LIST.block <- as.data.frame(LIST.block, stringsAsFactors = FALSE) - - # add block columns with current values in BLOCK.rhs + + # add block columns with current values in BLOCK.rhs for(b in seq_len(length(BLOCK.lhs))) { block.lhs <- BLOCK.lhs[b] block.rhs <- BLOCK.rhs[b] @@ -226,7 +226,7 @@ lavaanify <- lavParTable <- function( for(b in seq_len(length(BLOCK.lhs))) { block.lhs <- BLOCK.lhs[b] block.rhs <- BLOCK.rhs[b] - tmp <- try(scan(text = LIST[[block.lhs]], what = integer(), + tmp <- try(scan(text = LIST[[block.lhs]], what = integer(), quiet = TRUE), silent = TRUE) if(class(tmp) == "integer") { LIST[[block.lhs]] <- tmp @@ -234,20 +234,20 @@ lavaanify <- lavParTable <- function( } } else { - LIST <- lav_partable_flat(FLAT, blocks = "group", - meanstructure = meanstructure, + LIST <- lav_partable_flat(FLAT, blocks = "group", + meanstructure = meanstructure, int.ov.free = int.ov.free, int.lv.free = int.lv.free, - orthogonal = orthogonal, std.lv = std.lv, + orthogonal = orthogonal, std.lv = std.lv, conditional.x = conditional.x, fixed.x = fixed.x, parameterization = parameterization, auto.fix.first = auto.fix.first, auto.fix.single = auto.fix.single, auto.var = auto.var, auto.cov.lv.x = auto.cov.lv.x, - auto.cov.y = auto.cov.y, auto.th = auto.th, + auto.cov.y = auto.cov.y, auto.th = auto.th, auto.delta = auto.delta, - varTable = varTable, group.equal = group.equal, + varTable = varTable, group.equal = group.equal, group.w.free = group.w.free, ngroups = ngroups) - } + } if(debug) { cat("[lavaan DEBUG]: parameter LIST without MODIFIERS:\n") print( as.data.frame(LIST, stringsAsFactors=FALSE) ) @@ -302,13 +302,13 @@ lavaanify <- lavParTable <- function( # perhaps the corresponding element was duplicated, and removed if(length(idx) == 0L) { next - } + } - MOD.fixed <- MOD[[el]]$fixed + MOD.fixed <- MOD[[el]]$fixed MOD.start <- MOD[[el]]$start MOD.lower <- MOD[[el]]$lower MOD.upper <- MOD[[el]]$upper - MOD.label <- MOD[[el]]$label + MOD.label <- MOD[[el]]$label MOD.prior <- MOD[[el]]$prior # check for single argument if multiple groups @@ -320,7 +320,7 @@ lavaanify <- lavParTable <- function( if(length(MOD.lower) == 1L) MOD.lower <- rep(MOD.lower, ngroups) if(length(MOD.upper) == 1L) MOD.upper <- rep(MOD.upper, ngroups) if(length(MOD.prior) == 1L) MOD.prior <- rep(MOD.prior, ngroups) - # B) here we do NOT! otherwise, it would imply an equality + # B) here we do NOT! otherwise, it would imply an equality # constraint... # except if group.equal="loadings"! if(length(MOD.label) == 1L) { @@ -342,7 +342,7 @@ lavaanify <- lavParTable <- function( (!is.null(MOD.label) && nidx != length(MOD.label)) ) { el.idx <- which(LIST$mod.idx == el)[1L] stop("lavaan ERROR: wrong number of arguments in modifier (", - paste(MOD.label, collapse=","), ") of element ", + paste(MOD.label, collapse=","), ") of element ", LIST$lhs[el.idx], LIST$op[el.idx], LIST$rhs[el.idx]) } @@ -403,7 +403,7 @@ lavaanify <- lavParTable <- function( } else { blocks <- "group" } - LABEL <- lav_partable_labels(partable = LIST, + LABEL <- lav_partable_labels(partable = LIST, blocks = blocks, group.equal = group.equal, group.partial = group.partial) @@ -427,10 +427,10 @@ lavaanify <- lavParTable <- function( CON <- lapply(CON, function(x) {x$user <- 1L; x} ) for(idx in idx.eq.label) { eq.label <- LABEL[idx] - all.idx <- which(LABEL == eq.label) # all same-label parameters - ref.idx <- all.idx[1L] # the first one only + all.idx <- which(LABEL == eq.label) # all same-label parameters + ref.idx <- all.idx[1L] # the first one only - # two possibilities: + # two possibilities: # 1. all.idx contains a fixed parameter: in this case, # we fix them all (hopefully to the same value) # 2. all.idx contains only free parameters @@ -457,7 +457,7 @@ lavaanify <- lavParTable <- function( # be equal to the 'fixed' parameter # (Note: Mplus ignores this) - # just in case: if ref.idx is not equal to fixed.idx, + # just in case: if ref.idx is not equal to fixed.idx, # fix this one too LIST$ustart[ref.idx] <- LIST$ustart[fixed.idx] LIST$free[ref.idx] <- 0L @@ -470,8 +470,8 @@ lavaanify <- lavParTable <- function( # lhs.lab <- PLABEL[ref.idx] #} CON.idx <- CON.idx + 1L - CON[[CON.idx]] <- list(op = "==", - lhs = LIST$plabel[ref.idx], + CON[[CON.idx]] <- list(op = "==", + lhs = LIST$plabel[ref.idx], rhs = LIST$plabel[idx], user = 2L) @@ -517,7 +517,7 @@ lavaanify <- lavParTable <- function( LIST$op[IDX] <- unlist(lapply(CON, "[[", "op")) LIST$rhs[IDX] <- unlist(lapply(CON, "[[", "rhs")) LIST$user[IDX] <- unlist(lapply(CON, "[[", "user")) - + # zero is nicer? LIST$free[IDX] <- rep(0L, nCon) LIST$exo[IDX] <- rep(0L, nCon) @@ -551,7 +551,7 @@ lavaanify <- lavParTable <- function( LIST$label[def.idx] <- LIST$lhs[def.idx] - if(debug) { + if(debug) { cat("[lavaan DEBUG] lavParTable\n") print( as.data.frame(LIST) ) } diff --git a/R/lav_partable_attributes.R b/R/lav_partable_attributes.R index b1f57bd4..b3e6a5c4 100644 --- a/R/lav_partable_attributes.R +++ b/R/lav_partable_attributes.R @@ -62,7 +62,7 @@ lav_partable_attributes <- function(partable, pta = NULL) { # th.idx (new in 0.6-1) pta$th.idx <- lapply(seq_len(pta$nblocks), function(g) { out <- numeric( length(pta$vnames$th.mean[[g]]) ) - idx <- ( pta$vnames$th.mean[[g]] %in% + idx <- ( pta$vnames$th.mean[[g]] %in% pta$vnames$th[[g]] ) out[idx] <- pta$vidx$th[[g]] out diff --git a/R/lav_partable_check.R b/R/lav_partable_check.R index 64c8d839..67400056 100644 --- a/R/lav_partable_check.R +++ b/R/lav_partable_check.R @@ -20,7 +20,7 @@ lav_partable_check <- function(partable, categorical = FALSE, warn = TRUE) { warning("lavaan WARNING: parameter table does not contain thresholds ") } } - + # we should have a (residual) variance for *each* ov/lv # note: if lavaanify() has been used, this is always TRUE var.idx <- which(partable$op == "~~" & @@ -56,7 +56,7 @@ lav_partable_check <- function(partable, categorical = FALSE, warn = TRUE) { # this is not necessarily problematic! # eg. in latent change score models # therefore, we do NOT give a warning - + # var.fixed <- which(partable$op == "~~" & # partable$lhs == partable$rhs & # partable$user == 0 & @@ -67,7 +67,7 @@ lav_partable_check <- function(partable, categorical = FALSE, warn = TRUE) { # warning("lavaan WARNING: missing (residual) variances are set to zero: [", paste(partable$lhs[var.fixed], collapse = " "), "]") # } # } - + # do we have added intercepts (user = 0) that are fixed to zero? # this is not necessarily problematic; perhaps only for # exogenous variables? diff --git a/R/lav_partable_complete.R b/R/lav_partable_complete.R index b36947d9..ca73a9bb 100644 --- a/R/lav_partable_complete.R +++ b/R/lav_partable_complete.R @@ -13,7 +13,7 @@ lav_partable_complete <- function(partable = NULL, start = TRUE) { stopifnot(!is.null(partable$lhs), !is.null(partable$op), !is.null(partable$rhs)) - + # number of elements N <- length(partable$lhs) if(!is.data.frame(partable)) { @@ -29,10 +29,10 @@ lav_partable_complete <- function(partable = NULL, start = TRUE) { for(i in short.idx) { too.short <- N - nel[i] if(is.integer(partable[[i]])) { - partable[[i]] <- c(partable[[i]], + partable[[i]] <- c(partable[[i]], integer( too.short )) } else if(is.numeric(partable[[i]])) { - partable[[i]] <- c(partable[[i]], + partable[[i]] <- c(partable[[i]], numeric( too.short )) } else { partable[[i]] <- c(partable[[i]], @@ -105,7 +105,7 @@ lav_partable_complete <- function(partable = NULL, start = TRUE) { partable$label <- as.character( partable$label ) } - # add eq.id column + # add eq.id column #if(is.null(partable$eq.id)) { # partable$eq.id <- rep(0, N) #} @@ -122,7 +122,7 @@ lav_partable_complete <- function(partable = NULL, start = TRUE) { # order them nicely: id lhs op rhs group #idx <- match(c("id", "lhs","op","rhs", "group","user", - # "free","ustart","exo","label","eq.id","unco"), + # "free","ustart","exo","label","eq.id","unco"), # names(partable)) tmp <- partable[idx] partable <- c(tmp, partable[-idx]) diff --git a/R/lav_partable_constraints.R b/R/lav_partable_constraints.R index 8e7f6b81..d26bf618 100644 --- a/R/lav_partable_constraints.R +++ b/R/lav_partable_constraints.R @@ -14,7 +14,7 @@ lav_partable_constraints_def <- function(partable, con = NULL, debug = FALSE, # get := definitions def.idx <- which(partable$op == ":=") - + # catch empty def if(length(def.idx) == 0L) { if(txtOnly) { @@ -89,7 +89,7 @@ lav_partable_constraints_def <- function(partable, con = NULL, debug = FALSE, # eg. if b1 + b2 == 2 (and b1 correspond to, say, x[10] and x[17]) # ceq <- function(x) { # out <- rep(NA, 1) -# b1 = x[10]; b2 = x[17] +# b1 = x[10]; b2 = x[17] # out[1] <- b1 + b2 - 2 # } lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, @@ -104,7 +104,7 @@ lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, partable$op <- c(partable$op, con$op ) partable$rhs <- c(partable$rhs, con$rhs) } - + # get equality constraints eq.idx <- which(partable$op == "==") @@ -145,13 +145,13 @@ lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, # get user-labels ids ulab.idx <- which(eq.labels %in% partable$label) if(length(ulab.idx) > 0L) { - eq.x.idx[ ulab.idx] <- partable$free[match(eq.labels[ulab.idx], + eq.x.idx[ ulab.idx] <- partable$free[match(eq.labels[ulab.idx], partable$label)] } # get plabels ids plab.idx <- which(eq.labels %in% partable$plabel) if(length(plab.idx) > 0L) { - eq.x.idx[ plab.idx] <- partable$free[match(eq.labels[plab.idx], + eq.x.idx[ plab.idx] <- partable$free[match(eq.labels[plab.idx], partable$plabel)] } @@ -192,7 +192,7 @@ lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, for(i in 1:length(eq.idx)) { lhs <- partable$lhs[ eq.idx[i] ] rhs <- partable$rhs[ eq.idx[i] ] - if(rhs == "0") { + if(rhs == "0") { eq.string <- lhs } else { eq.string <- paste(lhs, " - (", rhs, ")", sep="") @@ -224,7 +224,7 @@ lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, # eg. if b1 + b2 > 2 (and b1 correspond to, say, x[10] and x[17]) # cin <- function(x) { # out <- rep(NA, 1) -# b1 = x[10]; b2 = x[17] +# b1 = x[10]; b2 = x[17] # out[1] <- b1 + b2 - 2 # } # @@ -243,7 +243,7 @@ lav_partable_constraints_ciq <- function(partable, con = NULL, debug = FALSE, partable$op <- c(partable$op, con$op ) partable$rhs <- c(partable$rhs, con$rhs) } - + # get inequality constraints ineq.idx <- which(partable$op == ">" | partable$op == "<") @@ -283,13 +283,13 @@ lav_partable_constraints_ciq <- function(partable, con = NULL, debug = FALSE, # get user-labels ids ulab.idx <- which(ineq.labels %in% partable$label) if(length(ulab.idx) > 0L) { - ineq.x.idx[ ulab.idx] <- partable$free[match(ineq.labels[ulab.idx], + ineq.x.idx[ ulab.idx] <- partable$free[match(ineq.labels[ulab.idx], partable$label)] } # get plabels ids plab.idx <- which(ineq.labels %in% partable$plabel) if(length(plab.idx) > 0L) { - ineq.x.idx[ plab.idx] <- partable$free[match(ineq.labels[plab.idx], + ineq.x.idx[ plab.idx] <- partable$free[match(ineq.labels[plab.idx], partable$plabel)] } @@ -370,7 +370,7 @@ lav_partable_constraints_label_id <- function(partable, con = NULL, partable$op <- c(partable$op, con$op ) partable$rhs <- c(partable$rhs, con$rhs) } - + # get constraints con.idx <- which(partable$op %in% c("==", "<", ">")) @@ -399,13 +399,13 @@ lav_partable_constraints_label_id <- function(partable, con = NULL, # get user-labels ids ulab.idx <- which(con.labels %in% partable$label) if(length(ulab.idx) > 0L) { - con.x.idx[ ulab.idx] <- partable$free[match(con.labels[ulab.idx], + con.x.idx[ ulab.idx] <- partable$free[match(con.labels[ulab.idx], partable$label)] } # get plabels ids plab.idx <- which(con.labels %in% partable$plabel) if(length(plab.idx) > 0L) { - con.x.idx[ plab.idx] <- partable$free[match(con.labels[plab.idx], + con.x.idx[ plab.idx] <- partable$free[match(con.labels[plab.idx], partable$plabel)] } diff --git a/R/lav_partable_flat.R b/R/lav_partable_flat.R index d61b4177..753c263e 100644 --- a/R/lav_partable_flat.R +++ b/R/lav_partable_flat.R @@ -25,7 +25,7 @@ lav_partable_flat <- function(FLAT = NULL, categorical <- FALSE ### DEFAULT elements: parameters that are typically not specified by - ### users, but should typically be considered, + ### users, but should typically be considered, ### either free or fixed # extract `names' of various types of variables: @@ -33,7 +33,7 @@ lav_partable_flat <- function(FLAT = NULL, #lv.names.r <- lav_partable_vnames(FLAT, type="lv.regular") # regular latent variables lv.names.f <- lav_partable_vnames(FLAT, type="lv.formative") # formative latent variables ov.names <- lav_partable_vnames(FLAT, type="ov") # observed variables - ov.names.x <- lav_partable_vnames(FLAT, type="ov.x") # exogenous x covariates + ov.names.x <- lav_partable_vnames(FLAT, type="ov.x") # exogenous x covariates ov.names.nox <- lav_partable_vnames(FLAT, type="ov.nox") lv.names.x <- lav_partable_vnames(FLAT, type="lv.x") # exogenous lv ov.names.y <- lav_partable_vnames(FLAT, type="ov.y") # dependent ov @@ -51,7 +51,7 @@ lav_partable_flat <- function(FLAT = NULL, warning("lavaan WARNING: thresholds are defined for exogenous variables: ", paste(ov.names.ord1[idx], collapse=" ")) } } - + if(!is.null(varTable)) { ov.names.ord2 <- as.character(varTable$name[ varTable$type == "ordered" ]) # remove fixed.x variables @@ -77,7 +77,7 @@ lav_partable_flat <- function(FLAT = NULL, nth <- varTable$nlev[ varTable$name == o ] - 1L nth.in.partable <- sum(FLAT$op == "|" & FLAT$lhs == o) if(nth != nth.in.partable) { - stop("lavaan ERROR: expected ", max(0,nth), + stop("lavaan ERROR: expected ", max(0,nth), " threshold(s) for variable ", sQuote(o), "; syntax contains ", nth.in.partable, "\n") } @@ -115,7 +115,7 @@ lav_partable_flat <- function(FLAT = NULL, # 2. default (residual) variances and covariances # a) (residual) VARIANCES (all ov's except exo, and all lv's) - # NOTE: change since 0.5-17: we ALWAYS include the vars in the + # NOTE: change since 0.5-17: we ALWAYS include the vars in the # parameter table; but only if auto.var = TRUE, we set them free #if(auto.var) { ov.var <- ov.names.nox @@ -146,7 +146,7 @@ lav_partable_flat <- function(FLAT = NULL, lhs <- c(lhs, rep(ov.names.x, each=nx)[idx]) # fill upper.tri rhs <- c(rhs, rep(ov.names.x, times=nx)[idx]) } - + # create 'op' (thresholds come first, then variances) op <- rep("~~", length(lhs)); op[seq_len(nth)] <- "|" @@ -154,7 +154,7 @@ lav_partable_flat <- function(FLAT = NULL, # NOTE: - new in 0.5-19: ALWAYS include scaling parameters in partable, # but only free them if auto.delta = TRUE (and parameterization # is "delta" - #if(auto.delta && auto.th && length(ov.names.ord) > 0L && + #if(auto.delta && auto.th && length(ov.names.ord) > 0L && # # length(lv.names) > 0L && # (ngroups > 1L || any(FLAT$op == "~*~") || parameterization == "theta")) { if(length(ov.names.ord) > 0L) { @@ -184,7 +184,7 @@ lav_partable_flat <- function(FLAT = NULL, if(group.w.free) { lhs <- c(lhs, "group") rhs <- c(rhs, "w") - op <- c(op, "%") + op <- c(op, "%") } DEFAULT <- data.frame(lhs=lhs, op=op, rhs=rhs, @@ -207,11 +207,11 @@ lav_partable_flat <- function(FLAT = NULL, TMP <- USER[,1:3] idx <- which(duplicated(TMP)) if(length(idx) > 0L) { - txt <- sapply(1:length(idx), function(i) { - paste(" ", TMP[idx[i],"lhs"], - TMP[idx[i], "op"], + txt <- sapply(1:length(idx), function(i) { + paste(" ", TMP[idx[i],"lhs"], + TMP[idx[i], "op"], TMP[idx[i],"rhs"]) }) - warning("duplicated elements in model syntax have been ignored:\n", + warning("duplicated elements in model syntax have been ignored:\n", paste(txt, collapse = "\n")) USER <- USER[-idx,] } @@ -219,7 +219,7 @@ lav_partable_flat <- function(FLAT = NULL, # check for duplicated elements in DEFAULT # - FIXME: can we not avoid this somehow?? # - for example, if the user model includes 'x1 ~~ x1' - # or 'x1 ~ 1' + # or 'x1 ~ 1' # - remove them from DEFAULT TMP <- rbind(DEFAULT[,1:3], USER[,1:3]) idx <- which(duplicated(TMP, fromLast=TRUE)) # idx should be in DEFAULT @@ -503,7 +503,7 @@ lav_partable_flat <- function(FLAT = NULL, # for now, only group LIST$block <- group } - + # block columns (typically only group) for(block in blocks) { if(block == "group") { diff --git a/R/lav_partable_from_lm.R b/R/lav_partable_from_lm.R index ee0ea38a..232459b1 100644 --- a/R/lav_partable_from_lm.R +++ b/R/lav_partable_from_lm.R @@ -13,7 +13,7 @@ lav_partable_from_lm <- function(object, est = FALSE, label = FALSE, varNames <- as.character(attr(objectTerms, "variables"))[-1] responseName <- varNames[responseIndex] - predCoef <- lav_object_inspect_coef(object, type = "free", + predCoef <- lav_object_inspect_coef(object, type = "free", add.labels = TRUE) predNames <- names(predCoef) @@ -56,6 +56,6 @@ lav_partable_from_lm <- function(object, est = FALSE, label = FALSE, if(as.data.frame.) { partable <- as.data.frame(partable, stringsAsFactors = FALSE) } - + partable } diff --git a/R/lav_partable_full.R b/R/lav_partable_full.R index d1d8a9b5..203206e9 100644 --- a/R/lav_partable_full.R +++ b/R/lav_partable_full.R @@ -31,7 +31,7 @@ lav_partable_full <- function(partable = NULL, ngroups <- lavpta$ngroups nlevels <- lavpta$nlevels - + lhs <- rhs <- op <- character(0L) block <- group <- level <- integer(0L) @@ -48,7 +48,7 @@ lav_partable_full <- function(partable = NULL, ov.names.x <- lavpta$vnames$ov.x[[b]] ov.names.ind <- lavpta$vnames$ov.ind[[b]] ov.names.ord <- lavpta$vnames$ov.ord[[b]] - + lv.names <- lavpta$vnames$lv[[b]] # eqs.y, eqs.x @@ -119,14 +119,14 @@ lav_partable_full <- function(partable = NULL, r.lhs <- rep(eqs.y, each = length(eqs.x)) r.rhs <- rep(eqs.x, times = length(eqs.y)) - + # remove self-arrows idx <- which(r.lhs == r.rhs) if(length(idx) > 0L) { r.lhs <- r.lhs[-idx] r.rhs <- r.rhs[-idx] } - + # remove indicator ~ factor if they exist bad.idx <- which(r.lhs %in% ov.names.ind & r.rhs %in% lv.names) @@ -167,16 +167,16 @@ lav_partable_full <- function(partable = NULL, delta.rhs <- ov.names.ord delta.op <- rep("~*~", length(delta.lhs)) } - + # combine - this.lhs <- c(l.lhs, ov.lhs, lv.lhs, r.lhs, int.lhs, th.lhs, + this.lhs <- c(l.lhs, ov.lhs, lv.lhs, r.lhs, int.lhs, th.lhs, delta.lhs) - this.rhs <- c(l.rhs, ov.rhs, lv.rhs, r.rhs, int.rhs, th.rhs, + this.rhs <- c(l.rhs, ov.rhs, lv.rhs, r.rhs, int.rhs, th.rhs, delta.rhs) - this.op <- c(l.op, ov.op, lv.op, r.op, int.op, th.op, + this.op <- c(l.op, ov.op, lv.op, r.op, int.op, th.op, delta.op) n.el <- length(this.lhs) - + lhs <- c(lhs, this.lhs) rhs <- c(rhs, this.rhs) op <- c(op, this.op) diff --git a/R/lav_partable_independence.R b/R/lav_partable_independence.R index a14204a8..a2af071a 100644 --- a/R/lav_partable_independence.R +++ b/R/lav_partable_independence.R @@ -14,7 +14,7 @@ lav_partable_independence <- function(lavobject = NULL, sample.th.idx = NULL, sample.cov.x = NULL, sample.mean.x = NULL) { - + lav_partable_indep_or_unrestricted(lavobject = lavobject, lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, lavsamplestats = lavsamplestats, sample.cov = sample.cov, diff --git a/R/lav_partable_merge.R b/R/lav_partable_merge.R index bf247608..e73df3cf 100644 --- a/R/lav_partable_merge.R +++ b/R/lav_partable_merge.R @@ -1,6 +1,6 @@ # merge two parameter tables # - but allow different number of columns -lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, +lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, remove.duplicated = FALSE, fromLast=FALSE, warn = TRUE) { @@ -28,7 +28,7 @@ lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, pt2[, c("lhs","op","rhs","block")]) } - # if missing columns, provide default values of the right type + # if missing columns, provide default values of the right type # (numeric/integer/character) # group @@ -94,7 +94,7 @@ lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, pt2$start <- rep(as.numeric(NA), length(pt2$lhs)) } - # est + # est if(is.null(pt1$est) && !is.null(pt2$est)) { pt1$est <- rep(0, length(pt1$lhs)) } else if(is.null(pt2$est) && !is.null(pt1$est)) { @@ -106,8 +106,8 @@ lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, if(remove.duplicated) { # if fromLast = TRUE, idx is in pt1 # if fromLast = FALSE, idx is in pt2 - idx <- which(duplicated(TMP, fromLast=fromLast)) - + idx <- which(duplicated(TMP, fromLast=fromLast)) + if(length(idx)) { if(warn) { warning("lavaan WARNING: duplicated parameters are ignored:\n", diff --git a/R/lav_partable_subset.R b/R/lav_partable_subset.R index 375d5e6e..747b721b 100644 --- a/R/lav_partable_subset.R +++ b/R/lav_partable_subset.R @@ -8,7 +8,7 @@ # ... -# FIXME: +# FIXME: # - if we have more than 1 factor, we remove the structural # part, but should we add ALL correlations among the latent variables? # (YES for now) @@ -37,7 +37,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, } else if(!is.list(lv.names)) { lv.names <- list(lv.names) } - + # keep rows idx keep.idx <- integer(0L) @@ -91,7 +91,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, keep.idx <- c(keep.idx, SC.idx) # FIXME: ==, :=, <, >, == involving IND... - + # `simple' == constraints (simple lhs and rhs) #EQ.idx <- which(PT$op == "==" & # PT$lhs %in% IND.plabel & @@ -121,7 +121,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, } else { lhs.keep <- TRUE } - + # rhs RHS.labels <- all.vars(as.formula(paste("~", @@ -152,7 +152,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, if(idx.only) { return(keep.idx) } - + PT <- PT[keep.idx,,drop = FALSE] # check if we have enough indicators? @@ -188,7 +188,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, # clean up PT <- lav_partable_complete(PT) - + PT } @@ -199,7 +199,7 @@ lav_partable_subset_measurement_model <- function(PT = NULL, # we return all covariances among the latent variables # # - also, we should check if we have any 'higher' order factors -# +# lav_partable_subset_structural_model <- function(PT = NULL, lavpta = NULL, idx.only = FALSE) { diff --git a/R/lav_partable_unrestricted.R b/R/lav_partable_unrestricted.R index 9181e423..615e02ae 100644 --- a/R/lav_partable_unrestricted.R +++ b/R/lav_partable_unrestricted.R @@ -16,11 +16,11 @@ lav_partable_unrestricted <- function(lavobject = NULL, sample.cov.x = NULL, sample.mean.x = NULL) { - lav_partable_indep_or_unrestricted(lavobject = lavobject, - lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, - lavsamplestats = lavsamplestats, sample.cov = sample.cov, - sample.mean = sample.mean , sample.slopes = sample.slopes, - sample.th = sample.th, sample.th.idx = sample.th.idx, + lav_partable_indep_or_unrestricted(lavobject = lavobject, + lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, + lavsamplestats = lavsamplestats, sample.cov = sample.cov, + sample.mean = sample.mean , sample.slopes = sample.slopes, + sample.th = sample.th, sample.th.idx = sample.th.idx, independent = FALSE) } @@ -119,9 +119,9 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, ngroups <- lavdata@ngroups nlevels <- lavdata@nlevels - # what with fixed.x? + # what with fixed.x? # - does not really matter; fit will be saturated any way - # - fixed.x = TRUE may avoid convergence issues with non-numeric + # - fixed.x = TRUE may avoid convergence issues with non-numeric # x-covariates #if(lavoptions$mimic %in% c("lavaan", "Mplus")) { fixed.x = lavoptions$fixed.x @@ -207,11 +207,11 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, block.idx <- match(ov.names, OV.NAMES) if(l == 1L) { - sample.cov <- YLp[[2]]$Sigma.W[block.idx, block.idx, + sample.cov <- YLp[[2]]$Sigma.W[block.idx, block.idx, drop = FALSE] sample.mean <- YLp[[2]]$Mu.W[block.idx] } else { - sample.cov <- YLp[[2]]$Sigma.B[block.idx, block.idx, + sample.cov <- YLp[[2]]$Sigma.B[block.idx, block.idx, drop = FALSE] sample.mean <- YLp[[2]]$Mu.B[block.idx] } @@ -219,14 +219,14 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, # force local sample.cov to be strictly pd (and exaggerate) # just for starting values anyway, but at least the first # evaluation will be feasible - sample.cov <- lav_matrix_symmetric_force_pd(sample.cov, + sample.cov <- lav_matrix_symmetric_force_pd(sample.cov, tol = 1e-03) } # a) VARIANCES (all ov's, if !conditional.x, also exo's) nvar <- length(ov.names) - + lhs <- c(lhs, ov.names) op <- c(op, rep("~~", nvar)) rhs <- c(rhs, ov.names) @@ -257,29 +257,29 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, free <- c(free, rep(1L, pstar)) exo <- c(exo, rep(0L, pstar)) } - + # starting values -- covariances if(!is.null(sample.cov)) { - ustart <- c(ustart, lav_matrix_vech(sample.cov, + ustart <- c(ustart, lav_matrix_vech(sample.cov, diagonal = FALSE)) } else { ustart <- c(ustart, rep(as.numeric(NA), pstar)) } } - + # ordered? fix variances, add thresholds ord.names <- character(0L) if(categorical) { ord.names <- ov$name[ ov$type == "ordered" ] # only for this group ord.names <- ov.names[ which(ov.names %in% ord.names) ] - + if(length(ord.names) > 0L) { # fix variances to 1.0 idx <- which(lhs %in% ord.names & op == "~~" & lhs == rhs) ustart[idx] <- 1.0 free[idx] <- 0L - + # add thresholds lhs.th <- character(0); rhs.th <- character(0) for(o in ord.names) { @@ -297,7 +297,7 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, level <- c(level, rep(l, nel)) free <- c(free, rep(1L, nel)) exo <- c(exo, rep(0L, nel)) - + # starting values if(!is.null(sample.th) && !is.null(sample.th.idx)) { th.start <- sample.th[ sample.th.idx > 0L ] @@ -332,7 +332,7 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, ustart <- c(ustart, rep(1, nel)) } } # categorical - + # meanstructure? if(meanstructure) { @@ -398,13 +398,13 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, } if(fixed.x) { - # fix variances/covariances + # fix variances/covariances exo.idx <- which(rhs %in% ov.names.x & lhs %in% ov.names.x & op == "~~" & group == g) exo[exo.idx] <- 1L free[exo.idx] <- 0L - + # fix means exo.idx <- which(lhs %in% ov.names.x & op == "~1" & group == g) @@ -537,7 +537,7 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, # unrestricted nnox <- length(ov.names.nox) nel <- nnox * nx - + lhs <- c(lhs, rep(ov.names.nox, times = nx)) op <- c(op, rep("~", nel)) rhs <- c(rhs, rep(ov.names.x, each = nnox)) @@ -546,7 +546,7 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, level <- c(level, rep(l, nel)) free <- c(free, rep(1L, nel)) exo <- c(exo, rep(1L, nel)) - + # starting values -- slopes if(!is.null(sample.slopes)) { ustart <- c(ustart, lav_matrix_vec(sample.slopes)) @@ -583,7 +583,7 @@ lav_partable_indep_or_unrestricted <- function(lavobject = NULL, #unco = free ) - + # keep level column if no levels? (no for now) if(nlevels < 2L) { LIST$level <- NULL diff --git a/R/lav_partable_utils.R b/R/lav_partable_utils.R index 45ec0cd9..bcc45456 100644 --- a/R/lav_partable_utils.R +++ b/R/lav_partable_utils.R @@ -73,7 +73,7 @@ lav_partable_ndat <- function(partable) { fixed.x <- any(partable$exo > 0L & partable$free == 0L) conditional.x <- any(partable$exo > 0L & partable$op == "~") categorical <- any(partable$op == "|") - if(categorical) { + if(categorical) { meanstructure <- TRUE } @@ -111,10 +111,10 @@ lav_partable_ndat <- function(partable) { if(length(ov.names.y) > 0L) { pstar <- pstar + length(ov.names.y) } - + # except within-only 'x' (unless fixed.x) ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) - ov.names.x2 <- unlist(lav_partable_vnames(partable, "ov.x", + ov.names.x2 <- unlist(lav_partable_vnames(partable, "ov.x", block = seq_len(nblocks)[-b])) ov.names.x <- ov.names.x[ !ov.names.x %in% ov.names.x2 ] if(!fixed.x && length(ov.names.x) > 0L) { @@ -207,7 +207,7 @@ lav_partable_df <- function(partable) { # check order of covariances: we only fill the upper.tri # therefore, we 'switch' lhs & rhs if they appear in the wrong order -lav_partable_covariance_reorder <- function(partable, +lav_partable_covariance_reorder <- function(partable, ov.names = NULL, lv.names = NULL) { @@ -245,7 +245,7 @@ lav_partable_covariance_reorder <- function(partable, tmp <- partable$lhs[ swap.idx ] partable$lhs[ swap.idx ] <- partable$rhs[ swap.idx ] partable$rhs[ swap.idx ] <- tmp - + partable } diff --git a/R/lav_partable_vnames.R b/R/lav_partable_vnames.R index 0a8bdeef..086c558e 100644 --- a/R/lav_partable_vnames.R +++ b/R/lav_partable_vnames.R @@ -80,8 +80,8 @@ lav_partable_vnames <- function(partable, type = NULL, ..., # ALWAYS need `block' column -- create one if missing if(is.null(partable$block)) { partable$block <- rep(1L, length(partable$lhs)) - } - + } + # nblocks -- block column is integer only nblocks <- lav_partable_nblocks(partable) @@ -111,7 +111,7 @@ lav_partable_vnames <- function(partable, type = NULL, ..., block.select <- ( block.select & partable[[block.var]] %in% block.val ) } else { - stop("lavaan ERROR: selection variable `", + stop("lavaan ERROR: selection variable `", block.var, " not found in the parameter table.") } @@ -120,7 +120,7 @@ lav_partable_vnames <- function(partable, type = NULL, ..., stop("lavaan ERROR: ", block.var , " column does not contain value `", block.val, "'") } - block.select <- ( block.select & + block.select <- ( block.select & partable[[block.var]] %in% block.val ) } } # dot @@ -281,8 +281,8 @@ lav_partable_vnames <- function(partable, type = NULL, ..., ov.tmp <- c(ov.ind, ov.y, ov.x) ov.extra <- unique(c(ov.cov, ov.int)) # must be in this order! - # so that - # lav_partable_independence + # so that + # lav_partable_independence # retains the same order ov.names <- c(ov.tmp, ov.extra[ !ov.extra %in% ov.tmp ]) } diff --git a/R/lav_pearson.R b/R/lav_pearson.R index 89735707..bfa34901 100644 --- a/R/lav_pearson.R +++ b/R/lav_pearson.R @@ -4,7 +4,7 @@ pp_logl <- function(Y1, Y2, eXo=NULL, rho=NULL, fit.y1=NULL, fit.y2=NULL) { lik <- pp_lik(Y1=Y1, Y2=Y2, eXo=eXo, rho=rho, fit.y1=fit.y1, fit.y2=fit.y2) - if(all(lik > 0, na.rm = TRUE)) + if(all(lik > 0, na.rm = TRUE)) logl <- sum(log(lik), na.rm = TRUE) else logl <- -Inf @@ -12,7 +12,7 @@ pp_logl <- function(Y1, Y2, eXo=NULL, rho=NULL, fit.y1=NULL, fit.y2=NULL) { } # individual likelihoods -pp_lik <- function(Y1, Y2, eXo=NULL, +pp_lik <- function(Y1, Y2, eXo=NULL, eta.y1 = NULL, eta.y2 = NULL, var.y1 = NULL, var.y2 = NULL, rho=NULL, fit.y1=NULL, fit.y2=NULL) { @@ -36,12 +36,12 @@ pp_lik <- function(Y1, Y2, eXo=NULL, eta.y2 <- fit.y2$yhat } - # lik + # lik cov.y12 <- rho*sqrt(var.y1)*sqrt(var.y2) sigma <- matrix(c(var.y1,cov.y12,cov.y12,var.y2), 2L, 2L) #lik <- numeric(length(Y1)) #for(i in 1:length(Y1)) - # lik[i] <- dmvnorm(c(Y1[i],Y2[i]), mean=c(eta.y1[i], eta.y2[i]), + # lik[i] <- dmvnorm(c(Y1[i],Y2[i]), mean=c(eta.y1[i], eta.y2[i]), # sigma=sigma) lik <- dmnorm( cbind(Y1,Y2), mean=cbind(eta.y1, eta.y2), varcov=sigma) @@ -129,7 +129,7 @@ pp_cor_TS <- function(Y1, Y2, eXo=NULL, fit.y1=NULL, fit.y2=NULL, rho } -pp_cor_scores <- function(Y1, Y2, eXo=NULL, rho=NULL, +pp_cor_scores <- function(Y1, Y2, eXo=NULL, rho=NULL, fit.y1=NULL, fit.y2=NULL) { stopifnot(!is.null(rho)) @@ -174,13 +174,13 @@ pp_cor_scores <- function(Y1, Y2, eXo=NULL, rho=NULL, z <- (Y1c*Y1c)/var.y1 - 2*rho*Y1c*Y2c/(sd.y1*sd.y2) + (Y2c*Y2c)/var.y2 dx.rho <- rho/R + (Y1c*Y2c/(sd.y1*sd.y2*R) - z*rho/(R*R)) - list(dx.mu.y1=dx.mu.y1, dx.var.y1=dx.var.y1, - dx.mu.y2=dx.mu.y2, dx.var.y2=dx.var.y2, + list(dx.mu.y1=dx.mu.y1, dx.var.y1=dx.var.y1, + dx.mu.y2=dx.mu.y2, dx.var.y2=dx.var.y2, dx.sl.y1=dx.sl.y1, dx.sl.y2=dx.sl.y2, dx.rho=dx.rho) } -pp_cor_scores_no_exo <- function(Y1, Y2, +pp_cor_scores_no_exo <- function(Y1, Y2, eta.y1 = NULL, var.y1 = NULL, eta.y2 = NULL, var.y2 = NULL, rho = NULL) { @@ -212,8 +212,8 @@ pp_cor_scores_no_exo <- function(Y1, Y2, z <- (Y1c*Y1c)/var.y1 - 2*rho*Y1c*Y2c/(sd.y1*sd.y2) + (Y2c*Y2c)/var.y2 dx.rho <- rho/R + (Y1c*Y2c/(sd.y1*sd.y2*R) - z*rho/(R*R)) - list(dx.mu.y1=dx.mu.y1, dx.var.y1=dx.var.y1, - dx.mu.y2=dx.mu.y2, dx.var.y2=dx.var.y2, + list(dx.mu.y1=dx.mu.y1, dx.var.y1=dx.var.y1, + dx.mu.y2=dx.mu.y2, dx.var.y2=dx.var.y2, dx.rho=dx.rho) } diff --git a/R/lav_predict.R b/R/lav_predict.R index f0ed31bf..f9d30d37 100644 --- a/R/lav_predict.R +++ b/R/lav_predict.R @@ -34,7 +34,7 @@ lavPredict <- function(object, type = "lv", newdata = NULL, method = "EBM", type <- tolower(type) if(type %in% c("latent", "lv", "factor", "factor.score", "factorscore")) type <- "lv" - if(type %in% c("ov","yhat")) + if(type %in% c("ov","yhat")) type <- "yhat" # se? @@ -78,7 +78,7 @@ lavPredict <- function(object, type = "lv", newdata = NULL, method = "EBM", if(!is.null(ETA)) { warning("lavaan WARNING: lvs will be predicted here; supplying ETA has no effect") } - + # post fit check (lv pd?) ok <- lav_object_post_check(object) #if(!ok) { @@ -179,7 +179,7 @@ lavPredict <- function(object, type = "lv", newdata = NULL, method = "EBM", } else if(type == "fy") { out <- lav_predict_fy(lavobject = NULL, lavmodel = lavmodel, lavdata = lavdata, lavsamplestats = lavsamplestats, - lavimplied = lavimplied, + lavimplied = lavimplied, data.obs = data.obs, eXo = eXo, ETA = ETA, method = method, optim.method = optim.method) @@ -206,7 +206,7 @@ lavPredict <- function(object, type = "lv", newdata = NULL, method = "EBM", if(fsm) { attr(out, "fsm") <- FSM } - + if(se != "none") { attr(out, "se") <- SE } @@ -267,14 +267,14 @@ lav_predict_eta <- function(lavobject = NULL, # for convenience if(method == "ebm") { out <- lav_predict_eta_ebm_ml(lavobject = lavobject, lavmodel = lavmodel, lavdata = lavdata, - lavsamplestats = lavsamplestats, se = se, - level = level, data.obs = data.obs, eXo = eXo, + lavsamplestats = lavsamplestats, se = se, + level = level, data.obs = data.obs, eXo = eXo, ML = FALSE, optim.method = optim.method) } else if(method == "ml") { out <- lav_predict_eta_ebm_ml(lavobject = lavobject, lavmodel = lavmodel, lavdata = lavdata, - lavsamplestats = lavsamplestats, se = se, - level = level, data.obs = data.obs, eXo = eXo, + lavsamplestats = lavsamplestats, se = se, + level = level, data.obs = data.obs, eXo = eXo, ML = TRUE, optim.method = optim.method) } else { stop("lavaan ERROR: unkown method: ", method) @@ -286,17 +286,17 @@ lav_predict_eta <- function(lavobject = NULL, # for convenience # factor scores - normal case -# NOTE: this is the classic 'regression' method; for the linear/continuous +# NOTE: this is the classic 'regression' method; for the linear/continuous # case, this is equivalent to both EB and EBM lav_predict_eta_normal <- function(lavobject = NULL, # for convenience # sub objects - lavmodel = NULL, lavdata = NULL, + lavmodel = NULL, lavdata = NULL, lavsamplestats = NULL, lavimplied = NULL, # optional new data data.obs = NULL, eXo = NULL, se = "none", level = 1L, - fsm = FALSE) { + fsm = FALSE) { # full object? if(inherits(lavobject, "lavaan")) { @@ -328,7 +328,7 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience DATA <- lavdata@X[[g]] MP <- lavdata@Mp[[g]] } - data.obs[[g]] <- + data.obs[[g]] <- lav_mvnorm_missing_impute_pattern(Y = DATA, Mp = MP, Mu = lavimplied$mean[[g]], @@ -342,7 +342,7 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience VETA <- computeVETA(lavmodel = lavmodel) EETA <- computeEETA(lavmodel = lavmodel, lavsamplestats = lavsamplestats) EY <- computeEY( lavmodel = lavmodel, lavsamplestats = lavsamplestats) - + FS <- vector("list", length = lavdata@ngroups) if(fsm) { FSM <- vector("list", length = lavdata@ngroups) @@ -356,20 +356,20 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience if(lavdata@nlevels > 1L) { Lp <- lavdata@Lp[[g]] YLp <- lavsamplestats@YLp[[g]] - + # implied for this group group.idx <- (g - 1)*lavdata@nlevels + seq_len(lavdata@nlevels) implied.group <- lapply(lavimplied, function(x) x[group.idx]) # random effects (=random intercepts or cluster means) - out <- lav_mvnorm_cluster_implied22l(Lp = Lp, + out <- lav_mvnorm_cluster_implied22l(Lp = Lp, implied = implied.group) MB.j <- lav_mvnorm_cluster_em_estep_ranef(YLp = YLp, Lp = Lp, sigma.w = out$sigma.w, sigma.b = out$sigma.b, sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz, mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b, se = FALSE) - + ov.idx <- Lp$ov.idx if(level == 1L) { @@ -379,7 +379,7 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience # center data.obs.g <- data.W - data.B } else if(level == 2L) { - Data.B <- matrix(0, nrow = nrow(MB.j), + Data.B <- matrix(0, nrow = nrow(MB.j), ncol = ncol(data.obs[[g]])) Data.B[, ov.idx[[1]] ] <- MB.j data.obs.g <- Data.B[, ov.idx[[2]] ] @@ -418,7 +418,7 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience # standard error if(se == "standard") { - tmp <- (VETA.g - + tmp <- (VETA.g - VETA.g %*% t(LAMBDA.g) %*% Sigma.hat.inv.g %*% LAMBDA.g %*% VETA.g) tmp.d <- diag(tmp) tmp.d[ tmp.d < 1e-05 ] <- as.numeric(NA) @@ -452,28 +452,28 @@ lav_predict_eta_normal <- function(lavobject = NULL, # for convenience } # factor scores - normal case - Bartlett method -# NOTES: 1) this is the classic 'Bartlett' method; for the linear/continuous +# NOTES: 1) this is the classic 'Bartlett' method; for the linear/continuous # case, this is equivalent to 'ML' -# 2) the usual formula is: +# 2) the usual formula is: # FSC = solve(lambda' theta.inv lambda) (lambda' theta.inv) -# BUT to deal with zero or negative variances, we use the +# BUT to deal with zero or negative variances, we use the # 'GLS' version instead: # FSC = solve(lambda' sigma.inv lambda) (lambda' sigma.inv) -# Reference: Bentler & Yuan (1997) 'Optimal Conditionally Unbiased -# Equivariant Factor Score Estimators' -# in Berkane (Ed) 'Latent variable modeling with +# Reference: Bentler & Yuan (1997) 'Optimal Conditionally Unbiased +# Equivariant Factor Score Estimators' +# in Berkane (Ed) 'Latent variable modeling with # applications to causality' (Springer-Verlag) # 3) instead of solve(), we use MASS::ginv, for special settings where # -by construction- (lambda' sigma.inv lambda) is singular lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience # sub objects - lavmodel = NULL, lavdata = NULL, + lavmodel = NULL, lavdata = NULL, lavsamplestats = NULL, lavimplied = NULL, # optional new data data.obs = NULL, eXo = NULL, se = "none", level = 1L, - fsm = FALSE) { + fsm = FALSE) { # full object? if(inherits(lavobject, "lavaan")) { @@ -522,7 +522,7 @@ lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience VETA <- computeVETA(lavmodel = lavmodel) # for se only EETA <- computeEETA(lavmodel = lavmodel, lavsamplestats = lavsamplestats) EY <- computeEY( lavmodel = lavmodel, lavsamplestats = lavsamplestats) - + FS <- vector("list", length = lavdata@ngroups) if(fsm) { FSM <- vector("list", length = lavdata@ngroups) @@ -536,20 +536,20 @@ lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience if(lavdata@nlevels > 1L) { Lp <- lavdata@Lp[[g]] YLp <- lavsamplestats@YLp[[g]] - + # implied for this group group.idx <- (g - 1)*lavdata@nlevels + seq_len(lavdata@nlevels) implied.group <- lapply(lavimplied, function(x) x[group.idx]) # random effects (=random intercepts or cluster means) - out <- lav_mvnorm_cluster_implied22l(Lp = Lp, + out <- lav_mvnorm_cluster_implied22l(Lp = Lp, implied = implied.group) MB.j <- lav_mvnorm_cluster_em_estep_ranef(YLp = YLp, Lp = Lp, sigma.w = out$sigma.w, sigma.b = out$sigma.b, sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz, mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b, se = FALSE) - + ov.idx <- Lp$ov.idx if(level == 1L) { @@ -559,7 +559,7 @@ lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience # center data.obs.g <- data.W - data.B } else if(level == 2L) { - Data.B <- matrix(0, nrow = nrow(MB.j), + Data.B <- matrix(0, nrow = nrow(MB.j), ncol = ncol(data.obs[[g]])) Data.B[, ov.idx[[1]] ] <- MB.j data.obs.g <- Data.B[, ov.idx[[2]] ] @@ -599,14 +599,14 @@ lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience # standard error if(se == "standard") { - # the traditional formula is: + # the traditional formula is: # solve(t(lambda) %*% solve(theta) %*% lambda) - # but we replace it by + # but we replace it by # solve( t(lambda) %*% solve(sigma) %*% lambda ) - psi # to handle negative variances - # in addition, we use ginv - tmp <- ( MASS::ginv(t(LAMBDA.g) %*% - Sigma.hat.inv.g %*% LAMBDA.g) + # in addition, we use ginv + tmp <- ( MASS::ginv(t(LAMBDA.g) %*% + Sigma.hat.inv.g %*% LAMBDA.g) - VETA.g ) tmp.d <- diag(tmp) tmp.d[ tmp.d < 1e-05 ] <- as.numeric(NA) @@ -696,8 +696,8 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience } } EETAx <- computeEETAx(lavmodel = lavmodel, lavsamplestats = lavsamplestats, - eXo = eXo, nobs = lavdata@norig, - remove.dummy.lv = TRUE) ## FIXME? + eXo = eXo, nobs = lavdata@norig, + remove.dummy.lv = TRUE) ## FIXME? TH <- computeTH( lavmodel = lavmodel) THETA <- computeTHETA(lavmodel = lavmodel) @@ -716,7 +716,7 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience log.fy <- lav_predict_fy_eta.i(lavmodel = lavmodel, lavdata = lavdata, lavsamplestats = lavsamplestats, - y.i = y.i, + y.i = y.i, x.i = x.i, eta.i = matrix(x2, nrow=1L), # <---- eta! theta.sd = theta.sd, @@ -730,7 +730,7 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience # a pattern of all (in)correct drives the 'theta' parameter # towards +/- Inf # - therefore, we add a vague prior, just to stabilize - # + # diff <- t(x) - mu.i V <- diag( length(x) ) * 1e-05 tmp <- as.numeric(0.5 * diff %*% V %*% t(diff)) @@ -752,11 +752,11 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience nfac2 <- nfac2 + length(lavmodel@ov.y.dummy.lv.idx[[g]]) } FS[[g]] <- matrix(as.numeric(NA), nrow(data.obs[[g]]), nfac2) - + # special case: no regular lv's if(nfac == 0) { # impute dummy ov.y (if any) - FS[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]] ] <- + FS[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]] ] <- data.obs[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE] next } @@ -802,7 +802,7 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience y.i=y.i, x.i=x.i, mu.i=mu.i) } else if(optim.method == "bfgs") { out <- optim(par = START, fn = f.eta.i, - gr = NULL, + gr = NULL, control = list(reltol = 1e-8, fnscale = 1.1), method = "BFGS", y.i = y.i, x.i = x.i, mu.i = mu.i) @@ -833,7 +833,7 @@ lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience # variable scores # `measurement part': # y*_i = nu + lambda eta_i + K x_i + epsilon_i -# +# # where eta_i = latent variable value for i (either given or from predict) # # Two types: 1) nrow(ETA) = nrow(X) (factor scores) @@ -850,7 +850,7 @@ lav_predict_yhat <- function(lavobject = NULL, # for convience # ETA values ETA = NULL, # options - method = "EBM", + method = "EBM", duplicate = FALSE, optim.method = "bfgs") { @@ -861,7 +861,7 @@ lav_predict_yhat <- function(lavobject = NULL, # for convience lavsamplestats <- lavobject@SampleStats lavimplied <- lavobject@implied } else { - stopifnot(!is.null(lavmodel), !is.null(lavdata), + stopifnot(!is.null(lavmodel), !is.null(lavdata), !is.null(lavsamplestats), !is.null(lavimplied)) } @@ -884,7 +884,7 @@ lav_predict_yhat <- function(lavobject = NULL, # for convience # matrix if(is.matrix(ETA)) { # user-specified? if(nrow(ETA) == 1L) { - tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA), + tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA), byrow = TRUE) } else if(nrow(ETA) != lavsamplestats@ntotal) { stop("lavaan ERROR: nrow(ETA) != lavsamplestats@ntotal") @@ -969,9 +969,9 @@ lav_predict_fy <- function(lavobject = NULL, # for convience FY <- vector("list", length=lavdata@ngroups) for(g in seq_len(lavdata@ngroups)) { FY[[g]] <- lav_predict_fy_internal(X = data.obs[[g]], yhat = YHAT[[g]], - TH = TH[[g]], THETA = THETA[[g]], + TH = TH[[g]], THETA = THETA[[g]], num.idx = lavmodel@num.idx[[g]], - th.idx = lavmodel@th.idx[[g]], + th.idx = lavmodel@th.idx[[g]], link = lavmodel@link, log. = log.) } @@ -980,12 +980,12 @@ lav_predict_fy <- function(lavobject = NULL, # for convience # single group, internal function -lav_predict_fy_internal <- function(X = NULL, yhat = NULL, +lav_predict_fy_internal <- function(X = NULL, yhat = NULL, TH = NULL, THETA = NULL, - num.idx = NULL, th.idx = NULL, + num.idx = NULL, th.idx = NULL, link = NULL, log. = FALSE) { - + # shortcuts theta.var <- diag(THETA) @@ -1000,7 +1000,7 @@ lav_predict_fy_internal <- function(X = NULL, yhat = NULL, # tmp <- (X - yhat)^2 # } else { # tmp <- sweep(X, MARGIN=2, STATS=yhat, FUN="-")^2 - # } + # } # tmp1 <- sweep(tmp, MARGIN=2, theta.var, "/") # tmp2 <- exp( -0.5 * tmp1 ) # tmp3 <- sweep(tmp2, MARGIN=2, sqrt(2*pi*theta.var), "/") @@ -1017,15 +1017,15 @@ lav_predict_fy_internal <- function(X = NULL, yhat = NULL, # first, NUMERIC variables if(length(num.idx) > 0L) { # multivariate - # FY.group[,num.idx] <- - # dmnorm(X[,num.idx], - # mean = yhat[n,num.idx], + # FY.group[,num.idx] <- + # dmnorm(X[,num.idx], + # mean = yhat[n,num.idx], # varcov = THETA[[g]][num.idx, num.idx], log = log.) for(v in num.idx) { - FY.group[,v] <- dnorm(X[,v], + FY.group[,v] <- dnorm(X[,v], # YHAT may change or not per case - mean = yhat[,v], - sd = sqrt(theta.var[v]), + mean = yhat[,v], + sd = sqrt(theta.var[v]), log = log.) } } @@ -1059,7 +1059,7 @@ lav_predict_fy_internal <- function(X = NULL, yhat = NULL, if(length(idx) > 0L) { fy[idx] <- .Machine$double.eps } - + # log? if(log.) { fy <- log(fy) @@ -1078,7 +1078,7 @@ lav_predict_fy_internal <- function(X = NULL, yhat = NULL, FY.group } - + # conditional density y -- assuming independence!! # f(y_i | eta_i, x_i) @@ -1088,7 +1088,7 @@ lav_predict_fy_internal <- function(X = NULL, yhat = NULL, lav_predict_fy_eta.i <- function(lavmodel = NULL, lavdata = NULL, lavsamplestats = NULL, y.i = NULL, x.i = NULL, - eta.i = NULL, theta.sd = NULL, g = 1L, + eta.i = NULL, theta.sd = NULL, g = 1L, th = NULL, th.idx = NULL, log = TRUE) { mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0,lavmodel@nmat))[g] @@ -1114,7 +1114,7 @@ lav_predict_fy_eta.i <- function(lavmodel = NULL, lavdata = NULL, for(v in seq_len(lavmodel@nvar[g])) { if(lavdata@ov$type[v] == "numeric") { ### FIXME!!! we can do all numeric vars at once!! - FY[v] <- dnorm(y.i[v], mean = YHAT[v], sd = theta.sd[v], + FY[v] <- dnorm(y.i[v], mean = YHAT[v], sd = theta.sd[v], log = log) } else if(lavdata@ov$type[v] == "ordered") { # handle missing value @@ -1136,8 +1136,8 @@ lav_predict_fy_eta.i <- function(lavmodel = NULL, lavdata = NULL, } } } else { - stop("lavaan ERROR: unknown type: `", - lavdata@ov$type[v], "' for variable: ", + stop("lavaan ERROR: unknown type: `", + lavdata@ov$type[v], "' for variable: ", lavdata@ov$name[v]) } } diff --git a/R/lav_prelis.R b/R/lav_prelis.R index 067eb48a..b2bb00ef 100644 --- a/R/lav_prelis.R +++ b/R/lav_prelis.R @@ -1,5 +1,5 @@ # small utility functions to deal with PRELIS -# Y.R.: 11 dec 2012 +# Y.R.: 11 dec 2012 prelis.read.cor <- function(file = "") { # read in numbers as characters @@ -27,20 +27,20 @@ prelis.read.acm <- function(file = "", rescale=1e-3) { # scale numbers raw <- raw*rescale - + ACM <- lav_matrix_lower2full(raw, diagonal = TRUE) ACM } -prelis.write.data <- function(data, file = "prelis", na.rm = TRUE, +prelis.write.data <- function(data, file = "prelis", na.rm = TRUE, labels = FALSE, std.ov = FALSE) { dfile <- paste(file, ".raw", sep = "") - write.table(data, file = dfile, na = "-999999", col.names = FALSE, + write.table(data, file = dfile, na = "-999999", col.names = FALSE, row.names = FALSE, quote = FALSE) if (labels) { lfile <- paste(file, ".lab", sep = "") - write.table(unique(names(data)), file = lfile, row.names = F, + write.table(unique(names(data)), file = lfile, row.names = F, col.names = F, quote = F) } } diff --git a/R/lav_print.R b/R/lav_print.R index 24db5a50..7cda0390 100644 --- a/R/lav_print.R +++ b/R/lav_print.R @@ -1,6 +1,6 @@ ## NOTE: ## round(1.2355, 3) = 1.236 -## but +## but ## round(1.2345, 3) = 1.234 ## ## perhaps we should add 0.0005 or something to avoid this? @@ -43,7 +43,7 @@ print.lavaan.list <- function(x, ...) { print.lavaan.matrix.symmetric <- function(x, ..., nd=3) { # print only lower triangle of a symmetric matrix # this function was inspired by the `print.correlation' function - # in package nlme + # in package nlme y <- x; y <- unclass(y) ll <- lower.tri(x, diag=TRUE) y[ll] <- format(round(x[ll], digits=nd)); y[!ll] <- "" @@ -82,20 +82,20 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { # format for numeric values num.format <- paste("%", max(8, nd + 5), ".", nd, "f", sep = "") - char.format <- paste("%", max(8, nd + 5), "s", sep="") + char.format <- paste("%", max(8, nd + 5), "s", sep="") # output sections - GSECTIONS <- c("Latent Variables", - "Composites", - "Regressions", + GSECTIONS <- c("Latent Variables", + "Composites", + "Regressions", "Covariances", - "Intercepts", - "Thresholds", - "Variances", + "Intercepts", + "Thresholds", + "Variances", "Scales y*", "Group Weight", "R-Square") - ASECTIONS <- c("Defined Parameters", + ASECTIONS <- c("Defined Parameters", "Constraints") # header? @@ -108,7 +108,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { # 1. information # 2. se # 3. bootstrap requested/successful draws - if(!is.null(x$se)) { + if(!is.null(x$se)) { # 1. t0.txt <- sprintf(" %-35s", "Information") tmp.txt <- attr(x, "information") @@ -118,10 +118,10 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { # 2. if(attr(x, "information") %in% c("expected", "first.order") || - attr(x, "observed.information") == "h1") { + attr(x, "observed.information") == "h1") { t0.txt <- sprintf(" %-35s", "Information saturated (h1) model") tmp.txt <- attr(x, "h1.information") - t1.txt <- sprintf(" %15s", + t1.txt <- sprintf(" %15s", paste(toupper(substring(tmp.txt,1,1)), substring(tmp.txt,2), sep="")) cat(t0.txt, t1.txt, "\n", sep="") @@ -129,7 +129,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { if(attr(x, "information") == "observed") { t0.txt <- sprintf(" %-35s", "Observed information based on") tmp.txt <- attr(x, "observed.information") - t1.txt <- sprintf(" %15s", + t1.txt <- sprintf(" %15s", paste(toupper(substring(tmp.txt,1,1)), substring(tmp.txt,2), sep="")) cat(t0.txt, t1.txt, "\n", sep="") @@ -141,14 +141,14 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { t1.txt <- sprintf(" %19s", paste(toupper(substring(tmp.txt,1,1)), substring(tmp.txt,2), sep="")) cat(t0.txt, t1.txt, "\n", sep="") - + # 4. if(attr(x, "se") == "bootstrap" && !is.null(attr(x, "bootstrap"))) { - t0.txt <- + t0.txt <- sprintf(" %-40s", "Number of requested bootstrap draws") t1.txt <- sprintf(" %10i", attr(x, "bootstrap")) cat(t0.txt, t1.txt, "\n", sep="") - t0.txt <- + t0.txt <- sprintf(" %-40s", "Number of successful bootstrap draws") t1.txt <- sprintf(" %10i", attr(x, "bootstrap.successful")) cat(t0.txt, t1.txt, "\n", sep="") @@ -181,7 +181,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { y <- as.data.frame( lapply(x, function(x) { if(is.numeric(x)) { - sprintf(num.format, x) + sprintf(num.format, x) } else { x } @@ -199,9 +199,9 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { } # convert to character matrix - m <- as.matrix(format.data.frame(y, na.encode = FALSE, + m <- as.matrix(format.data.frame(y, na.encode = FALSE, justify = "right")) - + # use empty row names rownames(m) <- rep("", nrow(m)) @@ -307,7 +307,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { colnames(m)[ colnames(m) == "P(>|z|)"] <- "P(>|t|)" colnames(m)[ colnames(m) == "riv" ] <- "RIV" } - + # format column names colnames(m) <- sprintf(char.format, colnames(m)) @@ -352,7 +352,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { # ov/lv names ov.names <- lavNames(x, "ov", block = b) lv.names <- lavNames(x, "lv", block = b) - + # level header if(nlevels > 1L) { level.label <- attr(x, "level.label") @@ -363,7 +363,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { # group-specific sections for(s in GSECTIONS) { if(s == "Latent Variables") { - row.idx <- which( x$op == "=~" & !x$lhs %in% ov.names & + row.idx <- which( x$op == "=~" & !x$lhs %in% ov.names & x$block == b) if(length(row.idx) == 0L) next m[row.idx,1] <- .makeNames(x$rhs[row.idx], x$label[row.idx]) @@ -401,7 +401,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { } else if(s == "Thresholds") { row.idx <- which(x$op == "|" & x$block == b) if(length(row.idx) == 0L) next - m[row.idx,1] <- .makeNames(paste(x$lhs[row.idx], "|", + m[row.idx,1] <- .makeNames(paste(x$lhs[row.idx], "|", x$rhs[row.idx], sep=""), x$label[row.idx]) } else if(s == "Variances") { row.idx <- which(x$op == "~~" & x$lhs == x$rhs & !x$exo & @@ -429,16 +429,16 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { } else { row.idx <- integer(0L) } - + # do we need special formatting for this section? # three types: # - regular (nothing to do, except row/colnames) # - R-square # - Latent Variables (and Composites), Regressions and Covariances # 'bundle' the output per lhs element - + # bundling - if(s %in% c("Latent Variables", "Composites", + if(s %in% c("Latent Variables", "Composites", "Regressions", "Covariances")) { nel <- length(row.idx) M <- matrix("", nrow = nel*2, ncol = ncol(m)) @@ -476,7 +476,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { cat("\n", s, ":\n", sep = "") #cat("\n") print(M, quote = FALSE) - + # R-square } else if(s == "R-Square") { M <- m[row.idx,1:2,drop=FALSE] @@ -486,7 +486,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { cat("\n", s, ":\n", sep = "") #cat("\n") print(M, quote = FALSE) - + # Regular } else { #M <- rbind(matrix("", nrow = 1L, ncol = ncol(m)), @@ -500,7 +500,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { print(M, quote = FALSE) } } # GSECTIONS - + } # levels } # groups @@ -515,7 +515,7 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { } else if(s == "Constraints") { row.idx <- which(x$op %in% c("==", "<", ">")) if(length(row.idx) == 0) next - m[row.idx,1] <- .makeConNames(x$lhs[row.idx], x$op[row.idx], + m[row.idx,1] <- .makeConNames(x$lhs[row.idx], x$op[row.idx], x$rhs[row.idx], nd = nd) m[row.idx,2] <- sprintf(num.format, abs(x$est[row.idx])) M <- m[row.idx,1:2,drop=FALSE] @@ -609,13 +609,13 @@ print.lavaan.parameterEstimates <- function(x, ..., nd = 3L) { } summary.lavaan.fsr <- function(object, ...) { - + dotdotdot <- list(...) if(!is.null(dotdotdot$nd)) { nd <- dotdotdot$nd } else { nd <- 3L - } + } print.lavaan.fsr(x = object, nd = nd, mm = TRUE, struc = TRUE) } @@ -623,7 +623,7 @@ summary.lavaan.fsr <- function(object, ...) { print.lavaan.fsr <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) { y <- unclass(x) - + # print header if(!is.null(y$header)) { cat(y$header) @@ -636,7 +636,7 @@ print.lavaan.fsr <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) { for(b in seq_len(nblocks)) { cat("Measurement block for latent variable(s):", paste(lavNames(y$MM.FIT[[b]], "lv")), "\n") - + # fit measures? b.options <- lavInspect(y$MM.FIT[[b]], "options") if(b.options$test != "none") { @@ -656,7 +656,7 @@ print.lavaan.fsr <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) { if(struc) { cat("Structural Part\n") cat("\n") - #print.lavaan.parameterEstimates(y$PE, ..., nd = nd) + #print.lavaan.parameterEstimates(y$PE, ..., nd = nd) short.summary(y$STRUC.FIT) FIT <- fitMeasures(y$STRUC.FIT, fit.measures="default") @@ -664,7 +664,7 @@ print.lavaan.fsr <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) { print.fit.measures( FIT ) } } - PE <- parameterEstimates(y$STRUC.FIT, ci = FALSE, + PE <- parameterEstimates(y$STRUC.FIT, ci = FALSE, remove.eq = FALSE, remove.system.eq = TRUE, remove.ineq = FALSE, remove.def = FALSE, add.attributes = TRUE) diff --git a/R/lav_probit.R b/R/lav_probit.R index 9a73830f..e8890437 100644 --- a/R/lav_probit.R +++ b/R/lav_probit.R @@ -1,5 +1,5 @@ # ordered probit regression -# +# # YR 21 June 2012 # # why not using MASS::polr? @@ -14,9 +14,9 @@ # wrapper function -lavProbit <- function(y, X=NULL, y.levels=length(tabulate(y)), +lavProbit <- function(y, X=NULL, y.levels=length(tabulate(y)), weights = rep(1, length(y)), - offset = rep(0, length(y)), fast=FALSE, + offset = rep(0, length(y)), fast=FALSE, method = "nlminb.hessian", control = list(), verbose = FALSE) { @@ -33,7 +33,7 @@ lavProbit <- function(y, X=NULL, y.levels=length(tabulate(y)), stop("zero counts in middle categories; please recode") # initialize ref class - lavR <- lavRefProbit$new(y = y, X = X, y.levels=y.levels, + lavR <- lavRefProbit$new(y = y, X = X, y.levels=y.levels, weights = weights, offset = offset) # optimize (only if X) @@ -56,8 +56,8 @@ lavRefProbit <- setRefClass("lavProbit", contains = "lavML", # fields -fields = list(y = "integer", X = "matrix", - nobs = "integer", nexo = "integer", nth = "integer", +fields = list(y = "integer", X = "matrix", + nobs = "integer", nexo = "integer", nth = "integer", weights = "numeric", offset = "numeric", missing.values = "logical", missing.idx = "integer", Y1 = "matrix", Y2 = "matrix", @@ -77,7 +77,7 @@ initialize = function(y, X=NULL, y.levels=length(tabulate(y)), .self$y <- as.integer(y); .self$nth <- as.integer(y.levels - 1L) .self$nobs <- length(y) # X - if(is.null(X)) { + if(is.null(X)) { .self$nexo <- 0L } else { .self$X <- unname(X); .self$nexo <- ncol(X) @@ -91,7 +91,7 @@ initialize = function(y, X=NULL, y.levels=length(tabulate(y)), # weights and offset .self$weights <- weights; .self$offset <- offset - + # TH matrices (TRUE/FALSE) .self$Y1 <- matrix(1:nth, nobs, nth, byrow=TRUE) == .self$y .self$Y2 <- matrix(1:nth, nobs, nth, byrow=TRUE) == (.self$y - 1L) @@ -158,7 +158,7 @@ scores = function(x) { #gradient = function(x) { # if(!missing(x)) objective(x) # .self$p1 <- dnorm(z1); .self$p2 <- dnorm(z2) -# +# # # beta # dx.beta <- numeric(0L) # if(nexo > 0L) @@ -187,7 +187,7 @@ hessian = function(x) { .Y2 <- Y2[-missing.idx,,drop=FALSE] .z1 <- z1[-missing.idx] .z2 <- z2[-missing.idx] - .X <- X[-missing.idx,,drop=FALSE] + .X <- X[-missing.idx,,drop=FALSE] .p1 <- p1[-missing.idx] .p2 <- p2[-missing.idx] } else { @@ -212,7 +212,7 @@ hessian = function(x) { dxb <- .X*.p1 - .X*.p2 dx2.beta <- -1 * (crossprod(dxb, (dxb * .wtpr / .probits)) - - ( crossprod(.X * gnorm(.z1) * .wtpr, .X) - + ( crossprod(.X * gnorm(.z1) * .wtpr, .X) - crossprod(.X * gnorm(.z2) * .wtpr, .X) ) ) dx.ab <- crossprod(.dxa, (dxb * .wtpr / .probits)) - diff --git a/R/lav_representation_lisrel.R b/R/lav_representation_lisrel.R index 43e373e9..8f92282e 100644 --- a/R/lav_representation_lisrel.R +++ b/R/lav_representation_lisrel.R @@ -7,13 +7,13 @@ # updates: YR 2011-12-01: group specific extraction # YR 2012-05-17: thresholds -representation.LISREL <- function(partable = NULL, - target = NULL, - extra = FALSE, +representation.LISREL <- function(partable = NULL, + target = NULL, + extra = FALSE, remove.nonexisting = TRUE) { # prepare target list - if(is.null(target)) target <- partable + if(is.null(target)) target <- partable stopifnot(!is.null(target$block)) @@ -61,23 +61,23 @@ representation.LISREL <- function(partable = NULL, ov.names.x <- vnames(partable, "ov.x",block=g); nexo <- length(ov.names.x) ov.names.nox <- vnames(partable, "ov.nox",block=g) - # in this representation, we need to create 'phantom/dummy' latent + # in this representation, we need to create 'phantom/dummy' latent # variables for all `x' and `y' variables not in lv.names # (only y if conditional.x = TRUE) # regression dummys if(gamma) { tmp.names <- - unique( partable$lhs[(partable$op == "~" | + unique( partable$lhs[(partable$op == "~" | partable$op == "<~") & partable$block == g] ) } else { - tmp.names <- - unique( c(partable$lhs[(partable$op == "~" | - partable$op == "<~") & + tmp.names <- + unique( c(partable$lhs[(partable$op == "~" | + partable$op == "<~") & partable$block == g], - partable$rhs[(partable$op == "~" | - partable$op == "<~") & + partable$rhs[(partable$op == "~" | + partable$op == "<~") & partable$block == g]) ) } dummy.names1 <- tmp.names[ !tmp.names %in% lv.names ] @@ -101,7 +101,7 @@ representation.LISREL <- function(partable = NULL, # make sure order is the same as ov.names ov.dummy.names.nox[[g]] <- ov.names.nox[ ov.names.nox %in% dummy.names ] - ov.dummy.names.x[[g]] <- + ov.dummy.names.x[[g]] <- ov.names.x[ ov.names.x %in% dummy.names ] # combine them, make sure order is identical to ov.names @@ -131,7 +131,7 @@ representation.LISREL <- function(partable = NULL, tmp.mat[idx] <- "beta" tmp.row[idx] <- match(target$rhs[idx], lv.names) tmp.col[idx] <- match(target$lhs[idx], lv.names) - + # 1c. "=~" indicators that are both in ov and lv idx <- which(target$block == g & target$op == "=~" & target$rhs %in% ov.names @@ -139,7 +139,7 @@ representation.LISREL <- function(partable = NULL, tmp.mat[idx] <- "beta" tmp.row[idx] <- match(target$rhs[idx], lv.names) tmp.col[idx] <- match(target$lhs[idx], lv.names) - + # 2. "~" regressions if(gamma) { # gamma @@ -164,7 +164,7 @@ representation.LISREL <- function(partable = NULL, tmp.row[idx] <- match(target$lhs[idx], lv.names) tmp.col[idx] <- match(target$rhs[idx], lv.names) } - + # 3a. "~~" ov idx <- which(target$block == g & target$op == "~~" & !(target$lhs %in% lv.names)) @@ -180,14 +180,14 @@ representation.LISREL <- function(partable = NULL, tmp.row[idx] <- match(target$lhs[idx], ov.names.x) tmp.col[idx] <- match(target$rhs[idx], ov.names.x) } - + # 3b. "~~" lv idx <- which(target$block == g & target$op == "~~" & target$rhs %in% lv.names) tmp.mat[idx] <- "psi" tmp.row[idx] <- match(target$lhs[idx], lv.names) tmp.col[idx] <- match(target$rhs[idx], lv.names) - + # 4a. "~1" ov idx <- which(target$block == g & target$op == "~1" & !(target$lhs %in% lv.names)) @@ -203,7 +203,7 @@ representation.LISREL <- function(partable = NULL, tmp.row[idx] <- match(target$lhs[idx], ov.names.x) tmp.col[idx] <- 1L } - + # 4b. "~1" lv idx <- which(target$block == g & target$op == "~1" & target$lhs %in% lv.names) @@ -213,7 +213,7 @@ representation.LISREL <- function(partable = NULL, # 5. "|" th LABEL <- paste(target$lhs, target$op, target$rhs, sep="") - idx <- which(target$block == g & + idx <- which(target$block == g & target$op == "|" & LABEL %in% ov.th) TH <- paste(target$lhs[idx], "|", target$rhs[idx], sep="") tmp.mat[idx] <- "tau" @@ -284,7 +284,7 @@ representation.LISREL <- function(partable = NULL, mean.x = list( ov.names.x, "intercepts"), gw = list( "group", "weight"), psi = list( lv.names, lv.names)) - + # isSymmetric mmSymmetric <- list(tau = FALSE, delta = FALSE, @@ -298,7 +298,7 @@ representation.LISREL <- function(partable = NULL, mean.x = FALSE, gw = FALSE, psi = TRUE) - + # which mm's do we need? (always include lambda, theta and psi) # new: 0.6 this block only!! IDX <- which(target$block == g) @@ -341,7 +341,7 @@ representation.LISREL <- function(partable = NULL, row = tmp.row, col = tmp.col) - # remove non-existing (NAs)? + # remove non-existing (NAs)? # here we remove `non-existing' parameters; this depends on the matrix # representation (eg in LISREL rep, there is no ~~ between lv and ov) #if(remove.nonexisting) { @@ -372,7 +372,7 @@ representation.LISREL <- function(partable = NULL, } -# ETA: +# ETA: # 1) EETA # 2) EETAx # 3) VETA @@ -380,11 +380,11 @@ representation.LISREL <- function(partable = NULL, # 1) EETA # compute E(ETA): expected value of latent variables (marginal over x) -# - if no eXo (and GAMMA): -# E(ETA) = (I-B)^-1 ALPHA +# - if no eXo (and GAMMA): +# E(ETA) = (I-B)^-1 ALPHA # - if eXo and GAMMA: # E(ETA) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA mean.x -computeEETA.LISREL <- function(MLIST=NULL, mean.x=NULL, +computeEETA.LISREL <- function(MLIST=NULL, mean.x=NULL, sample.mean=NULL, ov.y.dummy.ov.idx=NULL, ov.x.dummy.ov.idx=NULL, @@ -424,7 +424,7 @@ computeEETA.LISREL <- function(MLIST=NULL, mean.x=NULL, # 2) EETAx # compute E(ETA|x_i): conditional expected value of latent variable, # given specific value of x_i -# - if no eXo (and GAMMA): +# - if no eXo (and GAMMA): # E(ETA) = (I-B)^-1 ALPHA # we return a matrix of size [nobs x nfac] replicating E(ETA) # - if eXo and GAMMA: @@ -545,7 +545,7 @@ computeVETAx.LISREL <- function(MLIST=NULL, lv.dummy.idx=NULL) { # 1) EY # compute E(Y): expected value of observed -# E(Y) = NU + LAMBDA %*% E(eta) +# E(Y) = NU + LAMBDA %*% E(eta) # = NU + LAMBDA %*% (IB.inv %*% ALPHA) # no exo, no GAMMA # = NU + LAMBDA %*% (IB.inv %*% ALPHA + IB.inv %*% GAMMA %*% mean.x) # eXo # if DELTA -> E(Y) = delta * E(Y) @@ -591,9 +591,9 @@ computeEY.LISREL <- function(MLIST=NULL, mean.x = NULL, sample.mean = NULL, # 2) EYx # compute E(Y|x_i): expected value of observed, conditional on x_i -# E(Y|x_i) = NU + LAMBDA %*% E(eta|x_i) +# E(Y|x_i) = NU + LAMBDA %*% E(eta|x_i) -# - if no eXo (and GAMMA): +# - if no eXo (and GAMMA): # E(ETA|x_i) = (I-B)^-1 ALPHA # we return a matrix of size [nobs x nfac] replicating E(ETA) # - if eXo and GAMMA: @@ -604,8 +604,8 @@ computeEY.LISREL <- function(MLIST=NULL, mean.x = NULL, sample.mean = NULL, # - never used if GAMMA, since we then have categorical variables, and the # 'part 1' structure contains the (thresholds +) intercepts, not # the means -computeEYx.LISREL <- function(MLIST = NULL, - eXo = NULL, +computeEYx.LISREL <- function(MLIST = NULL, + eXo = NULL, N = nrow(eXo), sample.mean = NULL, ov.y.dummy.ov.idx = NULL, @@ -616,7 +616,7 @@ computeEYx.LISREL <- function(MLIST = NULL, LAMBDA <- MLIST$lambda # get NU, but do not 'fix' - NU <- .internal_get_NU(MLIST = MLIST, + NU <- .internal_get_NU(MLIST = MLIST, sample.mean = sample.mean, ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, @@ -624,7 +624,7 @@ computeEYx.LISREL <- function(MLIST = NULL, ov.x.dummy.lv.idx = ov.x.dummy.lv.idx) # compute E(ETA|x_i) - EETAx <- computeEETAx.LISREL(MLIST = MLIST, + EETAx <- computeEETAx.LISREL(MLIST = MLIST, eXo = eXo, N = N, sample.mean = sample.mean, @@ -649,7 +649,7 @@ computeEYx.LISREL <- function(MLIST = NULL, # given specific value of eta_i AND x_i # # E(y*_i|eta_i, x_i) = NU + LAMBDA eta_i + KAPPA x_i -# +# # where eta_i = predict(fit) = factor scores OR specific values for eta_i # (as in GH integration) # @@ -661,8 +661,8 @@ computeEYx.LISREL <- function(MLIST = NULL, # care off # categorical version -computeEYetax.LISREL <- function(MLIST = NULL, - eXo = NULL, +computeEYetax.LISREL <- function(MLIST = NULL, + eXo = NULL, ETA = NULL, N = nrow(eXo), sample.mean = NULL, @@ -752,7 +752,7 @@ computeEYetax.LISREL <- function(MLIST = NULL, } # unconditional version -computeEYetax2.LISREL <- function(MLIST = NULL, +computeEYetax2.LISREL <- function(MLIST = NULL, ETA = NULL, sample.mean = NULL, ov.y.dummy.ov.idx = NULL, @@ -783,7 +783,7 @@ computeEYetax2.LISREL <- function(MLIST = NULL, ALPHAY <- ALPHA[ov.y.dummy.lv.idx,, drop=FALSE] # impute ov.y values in ETA - ETA[,ov.y.dummy.lv.idx] <- + ETA[,ov.y.dummy.lv.idx] <- sweep(tcrossprod(OV.NOY, BETAY), 2L, STATS = ALPHAY, FUN = "+") } @@ -807,7 +807,7 @@ computeEYetax2.LISREL <- function(MLIST = NULL, } # unconditional version -computeEYetax3.LISREL <- function(MLIST = NULL, +computeEYetax3.LISREL <- function(MLIST = NULL, ETA = NULL, sample.mean = NULL, mean.x = NULL, @@ -817,10 +817,10 @@ computeEYetax3.LISREL <- function(MLIST = NULL, ov.x.dummy.lv.idx = NULL) { LAMBDA <- MLIST$lambda - + # special case: empty lambda if(ncol(LAMBDA) == 0L) { - return( matrix(sample.mean, + return( matrix(sample.mean, nrow(ETA), length(sample.mean), byrow=TRUE) ) } @@ -847,7 +847,7 @@ computeEYetax3.LISREL <- function(MLIST = NULL, } # compute model-implied means - EY <- computeEY.LISREL(MLIST = MLIST, mean.x = mean.x, + EY <- computeEY.LISREL(MLIST = MLIST, mean.x = mean.x, sample.mean = sample.mean, ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, @@ -862,13 +862,13 @@ computeEYetax3.LISREL <- function(MLIST = NULL, ov.x.dummy.lv.idx = ov.x.dummy.lv.idx) # center regular lv only - ETA[,nondummy.idx] <- sweep(ETA[,nondummy.idx,drop = FALSE], 2L, + ETA[,nondummy.idx] <- sweep(ETA[,nondummy.idx,drop = FALSE], 2L, STATS = EETA[nondummy.idx], FUN = "-") # project from lv to ov, if we have any lv if(length(nondummy.idx) > 0) { - EYetax <- sweep(tcrossprod(ETA[,nondummy.idx,drop=FALSE], - LAMBDA..IB.inv[,nondummy.idx,drop=FALSE]), + EYetax <- sweep(tcrossprod(ETA[,nondummy.idx,drop=FALSE], + LAMBDA..IB.inv[,nondummy.idx,drop=FALSE]), 2L, STATS = EY, FUN = "+") } else { EYetax <- ETA @@ -900,7 +900,7 @@ computeVY.LISREL <- function(MLIST = NULL) { LAMBDA <- MLIST$lambda THETA <- MLIST$theta - + VETA <- computeVETA.LISREL(MLIST = MLIST) VY <- tcrossprod(LAMBDA %*% VETA, LAMBDA) + THETA VY @@ -909,7 +909,7 @@ computeVY.LISREL <- function(MLIST = NULL) { # 5) VYx # compute V(Y*|x_i) == model-implied covariance matrix # this equals V(Y*) if no (explicit) eXo no GAMMA -computeVYx.LISREL <- computeSigmaHat.LISREL <- function(MLIST = NULL, +computeVYx.LISREL <- computeSigmaHat.LISREL <- function(MLIST = NULL, delta = TRUE) { LAMBDA <- MLIST$lambda; nvar <- nrow(LAMBDA) @@ -962,7 +962,7 @@ computeVYetax.LISREL <- function(MLIST = NULL, delta = TRUE) { # compute MuHat for a single block/group; only for the continuous case (no eXo) # -# this is a special case of E(Y) where +# this is a special case of E(Y) where # - we have no (explicit) eXogenous variables # - only continuous computeMuHat.LISREL <- function(MLIST=NULL) { @@ -982,7 +982,7 @@ computeMuHat.LISREL <- function(MLIST=NULL) { IB.inv <- .internal_get_IB.inv(MLIST = MLIST) LAMBDA..IB.inv <- LAMBDA %*% IB.inv } - + # compute Mu Hat Mu.hat <- NU + LAMBDA..IB.inv %*% ALPHA @@ -1030,7 +1030,7 @@ computeTH.LISREL <- function(MLIST=NULL, th.idx=NULL) { IB.inv <- .internal_get_IB.inv(MLIST = MLIST) LAMBDA..IB.inv <- LAMBDA %*% IB.inv } - + # compute pi0 pi0 <- NU + LAMBDA..IB.inv %*% ALPHA @@ -1051,7 +1051,7 @@ computeTH.LISREL <- function(MLIST=NULL, th.idx=NULL) { as.vector(TH) } -# compute PI for a single block/group +# compute PI for a single block/group computePI.LISREL <- function(MLIST=NULL) { LAMBDA <- MLIST$lambda @@ -1117,7 +1117,7 @@ computeTHETA.LISREL <- function(MLIST=NULL, # fix THETA THETA <- MLIST$theta if(length(ov.dummy.idx) > 0L) { - THETA[ov.dummy.idx, ov.dummy.idx] <- + THETA[ov.dummy.idx, ov.dummy.idx] <- MLIST$psi[lv.dummy.idx, lv.dummy.idx] } @@ -1145,7 +1145,7 @@ computeTHETA.LISREL <- function(MLIST=NULL, # # without any dummy variables, this is just the zero vector # but if we have dummy variables, we need to fill in their values -# +# # .internal_get_ALPHA <- function(MLIST = NULL, sample.mean = NULL, ov.y.dummy.ov.idx = NULL, @@ -1173,7 +1173,7 @@ computeTHETA.LISREL <- function(MLIST=NULL, IB.inv <- .internal_get_IB.inv(MLIST = MLIST) LAMBDA..IB.inv <- LAMBDA %*% IB.inv LAMBDA..IB.inv.dummy <- LAMBDA..IB.inv[ov.dummy.idx, lv.dummy.idx] - ALPHA[lv.dummy.idx] <- + ALPHA[lv.dummy.idx] <- solve(LAMBDA..IB.inv.dummy) %*% sample.mean[ov.dummy.idx] } else { ALPHA <- matrix(0, nfac, 1L) @@ -1347,7 +1347,7 @@ computeYHATetax.LISREL <- function(MLIST=NULL, eXo=NULL, ETA=NULL, } -# deal with 'dummy' OV.X latent variables +# deal with 'dummy' OV.X latent variables # create additional matrices (eg GAMMA), and resize # remove all ov.x related entries MLIST2MLISTX <- function(MLIST=NULL, @@ -1368,7 +1368,7 @@ MLIST2MLISTX <- function(MLIST=NULL, # copy MLISTX <- MLIST - # fix LAMBDA: + # fix LAMBDA: # - remove all ov.x related columns/rows MLISTX$lambda <- MLIST$lambda[-ov.idx, -lv.idx,drop=FALSE] @@ -1395,7 +1395,7 @@ MLIST2MLISTX <- function(MLIST=NULL, if(!is.null(MLIST$nu)) { MLISTX$nu <- MLIST$nu[-ov.idx, 1L, drop=FALSE] } - + # fix ALPHA if(!is.null(MLIST$alpha)) { MLISTX$alpha <- MLIST$alpha[-lv.idx, 1L, drop=FALSE] @@ -1439,7 +1439,7 @@ MLISTX2MLIST <- function(MLISTX=NULL, MLIST$nu <- rbind(MLISTX$nu, matrix(0, ndum, 1)) } - # fix LAMBDA: + # fix LAMBDA: # - add columns for all dummy latent variables MLIST$lambda[ cbind(ov.idx, lv.idx) ] <- 1 @@ -1455,7 +1455,7 @@ MLISTX2MLIST <- function(MLISTX=NULL, if(!is.null(MLIST$alpha)) { MLIST$alpha[lv.idx] <- mean.x } - + MLIST } @@ -1486,7 +1486,7 @@ setResidualElements.LISREL <- function(MLIST=NULL, } # special case: PSI=0, and lambda=I (eg ex3.12) - if(ncol(MLIST$psi) > 0L && + if(ncol(MLIST$psi) > 0L && sum(diag(MLIST$psi)) == 0.0 && all(diag(MLIST$lambda) == 1)) { ### FIXME: more elegant/general solution?? diag(MLIST$psi) <- 1 @@ -1514,7 +1514,7 @@ setResidualElements.LISREL <- function(MLIST=NULL, # move ov.y.dummy 'RESIDUAL' elements from THETA to PSI if(length(ov.y.dummy.ov.idx) > 0L) { - MLIST$psi[cbind(ov.y.dummy.lv.idx, ov.y.dummy.lv.idx)] <- + MLIST$psi[cbind(ov.y.dummy.lv.idx, ov.y.dummy.lv.idx)] <- MLIST$theta[cbind(ov.y.dummy.ov.idx, ov.y.dummy.ov.idx)] MLIST$theta[cbind(ov.y.dummy.ov.idx, ov.y.dummy.ov.idx)] <- 0.0 } @@ -1522,7 +1522,7 @@ setResidualElements.LISREL <- function(MLIST=NULL, MLIST } -# if THETA parameterization, compute delta elements +# if THETA parameterization, compute delta elements # of observed categorical variables, as a function of other model parameters setDeltaElements.LISREL <- function(MLIST=NULL, num.idx=NULL) { @@ -1570,7 +1570,7 @@ computeCOV.LISREL <- function(MLIST = NULL, delta = TRUE) { # if delta, scale if(delta && !is.null(MLIST$delta)) { DELTA <- diag(MLIST$delta[,1L], nrow=nvar, ncol=nvar) - COV[seq_len(nvar),seq_len(nvar)] <- + COV[seq_len(nvar),seq_len(nvar)] <- DELTA %*% COV[seq_len(nvar),seq_len(nvar)] %*% DELTA } @@ -1585,7 +1585,7 @@ computeCOV.LISREL <- function(MLIST = NULL, delta = TRUE) { IB.inv..GAMMA <- IB.inv %*% GAMMA SX <- tcrossprod(IB.inv..GAMMA %*% COV.X, IB.inv..GAMMA) } - COV[(nvar+1):(nvar+nlat),(nvar+1):(nvar+nlat)] <- + COV[(nvar+1):(nvar+nlat),(nvar+1):(nvar+nlat)] <- COV[(nvar+1):(nvar+nlat),(nvar+1):(nvar+nlat)] + SX } @@ -1599,7 +1599,7 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { LAMBDA <- MLIST$lambda PSI <- MLIST$psi BETA <- MLIST$beta - ALPHA <- MLIST$alpha + ALPHA <- MLIST$alpha # beta? if(is.null(BETA)) { @@ -1618,12 +1618,12 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { # pre-compute some values tLAMBDA..IB.inv <- t(LAMBDA..IB.inv) if(!is.null(BETA)) { - Omega..LAMBDA..IB.inv..PSI..tIB.inv <- + Omega..LAMBDA..IB.inv..PSI..tIB.inv <- ( Omega %*% LAMBDA..IB.inv %*% PSI %*% t(IB.inv) ) } else { Omega..LAMBDA <- Omega %*% LAMBDA } - + # 1. LAMBDA if(!is.null(BETA)) { if(meanstructure) { @@ -1635,7 +1635,7 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { } else { # no BETA if(meanstructure) { - LAMBDA.deriv <- -1.0 * ( Omega.mu %*% t(ALPHA) + + LAMBDA.deriv <- -1.0 * ( Omega.mu %*% t(ALPHA) + Omega..LAMBDA %*% PSI ) } else { LAMBDA.deriv <- -1.0 * (Omega..LAMBDA %*% PSI) @@ -1645,10 +1645,10 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { # 2. BETA if(!is.null(BETA)) { if(meanstructure) { - BETA.deriv <- -1.0*(( t(IB.inv) %*% - (t(LAMBDA) %*% Omega.mu %*% t(ALPHA)) %*% + BETA.deriv <- -1.0*(( t(IB.inv) %*% + (t(LAMBDA) %*% Omega.mu %*% t(ALPHA)) %*% t(IB.inv)) + - (tLAMBDA..IB.inv %*% + (tLAMBDA..IB.inv %*% Omega..LAMBDA..IB.inv..PSI..tIB.inv)) } else { BETA.deriv <- -1.0 * ( tLAMBDA..IB.inv %*% @@ -1657,8 +1657,8 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { } else { BETA.deriv <- NULL } - - # 3. PSI + + # 3. PSI PSI.deriv <- -1.0 * ( tLAMBDA..IB.inv %*% Omega %*% LAMBDA..IB.inv ) diag(PSI.deriv) <- 0.5 * diag(PSI.deriv) @@ -1696,11 +1696,11 @@ derivative.F.LISREL <- function(MLIST=NULL, Omega=NULL, Omega.mu=NULL) { # note: # we avoid using the duplication and elimination matrices # for now (perhaps until we'll use the Matrix package) -derivative.sigma.LISREL_OLD <- function(m="lambda", +derivative.sigma.LISREL_OLD <- function(m="lambda", # all model matrix elements, or only a few? - # NOTE: for symmetric matrices, - # we assume that the have full size - # (nvar*nvar) (but already correct for + # NOTE: for symmetric matrices, + # we assume that the have full size + # (nvar*nvar) (but already correct for # symmetry) idx=seq_len(length(MLIST[[m]])), MLIST=NULL, @@ -1708,7 +1708,7 @@ derivative.sigma.LISREL_OLD <- function(m="lambda", LAMBDA <- MLIST$lambda; nvar <- nrow(LAMBDA); nfac <- ncol(LAMBDA) PSI <- MLIST$psi - + # only lower.tri part of sigma (not same order as elimination matrix?) v.idx <- lav_matrix_vech_idx( nvar ); pstar <- nvar*(nvar+1)/2 @@ -1732,10 +1732,10 @@ derivative.sigma.LISREL_OLD <- function(m="lambda", IB.inv <- MLIST$ibeta.inv } else { IB.inv <- .internal_get_IB.inv(MLIST = MLIST) - } + } # pre - if(m == "lambda" || m == "beta") + if(m == "lambda" || m == "beta") IK <- diag(nvar*nvar) + lav_matrix_commutation(nvar, nvar) if(m == "lambda" || m == "beta") { IB.inv..PSI..tIB.inv..tLAMBDA <- @@ -1755,10 +1755,10 @@ derivative.sigma.LISREL_OLD <- function(m="lambda", # this is not really needed (because we select idx=m.el.idx) # but just in case we need all elements of beta... DX[,lav_matrix_diag_idx(nfac)] <- 0.0 - if(delta.flag) + if(delta.flag) DX <- DX * as.vector(DELTA %x% DELTA) } else if(m == "psi") { - DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) + DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) # symmetry correction, but keeping all duplicated elements # since we depend on idx=m.el.idx # otherwise, we could simply postmultiply with the duplicationMatrix @@ -1787,9 +1787,9 @@ derivative.sigma.LISREL_OLD <- function(m="lambda", DD <- diag(DELTA[,1], nvar, nvar) DD.Omega <- (DD %*% Omega) A <- DD.Omega %x% diag(nvar); B <- diag(nvar) %x% DD.Omega - DX <- A[,lav_matrix_diag_idx(nvar),drop=FALSE] + + DX <- A[,lav_matrix_diag_idx(nvar),drop=FALSE] + B[,lav_matrix_diag_idx(nvar),drop=FALSE] - + } else { stop("wrong model matrix names: ", m, "\n") } @@ -1799,11 +1799,11 @@ derivative.sigma.LISREL_OLD <- function(m="lambda", } # dSigma/dx -- per model matrix -derivative.sigma.LISREL <- function(m = "lambda", +derivative.sigma.LISREL <- function(m = "lambda", # all model matrix elements, or only a few? - # NOTE: for symmetric matrices, - # we assume that the have full size - # (nvar*nvar) (but already correct for + # NOTE: for symmetric matrices, + # we assume that the have full size + # (nvar*nvar) (but already correct for # symmetry) idx = seq_len(length(MLIST[[m]])), MLIST = NULL, @@ -1812,12 +1812,12 @@ derivative.sigma.LISREL <- function(m = "lambda", LAMBDA <- MLIST$lambda; nvar <- nrow(LAMBDA); nfac <- ncol(LAMBDA) PSI <- MLIST$psi - + # only lower.tri part of sigma (not same order as elimination matrix?) v.idx <- lav_matrix_vech_idx( nvar ); pstar <- nvar*(nvar+1)/2 # shortcut for gamma, nu, alpha, tau,.... : empty matrix - if(m == "nu" || m == "alpha" || m == "tau" || m == "gamma" || + if(m == "nu" || m == "alpha" || m == "tau" || m == "gamma" || m == "gw" || m == "cov.x" || m == "mean.x") { return( matrix(0.0, nrow=pstar, ncol=length(idx)) ) } @@ -1836,10 +1836,10 @@ derivative.sigma.LISREL <- function(m = "lambda", IB.inv <- MLIST$ibeta.inv } else { IB.inv <- .internal_get_IB.inv(MLIST = MLIST) - } + } # pre - #if(m == "lambda" || m == "beta") + #if(m == "lambda" || m == "beta") # IK <- diag(nvar*nvar) + lav_matrix_commutation(nvar, nvar) if(m == "lambda" || m == "beta") { L1 <- LAMBDA %*% IB.inv %*% PSI %*% t(IB.inv) @@ -1851,7 +1851,7 @@ derivative.sigma.LISREL <- function(m = "lambda", # here we go: if(m == "lambda") { KOL.idx <- matrix(1:(nvar*nfac), nvar, nfac, byrow = TRUE)[idx] - DX <- (L1 %x% diag(nvar))[,idx, drop = FALSE] + + DX <- (L1 %x% diag(nvar))[,idx, drop = FALSE] + (diag(nvar) %x% L1)[,KOL.idx, drop = FALSE] } else if(m == "beta") { KOL.idx <- matrix(1:(nfac*nfac), nfac, nfac, byrow = TRUE)[idx] @@ -1861,7 +1861,7 @@ derivative.sigma.LISREL <- function(m = "lambda", # but just in case we need all elements of beta... DX[, which(idx %in% lav_matrix_diag_idx(nfac))] <- 0.0 } else if(m == "psi") { - DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) + DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) # symmetry correction, but keeping all duplicated elements # since we depend on idx=m.el.idx lower.idx <- lav_matrix_vech_idx(nfac, diagonal = FALSE) @@ -1880,7 +1880,7 @@ derivative.sigma.LISREL <- function(m = "lambda", DD <- diag(DELTA[,1], nvar, nvar) DD.Omega <- (DD %*% Omega) A <- DD.Omega %x% diag(nvar); B <- diag(nvar) %x% DD.Omega - DX <- A[,lav_matrix_diag_idx(nvar),drop=FALSE] + + DX <- A[,lav_matrix_diag_idx(nvar),drop=FALSE] + B[,lav_matrix_diag_idx(nvar),drop=FALSE] DX <- DX[,idx, drop = FALSE] } else { @@ -1900,33 +1900,33 @@ derivative.sigma.LISREL <- function(m = "lambda", } # dMu/dx -- per model matrix -derivative.mu.LISREL <- function(m="alpha", +derivative.mu.LISREL <- function(m="alpha", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { LAMBDA <- MLIST$lambda; nvar <- nrow(LAMBDA); nfac <- ncol(LAMBDA) # shortcut for empty matrices - if(m == "gamma" || m == "psi" || m == "theta" || m == "tau" || + if(m == "gamma" || m == "psi" || m == "theta" || m == "tau" || m == "delta"|| m == "gw" || m == "cov.x" || m == "mean.x") { return( matrix(0.0, nrow=nvar, ncol=length(idx) ) ) } # missing alpha - if(is.null(MLIST$alpha)) + if(is.null(MLIST$alpha)) ALPHA <- matrix(0, nfac, 1L) else ALPHA <- MLIST$alpha - + # beta? if(!is.null(MLIST$ibeta.inv)) { IB.inv <- MLIST$ibeta.inv } else { IB.inv <- .internal_get_IB.inv(MLIST = MLIST) - } + } if(m == "nu") { DX <- diag(nvar) @@ -2059,7 +2059,7 @@ derivative.pi.LISREL <- function(m="lambda", } # shortcut for empty matrices - if(m == "tau" || m == "nu" || m == "alpha" || m == "psi" || + if(m == "tau" || m == "nu" || m == "alpha" || m == "psi" || m == "theta" || m == "gw" || m == "cov.x" || m == "mean.x") { return( matrix(0.0, nrow=nvar*nexo, ncol=length(idx) ) ) } @@ -2097,9 +2097,9 @@ derivative.pi.LISREL <- function(m="lambda", } # dGW/dx -- per model matrix -derivative.gw.LISREL <- function(m="gw", +derivative.gw.LISREL <- function(m="gw", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { # shortcut for empty matrices @@ -2115,9 +2115,9 @@ derivative.gw.LISREL <- function(m="gw", } # dlambda/dx -- per model matrix -derivative.lambda.LISREL <- function(m="lambda", +derivative.lambda.LISREL <- function(m="lambda", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { LAMBDA <- MLIST$lambda @@ -2135,9 +2135,9 @@ derivative.lambda.LISREL <- function(m="lambda", } # dpsi/dx -- per model matrix - FIXME!!!!! -derivative.psi.LISREL <- function(m="psi", +derivative.psi.LISREL <- function(m="psi", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { PSI <- MLIST$psi; nfac <- nrow(PSI) @@ -2157,9 +2157,9 @@ derivative.psi.LISREL <- function(m="psi", } # dtheta/dx -- per model matrix -derivative.theta.LISREL <- function(m="theta", +derivative.theta.LISREL <- function(m="theta", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { THETA <- MLIST$theta; nvar <- nrow(THETA) @@ -2180,9 +2180,9 @@ derivative.theta.LISREL <- function(m="theta", # dbeta/dx -- per model matrix -derivative.beta.LISREL <- function(m="beta", +derivative.beta.LISREL <- function(m="beta", # all model matrix elements, or only a few? - idx=seq_len(length(MLIST[[m]])), + idx=seq_len(length(MLIST[[m]])), MLIST=NULL) { BETA <- MLIST$beta @@ -2295,7 +2295,7 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, debug = FALSE) { if(is.null(MLIST)) { - # create artificial matrices, compare 'numerical' vs 'analytical' + # create artificial matrices, compare 'numerical' vs 'analytical' # derivatives #nvar <- 12; nfac <- 3; nexo <- 4 # this combination is special? if(is.null(nvar)) { @@ -2323,7 +2323,7 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, nth <- sum(th.idx > 0L) MLIST <- list() - MLIST$lambda <- matrix(0,nvar,nfac) + MLIST$lambda <- matrix(0,nvar,nfac) MLIST$beta <- matrix(0,nfac,nfac) MLIST$theta <- matrix(0,nvar,nvar) MLIST$psi <- matrix(0,nfac,nfac) @@ -2340,11 +2340,11 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, MLIST <- lapply(MLIST, function(x) {x[,] <- rnorm(length(x)); x}) # fix diag(MLIST$beta) <- 0.0 - diag(MLIST$theta) <- diag(MLIST$theta)*diag(MLIST$theta) * 10 + diag(MLIST$theta) <- diag(MLIST$theta)*diag(MLIST$theta) * 10 diag(MLIST$psi) <- diag(MLIST$psi)*diag(MLIST$psi) * 10 - MLIST$psi[ lav_matrix_vechru_idx(nfac) ] <- + MLIST$psi[ lav_matrix_vechru_idx(nfac) ] <- MLIST$psi[ lav_matrix_vech_idx(nfac) ] - MLIST$theta[ lav_matrix_vechru_idx(nvar) ] <- + MLIST$theta[ lav_matrix_vechru_idx(nvar) ] <- MLIST$theta[ lav_matrix_vech_idx(nvar) ] if(delta) MLIST$delta[,] <- abs(MLIST$delta)*10 } else { @@ -2437,14 +2437,14 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, DX2 <- derivative.sigma.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST, delta = !theta) if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal=FALSE) if(length(idx) > 0L) DX2 <- DX2[,-idx] } if(theta) { sigma.hat <- computeSigmaHat.LISREL(MLIST=MLIST, delta=FALSE) R <- lav_deriv_cov2cor(sigma.hat, num.idx = num.idx) - + DX3 <- DX2 DX2 <- R %*% DX2 } @@ -2467,7 +2467,7 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, DX2 <- derivative.mu.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST) if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) if(length(idx) > 0L) DX2 <- DX2[,-idx] } @@ -2483,17 +2483,17 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, # 3. th if(th) { - DX1 <- lav_func_jacobian_complex(func=compute.th2, x=x, mm=mm, MLIST=MLIST, + DX1 <- lav_func_jacobian_complex(func=compute.th2, x=x, mm=mm, MLIST=MLIST, th.idx=th.idx) DX2 <- derivative.th.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST, th.idx=th.idx, delta=TRUE) if(theta) { # 1. compute dDelta.dx - dxSigma <- + dxSigma <- derivative.sigma.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST, delta = !theta) - var.idx <- which(!lav_matrix_vech_idx(nvar) %in% + var.idx <- which(!lav_matrix_vech_idx(nvar) %in% lav_matrix_vech_idx(nvar, diagonal = FALSE)) sigma.hat <- computeSigmaHat.LISREL(MLIST=MLIST, delta=FALSE) dsigma <- diag(sigma.hat) @@ -2501,19 +2501,19 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, dDelta.dx <- dxSigma[var.idx,] * -0.5 / (dsigma*sqrt(dsigma)) # 2. compute dth.dDelta - dth.dDelta <- - derivative.th.LISREL(m="delta", + dth.dDelta <- + derivative.th.LISREL(m="delta", idx=seq_len(length(MLIST[["delta"]])), MLIST=MLIST, th.idx=th.idx) # 3. add dth.dDelta %*% dDelta.dx no.num.idx <- which(th.idx > 0) - DX2[no.num.idx,] <- DX2[no.num.idx,,drop=FALSE] + + DX2[no.num.idx,] <- DX2[no.num.idx,,drop=FALSE] + (dth.dDelta %*% dDelta.dx)[no.num.idx,,drop=FALSE] #DX2 <- DX2 + dth.dDelta %*% dDelta.dx } if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) if(length(idx) > 0L) DX2 <- DX2[,-idx] } @@ -2534,21 +2534,21 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, DX2 <- derivative.pi.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST) if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) if(length(idx) > 0L) DX2 <- DX2[,-idx] } if(theta) { # 1. compute dDelta.dx - dxSigma <- + dxSigma <- derivative.sigma.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST, delta = !theta) if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(dxSigma)), diagonal = FALSE) if(length(idx) > 0L) dxSigma <- dxSigma[,-idx] } - var.idx <- which(!lav_matrix_vech_idx(nvar) %in% + var.idx <- which(!lav_matrix_vech_idx(nvar) %in% lav_matrix_vech_idx(nvar, diagonal = FALSE)) sigma.hat <- computeSigmaHat.LISREL(MLIST=MLIST, delta=FALSE) dsigma <- diag(sigma.hat) @@ -2556,16 +2556,16 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, dDelta.dx <- dxSigma[var.idx,] * -0.5 / (dsigma*sqrt(dsigma)) # 2. compute dpi.dDelta - dpi.dDelta <- - derivative.pi.LISREL(m="delta", + dpi.dDelta <- + derivative.pi.LISREL(m="delta", idx=seq_len(length(MLIST[["delta"]])), MLIST=MLIST) # 3. add dpi.dDelta %*% dDelta.dx no.num.idx <- which(! seq.int(1L, nvar) %in% num.idx ) - no.num.idx <- rep(seq.int(0,nexo-1) * nvar, + no.num.idx <- rep(seq.int(0,nexo-1) * nvar, each=length(no.num.idx)) + no.num.idx - DX2[no.num.idx,] <- DX2[no.num.idx,,drop=FALSE] + + DX2[no.num.idx,] <- DX2[no.num.idx,,drop=FALSE] + (dpi.dDelta %*% dDelta.dx)[no.num.idx,,drop=FALSE] } cat("[PI ] mm = ", sprintf("%-8s:", mm), "sum delta = ", @@ -2585,7 +2585,7 @@ TESTING_derivatives.LISREL <- function(MLIST = NULL, DX2 <- derivative.gw.LISREL(m=mm, idx=seq_len(length(MLIST[[mm]])), MLIST=MLIST) if(mm %in% c("psi","theta")) { - # remove duplicated columns of symmetric matrices + # remove duplicated columns of symmetric matrices idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) if(length(idx) > 0L) DX2 <- DX2[,-idx] } diff --git a/R/lav_residuals.R b/R/lav_residuals.R index d6c77642..01f82c3d 100644 --- a/R/lav_residuals.R +++ b/R/lav_residuals.R @@ -17,7 +17,7 @@ function(object, type="raw", labels=TRUE) { if(type %in% c("casewise","case","obs","observations","ov")) { return( lav_residuals_casewise(object, labels = labels) ) } - + # checks if(type %in% c("normalized", "standardized")) { if(object@Options$estimator != "ML") { @@ -35,7 +35,7 @@ function(object, type="raw", labels=TRUE) { } # NOTE: for some reason, Mplus does not compute the normalized/standardized # residuals if estimator = MLM !!! - + # check type if(!type %in% c("raw", "cor", @@ -43,7 +43,7 @@ function(object, type="raw", labels=TRUE) { "normalized", "standardized", "casewise")) { stop("type must be one of \"raw\", \"cor\", \"cor.bollen\", \"cor.bentler\", \"normalized\" or \"standardized\" or \"casewise\"") } - + # if cor, choose 'default' if(type == "cor") { if(object@Options$mimic == "EQS") { @@ -83,13 +83,13 @@ function(object, type="raw", labels=TRUE) { augUser <- object@ParTable idx <- which(augUser$exo > 0L) augUser$exo[ idx ] <- 0L - augUser$free[ idx ] <- max(augUser$free) + 1:length(idx) - #augUser$unco[idx ] <- max(augUser$unco) + 1:length(idx) + augUser$free[ idx ] <- max(augUser$free) + 1:length(idx) + #augUser$unco[idx ] <- max(augUser$unco) + 1:length(idx) augModel <- lav_model(lavpartable = augUser, lavoptions = object@Options, cov.x = object@SampleStats@cov.x, mean.x = object@SampleStats@mean.x) - VarCov <- lav_model_vcov(lavmodel = augModel, + VarCov <- lav_model_vcov(lavmodel = augModel, lavsamplestats = object@SampleStats, lavdata = object@Data, lavpartable = object@ParTable, @@ -101,7 +101,7 @@ function(object, type="raw", labels=TRUE) { ### FIXME: should we not do this on the information level, ### *before* we compute VarCov? ### - fixed.x.idx <- max(object@ParTable$free) + 1:length(idx) + fixed.x.idx <- max(object@ParTable$free) + 1:length(idx) free.idx <- 1:max(object@ParTable$free) VarCov[free.idx, fixed.x.idx] <- 0.0 VarCov[fixed.x.idx, free.idx] <- 0.0 @@ -116,7 +116,7 @@ function(object, type="raw", labels=TRUE) { lavimplied = object@implied, lavh1 = object@h1) Delta <- computeDelta(lavmodel = object@Model) - } + } } R <- vector("list", length=G) @@ -147,8 +147,8 @@ function(object, type="raw", labels=TRUE) { if(type == "cor.bollen") { if(object@Model@conditional.x) { R[[g]]$cov <- cov2cor(S) - cov2cor(object@implied$res.cov[[g]]) - R[[g]]$mean <- ( M/sqrt(diag(S)) - - ( object@implied$res.int[[g]] / + R[[g]]$mean <- ( M/sqrt(diag(S)) - + ( object@implied$res.int[[g]] / sqrt(diag(object@implied$res.cov[[g]])) ) ) } else { R[[g]]$cov <- cov2cor(S) - cov2cor(object@implied$cov[[g]]) @@ -203,7 +203,7 @@ function(object, type="raw", labels=TRUE) { } if(type == "normalized" || type == "standardized") { - + # compute normalized residuals N <- object@SampleStats@nobs[[g]]; nvar <- length(R[[g]]$mean) idx.mean <- 1:nvar @@ -211,7 +211,7 @@ function(object, type="raw", labels=TRUE) { if(object@Options$se == "standard" || object@Options$se == "none") { dS <- diag(S) - Var.mean <- Var.sample.mean <- dS / N + Var.mean <- Var.sample.mean <- dS / N Var.cov <- Var.sample.cov <- (tcrossprod(dS) + S*S) / N # this is identical to solve(A1)/N for complete data!! } else if(object@Options$se == "robust.huber.white" || @@ -283,7 +283,7 @@ function(object, type="raw", labels=TRUE) { if(type == "standardized") { Var.model <- diag(Delta[[g]] %*% VarCov %*% t(Delta[[g]])) - + if(meanstructure) { Var.model.mean <- Var.model[idx.mean] Var.model.cov <- lav_matrix_vech_reverse(Var.model[-idx.mean]) @@ -314,7 +314,7 @@ function(object, type="raw", labels=TRUE) { tol <- 1.0e-5 R[[g]]$mean[ which(abs(R[[g]]$mean) < tol)] <- 0.0 R[[g]]$cov[ which(abs(R[[g]]$cov) < tol)] <- 0.0 - + R[[g]]$mean <- R[[g]]$mean / sqrt( Var.mean ) R[[g]]$cov <- R[[g]]$cov / sqrt( Var.cov ) } @@ -372,8 +372,8 @@ lav_residuals_casewise <- function(object, labels = labels) { M <- lav_predict_yhat(object) # Note: if M has already class lavaan.matrix, print goes crazy # with Error: C stack usage is too close to the limit - OUT <- lapply(seq_len(G), function(x) { - out <- X[[x]] - M[[x]] + OUT <- lapply(seq_len(G), function(x) { + out <- X[[x]] - M[[x]] class(out) <- c("lavaan.matrix", "matrix") out }) diff --git a/R/lav_samplestats.R b/R/lav_samplestats.R index 078feb4e..0e859181 100644 --- a/R/lav_samplestats.R +++ b/R/lav_samplestats.R @@ -116,7 +116,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, WLS.VD <- vector("list", length = ngroups) if(is.null(WLS.V)) { WLS.V <- vector("list", length = ngroups) - WLS.V.user <- FALSE + WLS.V.user <- FALSE } else { if(!is.list(WLS.V)) { if(ngroups == 1L) { @@ -225,13 +225,13 @@ lav_samplestats_from_data <- function(lavdata = NULL, categorical <- TRUE if(nlevels > 1L) { warning("lavaan ERROR: multilevel + categorical not supported yet.") - } + } } if(categorical) { if(estimator %in% c("ML","REML","PML","FML","MML","none","ULS")) { WLS.W <- FALSE - if(estimator == "ULS" && se == "robust.sem") { #|| + if(estimator == "ULS" && se == "robust.sem") { #|| #test %in% c("satorra.bentler", "scaled.shifted", # "mean.var.adjusted"))) { WLS.W <- TRUE @@ -296,7 +296,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, res.th[[g]] <- unlist(CAT$TH) res.th.nox[[g]] <- unlist(CAT$TH.NOX) - # for convenience, we store the intercept of numeric + # for convenience, we store the intercept of numeric # variables in res.int NVAR <- NCOL(res.cov[[g]]) mean[[g]] <- res.int[[g]] <- numeric(NVAR) @@ -340,7 +340,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, var[[g]] <- diag(cov[[g]]) } else { # continuous, single-level case - + if(conditional.x) { # FIXME! @@ -358,7 +358,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, cov[[g]] <- COV # rescale cov by (N-1)/N? (only COV!) if(rescale) { - # we 'transform' the sample cov (divided by n-1) + # we 'transform' the sample cov (divided by n-1) # to a sample cov divided by 'n' COV <- (nobs[[g]]-1)/nobs[[g]] * COV } @@ -371,7 +371,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, # FIXME: make robust against singular C!!! res.cov[[g]] <- A - B %*% solve(C) %*% t(B) res.var[[g]] <- diag( cov[[g]] ) - + MY <- MEAN[-x.idx[[g]]]; MX <- MEAN[x.idx[[g]]] C3 <- rbind(c(1,MX), @@ -494,7 +494,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, if(!is.null(eXo[[g]])) { if(!is.null(WT[[g]])) { if(missing != "listwise") { - cov.x[[g]] <- missing.h1.[[g]]$sigma[ x.idx[[g]], + cov.x[[g]] <- missing.h1.[[g]]$sigma[ x.idx[[g]], x.idx[[g]], drop = FALSE ] mean.x[[g]] <- missing.h1.[[g]]$mu[ x.idx[[g]] ] @@ -507,7 +507,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, } else { cov.x[[g]] <- cov(eXo[[g]], use="pairwise") if(rescale) { - # we 'transform' the sample cov (divided by n-1) + # we 'transform' the sample cov (divided by n-1) # to a sample cov divided by 'n' cov.x[[g]] <- (nobs[[g]]-1)/nobs[[g]] * cov.x[[g]] } @@ -523,7 +523,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, } else { Y <- X[[g]] } - NACOV[[g]] <- + NACOV[[g]] <- lav_samplestats_Gamma(Y = Y, x.idx = x.idx[[g]], fixed.x = fixed.x, @@ -595,7 +595,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, meanstructure = meanstructure, slopestructure = conditional.x) if(mimic == "Mplus" && !conditional.x && meanstructure) { - # bug in Mplus? V11 rescaled by nobs[[g]]/(nobs[[g]]-1) + # bug in Mplus? V11 rescaled by nobs[[g]]/(nobs[[g]]-1) nvar <- NCOL(cov[[g]]) WLS.V[[g]][1:nvar, 1:nvar] <- WLS.V[[g]][1:nvar, 1:nvar, drop = FALSE] * nobs[[g]]/(nobs[[g]]-1) @@ -611,7 +611,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, if(estimator == "WLS") { if(!fixed.x) { # Gamma should be po before we invert - ev <- eigen(NACOV[[g]], # symmetric=FALSE, + ev <- eigen(NACOV[[g]], # symmetric=FALSE, only.values=TRUE)$values if(is.complex(ev)) { stop("lavaan ERROR: Gamma (NACOV) matrix is not positive-definite") @@ -708,7 +708,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, cov.x = cov.x, bifreq = bifreq, group.w = group.w, - + # convenience nobs = nobs, ntotal = sum(unlist(nobs)), @@ -738,7 +738,7 @@ lav_samplestats_from_data <- function(lavdata = NULL, ) # just a SINGLE warning if we have empty cells - if(categorical && zero.cell.warn && + if(categorical && zero.cell.warn && any(sapply(zero.cell.tables, nrow) > 0L)) { nempty <- sum(sapply(zero.cell.tables, nrow)) warning("lavaan WARNING: ", nempty, @@ -913,7 +913,7 @@ lav_samplestats_from_moments <- function(sample.cov = NULL, cat("found: ", cov.names, "\n") cat("expected: ", ov.names[[g]], "\n") stop("lavaan ERROR: rownames of covariance matrix do not match ", - "the model!\n", + "the model!\n", " found: ", paste(cov.names, collapse=" "), "\n", " expected: ", paste(ov.names[[g]], collapse=" "), "\n") } else { @@ -937,7 +937,7 @@ lav_samplestats_from_moments <- function(sample.cov = NULL, # rescale cov by (N-1)/N? if(rescale) { - # we 'transform' the sample cov (divided by n-1) + # we 'transform' the sample cov (divided by n-1) # to a sample cov divided by 'n' cov[[g]] <- (nobs[[g]]-1)/nobs[[g]] * cov[[g]] } @@ -1162,7 +1162,7 @@ lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL) { } # WARNING: aggregate() converts to FACTOR (changing the ORDER!) - Y2 <- unname(as.matrix(aggregate(Y1, by = list(cluster.idx), + Y2 <- unname(as.matrix(aggregate(Y1, by = list(cluster.idx), FUN = mean, na.rm = TRUE)[,-1])) Y2c <- t( t(Y2) - Y1.means ) @@ -1197,7 +1197,7 @@ lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL) { S <- cov(Y1, use = "pairwise.complete.obs") * (N - 1L)/N S.PW.start <- S.w if(length(within.idx) > 0L) { - S.PW.start[within.idx, within.idx] <- + S.PW.start[within.idx, within.idx] <- S[within.idx, within.idx, drop = FALSE] } @@ -1231,17 +1231,17 @@ lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL) { Mu.B[within.idx] <- 0 if(length(between.idx) > 0L) { # replace between.idx by cov(Y2)[,] elements... - Mu.B[between.idx] <- colMeans(Y2[,between.idx,drop = FALSE], + Mu.B[between.idx] <- colMeans(Y2[,between.idx,drop = FALSE], na.rm = TRUE) - S2 <- ( cov(Y2, use = "pairwise.complete.obs") * + S2 <- ( cov(Y2, use = "pairwise.complete.obs") * (nclusters - 1L) / nclusters ) - Sigma.B[ between.idx, between.idx] <- + Sigma.B[ between.idx, between.idx] <- S2[between.idx, between.idx, drop = FALSE] } - # FIXME: Mu.B not quite ok for (fixed.x) x variables if they + # FIXME: Mu.B not quite ok for (fixed.x) x variables if they # occur both at level 1 AND level 2 Mu.B.start <- Mu.B #Mu.B.start[both.idx] <- Mu.B.start[both.idx] - colMeans(Y2c[,both.idx]) @@ -1258,12 +1258,12 @@ lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL) { # NOTE:!!!! # reorder columns # to match A.inv and m.k later on in objective!!! - tmp2 <- Y2[d.idx, - c(between.idx, sort.int(c(both.idx, within.idx))), + tmp2 <- Y2[d.idx, + c(between.idx, sort.int(c(both.idx, within.idx))), drop = FALSE] mean.d[[clz]] <- colMeans(tmp2, na.rm = TRUE) if(length(d.idx) > 1L) { - cov.d[[clz]] <- ( cov(tmp2, use = "pairwise.complete.obs") * + cov.d[[clz]] <- ( cov(tmp2, use = "pairwise.complete.obs") * (ns-1) / ns ) } else { cov.d[[clz]] <- 0 @@ -1279,7 +1279,7 @@ lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL) { # diag(S.PW.start)[tiny.idx] <- diag(S.PW.start)[tiny.idx] - 0.020 #} - + YLp[[l]] <- list(Y1Y1 = Y1Y1, Y2 = Y2, s = s, S.b = S.b, S.PW.start = S.PW.start, diff --git a/R/lav_samplestats_gamma.R b/R/lav_samplestats_gamma.R index 5a96a441..06ab5634 100644 --- a/R/lav_samplestats_gamma.R +++ b/R/lav_samplestats_gamma.R @@ -1,5 +1,5 @@ # YR 21 March 2015 -# new approach to compute 'Gamma': the asymptotic variance matrix of +# new approach to compute 'Gamma': the asymptotic variance matrix of # sqrt{N} times the # observed sample statistics (means + varcov) # @@ -16,7 +16,7 @@ lavGamma <- function(object, group = NULL, missing = "listwise", ov.names.x = NULL, fixed.x = FALSE, conditional.x = FALSE, meanstructure = FALSE, slopestructure = FALSE, Mplus.WLS = FALSE, add.labels) { - + if(inherits(object, "lavaan")) { lavdata <- object@Data if(missing(missing)) { @@ -38,7 +38,7 @@ lavGamma <- function(object, group = NULL, missing = "listwise", } lavdata <- lavData(data = object, group = group, ov.names = NAMES, ordered = NULL, - ov.names.x = ov.names.x, + ov.names.x = ov.names.x, lavoptions = list(warn = FALSE, missing = missing)) } else { @@ -62,7 +62,7 @@ lavGamma <- function(object, group = NULL, missing = "listwise", meanstructure = meanstructure, slopestructure = slopestructure, Mplus.WLS = Mplus.WLS)) - + OUT } @@ -75,7 +75,7 @@ lavGamma <- function(object, group = NULL, missing = "listwise", # NORMAL-THEORY lav_samplestats_Gamma_NT <- function(Y = NULL, # should include - # eXo if + # eXo if #conditional.x=TRUE wt = NULL, COV = NULL, # joint! @@ -95,7 +95,7 @@ lav_samplestats_Gamma_NT <- function(Y = NULL, # should include if(is.null(COV)) { stopifnot(!is.null(Y)) - + # coerce to matrix Y <- unname(as.matrix(Y)); N <- nrow(Y) if(is.null(wt)) { @@ -138,7 +138,7 @@ lav_samplestats_Gamma_NT <- function(Y = NULL, # should include } else { # handle fixed.x = TRUE - # cov(Y|X) = A - B C^{-1} B' + # cov(Y|X) = A - B C^{-1} B' # where A = cov(Y), B = cov(Y,X), C = cov(X) A <- S[-x.idx, -x.idx, drop=FALSE] B <- S[-x.idx, x.idx, drop=FALSE] @@ -162,7 +162,7 @@ lav_samplestats_Gamma_NT <- function(Y = NULL, # should include } } else { - # conditional.x + # conditional.x # 4 possibilities: # - no meanstructure, no slopes @@ -203,7 +203,7 @@ lav_samplestats_Gamma_NT <- function(Y = NULL, # should include Gamma <- lav_matrix_bdiag(A11, Gamma) } - + Gamma } @@ -225,7 +225,7 @@ lav_samplestats_Gamma <- function(Y, fixed.x = FALSE, conditional.x = FALSE, meanstructure = FALSE, - slopestructure = FALSE, + slopestructure = FALSE, gamma.n.minus.one = FALSE, Mplus.WLS = FALSE, add.attributes = FALSE) { @@ -274,10 +274,10 @@ lav_samplestats_Gamma <- function(Y, idx1 <- lav_matrix_vech_col_idx(p) idx2 <- lav_matrix_vech_row_idx(p) if(meanstructure) { - Z <- cbind(Y, Yc[,idx1, drop = FALSE] * + Z <- cbind(Y, Yc[,idx1, drop = FALSE] * Yc[,idx2, drop = FALSE] ) } else { - Z <- ( Yc[,idx1, drop = FALSE] * + Z <- ( Yc[,idx1, drop = FALSE] * Yc[,idx2, drop = FALSE] ) } @@ -322,9 +322,9 @@ lav_samplestats_Gamma <- function(Y, YHAT <- cbind(yhat, Y[,x.idx]) YHATc <- t( t(YHAT) - YHAT.bar ) if(meanstructure) { - Z <- ( cbind(Y, Yc[,idx1, drop = FALSE] * + Z <- ( cbind(Y, Yc[,idx1, drop = FALSE] * Yc[,idx2, drop = FALSE] ) - - cbind(YHAT, YHATc[,idx1, drop = FALSE] * + cbind(YHAT, YHATc[,idx1, drop = FALSE] * YHATc[,idx2, drop = FALSE]) ) sigma1 <- c(Mu, lav_matrix_vech(Sigma)) sigma2 <- c(YHAT.bar, lav_matrix_vech(YHAT.cov)) @@ -347,14 +347,14 @@ lav_samplestats_Gamma <- function(Y, idx1 <- lav_matrix_vech_col_idx(p) idx2 <- lav_matrix_vech_row_idx(p) if(meanstructure) { - Z <- ( cbind(Y, Yc[,idx1, drop = FALSE] * - Yc[,idx2, drop = FALSE]) - - cbind(YHAT, YHATc[,idx1, drop = FALSE] * + Z <- ( cbind(Y, Yc[,idx1, drop = FALSE] * + Yc[,idx2, drop = FALSE]) - + cbind(YHAT, YHATc[,idx1, drop = FALSE] * YHATc[,idx2, drop = FALSE]) ) } else { - Z <- ( Yc[,idx1, drop = FALSE] * + Z <- ( Yc[,idx1, drop = FALSE] * Yc[,idx2, drop = FALSE] - - YHATc[,idx1, drop = FALSE] * + YHATc[,idx1, drop = FALSE] * YHATc[,idx2, drop = FALSE] ) } Zc <- t( t(Z) - colMeans(Z) ) @@ -368,7 +368,7 @@ lav_samplestats_Gamma <- function(Y, } else { - # conditional.x + # conditional.x # 4 possibilities: # - no meanstructure, no slopes @@ -399,13 +399,13 @@ lav_samplestats_Gamma <- function(Y, Res.idx <- rep(seq_len(ncY), each = ncX) Z <- cbind( Xi[, Xi.idx, drop = FALSE] * RES[,Res.idx, drop = FALSE], - RES[, idx1, drop = FALSE] * + RES[, idx1, drop = FALSE] * RES[, idx2, drop = FALSE] ) } else { Xi.idx <- rep(1L, each = ncY) Z <- cbind( Xi[, Xi.idx ,drop = FALSE] * RES, - RES[, idx1, drop = FALSE] * + RES[, idx1, drop = FALSE] * RES[, idx2, drop = FALSE] ) } } else { @@ -417,7 +417,7 @@ lav_samplestats_Gamma <- function(Y, Res.idx <- rep(seq_len(ncY), each = (ncX - 1L)) Z <- cbind( Xi[, Xi.idx, drop = FALSE] * RES[,Res.idx, drop = FALSE], - RES[, idx1, drop = FALSE] * + RES[, idx1, drop = FALSE] * RES[, idx2, drop = FALSE] ) } else { Z <- RES[,idx1, drop = FALSE] * RES[,idx2, drop = FALSE] @@ -436,7 +436,7 @@ lav_samplestats_Gamma <- function(Y, Gamma <- base::crossprod(Zc) / N } } - + # only to mimic Mplus when estimator = "WLS" if(Mplus.WLS && !fixed.x && !conditional.x) { diff --git a/R/lav_samplestats_icov.R b/R/lav_samplestats_icov.R index e544aef1..bb8732b8 100644 --- a/R/lav_samplestats_icov.R +++ b/R/lav_samplestats_icov.R @@ -10,10 +10,10 @@ lav_samplestats_icov <- function(COV = NULL, ridge = 0.0, x.idx = integer(0L), # maybe, we can fix it by gently ridging the exo variances ridge.eps <- ridge diag(COV)[x.idx] <- diag(COV)[x.idx] + ridge.eps - + # try again tmp <- try(inv.chol(COV, logdet = TRUE), silent = TRUE) - + if(inherits(tmp, "try-error")) { # fatal stop after all stop("lavaan ERROR: sample covariance matrix is not positive-definite") @@ -25,7 +25,7 @@ lav_samplestats_icov <- function(COV = NULL, ridge = 0.0, x.idx = integer(0L), # give a warning if(warn) { if(ngroups > 1) { - warning("lavaan WARNING sample covariance matrix in group: ", + warning("lavaan WARNING sample covariance matrix in group: ", g, " is not positive-definite") } else { warning("lavaan WARNING: sample covariance matrix is not positive-definite") diff --git a/R/lav_samplestats_igamma.R b/R/lav_samplestats_igamma.R index 228479d8..07938f81 100644 --- a/R/lav_samplestats_igamma.R +++ b/R/lav_samplestats_igamma.R @@ -32,7 +32,7 @@ lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, if(is.null(ICOV)) { if(is.null(COV)) { stopifnot(!is.null(Y)) - + # coerce to matrix Y <- unname(as.matrix(Y)); N <- nrow(Y) COV <- cov(Y) @@ -45,7 +45,7 @@ lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, } # if conditional.x, we may also need COV and MEAN - if(conditional.x && length(x.idx) > 0L && + if(conditional.x && length(x.idx) > 0L && (meanstructure || slopestructure)) { if(is.null(COV)) { @@ -102,7 +102,7 @@ lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, } } else { - # conditional.x + # conditional.x # 4 possibilities: # - no meanstructure, no slopes @@ -123,7 +123,7 @@ lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, if(meanstructure) { if(slopestructure) { - A11 <- C3 %x% S11 + A11 <- C3 %x% S11 } else { c11 <- 1 / solve(C3)[1, 1, drop=FALSE] A11 <- c11 %x% S11 @@ -140,7 +140,7 @@ lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, Gamma.inv <- lav_matrix_bdiag(A11, Gamma.inv) } } - + Gamma.inv } diff --git a/R/lav_samplestats_step1.R b/R/lav_samplestats_step1.R index 9d4facd9..6c238a17 100644 --- a/R/lav_samplestats_step1.R +++ b/R/lav_samplestats_step1.R @@ -1,13 +1,13 @@ -lav_samplestats_step1 <- function(Y, - ov.names = NULL, - ov.types = NULL, +lav_samplestats_step1 <- function(Y, + ov.names = NULL, + ov.types = NULL, ov.levels = NULL, - ov.names.x = character(0L), - eXo = NULL, + ov.names.x = character(0L), + eXo = NULL, scores.flag = TRUE, # scores? group = 1L) { # for error message - + # just in case Y is a vector Y <- as.matrix(Y) @@ -88,7 +88,7 @@ lav_samplestats_step1 <- function(Y, SC.SL[,sl.idx] <- scores[,fit$slope.idx,drop=FALSE] } VAR[i] <- 1.0 - TH.NAMES[[i]] <- paste(ov.names[i], "|t", 1:length(TH[[i]]), + TH.NAMES[[i]] <- paste(ov.names[i], "|t", 1:length(TH[[i]]), sep="") TH.IDX[[i]] <- rep(i, length(TH[[i]])) } else { diff --git a/R/lav_samplestats_step2.R b/R/lav_samplestats_step2.R index 9d6da1a0..b0c08ec9 100644 --- a/R/lav_samplestats_step2.R +++ b/R/lav_samplestats_step2.R @@ -8,7 +8,7 @@ lav_samplestats_step2 <- function(UNI = NULL, # keep track of tables with zero cells? zero.cell.tables = TRUE, - + optim.method = "nlminb") { nvar <- length(UNI) @@ -22,7 +22,7 @@ lav_samplestats_step2 <- function(UNI = NULL, # one-by-one (for now) for(j in seq_len(nvar-1L)) { for(i in (j+1L):nvar) { - #if(verbose) { cat(" i = ", i, " j = ", j, + #if(verbose) { cat(" i = ", i, " j = ", j, # "[",ov.names[i], "-", ov.names[j], "] ", # "(",ov.types[i], "-", ov.types[j], ")\n") } #pstar.idx <- PSTAR[i,j] @@ -35,12 +35,12 @@ lav_samplestats_step2 <- function(UNI = NULL, Y1 <- UNI[[i]]$y; Y2 <- UNI[[j]]$y } COR[i,j] <- COR[j,i] <- cor(Y1, Y2, use="pairwise.complete.obs") - } else if(class(UNI[[i]]) == "lavOLS" && + } else if(class(UNI[[i]]) == "lavOLS" && class(UNI[[j]]) == "lavProbit") { # polyserial out <- ps_cor_TS(fit.y1=UNI[[i]], fit.y2=UNI[[j]]) COR[i,j] <- COR[j,i] <- out - } else if(class(UNI[[j]]) == "lavOLS" && + } else if(class(UNI[[j]]) == "lavOLS" && class(UNI[[i]]) == "lavProbit") { # polyserial out <- ps_cor_TS(fit.y1=UNI[[j]], fit.y2=UNI[[i]]) @@ -50,7 +50,7 @@ lav_samplestats_step2 <- function(UNI = NULL, # polychoric correlation out <- pc_cor_TS(fit.y1=UNI[[i]], fit.y2=UNI[[j]], method = optim.method, - zero.add = zero.add, + zero.add = zero.add, zero.keep.margins = zero.keep.margins, zero.cell.warn = zero.cell.warn, zero.cell.flag = zero.cell.tables, diff --git a/R/lav_samplestats_wls_obs.R b/R/lav_samplestats_wls_obs.R index 015ab7fa..36a1d773 100644 --- a/R/lav_samplestats_wls_obs.R +++ b/R/lav_samplestats_wls_obs.R @@ -1,11 +1,11 @@ -lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g, +lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g, th.g, th.idx.g, res.int.g, res.cov.g, res.var.g, res.th.g, - res.slopes.g, - group.w.g, - categorical = FALSE, + res.slopes.g, + group.w.g, + categorical = FALSE, conditional.x = FALSE, - meanstructure = FALSE, + meanstructure = FALSE, slopestructure = FALSE, group.w.free = FALSE) { @@ -53,10 +53,10 @@ lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g, # so we need vecr WLS.obs <- c( lav_matrix_vecr( cbind(res.int.g, res.slopes.g)), - lav_matrix_vech( res.cov.g ) + lav_matrix_vech( res.cov.g ) ) #WLS.obs <- c( res.int.g, - # lav_matrix_vec( res.slopes.g ), + # lav_matrix_vec( res.slopes.g ), # lav_matrix_vech( res.cov.g )) } else { WLS.obs <- c( res.int.g, @@ -70,7 +70,7 @@ lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g, WLS.obs <- lav_matrix_vech( res.cov.g ) } } - + } else { if(meanstructure) { WLS.obs <- c( mean.g, diff --git a/R/lav_simulate.R b/R/lav_simulate.R index b593dad1..93226bac 100644 --- a/R/lav_simulate.R +++ b/R/lav_simulate.R @@ -4,7 +4,7 @@ # # - calls lavaan directly to get model-implied statistics # - allows for groups with different sets of variables -# - +# - lavSimulateData <- function(model = NULL, @@ -17,7 +17,7 @@ lavSimulateData <- function(model = NULL, # control empirical = FALSE, - + # output add.labels = TRUE, return.fit = FALSE, @@ -32,11 +32,11 @@ lavSimulateData <- function(model = NULL, dotdotdot$debug <- FALSE dotdotdot$data <- NULL dotdotdot$sample.cov <- NULL - + # add sample.nobs/group.label to lavaan call dotdotdot$sample.nobs <- sample.nobs - + # remove 'ordered' argument: we will first pretend we generate # continuous data only dotdotdot$ordered <- NULL @@ -64,14 +64,14 @@ lavSimulateData <- function(model = NULL, # number of groups/levels ngroups <- lavdata@ngroups nblocks <- length(fit.pop@implied$cov) # usually ngroups * nlevels - + # check sample.nobs argument if(lavdata@nlevels > 1L) { # multilevel if(is.null(cluster.idx)) { # default? -> 1000 per block if(is.null(sample.nobs)) { - sample.nobs <- rep.int( c(1000L, + sample.nobs <- rep.int( c(1000L, rep.int(100L, lavdata@nlevels - 1L)), times = ngroups ) } else { @@ -131,7 +131,7 @@ lavSimulateData <- function(model = NULL, COV <- lavimplied$cov[[b]] MU <- lavimplied$mean[[b]] - # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML + # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML # returns exact results if(empirical) { # check if sample.nobs is large enough @@ -139,7 +139,7 @@ lavSimulateData <- function(model = NULL, stop("lavaan ERROR: empirical = TRUE requires sample.nobs = ", sample.nobs[b], " to be larger than", "\n\t\tthe number of variables = ", NCOL(COV), - " in block = ", b) + " in block = ", b) } if(lavdata@nlevels > 1L && (b %% lavdata@nlevels == 1L)) { COV <- COV * sample.nobs[b] / (sample.nobs[b] - sample.nobs[b+1]) @@ -150,7 +150,7 @@ lavSimulateData <- function(model = NULL, # generate normal data tmp <- try(MASS::mvrnorm(n = sample.nobs[b], - mu = MU, Sigma = COV, empirical = empirical), + mu = MU, Sigma = COV, empirical = empirical), silent = TRUE) if(inherits(tmp, "try-error")) { @@ -180,10 +180,10 @@ lavSimulateData <- function(model = NULL, X.block <- X X <- vector("list", length = ngroups) } - + # assemble data per group for(g in 1:ngroups) { - + # multilevel? if(lavdata@nlevels > 1L) { @@ -218,12 +218,12 @@ lavSimulateData <- function(model = NULL, S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv) # transform - X.block[[bb]] <- Y1c %*% S.inv.sqrt %*% sigma.sqrt + X.block[[bb]] <- Y1c %*% S.inv.sqrt %*% sigma.sqrt } tmp1[, Lp$ov.idx[[1]] ] <- X.block[[bb]] # level 2 - tmp2[, Lp$ov.idx[[2]] ] <- X.block[[bb + 1L]][cluster.idx[[g]],, + tmp2[, Lp$ov.idx[[2]] ] <- X.block[[bb + 1L]][cluster.idx[[g]],, drop = FALSE] # final X[[g]] <- tmp1 + tmp2 @@ -260,7 +260,7 @@ lavSimulateData <- function(model = NULL, TH.VAL <- TH.VAL[-NUM.idx] } th.names <- fit.pop@pta$vnames$th[[bb]] - TH.NAMES <- sapply(strsplit(th.names, split = "|", + TH.NAMES <- sapply(strsplit(th.names, split = "|", fixed = TRUE), "[[", 1L) # use thresholds to cut diff --git a/R/lav_simulate_old.R b/R/lav_simulate_old.R index d609b367..32f56cea 100644 --- a/R/lav_simulate_old.R +++ b/R/lav_simulate_old.R @@ -56,9 +56,9 @@ simulateData <- function( stop("lavaan ERROR: model is a list, but not a parameterTable?") } } else { - lav <- lavaanify(model = model, + lav <- lavaanify(model = model, meanstructure=meanstructure, - int.ov.free=int.ov.free, + int.ov.free=int.ov.free, int.lv.free=int.lv.free, conditional.x=conditional.x, fixed.x=fixed.x, @@ -91,7 +91,7 @@ simulateData <- function( idx <- which(lav$op == "~~" & is.na(lav$ustart) & lav$lhs == lav$rhs) if(length(idx) > 0L) lav$ustart[idx] <- 1.0 - idx <- which(lav$op == "~" & is.na(lav$ustart)) + idx <- which(lav$op == "~" & is.na(lav$ustart)) if(length(idx) > 0L) { warning("lavaan WARNING: some regression coefficients are unspecified and will be set to zero") } @@ -106,7 +106,7 @@ simulateData <- function( # set residual variances to enforce a standardized solution # but only if no *residual* variances have been specified in the syntax - + if(standardized) { # check if factor loadings are smaller than 1.0 lambda.idx <- which(lav$op == "=~") @@ -121,7 +121,7 @@ simulateData <- function( } # for ordered observed variables, we will get '0.0', but that is ok - # so there is no need to make a distinction between numeric/ordered + # so there is no need to make a distinction between numeric/ordered # here?? lav2 <- lav ngroups <- lav_partable_ngroups(lav) @@ -129,7 +129,7 @@ simulateData <- function( ov.nox <- vnames(lav, "ov.nox") lv.names <- vnames(lav, "lv") lv.y <- vnames(lav, "lv.y") - ov.var.idx <- which(lav$op == "~~" & lav$lhs %in% ov.nox & + ov.var.idx <- which(lav$op == "~~" & lav$lhs %in% ov.nox & lav$rhs == lav$lhs) lv.var.idx <- which(lav$op == "~~" & lav$lhs %in% lv.y & lav$rhs == lav$lhs) @@ -148,7 +148,7 @@ simulateData <- function( # standardized OV for(g in 1:ngroups) { - var.group <- which(lav$op == "~~" & lav$lhs %in% ov.nox & + var.group <- which(lav$op == "~~" & lav$lhs %in% ov.nox & lav$rhs == lav$lhs & lav$group == g) ov.idx <- match(ov.nox, ov.names) lav$ustart[var.group] <- 1 - diag(Sigma.hat[[g]])[ov.idx] @@ -168,11 +168,11 @@ simulateData <- function( if(debug) { cat("after standardisation lav\n") print(as.data.frame(lav)) - } + } } - # unstandardize + # unstandardize if(!is.null(ov.var)) { # FIXME: if ov.var is named, check the order of the elements @@ -207,14 +207,14 @@ simulateData <- function( # ngroups ngroups <- length(sample.nobs) - # prepare + # prepare X <- vector("list", length=ngroups) out <- vector("list", length=ngroups) for(g in 1:ngroups) { COV <- Sigma.hat[[g]] - - # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML + + # if empirical = TRUE, rescale by N/(N-1), so that estimator=ML # returns exact results if(empirical) { COV <- COV * sample.nobs[g] / (sample.nobs[g] - 1) @@ -228,7 +228,7 @@ simulateData <- function( empirical = empirical) } else { # first generate Z - Z <- ValeMaurelli1983(n = sample.nobs[g], + Z <- ValeMaurelli1983(n = sample.nobs[g], COR = cov2cor(COV), skewness = skewness, # FIXME: per group? kurtosis = kurtosis, @@ -239,9 +239,9 @@ simulateData <- function( # this was reported by Jordan Brace (9 may 2014) #X[[g]] <- scale(Z, center = -Mu.hat[[g]], # scale = 1/sqrt(diag(COV))) - - # first, we scale - TMP <- scale(Z, center = FALSE, + + # first, we scale + TMP <- scale(Z, center = FALSE, scale = 1/sqrt(diag(COV)))[,,drop=FALSE] # then, we center @@ -318,13 +318,13 @@ Kurtosis <- function(x., N1=TRUE) { kurtosis } -# NOTE: as pointed out in Fleishman (1978), a real solution does not +# NOTE: as pointed out in Fleishman (1978), a real solution does not # always exist (for a/b/c/d) for all values of skew/kurtosis # # for example: skew = 3, only valid if kurtosis > 14 (approximately) # # fleishman eq 21 suggests: skew^2 < 0.0629576*kurtosis + 0.0717247 -# see figure 1 page 527 +# see figure 1 page 527 # # note also that the a/b/c/d solution is not unique, although this seems # not to matter for generating the data diff --git a/R/lav_start.R b/R/lav_start.R index f5f3a5f6..bf0d3ad9 100644 --- a/R/lav_start.R +++ b/R/lav_start.R @@ -8,7 +8,7 @@ # starting values, using the sample data lav_start <- function(start.method = "default", - lavpartable = NULL, + lavpartable = NULL, lavsamplestats = NULL, model.type = "sem", mimic = "lavaan", @@ -19,7 +19,7 @@ lav_start <- function(start.method = "default", # categorical? categorical <- any(lavpartable$op == "|") - + # conditional.x? conditional.x <- any(lavpartable$exo == 1L & lavpartable$op == "~") #ord.names <- unique(lavpartable$lhs[ lavpartable$op == "|" ]) @@ -56,7 +56,7 @@ lav_start <- function(start.method = "default", start.method. <- tolower(start.method) if(start.method. == "default") { # nothing to do - } else if(start.method. %in% c("simple", "lavaan", "mplus")) { + } else if(start.method. %in% c("simple", "lavaan", "mplus")) { start.initial <- start.method. } else { stop("lavaan ERROR: unknown value for start argument") @@ -84,14 +84,14 @@ lav_start <- function(start.method = "default", } else { stop("lavaan ERROR: problem with start argument: could not find est/start column in model list") } - } + } # global settings # 0. everyting is zero start <- numeric( length(lavpartable$ustart) ) - # 1. =~ factor loadings: + # 1. =~ factor loadings: if(categorical) { # if std.lv=TRUE, more likely initial Sigma.hat is positive definite # 0.8 is too large @@ -122,7 +122,7 @@ lav_start <- function(start.method = "default", lavpartable$group <- rep(1L, length(lavpartable$lhs)) lavpartable$group[ lavpartable$block == 0L] <- 0L } - + for(g in 1:ngroups) { @@ -154,21 +154,22 @@ lav_start <- function(start.method = "default", if(start.initial %in% c("lavaan", "mplus") && model.type %in% c("sem", "cfa") && #!categorical && - sum( lavpartable$ustart[ lavpartable$op == "=~" & lavpartable$group == group.values[g]], - na.rm=TRUE) == length(lv.names) ) { + sum( lavpartable$ustart[ lavpartable$op == "=~" & + lavpartable$group == group.values[g] ], + na.rm = TRUE) == length(lv.names) ) { # only if all latent variables have a reference item, # we use the fabin3 estimator (2sls) of Hagglund (1982) # per factor # 9 Okt 2013: if only 2 indicators, we use the regression # coefficient (y=marker, x=2nd indicator) for(f in lv.names) { - free.idx <- which( lavpartable$lhs == f & - lavpartable$op == "=~" & - lavpartable$group == group.values[g] & + free.idx <- which( lavpartable$lhs == f & + lavpartable$op == "=~" & + lavpartable$group == group.values[g] & lavpartable$free > 0L) - - user.idx <- which( lavpartable$lhs == f & - lavpartable$op == "=~" & + + user.idx <- which( lavpartable$lhs == f & + lavpartable$op == "=~" & lavpartable$group == group.values[g] ) # no second order if(any(lavpartable$rhs[user.idx] %in% lv.names)) next @@ -186,7 +187,8 @@ lav_start <- function(start.method = "default", COV <- lavsamplestats@cov[[g]][ov.idx,ov.idx] } } - start[user.idx] <- lav_cfa_1fac_fabin(COV) + fabin <- lav_cfa_1fac_fabin(COV, lambda.only = TRUE)$lambda + start[user.idx] <- fabin } else if(length(free.idx) == 1L && length(ov.idx) == 2L) { if(conditional.x) { REG2 <- ( lavsamplestats@res.cov[[g]][ov.idx[1], @@ -203,11 +205,11 @@ lav_start <- function(start.method = "default", } # standardized? - var.f.idx <- which(lavpartable$lhs == f & + var.f.idx <- which(lavpartable$lhs == f & lavpartable$op == "~~" & lavpartable$group == group.values[g] & lavpartable$rhs == f) - if(length(var.f.idx) > 0L && + if(length(var.f.idx) > 0L && lavpartable$free[var.f.idx] == 0 && lavpartable$ustart[var.f.idx] == 1) { # make sure factor loadings are between -0.7 and 0.7 @@ -215,7 +217,7 @@ lav_start <- function(start.method = "default", start[user.idx] <- (x / max(abs(x))) * 0.7 } } - } + } # fabin if(model.type == "unrestricted") { # fill in 'covariances' from lavsamplestats @@ -228,9 +230,9 @@ lav_start <- function(start.method = "default", } # 2g) residual ov variances (including exo, to be overriden) - ov.var.idx <- which(lavpartable$group == group.values[g] & - lavpartable$op == "~~" & - lavpartable$lhs %in% ov.names.num & + ov.var.idx <- which(lavpartable$group == group.values[g] & + lavpartable$op == "~~" & + lavpartable$lhs %in% ov.names.num & lavpartable$lhs == lavpartable$rhs) sample.var.idx <- match(lavpartable$lhs[ov.var.idx], ov.names) if(model.type == "unrestricted") { @@ -241,7 +243,7 @@ lav_start <- function(start.method = "default", start[ov.var.idx] <- (1.0 - 0.50)*lavsamplestats@res.var[[1L]][sample.var.idx] } else { - start[ov.var.idx] <- + start[ov.var.idx] <- (1.0 - 0.50)*lavsamplestats@var[[1L]][sample.var.idx] } } else { @@ -249,13 +251,13 @@ lav_start <- function(start.method = "default", start[ov.var.idx] <- (1.0 - 0.50)*diag(lavsamplestats@res.cov[[g]])[sample.var.idx] } else { - start[ov.var.idx] <- + start[ov.var.idx] <- (1.0 - 0.50)*diag(lavsamplestats@cov[[g]])[sample.var.idx] } } } - # variances of ordinal variables - set to 1.0 + # variances of ordinal variables - set to 1.0 if(categorical) { ov.var.ord.idx <- which(lavpartable$group == group.values[g] & lavpartable$op == "~~" & @@ -266,7 +268,7 @@ lav_start <- function(start.method = "default", # 3g) intercepts/means ov.int.idx <- which(lavpartable$group == group.values[g] & - lavpartable$op == "~1" & + lavpartable$op == "~1" & lavpartable$lhs %in% ov.names) sample.int.idx <- match(lavpartable$lhs[ov.int.idx], ov.names) if(lavsamplestats@missing.flag && nlevels == 1L) { @@ -278,38 +280,38 @@ lav_start <- function(start.method = "default", start[ov.int.idx] <- lavsamplestats@mean[[g]][sample.int.idx] } } - + # 4g) thresholds th.idx <- which(lavpartable$group == group.values[g] & lavpartable$op == "|") if(length(th.idx) > 0L) { th.names.lavpartable <- paste(lavpartable$lhs[th.idx], "|", lavpartable$rhs[th.idx], sep="") - th.names.sample <- + th.names.sample <- lavsamplestats@th.names[[g]][ lavsamplestats@th.idx[[g]] > 0L ] # th.names.sample should identical to # vnames(lavpartable, "th", group = group.values[g]) if(conditional.x) { - th.values <- + th.values <- lavsamplestats@res.th[[g]][lavsamplestats@th.idx[[g]] > 0L] } else { - th.values <- + th.values <- lavsamplestats@th[[g]][lavsamplestats@th.idx[[g]] > 0L] - } + } start[th.idx] <- th.values[match(th.names.lavpartable, th.names.sample)] } - + # 5g) exogenous `fixed.x' covariates if(length(ov.names.x) > 0) { exo.idx <- which(lavpartable$group == group.values[g] & - lavpartable$op == "~~" & + lavpartable$op == "~~" & lavpartable$lhs %in% ov.names.x & lavpartable$rhs %in% ov.names.x) if(!conditional.x) { row.idx <- match(lavpartable$lhs[exo.idx], ov.names) col.idx <- match(lavpartable$rhs[exo.idx], ov.names) if(lavsamplestats@missing.flag && nlevels == 1L) { - start[exo.idx] <- + start[exo.idx] <- lavsamplestats@missing.h1[[g]]$sigma[cbind(row.idx,col.idx)] # using slightly smaller starting values for free # variance/covariances (fixed.x = FALSE); @@ -391,7 +393,7 @@ lav_start <- function(start.method = "default", # lv.names.x <- unlist(lv.names.x) # for now # } # lv.names.xy <- unique(c(lv.names.x, lv.names.y)) - + # if(length(lv.names.xy) > 0L) { # free.var.idx <- which(lavpartable$op == "~~" & @@ -420,7 +422,7 @@ lav_start <- function(start.method = "default", # } else { # ov.var <- diag(lavsamplestats@cov[[g]])[ov.idx] # } - # + # # # exogenous? assume rel = 0.50 # lambda <- lavpartable$ustart[ind.idx] # tmp <- (0.50 * ov.var)/lambda^2 @@ -451,7 +453,7 @@ lav_start <- function(start.method = "default", } # groups - # nlevels > 1L + # nlevels > 1L if(nlevels > 1L) { for(g in 1:ngroups) { group.values <- lav_partable_group_values(lavpartable) @@ -469,7 +471,7 @@ lav_start <- function(start.method = "default", lavpartable$rhs %in% ov.names.x) row.idx <- match(lavpartable$lhs[exo.idx], ov.names) col.idx <- match(lavpartable$rhs[exo.idx], ov.names) - + if(l == 1L) { COV <- lavsamplestats@YLp[[g]][[2]]$S.PW.start } else { @@ -489,7 +491,7 @@ lav_start <- function(start.method = "default", } else { INT <- lavsamplestats@YLp[[g]][[l]]$Mu.B.start } - + start[ov.int.idx] <- INT[idx] } # levels } # fixed.x @@ -513,19 +515,19 @@ lav_start <- function(start.method = "default", # growth models: # - compute starting values for mean latent variables # - compute starting values for variance latent variables - if(start.initial %in% c("lavaan", "mplus") && + if(start.initial %in% c("lavaan", "mplus") && model.type == "growth") { ### DEBUG ONLY #lv.var.idx <- which(lavpartable$op == "~~" & # lavpartable$lhs %in% lv.names & # lavpartable$lhs == lavpartable$rhs) - + ### DEBUG ONLY #lv.int.idx <- which(lavpartable$op == "~1" & # lavpartable$lhs %in% lv.names) } - # override if a user list with starting values is provided + # override if a user list with starting values is provided # we only look at the 'est' column for now if(!is.null(start.user)) { @@ -540,7 +542,7 @@ lav_start <- function(start.method = "default", for(i in 1:length(lavpartable$lhs)) { # find corresponding parameters lhs <- lavpartable$lhs[i] - op <- lavpartable$op[i] + op <- lavpartable$op[i] rhs <- lavpartable$rhs[i] grp <- lavpartable$group[i] @@ -548,13 +550,13 @@ lav_start <- function(start.method = "default", start.user$op == op & start.user$rhs == rhs & start.user$group == grp) - if(length(start.user.idx) == 1L && + if(length(start.user.idx) == 1L && is.finite(start.user$est[start.user.idx])) { start[i] <- start.user$est[start.user.idx] } } } - + # override if the model syntax contains explicit starting values user.idx <- which(!is.na(lavpartable$ustart)) start[user.idx] <- lavpartable$ustart[user.idx] @@ -588,7 +590,7 @@ lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) { start != 0) # for each covariance, use corresponding variances to standardize; - # the end result should not exceed abs(1) + # the end result should not exceed abs(1) for(cc in seq_along(cov.idx)) { this.cov.idx <- cov.idx[cc] @@ -613,11 +615,11 @@ lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) { if(nblocks > 1L) { block.txt <- paste(" [in block ", g, "]", sep = "") } - + # check for zero variances if(var.lhs.value == 0 || var.rhs.value == 0) { # this can only happen if it is user-specified - # cov.idx free? set it to zero + # cov.idx free? set it to zero if(start[this.cov.idx] == 0) { # nothing to do } else if(lavpartable$free[this.cov.idx] > 0L) { @@ -643,20 +645,20 @@ lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) { # check COR <- start[this.cov.idx] / sqrt(var.lhs.value * var.rhs.value) - + if(!is.finite(COR)) { # force simple values warning( "lavaan WARNING: starting values imply NaN for a correlation value;\n", -" variables involved are: ", var.lhs, " ", var.rhs, block.txt) +" variables involved are: ", var.lhs, " ", var.rhs, block.txt) start[var.lhs.idx] <- 1 start[var.rhs.idx] <- 1 start[this.cov.idx] <- 0 } else if(abs(COR) > 1) { warning( - "lavaan WARNING: starting values imply a correlation larger than 1;\n", + "lavaan WARNING: starting values imply a correlation larger than 1;\n", " variables involved are: ", var.lhs, " ", var.rhs, block.txt) - + # three ways to fix it: rescale cov12, var1 or var2 # we prefer a free parameter, and not user-specified diff --git a/R/lav_syntax.R b/R/lav_syntax.R index ed68d401..ad407290 100644 --- a/R/lav_syntax.R +++ b/R/lav_syntax.R @@ -3,34 +3,34 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, warn = TRUE, debug = FALSE) { - + # check for empty syntax if(length(model.syntax) == 0) { stop("lavaan ERROR: empty model syntax") } - - # remove comments prior to split. + + # remove comments prior to split. # Match from comment character to newline, but don't eliminate newline model.syntax <- gsub("[#!].*(?=\n)","", model.syntax, perl=TRUE) - + # replace semicolons with newlines prior to split model.syntax <- gsub(";", "\n", model.syntax, fixed=TRUE) - + #remove whitespace prior to split model.syntax <- gsub("[ \t]+", "", model.syntax, perl=TRUE) # remove any occurrence of >= 2 consecutive newlines to eliminate \ - # blank statements; this retains a blank newline at the beginning, + # blank statements; this retains a blank newline at the beginning, # if such exists, but parser will not choke because of start.idx model.syntax <- gsub("\n{2,}", "\n", model.syntax, perl=TRUE) - - # break up in lines + + # break up in lines model <- unlist( strsplit(model.syntax, "\n") ) - + # check for multi-line formulas: they contain no "~" or "=" character # but before we do that, we remove all modifiers # to avoid confusion with for example equal("f1=~x1") statements model.simple <- gsub("\\(.*\\)\\*", "MODIFIER*", model) - + start.idx <- grep("[~=<>:|%]", model.simple) # check for empty start.idx: no operator found (new in 0.6-1) @@ -58,7 +58,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, for(i in 1:length(start.idx)) { model[i] <- paste(model.orig[start.idx[i]:end.idx[i]], collapse="") } - + # ok, in all remaining lines, we should have a '~' operator # OR one of '=', '<', '>', '|' outside the "" model.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", model) @@ -76,12 +76,12 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, print(model[idx.wrong]) stop("lavaan ERROR: syntax error in lavaan model syntax") } - - + + # main operation: flatten formulas into single bivariate pieces - # with a left-hand-side (lhs), an operator (eg "=~"), and a + # with a left-hand-side (lhs), an operator (eg "=~"), and a # right-hand-side (rhs) - # both lhs and rhs can have a modifier + # both lhs and rhs can have a modifier # (but we ignore the lhs modifier for now) FLAT.lhs <- character(0) #FLAT.lhs.mod <- character(0) @@ -89,8 +89,8 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, FLAT.rhs <- character(0) FLAT.rhs.mod.idx <- integer(0) FLAT.block <- integer(0) # keep track of groups using ":" operator - - FLAT.fixed <- character(0) # only for display purposes! + + FLAT.fixed <- character(0) # only for display purposes! FLAT.start <- character(0) # only for display purposes! FLAT.lower <- character(0) # only for display purposes! FLAT.upper <- character(0) # only for display purposes! @@ -108,7 +108,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, if(debug) { cat("formula to parse:\n"); print(x); cat("\n") } - + # 1. which operator is used? line.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", x) # "=~" operator? @@ -124,10 +124,10 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, op <- "~~" # "~" operator? } else if(grepl("~", line.simple, fixed=TRUE)) { - op <- "~" + op <- "~" # "==" operator? } else if(grepl("==", line.simple, fixed=TRUE)) { - op <- "==" + op <- "==" # "<" operator? } else if(grepl("<", line.simple, fixed=TRUE)) { op <- "<" @@ -149,15 +149,15 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, } else { stop("unknown operator in ", model[i]) } - + # 2. split by operator (only the *first* occurence!) # check first if equal/label modifier has been used on the LEFT! - if(substr(x,1,6) == "label(") + if(substr(x,1,6) == "label(") stop("label modifier can not be used on the left-hand side of the operator") if(op == "|") { op.idx <- regexpr("\\|", x) } else if(op == "~*~") { - op.idx <- regexpr("~\\*~", x) + op.idx <- regexpr("~\\*~", x) } else { op.idx <- regexpr(op, x) } @@ -181,7 +181,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, CON[[CON.idx]] <- list(op=op, lhs=lhs, rhs=rhs, user=1L) next } - + # 2c if operator is ":", put it in BLOCK if(op == ":") { FLAT.idx <- FLAT.idx + 1L @@ -202,7 +202,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, BLOCK_OP <- TRUE next } - + # 3. parse left hand # lhs modifiers will be ignored for now lhs.formula <- as.formula(paste("~",lhs)) @@ -212,7 +212,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, if(sum(sapply(out, length)) > 0L) { warning("lavaan WARNING: left-hand side of formula below contains modifier:\n", x,"\n") } - + # 4. lav_syntax_parse_rhs (as rhs of a single-sided formula) # new 0.5-12: before we do this, replace '0.2?' by 'start(0.2)*' @@ -222,13 +222,13 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, out <- lav_syntax_parse_rhs(rhs=rhs.formula[[2L]],op=op) if(debug) print(out) - + # for each lhs element for(l in 1:length(lhs.names)) { - + # for each rhs element for(j in 1:length(out)) { - + # catch intercepts if(names(out)[j] == "intercept") { if(op == "~") { @@ -244,13 +244,13 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, rhs.name <- names(out)[j] } - # move this 'check' to post-parse + # move this 'check' to post-parse #if(op == "|") { # th.name <- paste("t", j, sep="") # if(names(out)[j] != th.name) { - # stop("lavaan ERROR: threshold ", j, " of variable ", + # stop("lavaan ERROR: threshold ", j, " of variable ", # sQuote(lhs.names[1]), " should be named ", - # sQuote(th.name), "; found ", + # sQuote(th.name), "; found ", # sQuote(names(out)[j]), "\n") # } #} @@ -259,7 +259,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, if(op == "=~" && lhs.names[l] == names(out)[j]) { stop("lavaan ERROR: latent variable `", lhs.names[l], "' can not be measured by itself") } - + # check if we not already have this combination (in this group) # 1. asymmetric (=~, ~, ~1) if(op != "~~") { @@ -291,7 +291,7 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, FLAT.lower[FLAT.idx] <- "" FLAT.upper[FLAT.idx] <- "" FLAT.prior[FLAT.idx] <- "" - + mod <- list() rhs.mod <- 0L if(length(out[[j]]$fixed) > 0L) { @@ -335,9 +335,9 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse=";") rhs.mod <- 1L } - + FLAT.rhs.mod.idx[FLAT.idx] <- rhs.mod - + if(rhs.mod > 0L) { MOD.idx <- MOD.idx + 1L MOD[[MOD.idx]] <- mod @@ -345,11 +345,11 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, } # rhs elements } # lhs elements } # model elements - + # enumerate modifier indices mod.idx <- which(FLAT.rhs.mod.idx > 0L) FLAT.rhs.mod.idx[ mod.idx ] <- 1:length(mod.idx) - + FLAT <- list(lhs=FLAT.lhs, op=FLAT.op, rhs=FLAT.rhs, mod.idx=FLAT.rhs.mod.idx, block=FLAT.block, fixed=FLAT.fixed, start=FLAT.start, @@ -364,14 +364,14 @@ lavParseModelString <- function(model.syntax = '', as.data.frame. = FALSE, # new in 0.6, reorder covariances here! FLAT <- lav_partable_covariance_reorder(FLAT) - + if(as.data.frame.) { FLAT <- as.data.frame(FLAT, stringsAsFactors=FALSE) } - + attr(FLAT, "modifiers") <- MOD attr(FLAT, "constraints") <- CON - + FLAT } @@ -398,7 +398,7 @@ lav_syntax_parse_rhs <- function(rhs, op="") { out[[1L]]$fixed <- 0 } else { names(out)[1L] <- "..constant.." - out[[1L]]$fixed <- 0 + out[[1L]]$fixed <- 0 } } break @@ -451,7 +451,7 @@ lav_syntax_parse_rhs <- function(rhs, op="") { } else { names(out)[1L] <- "intercept" } - if(n.var > 1L) { + if(n.var > 1L) { # modifier are unquoted labels out[[1L]]$label <- i.var[-n.var] } else if(length(rhs[[3L]]) == 3L && rhs3.names[1L] == "*") { @@ -495,14 +495,14 @@ lav_syntax_get_modifier <- function(mod) { if(length(mod) == 1L) { # three possibilites: 1) numeric, 2) NA, or 3) quoted character - if( is.numeric(mod) ) + if( is.numeric(mod) ) return( list(fixed=mod) ) - if( is.na(mod) ) + if( is.na(mod) ) return( list(fixed=as.numeric(NA)) ) if( is.character(mod) ) return( list(label=mod) ) } else if(mod[[1L]] == "start") { - cof <- unlist(lapply(as.list(mod)[-1], + cof <- unlist(lapply(as.list(mod)[-1], eval, envir=NULL, enclos=NULL)) return( list(start=cof) ) } else if(mod[[1L]] == "lower") { @@ -514,7 +514,7 @@ lav_syntax_get_modifier <- function(mod) { eval, envir=NULL, enclos=NULL)) return( list(upper=cof) ) } else if(mod[[1L]] == "equal") { - label <- unlist(lapply(as.list(mod)[-1], + label <- unlist(lapply(as.list(mod)[-1], eval, envir=NULL, enclos=NULL)) return( list(label=label) ) } else if(mod[[1L]] == "label") { @@ -528,11 +528,11 @@ lav_syntax_get_modifier <- function(mod) { return( list(prior=prior) ) } else if(mod[[1L]] == "c") { # vector: we allow numeric and character only! - cof <- unlist(lapply(as.list(mod)[-1], + cof <- unlist(lapply(as.list(mod)[-1], eval, envir=NULL, enclos=NULL)) if(all(is.na(cof))) { return( list(fixed=rep(as.numeric(NA), length(cof))) ) - } else if(is.numeric(cof)) + } else if(is.numeric(cof)) return( list(fixed=cof) ) else if(is.character(cof)) { cof[is.na(cof)] <- "" # catch 'NA' elements in a label diff --git a/R/lav_syntax_independence.R b/R/lav_syntax_independence.R index 1099836b..e38dfc99 100644 --- a/R/lav_syntax_independence.R +++ b/R/lav_syntax_independence.R @@ -1,5 +1,5 @@ # generate syntax for an independence model -lav_syntax_independence <- function(ov.names=character(0), +lav_syntax_independence <- function(ov.names=character(0), ov.names.x=character(0), sample.cov=NULL) { @@ -34,17 +34,17 @@ lav_syntax_independence <- function(ov.names=character(0), # latent variances if(is.null(sample.cov)) { - txt <- paste(txt, paste(lv.names, " ~~ ", lv.names, + txt <- paste(txt, paste(lv.names, " ~~ ", lv.names, "\n", sep="", collapse=""), sep="") } else { # fill in sample values ov.idx <- match(ov.names.nox, ov.names) - start.txt <- paste("start(c(", + start.txt <- paste("start(c(", apply(matrix(unlist(lapply(sample.cov, function(x) { diag(x)[ov.idx] })), ncol=ngroups), 1,paste,collapse=","), "))", sep="") - txt <- paste(txt, paste(lv.names, " ~~ ", start.txt, " * ", + txt <- paste(txt, paste(lv.names, " ~~ ", start.txt, " * ", lv.names, "\n", sep="", collapse=""), sep="") } @@ -52,14 +52,14 @@ lav_syntax_independence <- function(ov.names=character(0), # latent *covariances* fixed to zero (= independence!) if(length(lv.names) > 1L) { tmp <- utils::combn(lv.names, 2) - txt <- paste(txt, paste(tmp[1,], " ~~ 0*", tmp[2,], "\n", sep="", + txt <- paste(txt, paste(tmp[1,], " ~~ 0*", tmp[2,], "\n", sep="", collapse=""), sep="") } # if 'independent x' variables, add an 'empty' regression if((nx <- length(ov.names.x)) > 0) { # dummy regression line - txt <- paste(txt, paste("f1 ~ 0*", ov.names.x, + txt <- paste(txt, paste("f1 ~ 0*", ov.names.x, "\n", sep="", collapse=""), sep="") } diff --git a/R/lav_tables.R b/R/lav_tables.R index b240c223..62c69de1 100644 --- a/R/lav_tables.R +++ b/R/lav_tables.R @@ -3,7 +3,7 @@ # Notes: # - we do NOT make a distinction here between unordered and ordered categorical # variables -# - object can be a matrix (most likely with integers), a full data frame, +# - object can be a matrix (most likely with integers), a full data frame, # a fitted lavaan object, or a lavData object # - 11 May 2013: added collapse=TRUE, min.std.resid options (suggested # by Myrsini Katsikatsou @@ -22,7 +22,7 @@ lavTables <- function(object, # what type of table? - dimension = 2L, + dimension = 2L, type = "cells", # if raw data, additional attributes categorical = NULL, @@ -60,7 +60,7 @@ lavTables <- function(object, # case 1: response patterns if(dimension == 0L) { out <- lav_tables_pattern(lavobject = lavobject, lavdata = lavdata, - statistic = statistic, + statistic = statistic, patternAsString = patternAsString) # output format if(output == "data.frame") { @@ -83,7 +83,7 @@ lavTables <- function(object, # case 3a: two-way/pairwise/bivariate + cells } else if(dimension == 2L && type == "cells") { - out <- lav_tables_pairwise_cells(lavobject = lavobject, + out <- lav_tables_pairwise_cells(lavobject = lavobject, lavdata = lavdata, statistic = statistic) # output format @@ -92,12 +92,12 @@ lavTables <- function(object, } else if(output == "table") { out <- lav_tables_cells_format(out, lavdata = lavdata) } else { - warning("lavaan WARNING: output option `", output, "' is not available; ignored.") + warning("lavaan WARNING: output option `", output, "' is not available; ignored.") } # case 3b: two-way/pairwise/bivariate + collapsed table } else if(dimension == 2L && (type == "table" || type == "tables")) { - out <- lav_tables_pairwise_table(lavobject = lavobject, + out <- lav_tables_pairwise_table(lavobject = lavobject, lavdata = lavdata, statistic = statistic, G2.min = G2.min, @@ -107,7 +107,7 @@ lavTables <- function(object, if(output == "data.frame") { class(out) <- c("lavaan.data.frame", "data.frame") } else if(output == "table") { - out <- lav_tables_table_format(out, lavdata = lavdata, + out <- lav_tables_table_format(out, lavdata = lavdata, lavobject = lavobject) } else { warning("lavaan WARNING: output option `", output, "' is not available; ignored.") @@ -119,7 +119,7 @@ lavTables <- function(object, # empty table (perhaps, no categorical variables) return(invisible(out)) } - + out } @@ -139,8 +139,8 @@ lavTables <- function(object, # # lavTables(object = object, dimension = 2L, type = "table", # categorical = categorical, group = group, -# statistic = statistic, -# G2.min = G2.min, X2.min = X2.min, p.value = p.value, +# statistic = statistic, +# G2.min = G2.min, X2.min = X2.min, p.value = p.value, # output = output, patternAsString = FALSE) #} @@ -171,7 +171,7 @@ lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, obs.freq=integer(0L), obs.prop=numeric(0L))) } # no support yet for mixture of endogenous ordered + numeric variables - if(!is.null(lavobject) && + if(!is.null(lavobject) && length(lavNames(lavobject, "ov.nox")) > length(cat.idx)) { warning("lavaan WARNING: some endogenous variables are not categorical") return(data.frame(pattern=character(0L), nobs=integer(0L), @@ -184,7 +184,7 @@ lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, statistic <- c("G2", "X2") } else { stopifnot(statistic %in% c("G2.un", "X2.un", "G2", "X2")) - } + } } else { # only data if(length(statistic) == 1L && statistic == "default") { @@ -242,7 +242,7 @@ lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, if(any(c("X2", "G2") %in% statistic)) { if(lavobject@Options$estimator %in% c("FML")) { # ok, nothing to say - } else if(lavobject@Options$estimator %in% + } else if(lavobject@Options$estimator %in% c("WLS","DWLS","PML","ULS")) { warning("lavaan WARNING: estimator ", lavobject@Options$estimator, " is not using full information while est.prop is using full information") @@ -264,7 +264,7 @@ lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, out$nobs) } } - + # remove nobs? # out$nobs <- NULL @@ -272,7 +272,7 @@ lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, } # pairwise tables, rows = table cells -lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, +lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, statistic = character(0L)) { # this only works if we have at least two 'categorical' variables @@ -308,7 +308,7 @@ lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, } # initial table, observed cell frequencies - out <- lav_tables_pairwise_freq_cell(lavdata = lavdata, + out <- lav_tables_pairwise_freq_cell(lavdata = lavdata, as.data.frame. = TRUE) out$obs.prop <- out$obs.freq/out$nobs if(any(c("cor.un", "th.un", "X2.un", "G2.un") %in% statistic)) { @@ -316,17 +316,17 @@ lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, lavdata = lavdata) out$est.prop.un <- unlist(PI) if("G2.un" %in% statistic) { - out$G2.un <- lav_tables_stat_G2(out$obs.prop, out$est.prop.un, + out$G2.un <- lav_tables_stat_G2(out$obs.prop, out$est.prop.un, out$nobs) } if("X2.un" %in% statistic) { - out$X2.un <- lav_tables_stat_X2(out$obs.prop, out$est.prop.un, + out$X2.un <- lav_tables_stat_X2(out$obs.prop, out$est.prop.un, out$nobs) } if("cor.un" %in% statistic) { COR <- attr(PI, "COR") - cor.all <- unlist(lapply(COR, function(x) + cor.all <- unlist(lapply(COR, function(x) x[lower.tri(x, diag=FALSE)])) out$cor.un <- cor.all[out$id] } @@ -335,7 +335,7 @@ lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, PI <- lav_tables_pairwise_model_pi(lavobject = lavobject) out$est.prop <- unlist(PI) if("G2" %in% statistic) { - out$G2 <- lav_tables_stat_G2(out$obs.prop, out$est.prop, + out$G2 <- lav_tables_stat_G2(out$obs.prop, out$est.prop, out$nobs) } if("X2" %in% statistic) { @@ -344,7 +344,7 @@ lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, } if("cor" %in% statistic) { COR <- attr(PI, "COR") - cor.all <- unlist(lapply(COR, function(x) + cor.all <- unlist(lapply(COR, function(x) x[lower.tri(x, diag=FALSE)])) out$cor <- cor.all[out$id] } @@ -409,7 +409,7 @@ lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, # pairwise tables #pairwise.tables <- utils::combn(vartable$name[cat.idx], m=2L) - #pairwise.tables <- rbind(seq_len(ncol(pairwise.tables)), + #pairwise.tables <- rbind(seq_len(ncol(pairwise.tables)), # pairwise.tables) #ntables <- ncol(pairwise.tables) @@ -472,7 +472,7 @@ lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, # X2 if("X2" %in% statistic) { - out$X2 <- tapply(out.cell$X2, INDEX=out.cell$id, FUN=sum, + out$X2 <- tapply(out.cell$X2, INDEX=out.cell$id, FUN=sum, na.rm=TRUE) if(p.value) { out$X2.pval <- pchisq(out$X2, df=out$df, lower.tail=FALSE) @@ -485,7 +485,7 @@ lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, out$X2.un.pval <- pchisq(out$X2.un, df=out$df, lower.tail=FALSE) } } - + # G2 if("G2" %in% statistic) { out$G2 <- tapply(out.cell$G2, INDEX=out.cell$id, FUN=sum, @@ -557,8 +557,8 @@ lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, if("X2.nlarge" %in% statistic) { out$X2.min <- rep(X2.min, length(out$lhs)) - out$X2.nlarge <- tapply(out.cell$X2, INDEX=out.cell$id, - FUN=function(x) sum(x > X2.min, na.rm=TRUE) ) + out$X2.nlarge <- tapply(out.cell$X2, INDEX=out.cell$id, + FUN=function(x) sum(x > X2.min, na.rm=TRUE) ) } if("X2.plarge" %in% statistic) { @@ -566,12 +566,12 @@ lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, out$X2.plarge <- tapply(out.cell$X2, INDEX=out.cell$id, FUN=function(x) sum(x > X2.min, na.rm=TRUE)/length(x) ) } - + out } -lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, +lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, statistic = NULL) { # shortcuts @@ -612,12 +612,12 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, list( id = rep.int(id, ncell), lhs = rep.int(vartable$name[idx], ncell), - # op = rep.int("freq", ncell), + # op = rep.int("freq", ncell), rhs = labels[[x]], group = rep.int(g, ncell), nobs = rep.int(sum(FREQ), ncell), obs.freq = FREQ, - obs.prop = FREQ/sum(FREQ) + obs.prop = FREQ/sum(FREQ) ) }) } @@ -632,7 +632,7 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, } } if(g == 1) { - # remove group column + # remove group column out$group <- NULL } @@ -641,7 +641,7 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, if(length(statistic) == 1L && statistic == "default") { statistic <- c("X2") } else { - stopifnot(statistic %in% c("th.un", + stopifnot(statistic %in% c("th.un", "th", "G2", "X2")) } @@ -650,9 +650,9 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, if("th.un" %in% statistic) { # sample based th <- unlist(lapply(1:lavdata@ngroups, function(x) { - TH <- lavobject@SampleStats@th[[x]][ + TH <- lavobject@SampleStats@th[[x]][ lavobject@SampleStats@th.idx[[x]] > 0 ] - TH.IDX <- lavobject@SampleStats@th.idx[[x]][ + TH.IDX <- lavobject@SampleStats@th.idx[[x]][ lavobject@SampleStats@th.idx[[x]] > 0 ] unname(unlist(tapply(TH, INDEX=TH.IDX, @@ -660,13 +660,13 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, # overwrite obs.prop # NOTE: if we have exogenous variables, obs.prop will NOT # correspond with qnorm(th) - out$obs.prop <- unname(unlist(tapply(th, INDEX=out$id, - FUN=function(x) (pnorm(c(x,Inf)) - + out$obs.prop <- unname(unlist(tapply(th, INDEX=out$id, + FUN=function(x) (pnorm(c(x,Inf)) - pnorm(c(-Inf,x)))[-(length(x)+1)] ))) out$th.un <- th } - + # model based if(any(c("th","G2","X2") %in% statistic)) { @@ -676,7 +676,7 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, TH <- lavobject@implied$res.th[[x]][ lavobject@SampleStats@th.idx[[x]] > 0 ] } else { - TH <- lavobject@implied$th[[x]][ + TH <- lavobject@implied$th[[x]][ lavobject@SampleStats@th.idx[[x]] > 0 ] } TH.IDX <- lavobject@SampleStats@th.idx[[x]][ @@ -684,11 +684,11 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, unname(unlist(tapply(TH, INDEX=TH.IDX, function(x) c(x,Inf)))) })) - est.prop <- unname(unlist(tapply(th.h0, INDEX=out$id, - FUN=function(x) (pnorm(c(x,Inf)) - + est.prop <- unname(unlist(tapply(th.h0, INDEX=out$id, + FUN=function(x) (pnorm(c(x,Inf)) - pnorm(c(-Inf,x)))[-(length(x)+1)] ))) out$est.prop <- est.prop - + if("th" %in% statistic) { out$th <- th.h0 } @@ -719,7 +719,7 @@ lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, } # compute pairwise (two-way) frequency tables -lav_tables_pairwise_freq_cell <- function(lavdata = NULL, +lav_tables_pairwise_freq_cell <- function(lavdata = NULL, as.data.frame. = TRUE) { # shortcuts @@ -750,7 +750,7 @@ lav_tables_pairwise_freq_cell <- function(lavdata = NULL, FUN=function(x) { idx1 <- which(vartable$name == x[1]) idx2 <- which(vartable$name == x[2]) - id <- (g-1)*ntables + as.numeric(x[3]) + id <- (g-1)*ntables + as.numeric(x[3]) nrow <- vartable$nlev[idx1] ncol <- vartable$nlev[idx2] ncell <- nrow*ncol @@ -760,10 +760,10 @@ lav_tables_pairwise_freq_cell <- function(lavdata = NULL, Y2 <- X[[g]][,idx2] # FREQ <- table(Y1, Y2) # we loose missings; useNA is ugly FREQ <- pc_freq(Y1, Y2) - + list( id = rep.int(id, ncell), - lhs = rep.int(x[1], ncell), - # op = rep.int("table", ncell), + lhs = rep.int(x[1], ncell), + # op = rep.int("table", ncell), rhs = rep.int(x[2], ncell), group = rep.int(g, ncell), nobs = rep.int(sum(FREQ), ncell), @@ -785,7 +785,7 @@ lav_tables_pairwise_freq_cell <- function(lavdata = NULL, } } if(g == 1) { - # remove group column + # remove group column out$group <- NULL } } else { @@ -832,7 +832,7 @@ lav_tables_pairwise_model_pi <- function(lavobject = NULL) { index.var.of.thres = th.idx[[g]], rho.xixj = cors) # get expected probability per table, per pair - PI[[g]] <- pairwiseExpProbVec(ind.vec = lavobject@Cache[[g]]$LONG, + PI[[g]] <- pairwiseExpProbVec(ind.vec = lavobject@Cache[[g]]$LONG, th.rho.vec=LONG2) } else { PI.group <- integer(0) @@ -856,7 +856,7 @@ lav_tables_pairwise_model_pi <- function(lavobject = NULL) { attr(PI, "COR") <- Sigma.hat attr(PI, "TH") <- TH attr(PI, "TH.IDX") <- th.idx - + PI } @@ -871,7 +871,7 @@ lav_tables_pairwise_sample_pi <- function(lavobject = NULL, lavdata = NULL) { if(lavobject@Model@conditional.x) { COR <- lavobject@SampleStats@res.cov TH <- lavobject@SampleStats@res.th - } else { + } else { COR <- lavobject@SampleStats@cov TH <- lavobject@SampleStats@th } @@ -895,7 +895,7 @@ lav_tables_pairwise_sample_pi <- function(lavobject = NULL, lavdata = NULL) { } # low-level function to compute expected proportions per cell -lav_tables_pairwise_sample_pi_cor <- function(COR = NULL, TH = NULL, +lav_tables_pairwise_sample_pi_cor <- function(COR = NULL, TH = NULL, TH.IDX = NULL) { ngroups <- length(COR) @@ -929,14 +929,14 @@ lav_tables_pairwise_sample_pi_cor <- function(COR = NULL, TH = NULL, } PI[[g]] <- PI.group } # g - + # add COR/TH/TH.IDX attr(PI, "COR") <- COR attr(PI, "TH") <- TH attr(PI, "TH.IDX") <- TH.IDX - + PI - + } # low-level function to compute expected proportions per PATTERN @@ -1003,7 +1003,7 @@ lav_tables_resp_pi <- function(lavobject = NULL, lavdata = NULL, npatterns <- nrow(PAT) freq <- as.numeric( rownames(PAT) ) PI.group <- numeric(npatterns) - TH.VAR <- lapply(1:nvar, + TH.VAR <- lapply(1:nvar, function(x) c(-Inf, TH[[g]][th.idx==x], +Inf)) # FIXME!!! ok to set diagonal to 1.0? diag(Sigmahat) <- 1.0 @@ -1017,18 +1017,18 @@ lav_tables_resp_pi <- function(lavobject = NULL, lavdata = NULL, lower <- lower[-na.idx] upper <- upper[-na.idx] MEAN.r <- MEAN[-na.idx] - Sigmahat.r <- Sigmahat[-na.idx, -na.idx, drop=FALSE] + Sigmahat.r <- Sigmahat[-na.idx, -na.idx, drop=FALSE] } else { MEAN.r <- MEAN Sigmahat.r <- Sigmahat } - PI.group[r] <- sadmvn(lower, upper, mean=MEAN.r, + PI.group[r] <- sadmvn(lower, upper, mean=MEAN.r, varcov=Sigmahat.r) } } else { # case-wise PI.group <- rep(as.numeric(NA), lavdata@nobs[[g]]) warning("lavaan WARNING: casewise PI not implemented") - } + } PI[[g]] <- PI.group } # g @@ -1055,7 +1055,7 @@ lav_tables_table_format <- function(out, lavdata = lavdata, } UNI <- NULL } else if(length(stat.idx) > 1) { - stop("lavaan ERROR: more than one statistic for table output: ", + stop("lavaan ERROR: more than one statistic for table output: ", paste(NAMES[stat.idx], collapse=" ")) } else { # univariate version of same statistic @@ -1086,11 +1086,11 @@ lav_tables_table_format <- function(out, lavdata = lavdata, } else { idx <- 1:length(UNI$lhs) } - if(NAMES[stat.idx] == "G2.average") { - diag(OUT[[g]]) <- tapply(UNI$G2[idx], INDEX=UNI$id[idx], + if(NAMES[stat.idx] == "G2.average") { + diag(OUT[[g]]) <- tapply(UNI$G2[idx], INDEX=UNI$id[idx], FUN=mean) } else if(NAMES[stat.idx] == "X2.average") { - diag(OUT[[g]]) <- tapply(UNI$X2[idx], INDEX=UNI$id[idx], + diag(OUT[[g]]) <- tapply(UNI$X2[idx], INDEX=UNI$id[idx], FUN=mean) } } else if(NAMES[stat.idx] %in% c("cor", "cor.un")) { @@ -1102,7 +1102,7 @@ lav_tables_table_format <- function(out, lavdata = lavdata, names(OUT) <- lavdata@group.label out <- OUT } else { - out <- OUT[[1]] + out <- OUT[[1]] } out @@ -1118,7 +1118,7 @@ lav_tables_cells_format <- function(out, lavdata = lavdata, # do we have a statistic? # determine column we need NAMES <- names(out) - stat.idx <- which(NAMES %in% c("cor", "cor.un", + stat.idx <- which(NAMES %in% c("cor", "cor.un", "G2", "G2.un", "X2", "X2.un", "RMSEA", "RMSEA.un", @@ -1144,7 +1144,7 @@ lav_tables_cells_format <- function(out, lavdata = lavdata, colnames(M) <- unique(Tx$col) class(M) <- c("lavaan.matrix", "matrix") M }) - names(TMP) <- unique(paste(out$lhs[case.idx], out$rhs[case.idx], + names(TMP) <- unique(paste(out$lhs[case.idx], out$rhs[case.idx], sep="_")) OUT[[g]] <- TMP } diff --git a/R/lav_tables_mvb.R b/R/lav_tables_mvb.R index 2ab7a6f4..6ed8fcc6 100644 --- a/R/lav_tables_mvb.R +++ b/R/lav_tables_mvb.R @@ -21,7 +21,7 @@ lav_tables_mvb_getPiDot <- function(PROP, order. = nitems) { IDX <- utils::combn(1:nitems, Order) tmp <- apply(IDX, 2L, function(idx) as.numeric(apply(PROP, idx, sum))[1L]) - tmp + tmp }) ) @@ -37,7 +37,7 @@ lav_tables_mvb_getT <- function(nitems = 3L, order. = nitems, rbind. = FALSE) { T.r <- lapply(1:order., function(Order) { IDX <- utils::combn(1:nitems, Order) TT <- matrix(0L, ncol(IDX), 2^nitems) - TT <- do.call("rbind", + TT <- do.call("rbind", lapply(1:ncol(IDX), function(i) { TRue <- as.list(rep(TRUE, nitems)); TRue[ IDX[,i] ] <- 1L ARGS <- c(list(INDEX), TRue) @@ -57,7 +57,7 @@ lav_tables_mvb_getT <- function(nitems = 3L, order. = nitems, rbind. = FALSE) { # simple test function to check that pidot = T %*% prop lav_tables_mvb_test <- function(nitems = 3L, verbose = FALSE) { - + freq <- sample( 5:50, 2^nitems, replace=TRUE) prop <- freq/sum(freq) TABLE <- array(freq, dim=rep(2, nitems)) @@ -78,14 +78,14 @@ lav_tables_mvb_test <- function(nitems = 3L, verbose = FALSE) { } # L_r test of Maydeu-Olivares & Joe (2005) eq (4) -lav_tables_mvb_Lr <- function(nitems = 0L, +lav_tables_mvb_Lr <- function(nitems = 0L, obs.prop = NULL, est.prop = NULL, nobs = 0L, order. = 2L) { # recreate tables obs.PROP <- array(obs.prop, dim = rep(2L, nitems)) est.PROP <- array(est.prop, dim = rep(2L, nitems)) - + # compute {obs,est}.prop.dot obs.prop.dot <- lav_tables_mvb_getPiDot(obs.PROP, order. = order.) est.prop.dot <- lav_tables_mvb_getPiDot(est.PROP, order. = order.) diff --git a/R/lav_test.R b/R/lav_test.R index 4803c408..740f7807 100644 --- a/R/lav_test.R +++ b/R/lav_test.R @@ -1,11 +1,11 @@ -lav_model_test <- function(lavmodel = NULL, - lavpartable = NULL, +lav_model_test <- function(lavmodel = NULL, + lavpartable = NULL, lavsamplestats = NULL, lavimplied = NULL, lavh1 = list(), - lavoptions = NULL, - x = NULL, - VCOV = NULL, + lavoptions = NULL, + x = NULL, + VCOV = NULL, lavcache = NULL, lavdata = NULL, lavloglik = NULL, @@ -25,7 +25,7 @@ lav_model_test <- function(lavmodel = NULL, # degrees of freedom df <- lav_partable_df(lavpartable) - # handle equality constraints (note: we ignore inequality constraints, + # handle equality constraints (note: we ignore inequality constraints, # active or not!) # we use the rank of con.jac (even if the constraints are nonlinear) if(nrow(lavmodel@con.jac) > 0L) { @@ -53,7 +53,7 @@ lav_model_test <- function(lavmodel = NULL, refdistr="unknown", pvalue=as.numeric(NA)) return(TEST) - } + } if(lavoptions$estimator == "PML" && test != "none") { PML <- ctr_pml_plrt(lavobject = NULL, @@ -74,7 +74,7 @@ lav_model_test <- function(lavmodel = NULL, } else { chisq.group <- rep(as.numeric(NA), lavdata@ngroups) } - + } else { # get fx.group fx <- attr(x, "fx") @@ -88,7 +88,7 @@ lav_model_test <- function(lavmodel = NULL, NFAC <- NFAC / 2 NFAC <- NFAC - 1 NFAC <- NFAC * 2 - } + } chisq.group <- fx.group * NFAC } @@ -126,17 +126,17 @@ lav_model_test <- function(lavmodel = NULL, } TEST[[1]] <- list(test="standard", - stat=chisq, - stat.group=chisq.group, + stat=chisq, + stat.group=chisq.group, df=df, refdistr=refdistr, - pvalue=pvalue) + pvalue=pvalue) if(df == 0 && test %in% c("satorra.bentler", "yuan.bentler", "yuan.bentler.mplus", "mean.var.adjusted", "scaled.shifted")) { TEST[[2]] <- list(test=test, stat=chisq, stat.group=chisq.group, - df=df, refdistr=refdistr, pvalue=pvalue, + df=df, refdistr=refdistr, pvalue=pvalue, scaling.factor=as.numeric(NA)) return(TEST) } @@ -184,10 +184,10 @@ lav_model_test <- function(lavmodel = NULL, } else { warning("test option ", test, " not available for estimator PML") } - } else if(test %in% + } else if(test %in% c("satorra.bentler", "mean.var.adjusted", "scaled.shifted") && df > 0 && lavoptions$estimator != "PML") { - + out <- lav_test_satorra_bentler(lavobject = NULL, lavsamplestats = lavsamplestats, lavmodel = lavmodel, @@ -204,7 +204,7 @@ lav_model_test <- function(lavmodel = NULL, method = "ABA", return.ugamma = FALSE) TEST[[2]] <- out[[test]] - + } else if(test %in% c("yuan.bentler", "yuan.bentler.mplus") && df > 0 && lavoptions$estimator != "PML") { @@ -234,14 +234,14 @@ lav_model_test <- function(lavmodel = NULL, R <- 1000L } boot.type <- "bollen.stine" - BOOT.TEST <- + BOOT.TEST <- bootstrap.internal(object = NULL, - lavmodel. = lavmodel, - lavsamplestats. = lavsamplestats, + lavmodel. = lavmodel, + lavsamplestats. = lavsamplestats, lavpartable. = lavpartable, - lavoptions. = lavoptions, + lavoptions. = lavoptions, lavdata. = lavdata, - R = R, + R = R, verbose = lavoptions$verbose, type = boot.type, FUN = "test", diff --git a/R/lav_test_LRT.R b/R/lav_test_LRT.R index da3d662a..df9e7df2 100644 --- a/R/lav_test_LRT.R +++ b/R/lav_test_LRT.R @@ -24,7 +24,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", mcall <- match.call(expand.dots = TRUE) dots <- list(...) - + modp <- if(length(dots)) sapply(dots, is, "lavaan") else logical(0) @@ -65,7 +65,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", if(!is.null(model.names)) { names(mods) <- model.names } else { - names(mods) <- sapply(as.list(mcall)[which(c(FALSE, TRUE, modp))], + names(mods) <- sapply(as.list(mcall)[which(c(FALSE, TRUE, modp))], deparse) } @@ -79,7 +79,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", #} # put them in order (using degrees of freedom) - ndf <- sapply(mods, function(x) x@test[[1]]$df) + ndf <- sapply(mods, function(x) x@test[[1]]$df) mods <- mods[order(ndf)] # here come the checks @@ -96,12 +96,12 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", # stop("lavaan ERROR: models must be fit to the same data") #} # 2. nested models? *different* npars? - + # TODO! - + # 3. all meanstructure? mean.structure <- sapply(mods, inspect, "meanstructure") - if(sum(mean.structure) > 0L && + if(sum(mean.structure) > 0L && sum(mean.structure) < length(mean.structure)) { warning("lavaan WARNING: not all models have a meanstructure") } @@ -109,7 +109,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", mods.scaled <- unlist( lapply(mods, function(x) { any(c("satorra.bentler", "yuan.bentler", "yuan.bentler.mplus", - "mean.var.adjusted", "scaled.shifted") %in% + "mean.var.adjusted", "scaled.shifted") %in% unlist(sapply(slot(x, "test"), "[", "test")) ) })) if(all(mods.scaled)) { @@ -124,8 +124,8 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", } # which models have used a MEANSTRUCTURE? - mods.meanstructure <- sapply(mods, function(x) { - unlist(slot(slot(x, "Model"), + mods.meanstructure <- sapply(mods, function(x) { + unlist(slot(slot(x, "Model"), "meanstructure"))}) if(all(mods.meanstructure)) { meanstructure <- "ok" @@ -143,7 +143,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", } else { stop("lavaan ERROR: test type unknown: ", type) } - + if(type == "chisq") { STAT <- sapply(mods, function(x) slot(x, "test")[[1]]$stat) @@ -156,9 +156,9 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", } # difference statistics - STAT.delta <- c(NA, diff(STAT)) + STAT.delta <- c(NA, diff(STAT)) Df.delta <- c(NA, diff(Df)) - + # correction for scaled test statistics if(type == "chisq" && scaled) { @@ -207,7 +207,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", } } else if(method == "satorra.2000") { for(m in seq_len(length(mods) - 1L)) { - if(TEST %in% c("satorra.bentler", "yuan.bentler", + if(TEST %in% c("satorra.bentler", "yuan.bentler", "yuan.bentler.mplus")) { Satterthwaite <- FALSE } else { @@ -255,7 +255,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", "Chisq diff" = STAT.delta, "Df diff" = Df.delta, "Pr(>Chisq)" = Pvalue.delta, - row.names = names(mods), + row.names = names(mods), check.names = FALSE) } @@ -278,7 +278,7 @@ lavTestLRT <- function(object, ..., method = "default", A.method = "delta", if(type == "chisq") { if(scaled) { - attr(val, "heading") <- + attr(val, "heading") <- paste("Scaled Chi Square Difference Test (method = \"", method, "\")\n", sep="") } else { diff --git a/R/lav_test_Wald.R b/R/lav_test_Wald.R index b1f0a522..fc05e4fe 100644 --- a/R/lav_test_Wald.R +++ b/R/lav_test_Wald.R @@ -61,13 +61,13 @@ lavTestWald <- function(object, constraints = NULL, verbose = FALSE) { # avoid S4 dispatch VCOV <- lav_object_inspect_vcov(object, standardized = FALSE, free.only = TRUE, - add.labels = FALSE, + add.labels = FALSE, add.class = FALSE, remove.duplicated = FALSE) # restricted vcov info.r <- JAC %*% VCOV %*% t(JAC) - + # Wald test statistic Wald <- as.numeric(t(theta.r) %*% solve( info.r ) %*% theta.r) diff --git a/R/lav_test_diff.R b/R/lav_test_diff.R index 7c2dac91..d3ce239d 100644 --- a/R/lav_test_diff.R +++ b/R/lav_test_diff.R @@ -19,7 +19,7 @@ lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", # m = difference between the df's m <- r0 - r1 - + Gamma <- lavTech(m1, "Gamma") # the same for m1 and m0 # check for NULL if(is.null(Gamma)) { @@ -34,7 +34,7 @@ lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", P.inv <- lav_model_information_augment_invert(m1@Model, information = P, inverted = TRUE) - # compute 'A' matrix + # compute 'A' matrix # NOTE: order of parameters may change between H1 and H0, so be # careful! if(is.null(A)) { @@ -56,7 +56,7 @@ lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", information = P, inverted = TRUE) - # compute 'A' matrix + # compute 'A' matrix # NOTE: order of parameters may change between H1 and H0, so be # careful! if(is.null(A)) { @@ -80,7 +80,7 @@ lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", APA <- A %*% P.inv %*% t(A) cSums <- colSums(APA) rSums <- rowSums(APA) - empty.idx <- which( abs(cSums) < .Machine$double.eps^0.5 & + empty.idx <- which( abs(cSums) < .Machine$double.eps^0.5 & abs(rSums) < .Machine$double.eps^0.5 ) if(length(empty.idx) > 0) { A <- A[-empty.idx,, drop = FALSE] @@ -127,12 +127,12 @@ lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", a <- as.numeric(NA); b <- as.numeric(NA) } - list(T.delta = T.delta, scaling.factor = cd, df.delta = df.delta, + list(T.delta = T.delta, scaling.factor = cd, df.delta = df.delta, a = a, b = b) } lav_test_diff_SatorraBentler2001 <- function(m1, m0) { - + # extract information from m1 and m2 T1 <- m1@test[[1]]$stat r1 <- m1@test[[1]]$df @@ -157,7 +157,7 @@ lav_test_diff_SatorraBentler2001 <- function(m1, m0) { cd <- as.numeric(NA) } - # compute scaled difference test + # compute scaled difference test T.delta <- (T0 - T1)/cd list(T.delta = T.delta, scaling.factor = cd, df.delta = m) @@ -191,7 +191,7 @@ lav_test_diff_SatorraBentler2010 <- function(m1, m0, H1 = FALSE) { M01 <- lav_test_diff_m10(m0, m1, test = TRUE) c01 <- M01@test[[2]]$scaling.factor - # check if vcov is positive definite (new in 0.6) + # check if vcov is positive definite (new in 0.6) # if not, we may get negative values eigvals <- eigen(lavTech(M10, "information"), symmetric=TRUE, only.values=TRUE)$values @@ -211,7 +211,7 @@ lav_test_diff_SatorraBentler2010 <- function(m1, m0, H1 = FALSE) { M10 <- lav_test_diff_m10(m1, m0, test = TRUE) c10 <- M10@test[[2]]$scaling.factor - # check if vcov is positive definite (new in 0.6) + # check if vcov is positive definite (new in 0.6) # if not, we may get negative values eigvals <- eigen(lavTech(M10, "information"), symmetric=TRUE, only.values=TRUE)$values @@ -229,11 +229,11 @@ lav_test_diff_SatorraBentler2010 <- function(m1, m0, H1 = FALSE) { # compute scaled difference test T.delta <- (T0 - T1)/cd - list(T.delta = T.delta, scaling.factor = cd, df.delta = m, + list(T.delta = T.delta, scaling.factor = cd, df.delta = m, T.delta.unscaled = (T0 - T1)) } -# create a new model 'm10', where we use model 'm1', but we +# create a new model 'm10', where we use model 'm1', but we # inject it with the values of 'm0' lav_test_diff_m10 <- function(m1, m0, test = FALSE) { @@ -250,7 +250,7 @@ lav_test_diff_m10 <- function(m1, m0, test = FALSE) { PT.M1 <- m1@ParTable # `extend' PT.M1 partable to include all `fixed-to-zero parameters' - PT.M1.FULL <- lav_partable_full(partable = PT.M1, lavpta = m1@pta, + PT.M1.FULL <- lav_partable_full(partable = PT.M1, lavpta = m1@pta, free = TRUE, start = TRUE) PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL, remove.duplicated = TRUE, warn = FALSE) @@ -287,7 +287,7 @@ lav_test_diff_m10 <- function(m1, m0, test = FALSE) { # compute the `A' matrix: the jacobian of the constraint function a(\delta) # (see Satorra 2000) # -# +# # lav_test_diff_A <- function(m1, m0, method = "delta", reference = "H1") { @@ -327,7 +327,7 @@ lav_test_diff_A <- function(m1, m0, method = "delta", reference = "H1") { H <- MASS::ginv(Delta1) %*% Delta0 A <- t(lav_matrix_orthogonal_complement(H)) } - + A } @@ -372,15 +372,15 @@ lav_test_diff_af_h1 <- function(m1, m0) { # change 'free' order in m0 # NOTE: this only works all the free parameters in h0 are also free # in h1 (and if not, they will become fixed in h0) - PT.M0.part1$free[p0.free.idx] <- + PT.M0.part1$free[p0.free.idx] <- PT.M1.part1$free[ PT.M0.part1$id[p1.id][p0.free.idx] ] # paste back PT.M0 <- rbind(PT.M0.part1, PT.M0.part2) PT.M1 <- rbind(PT.M1.part1, PT.M1.part2) - + # `extend' PT.M1 partable to include all `fixed-to-zero parameters' - PT.M1.FULL <- lav_partable_full(partable = PT.M1, lavpta = m1@pta, + PT.M1.FULL <- lav_partable_full(partable = PT.M1, lavpta = m1@pta, free = TRUE, start = TRUE) PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL, remove.duplicated = TRUE, warn = FALSE) @@ -443,7 +443,7 @@ lav_test_diff_af_h1 <- function(m1, m0) { DEFCON.txt <- lav_partable_constraints_ceq(P0, txtOnly=TRUE) BODY.txt <- paste(BODY.txt, DEFCON.txt, "\n", sep="") - + # for each parameter in p1, we 'check' is it is fixed to a constant in p0 ncon <- length( which(P0$op == "==") ) for(i in seq_len(np1)) { @@ -457,7 +457,7 @@ lav_test_diff_af_h1 <- function(m1, m0) { p0.idx <- which(p0$lhs == lhs & p0$op == op & p0$rhs == rhs & p0$group == group) if(length(p0.idx) == 0L) { - stop("lavaan ERROR: parameter in H1 not found in H0: ", + stop("lavaan ERROR: parameter in H1 not found in H0: ", paste(lhs, op, rhs, "(group = ", group, ")", sep=" ")) } @@ -467,7 +467,7 @@ lav_test_diff_af_h1 <- function(m1, m0) { # match, nothing to do } else { warning("lavaan WARNING: fixed parameter in H1 is free in H0: ", - paste("\"", lhs, " ", op, " ", rhs, + paste("\"", lhs, " ", op, " ", rhs, "\" (group = ", group, ")", sep="")) } } else { diff --git a/R/lav_test_satorra_bentler.R b/R/lav_test_satorra_bentler.R index 70513ecf..d2f76733 100644 --- a/R/lav_test_satorra_bentler.R +++ b/R/lav_test_satorra_bentler.R @@ -44,7 +44,7 @@ lav_test_satorra_bentler <- function(lavobject = NULL, # check method if(method == "default") { method <- "ABA" - } else if(!all(method %in% c("original", "orthogonal.complement", + } else if(!all(method %in% c("original", "orthogonal.complement", "ABA"))) { warning("lavaan WARNING: method must be one of `original', `ABA', `orthogonal.complement'; will use `original'") method <- "ABA" @@ -57,7 +57,7 @@ lav_test_satorra_bentler <- function(lavobject = NULL, augmented = FALSE, inverted = FALSE, lavsamplestats=lavsamplestats, extra = TRUE) } else { - E <- lav_model_information(lavmodel = lavmodel, + E <- lav_model_information(lavmodel = lavmodel, lavimplied = lavimplied, lavsamplestats = lavsamplestats, lavdata = lavdata, lavoptions = lavoptions, extra = TRUE) @@ -99,8 +99,8 @@ lav_test_satorra_bentler <- function(lavobject = NULL, if(method == "original") { out <- lav_test_satorra_bentler_trace_original(Gamma = Gamma, - Delta = Delta, WLS.V = WLS.V, E.inv = E.inv, - ngroups = ngroups, nobs = lavsamplestats@nobs, + Delta = Delta, WLS.V = WLS.V, E.inv = E.inv, + ngroups = ngroups, nobs = lavsamplestats@nobs, ntotal = lavsamplestats@ntotal, return.u = return.u, return.ugamma = return.ugamma, Satterthwaite = Satterthwaite) @@ -204,7 +204,7 @@ lav_test_satorra_bentler <- function(lavobject = NULL, # scaled test statistic global stat <- sum(stat.group) - + TEST$scaled.shifted <- list(test = "scaled.shifted", stat = stat, @@ -240,7 +240,7 @@ lav_test_satorra_bentler_trace_original <- function(Gamma = NULL, return.u = FALSE, return.ugamma = FALSE, Satterthwaite = FALSE) { - + # trace of UGamma per group trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups) @@ -260,8 +260,8 @@ lav_test_satorra_bentler_trace_original <- function(Gamma = NULL, WLS.Vg <- diag(WLS.Vg) } - U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*% - t(Delta[[g]]) %*% WLS.Vg) + U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*% + t(Delta[[g]]) %*% WLS.Vg) trace.UGamma[g] <- sum(U * Gamma.g) if(return.u) { @@ -279,7 +279,7 @@ lav_test_satorra_bentler_trace_original <- function(Gamma = NULL, trace.UGamma <- sum(trace.UGamma) trace.UGamma2 <- sum(trace.UGamma2) - list(trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, + list(trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, UGamma = UG, UfromUGamma = UfromUGamma) } @@ -352,7 +352,7 @@ lav_test_satorra_bentler_trace_complement <- function(Gamma = NULL, # # = A1.inv %*% AGA1 - # A1.inv %*% AGA1 %*% Delta %*% E.inv %*% tDelta %*% A1 -# +# # if only the trace is needed, we can use reduce the rhs (after the minus) # to AGA1 %*% Delta %*% E.inv %*% tDelta (eliminating A1 and A1.inv) @@ -391,10 +391,10 @@ lav_test_satorra_bentler_trace_ABA <- function(Gamma = NULL, # note: we have AGA1 at the end, to avoid ending up with # a transposed matrix (both parts are non-symmetric) if(diagonal) { - UG <- t(Gamma.g * a1) - + UG <- t(Gamma.g * a1) - (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) } else { - UG <- (Gamma.g %*% A1) - + UG <- (Gamma.g %*% A1) - (Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) } diff --git a/R/lav_test_score.R b/R/lav_test_score.R index 4a90990d..11848068 100644 --- a/R/lav_test_score.R +++ b/R/lav_test_score.R @@ -1,7 +1,7 @@ # classic score test (= Lagrange Multiplier test) # # this function can run in two modes: -# +# # MODE 1: 'add' # add new parameters that are currently not included in de model # (aka fixed to zero), but should be released @@ -42,7 +42,7 @@ lavTestScore <- function(object, add = NULL, release = NULL, # extend model with extra set of parameters FIT <- lav_object_extended(object, add = add) - + score <- lavTech(FIT, "gradient.logl") information <- lavTech(FIT, "information.expected") @@ -85,7 +85,7 @@ lavTestScore <- function(object, add = NULL, release = NULL, score <- lavTech(object, "gradient.logl") information <- lavTech(object, "information.expected") - J.inv <- MASS::ginv(information) #FIXME: move into if(is.null(release))? + J.inv <- MASS::ginv(information) #FIXME: move into if(is.null(release))? # else written over with Z1.plus if(is.numeric(release)) #R <- object@Model@con.jac[,] @@ -126,7 +126,7 @@ lavTestScore <- function(object, add = NULL, release = NULL, N <- N - 1 } } else { - # total number of clusters (over groups) + # total number of clusters (over groups) N <- 0 for(g in 1:object@SampleStats@ngroups) { N <- N + object@Data@Lp[[g]]$nclusters[[2]] @@ -134,7 +134,7 @@ lavTestScore <- function(object, add = NULL, release = NULL, #score <- score * (2 * object@SampleStats@ntotal) / N score <- score / 2 # -2 * LRT } - + if(lavoptions$se == "standard") { stat <- as.numeric(N * score %*% J.inv %*% score) } else { @@ -142,18 +142,18 @@ lavTestScore <- function(object, add = NULL, release = NULL, if(warn) { warning("lavaan WARNING: se is not `standard'; 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 + + #df <- qr(R[r.idx,,drop = FALSE])$rank + # ( qr(information)$rank - qr(information.plus)$rank ) df <- nrow( R[r.idx,,drop = FALSE] ) pvalue <- 1 - pchisq(stat, df=df) @@ -163,7 +163,7 @@ lavTestScore <- function(object, add = NULL, release = NULL, class(TEST) <- c("lavaan.data.frame", "data.frame") attr(TEST, "header") <- "total score test:" - OUT <- list(test = TEST) + OUT <- list(test = TEST) if(univariate) { TS <- numeric( nrow(R) ) diff --git a/R/lav_test_yuan_bentler.R b/R/lav_test_yuan_bentler.R index 3365229c..fe1b365d 100644 --- a/R/lav_test_yuan_bentler.R +++ b/R/lav_test_yuan_bentler.R @@ -43,9 +43,9 @@ lav_test_yuan_bentler <- function(lavobject = NULL, } else { x.idx <- lavsamplestats@x.idx } - # ndat + # ndat ndat <- numeric(lavsamplestats@ngroups) - + if(is.null(E.inv)) { E.inv <- try(lav_model_information(lavmodel = lavmodel, @@ -74,7 +74,7 @@ lav_test_yuan_bentler <- function(lavobject = NULL, #} # FIXME: should we not always use 'unstructured' here? - # if the model is, say, the independence model, the + # if the model is, say, the independence model, the # 'structured' information (A1) will be so far away from B1 # that we will end with 'NA' h1.options <- lavoptions @@ -111,7 +111,7 @@ lav_test_yuan_bentler <- function(lavobject = NULL, inverted = FALSE) B0.group <- attr(B0, "B0.group") } - trace.UGamma <- + trace.UGamma <- lav_test_yuan_bentler_mplus_trace(lavsamplestats = lavsamplestats, A1.group = A1.group, B1.group = B1.group, @@ -133,7 +133,7 @@ lav_test_yuan_bentler <- function(lavobject = NULL, Satterthwaite = TRUE) # for now } - # unscaled test + # unscaled test df <- TEST$standard$df chisq.group <- TEST$standard$stat.group @@ -151,7 +151,7 @@ lav_test_yuan_bentler <- function(lavobject = NULL, attributes(trace.UGamma) <- NULL if("yuan.bentler" %in% test) { - TEST$yuan.bentler <- + TEST$yuan.bentler <- list(test = test, stat = chisq.scaled, stat.group = (chisq.group / scaling.factor), @@ -235,7 +235,7 @@ lav_test_yuan_bentler_trace <- function(lavsamplestats =lavsamplestats, } trace.h1[g] <- sum( B1 * t( A1.inv ) ) - # fg cancels out: trace.h1[g] <- sum( fg*B1 * t( 1/fg*A1.inv ) ) + # fg cancels out: trace.h1[g] <- sum( fg*B1 * t( 1/fg*A1.inv ) ) trace.h0[g] <- fg * sum( B1 * DELTA %*% E.inv %*% t(DELTA) ) trace.UGamma[g] <- trace.h1[g] - trace.h0[g] diff --git a/R/lav_utils.R b/R/lav_utils.R index f9c5e3d6..5e215199 100644 --- a/R/lav_utils.R +++ b/R/lav_utils.R @@ -31,16 +31,16 @@ inv.chol <- function(S, logdet=FALSE) { cor2cov <- function(R, sds, names=NULL) { p <- (d <- dim(R))[1L] - if(!is.numeric(R) || length(d) != 2L || p != d[2L]) + if(!is.numeric(R) || length(d) != 2L || p != d[2L]) stop("'V' is not a square numeric matrix") - if(any(!is.finite(sds))) + if(any(!is.finite(sds))) warning("sds had 0 or NA entries; non-finite result is doubtful") - #if(sum(diag(R)) != p) + #if(sum(diag(R)) != p) # stop("The diagonal of a correlation matrix should be all ones.") - if(p != length(sds)) + if(p != length(sds)) stop("The standard deviation vector and correlation matrix have a different number of variables") S <- R @@ -53,7 +53,7 @@ cor2cov <- function(R, sds, names=NULL) { } S -} +} # convert characters within single quotes to numeric vector # eg. s <- '3 4.3 8e-3 2.0' @@ -64,7 +64,7 @@ char2num <- function(s = '') { tc <- textConnection(s.) x <- scan(tc, quiet=TRUE) close(tc) - x + x } # create full matrix based on lower.tri or upper.tri elements; add names @@ -75,7 +75,7 @@ getCov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL, # check x and sds if(is.character(x)) x <- char2num(x) if(is.character(sds)) sds <- char2num(sds) - + nels <- length(x) if(lower) { COV <- lav_matrix_lower2full(x, diagonal = diagonal) @@ -113,7 +113,7 @@ rowcol2vec <- function(row.idx, col.idx, nrow, symmetric=FALSE) { } # dummy function to 'pretty' print a vector with fixed width -pprint.vector <- function(x, +pprint.vector <- function(x, digits.after.period=3, ncols=NULL, max.col.width=11, newline=TRUE) { @@ -147,7 +147,7 @@ pprint.vector <- function(x, for(nc in 1:rest) { vname <- substr(var.names[(nr-1)*ncols + nc], 1, max.col.width) cat(sprintf(string.format, vname)) - } + } cat("\n") for(nc in 1:rest) { cat(sprintf(number.format, x[(nr-1)*ncols + nc])) @@ -159,7 +159,7 @@ pprint.vector <- function(x, } # print only lower half of symmetric matrix -pprint.matrix.symm <- function(x, +pprint.matrix.symm <- function(x, digits.after.period=3, ncols=NULL, max.col.width=11, newline=TRUE) { @@ -170,7 +170,7 @@ pprint.matrix.symm <- function(x, total.width = getOption("width") - max.width <- max(nchar(var.names)) + max.width <- max(nchar(var.names)) if( max.width < max.col.width) { # shrink max.col.width <- max( max.width, digits.after.period+2) } @@ -198,7 +198,7 @@ pprint.matrix.symm <- function(x, for(nc in 1:rest) { vname <- substr(var.names[(nb-1)*ncols + nc], 1, max.col.width) cat(sprintf(string.format, vname)) - } + } cat("\n") row.start <- (nb-1)*ncols + 1 for(nr in row.start:nrow) { @@ -220,7 +220,7 @@ pprint.matrix.symm <- function(x, # elimination of rows/cols symmetric matrix eliminate.rowcols <- function(x, el.idx=integer(0)) { - if(length(el.idx) == 0) { + if(length(el.idx) == 0) { return( x ) } stopifnot(ncol(x) == nrow(x)) @@ -233,16 +233,16 @@ eliminate.rowcols <- function(x, el.idx=integer(0)) { # # type = "all" -> only remove var(el.idx) and cov(el.idx) # type = "any" -> remove all rows/cols of el.idx -eliminate.pstar.idx <- function(nvar=1, el.idx=integer(0), +eliminate.pstar.idx <- function(nvar=1, el.idx=integer(0), meanstructure=FALSE, type="all") { if(length(el.idx) > 0) { stopifnot(min(el.idx) > 0 && max(el.idx) <= nvar) } - + XX <- utils::combn(1:(nvar+1),2) XX[2,] <- XX[2,] - 1 - + if(type == "all") { idx <- !(apply(apply(XX, 2, function(x) {x %in% el.idx}), 2, all)) } else { @@ -252,7 +252,7 @@ eliminate.pstar.idx <- function(nvar=1, el.idx=integer(0), if(meanstructure) { idx <- c(!(1:nvar %in% el.idx), idx) #idx <- c(rep(TRUE, nvar), idx) - + } idx @@ -278,7 +278,7 @@ augmented.covariance <- function(S., mean) { out[p+1,1:p] <- t(m) out[1:p,p+1] <- m out[p+1,p+1] <- 1 - + out } @@ -367,7 +367,7 @@ steepest.descent <- function(start, objective, gradient, iter.max, verbose) { alpha <- optimize(f.alpha, lower=-1, upper=0.0)$minimum } } - + # steepest descent step old.x <- x @@ -385,7 +385,7 @@ steepest.descent <- function(start, objective, gradient, iter.max, verbose) { norm.gx <- sqrt(gx %*% gx) if(verbose) { cat(sprintf("%4d %11.7E %10.7f %10.7f %11.5E %11.5E", - iter, fx.new, abs.change, rel.change, alpha, norm.gx), + iter, fx.new, abs.change, rel.change, alpha, norm.gx), "\n") } } diff --git a/R/lavaan-deprecated.R b/R/lavaan-deprecated.R index 128d6608..232cb891 100644 --- a/R/lavaan-deprecated.R +++ b/R/lavaan-deprecated.R @@ -54,7 +54,7 @@ upper2full <- function(x, diagonal = TRUE) { duplicationMatrix <- function(n = 1L) { .Deprecated("lav_matrix_duplication", package = "lavaan") - lav_matrix_duplication(n = n) + lav_matrix_duplication(n = n) } commutationMatrix <- function(m = 1L, n = 1L) { diff --git a/R/xxx_fsr.R b/R/xxx_fsr.R index 006d434d..539a016e 100644 --- a/R/xxx_fsr.R +++ b/R/xxx_fsr.R @@ -9,8 +9,8 @@ # TODO # - Hishino & Bentler: this is simple + WLS -fsr <- function(model = NULL, - data = NULL, +fsr <- function(model = NULL, + data = NULL, cmd = "sem", fsr.method = "Croon", fs.method = "Bartlett", @@ -21,7 +21,7 @@ fsr <- function(model = NULL, mm.list = NULL, ..., output = "fsr") { - + # we need full data if(is.null(data)) { stop("lavaan ERROR: full data is required for factor score regression") @@ -58,7 +58,7 @@ fsr <- function(model = NULL, if(output %in% c("scores", "fs.scores", "fsr.scores")) { fs.scores <- TRUE } - + # dot dot dot dotdotdot <- list(...) @@ -87,8 +87,8 @@ fsr <- function(model = NULL, # TODO # initial processing of the model, no fitting - FIT <- do.call(cmd, - args = c(list(model = model, + FIT <- do.call(cmd, + args = c(list(model = model, data = data, #meanstructure = TRUE, do.fit = FALSE), dotdotdot0) ) @@ -174,7 +174,7 @@ fsr <- function(model = NULL, # check each measurement block for(b in seq_len(nblocks)) { if(!all(mm.list[[b]] %in% lv.names)) { - stop("lavaan ERROR: mm.list contains unknown latent variable(s):", + stop("lavaan ERROR: mm.list contains unknown latent variable(s):", paste( mm.list[[b]][ mm.list[[b]] %in% lv.names ], sep = " "), "\n") } @@ -187,7 +187,7 @@ fsr <- function(model = NULL, mm.list <- as.list(lv.names) nblocks <- length(mm.list) } - + # compute factor scores, per latent variable FS.SCORES <- vector("list", length = ngroups) LVINFO <- vector("list", length = ngroups) @@ -211,13 +211,13 @@ fsr <- function(model = NULL, # override with mm.options dotdotdot2 <- modifyList(dotdotdot2, mm.options) - + # we assume the same number/names of lv's per group!!! MM.FIT <- vector("list", nblocks) for(b in 1:nblocks) { # create parameter table for this measurement block only - PT.block <- + PT.block <- lav_partable_subset_measurement_model(PT = PT, lavpta = lavpta, add.lv.cov = TRUE, @@ -240,7 +240,7 @@ fsr <- function(model = NULL, # compute factor scores if(fsr.method %in% c("croon", "simple") || - lavoptions$se == "robust.sem") { + lavoptions$se == "robust.sem") { # we use lavPredict() here to remove unwanted dummy lv's, if any SC <- lavPredict(fit.block, method = fs.method, fsm = TRUE) FSM <- attr(SC, "fsm"); attr(SC, "fsm") <- NULL @@ -255,13 +255,13 @@ fsr <- function(model = NULL, # because lavPredict() drops the list SC <- list(SC) } - + # store results for(g in 1:ngroups) { FS.SCORES[[g]][[b]] <- SC[[g]] if(fsr.method %in% c("croon", "simple")) { - LVINFO[[g]][[b]] <- list(fsm = FSM[[g]], + LVINFO[[g]][[b]] <- list(fsm = FSM[[g]], lambda = LAMBDA[[g]], psi = PSI[[g]], theta = THETA[[g]]) @@ -302,10 +302,10 @@ fsr <- function(model = NULL, mm.list = mm.list, force.pd = FALSE) } else { - FSR.COV <- FS.COV + FSR.COV <- FS.COV } - + # STEP 1c: do we need full set of factor scores? if(fs.scores) { @@ -325,7 +325,7 @@ fsr <- function(model = NULL, # unlist if multiple groups, add group column if(ngroups == 1L) { - FS.SCORES <- as.data.frame(FS.SCORES[[1]]) + FS.SCORES <- as.data.frame(FS.SCORES[[1]]) } else { stop("fix this!") } @@ -401,7 +401,7 @@ fsr <- function(model = NULL, } Omega.y <- lav_matrix_symmetric_inverse(Info) } else { - stop("lavaan ERROR: can not handle missing = ", + stop("lavaan ERROR: can not handle missing = ", lavoptions$missing) } @@ -420,7 +420,7 @@ fsr <- function(model = NULL, Mu = MU, Sigma = SIGMA, information = lavoptions$information) } else { - stop("lavaan ERROR: can not handle missing = ", + stop("lavaan ERROR: can not handle missing = ", lavoptions$missing) } } @@ -461,15 +461,15 @@ fsr <- function(model = NULL, #lavoptions2$se <- "none" #lavoptions2$test <- "none" lavoptions2$missing <- "listwise" # always complete data anyway... - fit <- lavaan(PT.PA, - sample.cov = FSR.COV, + fit <- lavaan(PT.PA, + sample.cov = FSR.COV, sample.mean = FS.MEAN, sample.nobs = FIT@SampleStats@nobs, NACOV = Omega.f, slotOptions = lavoptions2) # extra info - extra <- list( FS.COV = FS.COV, FS.SCORES = FS.SCORES, + extra <- list( FS.COV = FS.COV, FS.SCORES = FS.SCORES, FSR.COV = FSR.COV, LVINFO = LVINFO) @@ -488,7 +488,7 @@ fsr <- function(model = NULL, # PE$pvalue <- 2 * (1 - pnorm( abs(PE$z) )) # } #} - + if(output == "fsr") { #PE <- parameterEstimates(fit, add.attributes = TRUE, ci = FALSE) HEADER <- paste("This is fsr (0.2) -- factor score regression using ", @@ -508,14 +508,14 @@ fsr <- function(model = NULL, out <- LVINFO } else if(output %in% c("scores", "f.scores", "fs.scores")) { out <- FS.SCORES - } else if(output %in% c("FSR.COV", "fsr.cov", "croon", "cov.croon", + } else if(output %in% c("FSR.COV", "fsr.cov", "croon", "cov.croon", "croon.cov", "COV", "cov")) { out <- FSR.COV } else if(output %in% c("FS.COV", "fs.cov")) { out <- FS.COV } else { stop("lavaan ERROR: unknown output= argument: ", output) - } + } out } diff --git a/R/xxx_lavaan.R b/R/xxx_lavaan.R index 0f07f08b..6a7c200f 100644 --- a/R/xxx_lavaan.R +++ b/R/xxx_lavaan.R @@ -220,7 +220,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... stop("lavaan ERROR: when data is clustered, you must specify a model\n", " for each level in the model syntax (for now); see example(Demo.twolevel)") } - tmp.lav <- lavaanify(FLAT, ngroups = tmp.ngroups, warn = FALSE) + tmp.lav <- lavaanify(FLAT, ngroups = tmp.ngroups, warn = FALSE) # check for empty levels if(max(tmp.lav$level) < 2L) { stop("lavaan ERROR: at least one level has no model syntax; you must specify a model for each level in the model syntax (for now); see example(Demo.twolevel)") @@ -231,7 +231,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... ov.names.l[[g]] <- vector("list", length = tmp.nlevels) for(l in seq_len(tmp.nlevels)) { if(tmp.ngroups > 1L) { - ov.names.l[[g]][[l]] <- + ov.names.l[[g]][[l]] <- unique(unlist(lav_partable_vnames(tmp.lav, type = "ov", group = tmp.group.values[g], @@ -263,7 +263,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... # no level: in model syntax ov.names.l <- list() if(length(cluster) > 0L) { - stop("lavaan ERROR: when data is clustered, you must specify a model\n", " for each level in the model syntax (for now); see example(Demo.twolevel)") + stop("lavaan ERROR: when data is clustered, you must specify a model\n", " for each level in the model syntax (for now); see example(Demo.twolevel)") } } } @@ -287,7 +287,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... if(length(dotdotdot) > 0L) { dot.names <- names(dotdotdot) op.idx <- which(dot.names %in% names(slotOptions)) - warning("lavaan WARNING: the following argument(s) override(s) the options in slotOptions:\n\t\t", paste(dot.names[op.idx], collapse = " ")) + warning("lavaan WARNING: the following argument(s) override(s) the options in slotOptions:\n\t\t", paste(dot.names[op.idx], collapse = " ")) lavoptions[ dot.names[op.idx] ] <- dotdotdot[ op.idx ] } } else { @@ -457,7 +457,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... ######################## if(!is.null(slotParTable)) { lavpartable <- slotParTable - } else if(is.character(model) || + } else if(is.character(model) || inherits(model, "formula")) { # check FLAT before we proceed if(lavoptions$debug) { @@ -536,7 +536,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... lavpartable$free == 0L & lavpartable$ustart == 0) if(length(zero.var.idx) > 0L) { - lavpartable$ustart[zero.var.idx] <- lavoptions$em.zerovar.offset + lavpartable$ustart[zero.var.idx] <- lavoptions$em.zerovar.offset } } @@ -628,7 +628,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... h1.implied <- out$implied h1.loglik <- out$logl$loglik h1.loglik.group <- out$logl$loglik.group - + # collect in h1 list lavh1 <- list(implied = h1.implied, loglik = h1.loglik, @@ -731,18 +731,18 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... # check/warn if theta/delta values make sense if(!all(lavpartable$start == lavpartable$ustart)) { if(lavmodel@parameterization == "delta") { - # did the user specify theta values? + # did the user specify theta values? user.var.idx <- which(lavpartable$op == "~~" & lavpartable$lhs == lavpartable$rhs & lavpartable$lhs %in% unlist(lavpta$vnames$ov.ord) & lavpartable$user == 1L) if(length(user.var.idx)) { - warning("lavaan WARNING: ", - "variance (theta) values for categorical variables are ignored", + warning("lavaan WARNING: ", + "variance (theta) values for categorical variables are ignored", "\n\t\t if parameterization = \"delta\"!") } } else if(lavmodel@parameterization == "theta") { - # did the user specify theta values? + # did the user specify theta values? user.delta.idx <- which(lavpartable$op == "~*~" & lavpartable$lhs == lavpartable$rhs & lavpartable$lhs %in% unlist(lavpta$vnames$ov.ord) & @@ -779,9 +779,9 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... ov.types <- lavdata@ov$type if(lavmodel@conditional.x && lavmodel@nexo > 0L) { # remove ov.x - ov.x.idx <- unlist(lavpta$vidx$ov.x) + ov.x.idx <- unlist(lavpta$vidx$ov.x) ov.types <- ov.types[-ov.x.idx] - } + } if(lavoptions$estimator == "PML" && all(ov.types == "ordered")) { TH <- computeTH(lavmodel) @@ -971,7 +971,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... lavimplied = NULL, lavpartable = lavpartable, lavmodel = lavmodel, - lavoptions = lavoptions, + lavoptions = lavoptions, verbose = lavoptions$verbose, fx.tol = lavoptions$em.fx.tol, dx.tol = lavoptions$em.dx.tol, @@ -1051,8 +1051,8 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... lavimplied <- list() if(lavoptions$implied) { lavimplied <- lav_model_implied(lavmodel) - } - + } + lavloglik <- list() if(lavoptions$loglik) { lavloglik <- lav_model_loglik(lavdata = lavdata, @@ -1065,7 +1065,7 @@ lavaan <- function(# user-specified model: can be syntax, parameter Table, ... timing$implied <- (proc.time()[3] - start.time) start.time <- proc.time()[3] - + diff --git a/R/xxx_prelav.R b/R/xxx_prelav.R index 43ac7e87..94b1d348 100644 --- a/R/xxx_prelav.R +++ b/R/xxx_prelav.R @@ -6,9 +6,9 @@ prelav <- function(object = NULL, ordered = NULL, ov.names.x = NULL, group = NULL, missing = "pairwise", - output = list(MA ="none", # moment matrix + output = list(MA ="none", # moment matrix SR = FALSE, # transformed raw data - RA = FALSE, # transformed raw data + RA = FALSE, # transformed raw data SA = FALSE, # asymptotic covariance matrix AC = FALSE, # asymptotic covariance matrix SV = FALSE, # asymptotic variances @@ -85,6 +85,6 @@ print.prelav <- function(x, ..., nd=3) { cat("Univariate information:\n") # varTable! print(as.data.frame(lav.data@ov)) - + invisible(x) } diff --git a/R/xxx_twostep.R b/R/xxx_twostep.R index ff54091a..aa03fa8b 100644 --- a/R/xxx_twostep.R +++ b/R/xxx_twostep.R @@ -21,8 +21,8 @@ twostep <- function(model = NULL, # STEP 0: process full model, without fitting dotdotdot0 <- dotdotdot dotdotdot0$do.fit <- NULL - dotdotdot0$se <- "none" - dotdotdot0$test <- "none" + dotdotdot0$se <- "none" + dotdotdot0$test <- "none" # check for arguments that we do not want? # TODO @@ -70,9 +70,9 @@ twostep <- function(model = NULL, if(npar < 1L) { stop("lavaan ERROR: model does not contain any free parameters") } - - # make a copy + + # make a copy PT.orig <- PT # est equals ustart by default @@ -116,11 +116,11 @@ twostep <- function(model = NULL, # fit this measurement block, store the fitted object in the MM list MM[[f]] <- lavaan::lavaan(model = PTM, ...) ## FIXME: reuse slots! - + # fill in point estimates measurement block PT$est[ seq_len(length(PT$lhs)) %in% mm.idx & - PT$free > 0L ] <- MM[[f]]@ParTable$est[ PTM$free > 0L ] - + PT$free > 0L ] <- MM[[f]]@ParTable$est[ PTM$free > 0L ] + # fill in standard errors measurement block PT$se[ seq_len(length(PT$lhs)) %in% mm.idx & PT$free > 0L ] <- MM[[f]]@ParTable$se[ PTM$free > 0L ] @@ -147,8 +147,8 @@ twostep <- function(model = NULL, # remove 'exogenous' factor variances (if any) from reg.idx lv.names.x <- lv.names[ lv.names %in% unlist(lavpta$vnames$eqs.x) ] if(length(lv.names.x) > 0L) { - var.idx <- which(PT$lhs %in% lv.names.x & - PT$op == "~~" & + var.idx <- which(PT$lhs %in% lv.names.x & + PT$op == "~~" & PT$lhs == PT$rhs) rm.idx <- which(reg.idx %in% var.idx) if(length(rm.idx) > 0L) { @@ -216,8 +216,8 @@ twostep <- function(model = NULL, } return(PT) } else { - return( list(MM = MM, STRUC = STRUC, JOINT = JOINT, - V = V, V1 = V1, V2 = V2, Sigma.11 = Sigma.11, + return( list(MM = MM, STRUC = STRUC, JOINT = JOINT, + V = V, V1 = V1, V2 = V2, Sigma.11 = Sigma.11, MM.INFO = MM.INFO, PT = PT) ) } }