├── DESCRIPTION ├── NAMESPACE ├── NEWS ├── R ├── EBIClvglasso.R ├── cor2cov.R ├── generateRIMmodel.R ├── lassoSelect.R ├── lassoTest.R ├── lav2lvnet.R ├── lvglasso.R ├── lvnet.R ├── lvnetLasso.R ├── lvnetSearch.R ├── methods.R ├── modelComparison.R ├── plot.R ├── refit.R └── zzz.R ├── README.md ├── inst ├── .DS_Store ├── COPYING └── COPYRIGHTS └── man ├── .DS_Store ├── EBIClvglasso.Rd ├── lassoSelect.Rd ├── lav2lvnet.Rd ├── lvglasso.Rd ├── lvnet.Rd ├── lvnetCompare.Rd ├── lvnetLasso.Rd ├── lvnetRefit.Rd ├── lvnetSearch.Rd ├── plot.lvnet.Rd └── summary.lvnet.Rd /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: lvnet 2 | Type: Package 3 | Title: Latent Variable Network Modeling 4 | Version: 0.3.5 5 | Author: Sacha Epskamp 6 | Maintainer: Sacha Epskamp 7 | Description: Estimate, fit and compare Structural Equation Models (SEM) and network models (Gaussian Graphical Models; GGM) using OpenMx. Allows for two possible generalizations to include GGMs in SEM: GGMs can be used between latent variables (latent network modeling; LNM) or between residuals (residual network modeling; RNM). For details, see Epskamp, Rhemtulla and Borsboom (2017) . 8 | License: GPL-2 9 | Imports: glasso, qgraph, Matrix, psych, mvtnorm, parallel, corpcor, dplyr, methods, lavaan, semPlot 10 | Depends: R (>= 3.2.0), OpenMx -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Exports: 2 | export(lvnetRefit) 3 | export(lav2lvnet) 4 | export(EBIClvglasso) 5 | export(lvglasso) 6 | export(lassoSelect) 7 | export(lvnet) 8 | export(lvnetSearch) 9 | S3method(summary, lvnet) 10 | S3method(print, lvnet) 11 | S3method(plot, lvglasso) 12 | S3method(summary, lvnetLasso) 13 | S3method(print, lvnetLasso) 14 | S3method(plot, lvnetLasso) 15 | S3method(summary, lvnetSearch) 16 | S3method(print, lvnetSearch) 17 | S3method(plot, lvnetSearch) 18 | S3method(anova, lvnet) 19 | export(lvnetCompare) 20 | export(lvnetLasso) 21 | S3method(plot, lvnet) 22 | S3method(plot, lvnetLasso) 23 | S3method(plot, lvnetSearch) 24 | 25 | importFrom(qgraph, "ggmFit") 26 | 27 | 28 | # Imports 29 | import(glasso) 30 | import(Matrix) 31 | import(corpcor) 32 | import(mvtnorm) 33 | import(psych) 34 | import(dplyr) 35 | import(qgraph) 36 | importFrom(corpcor, "pseudoinverse") 37 | importFrom(qgraph, "qgraph") 38 | importFrom(qgraph, "qgraph.loadings") 39 | importFrom(OpenMx,"mxData") 40 | importFrom(OpenMx,"mxMatrix") 41 | importFrom(OpenMx,"mxExpectationNormal") 42 | importFrom(OpenMx,"mxFitFunctionML") 43 | importFrom(OpenMx,"mxAlgebra") 44 | importFrom(OpenMx,"mxRun") 45 | importFrom(qgraph,"EBICglasso") 46 | importFrom(lavaan,"lavaanify") 47 | importFrom(semPlot,"modelMatrices") 48 | import(parallel) 49 | 50 | 51 | 52 | importFrom("graphics", "par", "plot") 53 | importFrom("methods", "is") 54 | importFrom("stats", "C", "anova", "cov", "loadings", "pchisq", 55 | "promax", "residuals", "uniroot") 56 | importFrom("utils", "capture.output", "setTxtProgressBar", 57 | "txtProgressBar") -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | Changes in version 0.3.5 2 | o lvnet is now no longer supported, with most functionality moved to the psychonetrics package. A message now warns users of this on loading the package. 3 | 4 | Changes in Version 0.3.3 5 | o Added 'refitAll' argument to lvnetLasso to refit all models in the LASSO path before evaluating EBIC. This leads to similar functionality as qgraph::ggmModSelect(.., stepwise = FALSE), although the performance is slower. 6 | o The argument 'refit' has been renamed 'refitFinal' 7 | o Removed a warning on depracated dplyr functions 8 | o Fixed a bug in counting the number of parameters in RNM LASSO estimation 9 | 10 | Changes in Version 0.3.3 11 | o 'ggmFit' is no longer exported by lvnet 12 | 13 | Changes in Version 0.3.2 14 | o Summary output now contains parameter labels 15 | o Equality constraints now supported by supplying labels in model matrices 16 | 17 | Changes in Version 0.3.1: 18 | o 'ggmFit' is now moved to qgraph and exported by lvnet 19 | o Several updates to ggmFit in qgraph 20 | o Added 'lvnetRefit' to refit an lvnet model to new data 21 | 22 | Changes in Version 0.3: 23 | o 'scale' now defaults to FALSE! 24 | o Due to this change, some values such as the BIC will be different 25 | o Fixed a bug where higher order latent variables were not usuable 26 | o Added the 'mimic' argument. mimic = "lavaan" will mimic lavaan results (now default). 27 | o lvnet should now return the same fit as lavaan when std.lv=TRUE is used in lavaan. 28 | o Added the function 'lav2lvnet' to easily generate lvnet input from a lavaan model 29 | o Added 'ggmFit' to fit a given partial correlation network (Gaussian graphical model; GGM) -------------------------------------------------------------------------------- /R/EBIClvglasso.R: -------------------------------------------------------------------------------- 1 | 2 | # Computes optimal glasso network based on EBIC: 3 | EBIClvglasso <- function( 4 | S, # Sample cov 5 | n, # Sample size 6 | nLatents, # Number of latents 7 | gamma = 0.5, # EBIC parameter 8 | nRho = 100, 9 | lambda, 10 | ... # lvglasso arguments 11 | ){ 12 | if (missing(lambda)) lambda <- NULL 13 | 14 | # If nLatents is vector, do this function for every latent: 15 | if (length(nLatents) > 1){ 16 | Resses <- lapply(nLatents,function(nl)EBIClvglasso(S, n, nl, gamma, lambda, ...)) 17 | opt <- which.max(sapply(Resses,'[[','ebic')) 18 | return(Resses[[opt]]) 19 | } 20 | 21 | rho.max = max(max(S - diag(nrow(S))), -min(S - diag(nrow(S)))) 22 | rho.min = rho.max/100 23 | rho = exp(seq(log(rho.min), log(rho.max), length = nRho)) 24 | 25 | lvglas_res <- lapply(rho, function(r)try(lvglasso(S, nLatents, r,lambda = lambda, ...))) 26 | 27 | failed <- sapply(lvglas_res,is,"try-res") 28 | # Likelihoods: 29 | EBICs <- sapply(lvglas_res[!failed],function(res){ 30 | C <- solve(res$w[res$observed,res$observed]) 31 | qgraph:::EBIC(S, C, n, gamma, E = sum(res$wi[lower.tri(res$wi, diag = TRUE)] != 0)) 32 | }) 33 | 34 | # Smalles EBIC: 35 | opt <- which.min(EBICs) 36 | 37 | Res <- lvglas_res[!failed][[opt]] 38 | Res$rho <- rho[!failed][opt] 39 | Res$ebic <- EBICs[opt] 40 | 41 | # Return 42 | return(Res) 43 | } 44 | 45 | 46 | -------------------------------------------------------------------------------- /R/cor2cov.R: -------------------------------------------------------------------------------- 1 | # H. Seltman, May 2014 2 | 3 | # Goal: convert a correlation matrix and variance vector 4 | # into the corresponding covariance matrix 5 | # 6 | # Input: 7 | # 'corMat' is a square matrix with 1's on the diagonal 8 | # and valid correlations on the off-diagonal 9 | # 'varVec' is a valid variance vector, with length 10 | # matching the dimension of 'covMat'. A single 11 | # row or single column matrix is also allowed. 12 | # Output: 13 | # the covariance matrix 14 | # 15 | # A warning is given if the covariance matrix is not 16 | # positive definite. 17 | # 18 | cor2cov = function(corMat, varVec) { 19 | # test the input 20 | if (!is.matrix(corMat)) stop("'corMat must be a matrix") 21 | n = nrow(corMat) 22 | if (ncol(corMat) != n) stop("'corMat' must be square") 23 | if (mode(corMat) != "numeric") stop("'corMat must be numeric") 24 | if (mode(varVec) != "numeric") stop("'varVec must be numeric") 25 | if (!is.null(dim(varVec))) { 26 | if (length(dim(varVec)) != 2) stop("'varVec' should be a vector") 27 | if (any(dim(varVec)==1)) stop("'varVec' cannot be a matrix") 28 | varVec = as.numeric(varVec) # convert row or col matrix to a vector 29 | } 30 | if (!all(diag(corMat) == 1)) stop("correlation matrices have 1 on the diagonal") 31 | if (any(corMat < -1 | corMat > +1)) 32 | stop("correlations must be between -1 and 1") 33 | if (any(varVec <= 0)) stop("variances must be non-negative") 34 | if (length(varVec) != n) stop("length of 'varMat' does not match 'corMat' size") 35 | 36 | # Compute the covariance 37 | sdMat = diag(sqrt(varVec)) 38 | rtn = sdMat %*% corMat %*% t(sdMat) 39 | if (det(rtn)<=0) warning("covariance matrix is not positive definite") 40 | return(rtn) 41 | } 42 | -------------------------------------------------------------------------------- /R/generateRIMmodel.R: -------------------------------------------------------------------------------- 1 | start <- function(mat,list,alt){ 2 | if (!is.null(list[[mat]])){ 3 | return(list[[mat]]) 4 | } else { 5 | return(alt) 6 | } 7 | } 8 | 9 | # toFree: function to take input and return NA whenever NA or character: 10 | toFree <- function(x){ 11 | suppressWarnings(mode(x) <- "numeric") 12 | x 13 | } 14 | isFree <- function(x) is.na(toFree(x)) 15 | # to label, convert to equality constraints: 16 | toLabel <- function(x, mat, symmetric=FALSE){ 17 | isNA <- is.na(x) 18 | free <- toFree(x) 19 | suppressWarnings(mode(x) <- "character") 20 | inds <- which(isNA | !is.na(free),arr.ind=TRUE) 21 | x[isNA | !is.na(free)] <- paste0(mat,"_",inds[,1],"_",inds[,2]) 22 | if (symmetric){ 23 | x[lower.tri(x)] <- t(x)[lower.tri(x)] 24 | } 25 | # x[isNA | !is.na(free)] <- NA 26 | return(x) 27 | } 28 | 29 | 30 | # Model matrices should contain NA for free elements and a value for fixed elements. 31 | generatelvnetmodel <- function( 32 | data, # Raw data or a covariance matrix 33 | lambda, # Lambda design matrix. NA indicates free parameters. If missing and psi is missing, defaults to identity matrix with warning 34 | omega_theta, # Observed residual network. If missing, defaults to matrix of zeroes 35 | delta_theta, # Scaling matrix, can be missing 36 | omega_psi, # Latent residual network. If missing, defaults to matrix of zeroes 37 | delta_psi, # Scaling matrix, can be missing 38 | beta, # Structural matrix. If missing, defaults to zero. 39 | psi, # Latent variance-covariance matrix. If missing, defaults to free 40 | theta, # Used if model = "sem". Defaults to diagonal 41 | sampleSize, 42 | name = "mod", 43 | startValues = list(), 44 | parLabels = list(), 45 | lasso = 0, 46 | lassoMatrix = "", 47 | scale = FALSE, 48 | nLatents, # allows for quick specification of fully populated lambda matrix. 49 | mimic = c("lvnet","lavaan"), 50 | fitFunction = c("default","ML","penalizedML") 51 | ){ 52 | mimic <- match.arg(mimic) 53 | 54 | fitFunction <- match.arg(fitFunction) 55 | if (fitFunction=="default"){ 56 | fitFunction <- ifelse(lasso == 0, "ML", "penalizedML") 57 | } 58 | 59 | if (lasso != 0 && fitFunction != "penalizedML"){ 60 | stop("fitFunction must be 'penalizedML' when lasso != 0") 61 | } 62 | 63 | # Silly things to fool R check: 64 | I_lat <- NULL 65 | I_obs <- NULL 66 | PsiPlus <- NULL 67 | vec2diag <- NULL 68 | diag2vec <- NULL 69 | theta_inverse <- NULL 70 | eigenval <- NULL 71 | sigma_positive <- NULL 72 | P <- NULL 73 | penalty <- NULL 74 | sigma <- NULL 75 | # Lambda <- NULL 76 | 77 | # Check for input: 78 | stopifnot(is.matrix(data)|is.data.frame(data)) 79 | 80 | # Number of variables: 81 | Nvar <- ncol(data) 82 | 83 | # stopifnot(model[[1]] %in% c("lvnet","sem")) 84 | 85 | # Check matrices: 86 | # Lambda (Default to iden if psi is missing or full if psi is not) 87 | if (missing(lambda)){ 88 | if (!missing(nLatents)){ 89 | lambda <- matrix(NA,Nvar,nLatents) 90 | } else if (!missing(psi)){ 91 | lambda <- matrix(NA, Nvar, ncol(psi)) 92 | } else if (!missing(omega_psi)){ 93 | lambda <- matrix(NA, Nvar, ncol(omega_psi)) 94 | } else { 95 | lambda <- matrix(,Nvar,0) 96 | 97 | if (missing(theta) && missing(omega_theta)){ 98 | if (lasso !=0){ 99 | if (!(any(c("omega_theta","theta") %in% lassoMatrix))){ 100 | theta <- matrix(NA, Nvar, Nvar) 101 | } 102 | } else { 103 | theta <- matrix(NA, Nvar, Nvar) 104 | } 105 | } 106 | } 107 | } 108 | 109 | Nlat <- ncol(lambda) 110 | 111 | if (nrow(lambda) != ncol(data)){ 112 | stop("Number of rows in 'lambda' does not equal number of variables in 'data'") 113 | } 114 | 115 | # Check lasso matrix and set missing if needed: 116 | if (!missing(lassoMatrix)){ 117 | if ("omega_psi" %in% lassoMatrix && missing(omega_psi)){ 118 | omega_psi <- matrix(NA,Nlat,Nlat) 119 | diag(omega_psi) <- 0 120 | } 121 | if ("psi" %in% lassoMatrix && missing(psi)){ 122 | psi <- matrix(NA,Nlat,Nlat) 123 | diag(psi) <- 1 124 | } 125 | if ("omega_theta" %in% lassoMatrix && missing(omega_theta)){ 126 | omega_theta <- matrix(NA,Nvar,Nvar) 127 | diag(omega_theta) <- 0 128 | } 129 | if ("theta" %in% lassoMatrix && missing(theta)){ 130 | theta <- matrix(NA,Nvar,Nvar) 131 | } 132 | } 133 | 134 | # psi and omega_psi may not both be missing: 135 | if(!missing(psi) & !missing(omega_psi)){ 136 | stop("Both 'psi' and 'omega_psi' modeled.") 137 | } 138 | 139 | # Both theta and omega_theta may not be missing: 140 | if(!missing(theta) & !missing(omega_theta)){ 141 | stop("Both 'theta' and 'omega_theta' modeled.") 142 | } 143 | 144 | # Identify if estimation should be on psi or omega_psi: 145 | estPsi <- (!missing(psi)) | (missing(psi) & missing(omega_psi)) 146 | 147 | # Identify if estimation should be on theta or omega_theta: 148 | estTheta <- (!missing(theta)) | (missing(theta) & missing(omega_theta)) 149 | 150 | # psi (default to freely estimable; default scaling in psi) 151 | if (missing(psi)){ 152 | if (missing(beta)){ 153 | psi <- matrix(NA, Nlat, Nlat) 154 | diag(psi) <- 1 155 | } else { 156 | psi <- diag(1, Nlat) 157 | } 158 | } 159 | 160 | 161 | # Theta (defaults to diagonal) 162 | if (missing(theta)){ 163 | theta <- diag(NA, Nvar) 164 | } 165 | 166 | stopifnot(isSymmetric(psi)) 167 | stopifnot(isSymmetric(theta)) 168 | 169 | 170 | # Omega psi: 171 | if (missing(omega_psi)){ 172 | if (missing(beta)){ 173 | omega_psi <- matrix(NA, Nlat, Nlat) 174 | diag(omega_psi) <- 0 175 | } else { 176 | omega_psi <- matrix(0, Nlat, Nlat) 177 | } 178 | } 179 | 180 | # omega_theta (default to null) 181 | if (missing(omega_theta)){ 182 | omega_theta <- matrix(0, Nvar, Nvar) 183 | } 184 | 185 | # Check omegas: 186 | if (any(is.na(diag(omega_theta))) || any(diag(omega_theta)!=0)){ 187 | warning("'omega_theta' must have zero diagonal. Set to zero.") 188 | diag(omega_theta) <- 0 189 | } 190 | 191 | if (any(is.na(diag(omega_psi))) || any(diag(omega_psi)!=0)){ 192 | warning("'omega_psi' must have zero diagonal. Set to zero.") 193 | diag(omega_psi) <- 0 194 | } 195 | 196 | # Delta (defaults to diagonal) 197 | if (missing(delta_theta)){ 198 | delta_theta <- diag(NA, Nvar) 199 | } 200 | if (missing(delta_psi)){ 201 | delta_psi <- diag(1, Nlat) 202 | } 203 | 204 | stopifnot(isSymmetric(omega_psi)) 205 | stopifnot(isSymmetric(omega_theta)) 206 | 207 | # Beta (defaults to null) 208 | if (missing(beta)){ 209 | beta <- matrix(0, Nlat, Nlat) 210 | } 211 | 212 | if (is.null(colnames(data))){ 213 | colnames(data) <- paste0("y",seq_len(ncol(data))) 214 | } 215 | 216 | # Mx data 217 | if (ncol(data) == nrow(data) && isSymmetric(unname(data))){ 218 | if (missing(sampleSize)){ 219 | stop("sampleSize needs to be assigned if input is covariance matrix.") 220 | } 221 | 222 | # Mx_data <- OpenMx::mxData(observed = data, type = "cov", numObs = sampleSize) 223 | # # means: 224 | # Mx_means <- OpenMx::mxMatrix(type = "Full", nrow = 1, ncol = ncol(data), values=0, 225 | # free=FALSE, name = "means", dimnames = list("mean",colnames(data)) 226 | # ) 227 | 228 | covMat <- data * (sampleSize - 1)/sampleSize 229 | rownames(covMat) <- colnames(covMat) 230 | 231 | } else { 232 | sampleSize <- nrow(data) 233 | # Mx_data <- OpenMx::mxData(observed = data, type = "raw") 234 | # # means: 235 | # Mx_means <- OpenMx::mxMatrix(type = "Full", nrow = 1, ncol = ncol(data), values=colMeans(data), 236 | # free=FALSE, name = "means", dimnames = list("mean",colnames(data)) 237 | # ) 238 | 239 | data <- as.matrix(data) 240 | covMat <- cov(data, use = "pairwise.complete.obs") # * (sampleSize - 1)/sampleSize 241 | } 242 | 243 | if (scale){ 244 | covMat <- setSym(cov2cor(covMat)) 245 | } else { 246 | if (lasso != 0){ 247 | warning("It is advised to set 'scale = TRUE' when using LASSO estimation.") 248 | } 249 | } 250 | 251 | # Scale to divide by N: 252 | if (mimic == "lavaan"){ 253 | covMat <- covMat * (sampleSize - 1)/sampleSize 254 | } 255 | 256 | # 257 | Mx_data <- OpenMx::mxData(observed = covMat, type = "cov", numObs = sampleSize) 258 | # means: 259 | Mx_means <- OpenMx::mxMatrix(type = "Full", nrow = 1, ncol = ncol(data), values=0, 260 | free=FALSE, name = "means", dimnames = list("mean",colnames(data)) 261 | ) 262 | 263 | ### lvnet AND SEM ### 264 | # Lambda: 265 | if (Nlat > 0){ 266 | Mx_lambda <- OpenMx::mxMatrix( 267 | type = "Full", 268 | nrow = nrow(lambda), 269 | ncol = ncol(lambda), 270 | free = isFree(lambda), 271 | labels = toLabel(lambda,"lambda"), 272 | values = start("lambda",startValues,ifelse(isFree(lambda),1,toFree(lambda))), 273 | name = "lambda" 274 | ) 275 | } else { 276 | Mx_lambda <- OpenMx::mxMatrix( 277 | type = "Full", 278 | nrow = nrow(lambda), 279 | ncol = ncol(lambda), 280 | name = "lambda" 281 | ) 282 | } 283 | 284 | # Beta: 285 | if (Nlat > 0){ 286 | 287 | Mx_beta <- OpenMx::mxMatrix( 288 | type = "Full", 289 | nrow = nrow(beta), 290 | ncol = ncol(beta), 291 | free = isFree(beta),labels=toLabel(beta,"beta"), 292 | values = start("beta",startValues,ifelse(isFree(beta),0,toFree(beta))), 293 | name = "beta" 294 | ) 295 | } else { 296 | Mx_beta <- OpenMx::mxMatrix( 297 | type = "Full", 298 | nrow = nrow(beta), 299 | ncol = ncol(beta), 300 | name = "beta" 301 | ) 302 | } 303 | 304 | 305 | Mx_identity_lat <- OpenMx::mxMatrix( 306 | type = "Iden", 307 | nrow = Nlat, 308 | ncol = Nlat, 309 | name = "I_lat" 310 | ) 311 | 312 | 313 | Mx_identity_obs <- OpenMx::mxMatrix( 314 | type = "Iden", 315 | nrow = Nvar, 316 | ncol = Nvar, 317 | name = "I_obs" 318 | ) 319 | 320 | 321 | # Psi and omega_psi: 322 | if (estPsi){ 323 | if (Nlat > 0){ 324 | 325 | # bounds: 326 | ubound <- sqrt(diag(psi)) %o% sqrt(diag(psi)) 327 | 328 | # Force no cors of 1: 329 | ubound <- 0.99*ubound 330 | diag(ubound) <- diag(psi) 331 | 332 | ubound <- ifelse(is.na(ubound),Inf,ubound) 333 | lbound <- -ubound 334 | diag(lbound) <- 0 335 | 336 | Mx_psi <- OpenMx::mxMatrix( 337 | type = "Symm", 338 | nrow = nrow(psi), 339 | ncol = ncol(psi), 340 | free = isFree(psi),labels=toLabel(psi,"psi",TRUE), 341 | values = start("psi",startValues,ifelse(isFree(psi),diag(ncol(psi)),toFree(psi))), 342 | lbound = lbound, 343 | ubound = ubound, 344 | name = "psi" 345 | ) 346 | } else { 347 | Mx_psi <- OpenMx::mxMatrix( 348 | type = "Symm", 349 | nrow = nrow(psi), 350 | ncol = ncol(psi), 351 | name = "psi" 352 | ) 353 | } 354 | 355 | Mx_delta_psi <- OpenMx::mxAlgebra( 356 | vec2diag(1/sqrt(diag2vec(solve(psi)))), 357 | name = "delta_psi" 358 | ) 359 | 360 | Mx_omega_psi <- OpenMx::mxAlgebra( 361 | I_lat - delta_psi %*% solve(psi) %*% delta_psi, 362 | name = "omega_psi" 363 | ) 364 | 365 | # Mx_psi_inverse <- OpenMx::mxAlgebra( 366 | # solve(psi), 367 | # name = "psi_inverse" 368 | # ) 369 | 370 | } else { 371 | 372 | Mx_delta_psi <- OpenMx::mxMatrix( 373 | type = "Diag", 374 | nrow = nrow(delta_psi), 375 | ncol = ncol(delta_psi), 376 | free = isFree(delta_psi),labels=toLabel(delta_psi,"delta_psi",TRUE), 377 | values = start("delta_psi",startValues,ifelse(isFree(delta_psi),1,toFree(delta_psi))), 378 | lbound = 0, 379 | name = "delta_psi" 380 | ) 381 | # 382 | # # Omega: 383 | if (Nlat > 0){ 384 | Mx_omega_psi <- OpenMx::mxMatrix( 385 | type = "Symm", 386 | nrow = nrow(omega_psi), 387 | ncol = ncol(omega_psi), 388 | free = isFree(omega_psi),labels=toLabel(omega_psi,"omega_psi",TRUE), 389 | values = start("omega_psi",startValues,ifelse(isFree(omega_psi),0,toFree(omega_psi))), 390 | lbound = ifelse(diag(nrow(omega_psi)) == 1,0, -0.99), 391 | ubound = ifelse(diag(nrow(omega_psi)) == 1,0, 0.99), 392 | name = "omega_psi", 393 | ) 394 | } else { 395 | Mx_omega_psi <- OpenMx::mxMatrix( 396 | type = "Symm", 397 | nrow = nrow(omega_psi), 398 | ncol = ncol(omega_psi), 399 | name = "omega_psi" 400 | ) 401 | } 402 | # if (Nlat > 0){ 403 | # Mx_psi_inverse <- OpenMx::mxMatrix( 404 | # type = "Symm", 405 | # nrow = Nlat, 406 | # ncol = Nlat, 407 | # free = is.na(omega_psi) | is.na(delta_psi), 408 | # values = diag(1, Nlat, Nlat), 409 | # lbound = ifelse(diag(nrow(omega_psi)) == 1,0, -1), 410 | # ubound = 1, 411 | # name = "psi_inverse" 412 | # ) 413 | # } else { 414 | # Mx_psi_inverse <- OpenMx::mxMatrix( 415 | # type = "Symm", 416 | # nrow = nrow(omega_psi), 417 | # ncol = ncol(omega_psi), 418 | # name = "psi_inverse" 419 | # ) 420 | # } 421 | 422 | # Mx_omega_psi <- OpenMx::mxAlgebra( 423 | # I_obs - delta_psi %*% psi_inverse %*% delta_psi, 424 | # name = "omega_psi" 425 | # ) 426 | # 427 | Mx_psi <- OpenMx::mxAlgebra( 428 | delta_psi %*% solve(I_lat - omega_psi) %*% delta_psi, 429 | name = "psi" 430 | ) 431 | 432 | # Mx_delta_psi <- OpenMx::mxAlgebra( 433 | # vec2diag(1/sqrt(diag2vec(psi_inverse))), 434 | # name = "delta_psi" 435 | # ) 436 | # 437 | # Mx_omega_theta <- OpenMx::mxAlgebra( 438 | # I_obs - delta_theta %*% theta_inverse %*% delta_theta, 439 | # name = "omega_theta" 440 | # ) 441 | # 442 | # Mx_theta <- OpenMx::mxAlgebra( 443 | # solve(theta_inverse), 444 | # name = "theta" 445 | # ) 446 | 447 | 448 | 449 | } 450 | 451 | # Theta and omega_theta: 452 | if (estTheta){ 453 | 454 | Mx_theta <- OpenMx::mxMatrix( 455 | type = "Symm", 456 | nrow = nrow(theta), 457 | ncol = ncol(theta), 458 | free = isFree(theta),labels=toLabel(theta,"theta",TRUE), 459 | values = start("theta",startValues,ifelse(isFree(theta),diag(nrow(theta)),toFree(theta))), 460 | name = "theta" 461 | ) 462 | 463 | Mx_delta_theta <- OpenMx::mxAlgebra( 464 | vec2diag(1/sqrt(diag2vec(solve(theta)))), 465 | name = "delta_theta" 466 | ) 467 | 468 | Mx_omega_theta <- OpenMx::mxAlgebra( 469 | I_obs - delta_theta %*% solve(theta) %*% delta_theta, 470 | name = "omega_theta" 471 | ) 472 | 473 | 474 | Mx_theta_inverse <- OpenMx::mxAlgebra( 475 | solve(theta), 476 | name = "theta_inverse" 477 | ) 478 | 479 | } else { 480 | 481 | if (is.null(startValues[["delta_theta"]])){ 482 | startValues[["delta_theta"]] <- diag(1/sqrt(diag(corpcor::pseudoinverse(covMat)))) 483 | } 484 | 485 | 486 | ##### TEST CODES #### 487 | 488 | # Only estimate inverse of theta, obtain omega_theta and delta_theta afterwards: 489 | # Use 490 | Mx_theta_inverse <- OpenMx::mxMatrix( 491 | type = "Symm", 492 | nrow = Nvar, 493 | ncol = Nvar, 494 | free = is.na(omega_theta) | is.na(delta_theta), 495 | labels=toLabel(omega_theta,"theta_inverse",TRUE), 496 | values = diag(1,Nvar), 497 | lbound = ifelse(diag(Nvar) == 1,0, -Inf), 498 | ubound = Inf, 499 | name = "theta_inverse" 500 | ) 501 | 502 | if (is.character(omega_theta)){ 503 | stop("Equality constraints in residual network not yet supported.") 504 | } 505 | 506 | Mx_delta_theta <- OpenMx::mxAlgebra( 507 | vec2diag(1/sqrt(diag2vec(theta_inverse))), 508 | name = "delta_theta" 509 | ) 510 | 511 | Mx_omega_theta <- OpenMx::mxAlgebra( 512 | I_obs - delta_theta %*% theta_inverse %*% delta_theta, 513 | name = "omega_theta" 514 | ) 515 | 516 | Mx_theta <- OpenMx::mxAlgebra( 517 | solve(theta_inverse), 518 | name = "theta" 519 | ) 520 | 521 | # 522 | 523 | 524 | # 525 | # # Delta: 526 | # Mx_delta_theta <- OpenMx::mxMatrix( 527 | # type = "Diag", 528 | # nrow = nrow(delta_theta), 529 | # ncol = ncol(delta_theta), 530 | # free = is.na(delta_theta), 531 | # values = start("delta_theta",startValues,ifelse(is.na(delta_theta),1,delta_theta)), 532 | # lbound = 0, 533 | # name = "delta_theta" 534 | # ) 535 | # 536 | # # Omega: 537 | # Mx_omega_theta <- OpenMx::mxMatrix( 538 | # type = "Symm", 539 | # nrow = nrow(omega_theta), 540 | # ncol = ncol(omega_theta), 541 | # free = is.na(omega_theta), 542 | # values = start("omega_theta",startValues,0), 543 | # lbound = ifelse(diag(nrow(omega_theta)) == 1,0, -0.99), 544 | # ubound = ifelse(diag(nrow(omega_theta)) == 1,0, 0.99), 545 | # name = "omega_theta" 546 | # ) 547 | # 548 | # Mx_theta <- OpenMx::mxAlgebra( 549 | # delta_theta %*% solve(I_obs - omega_theta) %*% delta_theta, 550 | # name = "theta" 551 | # ) 552 | } 553 | 554 | 555 | # Fake psi with shifted eigenvalues if needed: 556 | # Mx_Psi_Positive <- OpenMx::mxAlgebra( 557 | # psi - min(0,(min(eigenval(psi))-.00001)) * I_lat, name = "psi_positive" 558 | # ) 559 | # Mx_Psi_Positive <- OpenMx::mxAlgebra( 560 | # psi -0* I_lat, name = "psi_positive" 561 | # ) 562 | # Constraint on psi: 563 | # Small values for diagonal: 564 | # Mx_PsiDiagplus <- mxMatrix( 565 | # "Diag", 566 | # nrow(psi), 567 | # ncol(psi), 568 | # FALSE, 569 | # values = 1e-5, 570 | # name = "PsiPlus" 571 | # ) 572 | # Mx_PsiCon <- OpenMx::mxConstraint(psi < sqrt(diag2vec(psi)) %*% sqrt(t(diag2vec(psi))) + PsiPlus) 573 | # 574 | 575 | 576 | 577 | ### FIT FUNCTIONS ### 578 | # if (lasso ==0){ 579 | # # Expectation: 580 | # expFunction <- OpenMx::mxExpectationNormal(covariance = "sigma") 581 | # 582 | # # Fit function: 583 | # fitFunction <- OpenMx::mxFitFunctionML() 584 | # 585 | # # Implied covariance: 586 | # if (Nlat > 0){ 587 | # Mx_sigma <- OpenMx::mxAlgebra( 588 | # lambda %*% solve(I_lat - beta) %*% psi %*% t(solve(I_lat - beta)) %*% t(lambda) + theta, 589 | # name = "sigma", 590 | # dimnames = list(colnames(data),colnames(data))) 591 | # 592 | # ### Model: 593 | # Mx_model <- OpenMx::mxModel( 594 | # name = name, 595 | # Mx_data, 596 | # Mx_means, 597 | # Mx_lambda, 598 | # Mx_theta, 599 | # Mx_psi, 600 | # Mx_delta_theta, 601 | # Mx_omega_theta, 602 | # Mx_delta_psi, 603 | # Mx_omega_psi, 604 | # Mx_identity_obs, 605 | # Mx_identity_lat, 606 | # Mx_beta, 607 | # Mx_sigma, 608 | # expFunction, 609 | # fitFunction 610 | # 611 | # # Mx_PsiCon, 612 | # # Mx_PsiDiagplus 613 | # ) 614 | # } else { 615 | # Mx_sigma <- OpenMx::mxAlgebra( 616 | # theta, 617 | # name = "sigma", 618 | # dimnames = list(colnames(data),colnames(data))) 619 | # 620 | # 621 | # ### Model: 622 | # Mx_model <- OpenMx::mxModel( 623 | # name = name, 624 | # Mx_data, 625 | # Mx_means, 626 | # Mx_theta, 627 | # Mx_delta_theta, 628 | # Mx_omega_theta, 629 | # Mx_identity_obs, 630 | # Mx_sigma, 631 | # expFunction, 632 | # fitFunction 633 | # ) 634 | # } 635 | # 636 | # } else { 637 | # Observed covariance matrix (used in mxAlgebra for LASSO): 638 | mx_observedCovs <- OpenMx::mxMatrix( 639 | "Symm", 640 | nrow = nrow(covMat), 641 | ncol = ncol(covMat), 642 | free = FALSE, 643 | values = covMat, 644 | dimnames = dimnames(covMat), 645 | name = "C" 646 | ) 647 | 648 | # Positive definite shifted sigma: 649 | Mx_Sigma_positive <- OpenMx::mxAlgebra( 650 | sigma - min(0,(min(eigenval(sigma))-.00001)) * I_obs, name = "sigma_positive", dimnames = dimnames(covMat) 651 | ) 652 | 653 | # Tuning parameter: 654 | mx_Tuning <- OpenMx::mxMatrix(nrow=1,ncol=1,free=FALSE,values=lasso,name="tuning") 655 | 656 | # Number of obsrved variables: 657 | mx_P <- OpenMx::mxMatrix(nrow=1,ncol=1,free=FALSE,values=nrow(covMat),name="P") 658 | 659 | # LASSO penalty: 660 | # Construct the penalty: 661 | 662 | if (!missing(lassoMatrix) && length(lassoMatrix) > 0){ 663 | 664 | # Put vechs around any matrix that is not lambda or beta: 665 | penString <- ifelse(lassoMatrix %in% c("lambda","beta"), lassoMatrix, 666 | paste0("vech(",lassoMatrix,")") 667 | ) 668 | 669 | # sum absolute values and plus:: 670 | penString <- paste0("sum(abs(",penString,"))", collapse = " + ") 671 | 672 | # Multiply with tuning: 673 | penString <- paste0("tuning * (",penString,")") 674 | 675 | # Add to penalty: 676 | Penalty <- OpenMx::mxAlgebraFromString( penString,name = "penalty") 677 | 678 | } else { 679 | Penalty <- OpenMx::mxAlgebra(0,name = "penalty") 680 | } 681 | 682 | 683 | 684 | # LASSO fit function: 685 | # logLik <- OpenMx::mxAlgebra(log(det(sigma)) + tr(C %*% solve(sigma)) - log(det(C)) - P + penalty,name = "logLik") 686 | 687 | # logLik <- OpenMx::mxAlgebra(log(det(sigma)) + tr(C %*% solve(sigma)) - log(det(C)) - P,name = "logLik") 688 | 689 | # Fit function: 690 | if (fitFunction == "ML"){ 691 | # expFunction <- OpenMx::mxExpectationNormal(covariance = "sigma") 692 | # 693 | # # Fit function: 694 | # fitFunction <- OpenMx::mxFitFunctionML() 695 | 696 | # Normal ML estimation 697 | logLik <- OpenMx::mxExpectationNormal(covariance = "sigma_positive") 698 | 699 | # Fit function: 700 | fitFunction <- OpenMx::mxFitFunctionML() 701 | 702 | } else { 703 | # Penalized ML 704 | logLik <- OpenMx::mxAlgebra(log(det(sigma_positive)) + tr(C %*% solve(sigma_positive)) - log(det(C)) - P + penalty,name = "logLik") 705 | 706 | # Fit function: 707 | fitFunction <- OpenMx::mxFitFunctionAlgebra("logLik", numObs = sampleSize, numStats = ncol(covMat)*(ncol(covMat)+1)/2) 708 | } 709 | 710 | 711 | if (Nlat > 0){ 712 | Mx_sigma <- OpenMx::mxAlgebra( 713 | lambda %*% solve(I_lat - beta) %*% psi %*% t(solve(I_lat - beta)) %*% t(lambda) + theta, 714 | name = "sigma", 715 | dimnames = list(colnames(data),colnames(data))) 716 | 717 | ### Model: 718 | Mx_model <- OpenMx::mxModel( 719 | name = name, 720 | Mx_data, 721 | Mx_means, 722 | Mx_lambda, 723 | Mx_theta, 724 | Mx_psi, 725 | Mx_delta_theta, 726 | Mx_omega_theta, 727 | Mx_delta_psi, 728 | Mx_omega_psi, 729 | Mx_identity_obs, 730 | Mx_identity_lat, 731 | Mx_beta, 732 | Mx_sigma, 733 | Mx_theta_inverse, 734 | # Mx_psi_inverse, 735 | 736 | # LASSO stuff: 737 | fitFunction, 738 | mx_Tuning, 739 | mx_P, 740 | logLik, 741 | mx_observedCovs, 742 | Penalty, 743 | Mx_Sigma_positive 744 | ) 745 | 746 | } else { 747 | Mx_sigma <- OpenMx::mxAlgebra( 748 | theta, 749 | name = "sigma", 750 | dimnames = list(colnames(data),colnames(data))) 751 | 752 | 753 | ### Model: 754 | Mx_model <- OpenMx::mxModel( 755 | name = name, 756 | Mx_data, 757 | Mx_means, 758 | Mx_theta, 759 | Mx_delta_theta, 760 | Mx_omega_theta, 761 | Mx_identity_obs, 762 | Mx_sigma, 763 | Mx_theta_inverse, 764 | # Mx_psi_inverse, 765 | 766 | # LASSO Stuff: 767 | fitFunction, 768 | mx_Tuning, 769 | mx_P, 770 | logLik, 771 | mx_observedCovs, 772 | Penalty, 773 | Mx_Sigma_positive 774 | ) 775 | 776 | } 777 | 778 | # } 779 | 780 | 781 | 782 | 783 | 784 | 785 | 786 | return(Mx_model) 787 | } 788 | -------------------------------------------------------------------------------- /R/lassoSelect.R: -------------------------------------------------------------------------------- 1 | lassoSelect <- function( 2 | object, # lvnetLasso object 3 | select, # an R expression. 4 | minimize = TRUE, 5 | refit = TRUE, 6 | lassoTol = 1e-4 7 | ){ 8 | stopifnot(is(object,"lvnetLasso")) 9 | 10 | # Table of fit measures: 11 | fitTable <- as.data.frame(do.call(rbind,lapply(object$modList,function(x)unlist(x$fitMeasures)))) 12 | 13 | # Eval selection: 14 | fits <- unlist(eval(substitute(select), envir = fitTable)) 15 | 16 | if (minimize){ 17 | best <- which.min(fits) 18 | } else { 19 | best <- which.max(fits) 20 | } 21 | 22 | if (refit){ 23 | newMod <- lapply(object$lassoMatrix, function(m){ 24 | mat <- object$modList[[best]]$matrices[[m]] 25 | ifelse(abs(mat) > lassoTol,NA,0) 26 | }) 27 | names(newMod) <- object$lassoMatrix 28 | 29 | args <- object$args 30 | for (i in seq_along(object$lassoMatrix)){ 31 | args[[object$lassoMatrix[[i]]]] <- newMod[[object$lassoMatrix[[i]]]] 32 | } 33 | 34 | bestModel <- do.call(lvnet,c(object$args)) 35 | } else { 36 | bestModel <- object$modList[[best]] 37 | } 38 | 39 | object$best <- bestModel 40 | return(object) 41 | } -------------------------------------------------------------------------------- /R/lassoTest.R: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SachaEpskamp/lvnet/88ec96c7b0dfb7c1898c6356ae813f0e560fae50/R/lassoTest.R -------------------------------------------------------------------------------- /R/lav2lvnet.R: -------------------------------------------------------------------------------- 1 | matConverter <- function(x){ 2 | mat <- ifelse(x[[1]]$par==0,x[[1]]$est,NA) 3 | mat 4 | } 5 | 6 | lav2lvnet <- function( 7 | model, # Lavaan model 8 | data, # data needed for ordering of lambda 9 | std.lv = TRUE, # DEFAULT IN lvnet! 10 | lavaanifyOps = list(auto=TRUE,std.lv=std.lv) # lavaanify options 11 | ){ 12 | # Variable names: 13 | varNames <- colnames(data) 14 | 15 | # Lavaanify: 16 | lavMod <- do.call(lavaan::lavaanify,c(list(model), lavaanifyOps)) 17 | 18 | # Test multiple groups: 19 | if (length(unique(lavMod$group)) > 1) stop("lvnet only supports single group analysis") 20 | 21 | # To model matrices: 22 | modelMatrices <- semPlot::modelMatrices(lavMod, "mplus") 23 | 24 | # Output list: 25 | output <- list( 26 | lambda = matConverter(modelMatrices$Lambda)[varNames,], 27 | beta = matConverter(modelMatrices$Beta), 28 | psi = matConverter(modelMatrices$Psi), 29 | theta = matConverter(modelMatrices$Theta)[varNames,varNames] 30 | ) 31 | 32 | return(output) 33 | } -------------------------------------------------------------------------------- /R/lvglasso.R: -------------------------------------------------------------------------------- 1 | wi2net <- function(x) 2 | { 3 | x <- -cov2cor(x) 4 | diag(x) <- 0 5 | x <- forceSymmetric(x) 6 | return(x) 7 | } 8 | 9 | forcePositive <- function(x){ 10 | if (any(eigen(x)$values<0)){ 11 | cov2cor(x - (min(eigen(x)$values)-.1) * diag(nrow(x))) 12 | } else { 13 | x 14 | } 15 | } 16 | # E-step in the optimization algorithm: 17 | Estep <- function( 18 | S, # Sample covariance 19 | Kcur, # Current estimate for K 20 | obs # Logical indicating observed 21 | ) 22 | { 23 | stopifnot(Matrix::isSymmetric(S)) 24 | if (missing(Kcur)) 25 | { 26 | if (missing(obs)) 27 | { 28 | Kcur <- diag(nrow(S)) 29 | } else 30 | { 31 | Kcur <- diag(length(obs)) 32 | } 33 | } 34 | stopifnot(Matrix::isSymmetric(Kcur)) 35 | if (missing(obs)) obs <- 1:nrow(Kcur) %in% 1:nrow(S) 36 | 37 | # To make life easier: 38 | H <- !obs 39 | O <- obs 40 | 41 | 42 | # Current estimate of S: 43 | Scur <- corpcor::pseudoinverse(Kcur) 44 | 45 | # Expected Sigma_OH: 46 | Sigma_OH <- S %*% corpcor::pseudoinverse(Scur[O,O]) %*% Scur[O, H] 47 | # Sigma_OH 48 | 49 | # Expected Sigma_H: 50 | Sigma_H <- Scur[H, H] - Scur[H,O] %*% corpcor::pseudoinverse(Scur[O,O]) %*% Scur[O,H] + Scur[H,O] %*% corpcor::pseudoinverse(Scur[O,O]) %*% S %*% corpcor::pseudoinverse(Scur[O,O]) %*% Scur[O, H] 51 | 52 | # Construct expected sigma: 53 | Sigma_Exp <- rbind(cbind(S,Sigma_OH),cbind(t(Sigma_OH), Sigma_H)) 54 | 55 | return(Sigma_Exp) 56 | } 57 | 58 | # M-step in the optimization algorithm: 59 | Mstep <- function( 60 | Sexp, # Expected full S 61 | obs, # Logica indiating oberved variables 62 | rho = 0, 63 | lambda 64 | ) 65 | { 66 | if (!is.positive.definite(Sexp)) 67 | { 68 | Sexp <- as.matrix(nearPD(Sexp)$mat) 69 | warning("Expected covariance matrix is not positive definite") 70 | } 71 | # Rho matrix: 72 | n <- nrow(Sexp) 73 | RhoMat <- matrix(rho, n, n) 74 | RhoMat[!obs,] <- 0 75 | RhoMat[,!obs] <- 0 76 | 77 | # Lambda: 78 | zeroes <- which(!lambda, arr.ind = TRUE) 79 | zeroes[,2] <- which(!obs)[zeroes[,2]] 80 | 81 | if (nrow(zeroes) > 0){ 82 | K <- glasso(Sexp, RhoMat, penalize.diagonal=FALSE, zero = zeroes)$wi 83 | } else { 84 | K <- glasso(Sexp, RhoMat, penalize.diagonal=FALSE)$wi 85 | } 86 | 87 | return(K) 88 | } 89 | 90 | ### Main lvglasso function 91 | lvglasso <- function( 92 | S, # Sample cov 93 | nLatents, # Number of latents 94 | rho = 0, # Penalty 95 | thr = 1.0e-4, # Threshold for convergence (sum absolute diff) 96 | maxit = 1e4, # Maximum number of iterations 97 | lambda # Logical matrix indicating the free factor loadings. Defaults to full TRUE matrix. 98 | ) 99 | { 100 | if (missing(nLatents)){ 101 | stop("'nLatents' must be specified") 102 | } 103 | 104 | nobs <- nrow(S) 105 | ntot <- nobs + nLatents 106 | 107 | if (missing(lambda) || is.null(lambda)){ 108 | lambda <- matrix(TRUE, nobs, nLatents) 109 | } 110 | 111 | if (nrow(lambda) != nobs | ncol(lambda) != nLatents) stop("Dimensions of 'lambda' are wrong.") 112 | 113 | # PCA prior for K: 114 | efaRes <- principal(S, nfactors = nLatents) 115 | 116 | # # If sampleSizeis missing, set to 1000. Is only used for prior anyway. 117 | # # if (missing(sampleSize)){ 118 | # sampleSize <- 1000 119 | # # } 120 | # 121 | # # Get prior for K: 122 | # efaRes <- fa(S, n.obs= sampleSize, nfactors=nLatents) 123 | resid <- residuals(efaRes) 124 | class(resid) <- "matrix" 125 | load <- loadings(efaRes) 126 | class(load) <- "matrix" 127 | r <- efaRes$r.scores 128 | class(r) <- "matrix" 129 | r <- diag(diag(r)) 130 | # 131 | # # Stupid nonanalytic way to get prior: 132 | # # Simulate N random variales: 133 | # # eta <- rmvnorm(10000, rep(0, nLatents), r) 134 | # # 135 | # # # Simulate oserved scores: 136 | # # Y <- eta %*% t(load) + rmvnorm(10000, rep(0, nobs), diag(diag(resid) 137 | # RAM FRAMEWORK: 138 | 139 | Sym <- rbind(cbind(diag( efaRes$uniquenesses),matrix(0,nobs,nLatents) ),cbind(t(matrix(0,nobs,nLatents) ),r)) 140 | As <- matrix(0, ntot, ntot) 141 | if (nLatents > 0) As[1:nobs, (nobs+1):ntot] <- load 142 | 143 | Sigma <- solve(diag(ntot) - As) %*% Sym %*% t(solve(diag(ntot) - As)) 144 | 145 | # Compute K: 146 | # browser() 147 | K <- solve(cor2cov(cov2cor(Sigma),c(sqrt(diag(S)), rep(1, nLatents) ))) 148 | # K <- K 149 | # K <- cov2cor(K) 150 | if (!is.positive.definite(K)) 151 | { 152 | K <- as.matrix(nearPD(K)$mat) 153 | # warning("Expected covariance matrix is not positive definite") 154 | } 155 | 156 | # browser() 157 | 158 | # K <- matrix(-0.5,ntot,ntot) 159 | # K[1:nobs,1:nobs] <- 0 160 | # diag(K) <- 1 161 | 162 | # K <- round(K,2) 163 | 164 | # K <- EBICglasso(cov(cbind(Y,eta)), sampleSize) 165 | # K <- as.matrix(forceSymmetric(cbind(rbind(pseudoinverse(resid),t(-load)), rbind(-load,pseudoinverse(r))))) 166 | 167 | # K <- as.matrix(forceSymmetric(cbind(rbind(pseudoinverse(resid),-0.5), rbind(rep(-0.5,nobs),1)))) 168 | # K <- as.matrix(forceSymmetric(cbind(rbind(diag(nrow(S)),t(-load)), rbind(-load,pseudoinverse(r))))) 169 | # browser() 170 | # K <- matrix(-0.5,ntot,ntot) 171 | # K[1:nobs,1:nobs] <- 0 172 | # diag(K) <- 1 173 | # obs <- c(rep(TRUE,nrow(S)), rep(FALSE,nLatents)) 174 | # 175 | # K <- rbind(cbind(2*diag(nobs),-load),cbind(t(-load), 2*diag(ntot - nobs))) 176 | # rownames(K) <- colnames(K) <- NULL 177 | # 178 | # diag(K) <- diag(K) - min(eigen(pseudoinverse(K))$values) 179 | 180 | # # K[1:nobs,1:nobs] <- 0 181 | # diag(K) <- 1 182 | obs <- c(rep(TRUE,nrow(S)), rep(FALSE,nLatents)) 183 | # 184 | # # Stupid prior: 185 | # K <- matrix(0, ntot, ntot) 186 | # diag(K) <- 1 187 | # if (nLatents > 0) K[1:nobs, (nobs+1):ntot] <- K[ (nobs+1):ntot, 1:nobs] <- -1/nobs 188 | 189 | # is.positive.definite(as.matrix(forceSymmetric(Estep(S, K, obs)))) 190 | ### EM ### 191 | it <- 1 192 | Kold <- K 193 | repeat 194 | { 195 | Sexp <- as.matrix(forceSymmetric(Estep(S, K, obs))) 196 | # Sexp <- cor2cov(cov2cor(Sexp),ifelse(obs,sqrt(diag(Sexp)),1)) 197 | K <- as.matrix(forceSymmetric(Mstep(Sexp, obs, rho, lambda))) 198 | # qgraph(wi2net(K), layout = "spring") 199 | 200 | # If not pos def, shift eigenvalues: 201 | K <- forcePositive(K) 202 | 203 | # Check for convergence: 204 | if (sum(abs(cov2cor(corpcor::pseudoinverse(Kold)[obs,obs]) - cov2cor(corpcor::pseudoinverse(K)[obs,obs]))) < thr){ 205 | break 206 | } else { 207 | it <- it + 1 208 | if (it > maxit){ 209 | warning("Algorithm did not converge!") 210 | break 211 | } else { 212 | Kold <- K 213 | } 214 | } 215 | } 216 | 217 | if (!is.null(colnames(S))) 218 | { 219 | colnames(K) <- c(colnames(S),rep(paste0("F",seq_len(nLatents)))) 220 | } 221 | 222 | if (is.null(rownames(S))) 223 | { 224 | rownames(K) <-c(paste0("x",seq_len(ncol(S))),paste0("F",seq_len(nLatents))) 225 | } 226 | 227 | # Partial correlations: 228 | pc <- wi2net(K) 229 | diag(pc) <- 1 230 | 231 | rownames(pc) <- colnames(pc) <- rownames(K) <- colnames(K) 232 | 233 | # Compute psychometric matrices: 234 | Theta <- solve(K[obs, obs]) 235 | Lambda <- -Theta %*% K[obs,!obs] 236 | Psi <- solve(K[!obs, !obs] - t(Lambda) %*% K[obs, obs] %*% Lambda) 237 | 238 | # Return list mimics glasso: 239 | Res <- list( 240 | w = corpcor::pseudoinverse(K), # Estimated covariance matrix 241 | wi = K, # Estimated precision matrix 242 | pcor = pc, # Estimated partial correlation matrix 243 | observed = obs, # observed and latents indicator 244 | niter = it, # Number of iterations used in the algorithm 245 | lambda = Lambda, 246 | theta = Theta, 247 | omega_theta = K[obs, obs], 248 | psi = Psi 249 | ) 250 | 251 | class(Res) <- "lvglasso" 252 | 253 | return(Res) 254 | } 255 | -------------------------------------------------------------------------------- /R/lvnet.R: -------------------------------------------------------------------------------- 1 | # Main function for confirmatory lvnet 2 | setSym <- function(x) { 3 | if (is.matrix(x)){ 4 | return((x + t(x)) / 2) 5 | } else return(x) 6 | } 7 | 8 | countPars <- function(x,tol=sqrt(.Machine$double.eps)){ 9 | Matrices <- x@matrices 10 | # Pars per matrix: 11 | counts <- sapply(Matrices,function(mat){ 12 | symm <- "SymmMatrix" %in% class(mat) 13 | # Index (either full or UT incl diag): 14 | if (symm){ 15 | ix <- upper.tri(mat@values,diag=TRUE) 16 | } else { 17 | ix <- matrix(TRUE,nrow(mat@values),ncol(mat@values)) 18 | } 19 | free <- mat@free 20 | 21 | # sum(abs(mat@values[free & ix]) > tol) 22 | # Collect labels: 23 | length(unique(c(mat$labels[abs(mat@values) > tol & free & ix]))) 24 | }) 25 | 26 | nPar <- sum(counts) 27 | nVar <- ncol(x@data@observed) 28 | nObs <- nVar * (nVar+1) / 2 29 | 30 | return(list(nPar=nPar,DF=nObs - nPar,nObs=nObs,nVar=nVar)) 31 | } 32 | 33 | lvnet <- function( 34 | data, # Raw data or a covariance matrix 35 | lambda, # Lambda design matrix. NA indicates free parameters. If missing and psi is missing, defaults to identity matrix with warning 36 | beta, # Structural matrix. If missing, defaults to zero. 37 | omega_theta, # Observed residual network. If missing, defaults to matrix of zeroes 38 | delta_theta, # Scaling matrix, can be missing 39 | omega_psi, # Latent residual network. If missing, defaults to matrix of zeroes 40 | delta_psi, # Scaling matrix, can be missing 41 | psi, # Latent variance-covariance matrix. If missing, defaults to free 42 | theta, # Used if model = "sem". Defaults to diagonal 43 | sampleSize, 44 | fitInd, 45 | fitSat, 46 | startValues=list(), # Named list of starting values. CAN ALSO BE lvnet OBJECT! 47 | scale = FALSE, # Standardize cov to cor before estimation 48 | nLatents, # allows for quick specification of fully populated lambda matrix. 49 | 50 | # Experimental!!! 51 | lasso = 0, # IF NOT 0, use lasso penalty 52 | lassoMatrix, # Vector of character-string of matrices to apply LASSO penalty on 53 | # optimizer = c("default","SLSQP","NPSOL","CSOLNP") 54 | lassoTol = 1e-4, 55 | ebicTuning = 0.5, 56 | mimic = c("lavaan","lvnet"), 57 | fitFunction = c("penalizedML","ML"), 58 | exogenous # Vector of exogenous variables 59 | 60 | # Optimizer: 61 | # nCores = 1 62 | ){ 63 | fitFunction <- match.arg(fitFunction) 64 | Nvar <- ncol(data) 65 | mimic <- match.arg(mimic) 66 | 67 | # Check args: 68 | if (!missing(lambda) & !missing(nLatents)){ 69 | warning("'nLatents' ignored if 'lambda' is also assigned.") 70 | } 71 | 72 | # if (nCores > 1){ 73 | # mxOption(NULL, "Number of Threads", nCores - 1) 74 | # } else { 75 | # mxOption(NULL, "Number of Threads", NULL) 76 | # } 77 | 78 | # optimizer <- match.arg(optimizer) 79 | # if (optimizer=="default"){ 80 | # if (lasso != 0) 81 | # optimizer <- "NPSOL" 82 | # } else { 83 | # optimizer <- "SLSQP" 84 | # } 85 | # 86 | # # Set optimizer: 87 | # mxOption(NULL,"Default optimizer",optimizer) 88 | 89 | # Check for lasso: 90 | if (lasso != 0){ 91 | if (missing(lassoMatrix)){ 92 | stop ("'lassoMatrix' must not be missing if lasso != 0") 93 | } 94 | if (any(!lassoMatrix %in% c("lambda","psi","omega_psi","theta","omega_theta","beta"))){ 95 | stop("LASSO only supported for 'lambda', 'beta', 'psi', 'omega_psi', 'theta' and 'omega_theta'") 96 | } 97 | } 98 | 99 | # If startvalues is lvnet, add to startvalues: 100 | if (is(startValues,"lvnet") || lasso != 0){ 101 | # if (is(startValues,"lvnet")){ 102 | if (is(startValues,"lvnet")){ 103 | initRes <- startValues 104 | startValues <- list() 105 | } else { 106 | 107 | initRes <- lvnet( 108 | data=data, # Raw data or a covariance matrix 109 | lambda=lambda, # Lambda design matrix. NA indicates free parameters. If missing and psi is missing, defaults to identity matrix with warning 110 | beta=beta, # Structural matrix. If missing, defaults to zero. 111 | omega_theta=omega_theta, # Observed residual network. If missing, defaults to matrix of zeroes 112 | delta_theta=delta_theta, # Scaling matrix, can be missing 113 | omega_psi=omega_psi, # Latent residual network. If missing, defaults to matrix of zeroes 114 | delta_psi=delta_psi, # Scaling matrix, can be missing 115 | psi=psi, # Latent variance-covariance matrix. If missing, defaults to free 116 | theta=theta, # Used if model = "sem". Defaults to diagonal 117 | sampleSize=sampleSize, 118 | fitInd=fitInd, 119 | fitSat=fitSat, 120 | startValues=startValues, 121 | nLatents=nLatents 122 | ) 123 | } 124 | 125 | if (is.null(startValues[['lambda']]) && !is.null(initRes$matrices$lambda) && ncol(initRes$matrices$lambda)>0 && nrow(initRes$matrices$lambda) > 0 && all(is.finite(initRes$matrices$lambda))){ 126 | startValues[['lambda']] <- initRes$matrices$lambda 127 | if (!missing(lambda)){ 128 | startValues[['lambda']] <- startValues[['lambda']] * is.na(lambda) 129 | } 130 | } 131 | if (is.null(startValues[['beta']])&& !is.null(initRes$matrices$beta) && ncol(initRes$matrices$beta)>0 && nrow(initRes$matrices$beta) > 0 && all(is.finite(initRes$matrices$beta))){ 132 | startValues[['beta']] <- initRes$matrices$beta 133 | if (!missing(beta)){ 134 | startValues[['beta']] <- startValues[['beta']] * is.na(beta) 135 | } 136 | } 137 | if (is.null(startValues[['omega_theta']]) && !is.null(initRes$matrices$omega_theta) && ncol(initRes$matrices$omega_theta)>0 && nrow(initRes$matrices$omega_theta) > 0 && all(is.finite(initRes$matrices$omega_theta))){ 138 | startValues[['omega_theta']] <- setSym(initRes$matrices$omega_theta) 139 | if (!missing(omega_theta)){ 140 | startValues[['omega_theta']] <- startValues[['omega_theta']] * is.na(omega_theta) 141 | } 142 | } 143 | if (is.null(startValues[['delta_theta']]) && !is.null(initRes$matrices$delta_theta) && ncol(initRes$matrices$delta_theta)>0 && nrow(initRes$matrices$delta_theta) > 0 && all(is.finite(initRes$matrices$delta_theta))){ 144 | startValues[['delta_theta']] <- setSym(initRes$matrices$delta_theta) 145 | if (!missing(delta_theta)){ 146 | startValues[['delta_theta']] <- startValues[['delta_theta']] * is.na(delta_theta) 147 | } 148 | } 149 | if (is.null(startValues[['omega_psi']]) &&!is.null(initRes$matrices$omega_psi) && ncol(initRes$matrices$omega_psi)>0 && nrow(initRes$matrices$omega_psi) > 0 && all(is.finite(initRes$matrices$omega_psi))){ 150 | startValues[['omega_psi']] <- setSym(initRes$matrices$omega_psi) 151 | if (!missing(omega_psi)){ 152 | startValues[['omega_psi']] <- startValues[['omega_psi']] * is.na(omega_psi) 153 | } 154 | } 155 | if (is.null(startValues[['delta_psi']]) && !is.null(initRes$matrices$delta_psi) && ncol(initRes$matrices$delta_psi)>0 && nrow(initRes$matrices$delta_psi) > 0 && all(is.finite(initRes$matrices$delta_psi))){ 156 | startValues[['delta_psi']] <- setSym(initRes$matrices$delta_psi) 157 | if (!missing(delta_psi)){ 158 | startValues[['delta_psi']] <- startValues[['delta_psi']] * is.na(delta_psi) 159 | } 160 | } 161 | if (is.null(startValues[['psi']]) && !is.null(initRes$matrices$psi) && ncol(initRes$matrices$psi)>0 && nrow(initRes$matrices$psi) > 0 && all(is.finite(initRes$matrices$psi))){ 162 | startValues[['psi']] <- setSym(initRes$matrices$psi) 163 | if (!missing(psi)){ 164 | startValues[['psi']] <- startValues[['psi']] * is.na(psi) 165 | } 166 | } 167 | if (is.null(startValues[['theta']]) && !is.null(initRes$matrices$theta) && ncol(initRes$matrices$theta)>0 && nrow(initRes$matrices$theta) > 0 && all(is.finite(initRes$matrices$theta))){ 168 | startValues[['theta']] <- setSym(initRes$matrices$theta) 169 | if (!missing(theta)){ 170 | startValues[['theta']] <- startValues[['theta']] * is.na(theta) 171 | } 172 | } 173 | if (missing(fitInd)){ 174 | fitInd <- initRes$mxResults$independence 175 | } 176 | if (missing(fitSat)){ 177 | fitInd <- initRes$mxResults$saturated 178 | } 179 | } 180 | 181 | ### Generate model: 182 | mod <- generatelvnetmodel( 183 | data = data, 184 | lambda = lambda, 185 | omega_psi = omega_psi, 186 | omega_theta = omega_theta, 187 | delta_psi = delta_psi, 188 | delta_theta = delta_theta, 189 | psi = psi, 190 | beta = beta, 191 | theta = theta, 192 | sampleSize = sampleSize, 193 | name = "model", 194 | startValues=startValues, 195 | lasso = lasso, 196 | lassoMatrix=lassoMatrix, 197 | scale=scale, 198 | nLatents=nLatents, 199 | mimic=mimic, 200 | fitFunction=fitFunction) 201 | 202 | 203 | # capture.output(fitMod <- OpenMx::mxRun(mod, silent = TRUE, 204 | # suppressWarnings = TRUE),type="message") 205 | fitMod <- OpenMx::mxRun(mod, silent = TRUE, suppressWarnings = TRUE) 206 | 207 | 208 | if (missing(fitSat)){ 209 | # Saturated model: 210 | satMod <- generatelvnetmodel( 211 | data = data, 212 | lambda = diag(Nvar), 213 | psi = matrix(NA,Nvar,Nvar), 214 | theta = matrix(0, Nvar,Nvar), 215 | name = "saturated", 216 | sampleSize = sampleSize, 217 | mimic=mimic, 218 | fitFunction=fitFunction 219 | ) 220 | 221 | capture.output(fitSat <- mxRun(satMod, silent = TRUE, 222 | suppressWarnings = TRUE) ,type="message") 223 | } 224 | 225 | if (missing(fitInd)){ 226 | 227 | # Construct Psi 228 | psiInd <- diag(NA, Nvar, Nvar) 229 | if (!missing(exogenous)){ 230 | if (is.numeric(exogenous)){ 231 | psiInd[exogenous,exogenous] <- NA 232 | } else { 233 | inds <- which(colnames(data) %in% exogenous) 234 | psiInd[exogenous,exogenous] <- NA 235 | } 236 | } 237 | 238 | 239 | # Independence model: 240 | indMod <- generatelvnetmodel( 241 | data = data, 242 | lambda = diag(Nvar), 243 | psi = psiInd, 244 | theta = matrix(0, Nvar, Nvar), 245 | name = "independence", 246 | sampleSize = sampleSize, 247 | mimic=mimic, 248 | fitFunction=fitFunction 249 | ) 250 | 251 | capture.output(fitInd <- mxRun(indMod, silent = TRUE, 252 | suppressWarnings = TRUE),type="message") 253 | } 254 | 255 | if (missing(sampleSize)){ 256 | sampleSize <- nrow(data) 257 | } 258 | 259 | # Estract estimated matrices: 260 | Matrices <- c(lapply(fitMod$matrices,'slot','values'), 261 | lapply(fitMod$algebras,'slot','result')) 262 | 263 | ### COMPUTE RESULTS ### 264 | Results <- list( 265 | matrices = Matrices, 266 | sampleStats = list( 267 | covMat = fitMod$data@observed, 268 | sampleSize = sampleSize 269 | ), 270 | mxResults = list( 271 | model = fitMod, 272 | independence = fitInd, 273 | saturated = fitSat), 274 | fitMeasures = list() 275 | ) 276 | 277 | sigma <- Results$matrices$sigma_positive 278 | S <- Results$sampleStats$covMat 279 | 280 | # fitMod@matrices$omega_theta@values 281 | # fitMod@algebras$penalty 282 | # sum(abs(fitMod@matrices$omega_theta@values[upper.tri(fitMod@matrices$omega_theta@values,FALSE)])) 283 | # 284 | # Compute chi-square: 285 | # if (lasso != 0){ 286 | # Compute DF from non-zero elements 287 | # Count number of non-zero parameters: 288 | # Start with means: 289 | 290 | Pars <- countPars(fitMod, ifelse(lasso==0,sqrt(.Machine$double.eps),lassoTol)) 291 | 292 | # Number of variables: 293 | Results$fitMeasures$nvar <- Pars$nVar 294 | 295 | # Number of observations: 296 | Results$fitMeasures$nobs <- Pars$nObs 297 | 298 | Results$fitMeasures$npar <- Pars$nPar 299 | Results$fitMeasures$df <- Pars$DF 300 | # } else { 301 | # Results$fitMeasures$npar <- summary(fitMod)$estimatedParameters 302 | # Results$fitMeasures$df <- summary(fitMod)$degreesOfFreedom 303 | # } 304 | 305 | # Ncons = samplesize constant. Set to N if mimic = lavaan: 306 | if (mimic == "lavaan"){ 307 | Ncons <- sampleSize 308 | } else { 309 | Ncons <- sampleSize - 1 310 | } 311 | 312 | Results$fitMeasures$fmin <- (sum(diag(S %*% corpcor::pseudoinverse(sigma)))- log(det(S %*% corpcor::pseudoinverse(sigma))) - Nvar)/2 313 | Results$fitMeasures$chisq <- 2 * Ncons * Results$fitMeasures$fmin 314 | Results$fitMeasures$pvalue <- pchisq(Results$fitMeasures$chisq, Results$fitMeasures$df, lower.tail = FALSE) 315 | 316 | # Baseline model: 317 | sigmaBase <- fitInd$algebras$sigma$result 318 | Results$fitMeasures$baseline.chisq <- Ncons * (sum(diag(S %*% corpcor::pseudoinverse(sigmaBase)))- log(det(S %*% corpcor::pseudoinverse(sigmaBase))) - Nvar) 319 | Results$fitMeasures$baseline.df <- countPars(fitInd)$DF 320 | Results$fitMeasures$baseline.pvalue <- pchisq(Results$fitMeasures$baseline.chisq, Results$fitMeasures$baseline.df, lower.tail = FALSE) 321 | 322 | # Incremental Fit Indices 323 | Tb <- Results$fitMeasures$baseline.chisq 324 | Tm <- Results$fitMeasures$chisq 325 | 326 | dfb <- Results$fitMeasures$baseline.df 327 | dfm <- Results$fitMeasures$df 328 | 329 | Results$fitMeasures$nfi <- (Tb - Tm) / Tb 330 | Results$fitMeasures$tli <- (Tb/dfb - Tm/dfm) / (Tb/dfb - 1) 331 | Results$fitMeasures$rfi <- (Tb/dfb - Tm/dfm) / (Tb/dfb ) 332 | Results$fitMeasures$ifi <- (Tb - Tm) / (Tb - dfm) 333 | Results$fitMeasures$rni <- ((Tb- dfb) - (Tm - dfm)) / (Tb - dfb) 334 | Results$fitMeasures$cfi <- ifelse(dfm > Tm, 1, 1 - (Tm - dfm)/(Tb - dfb)) 335 | 336 | # RMSEA 337 | Results$fitMeasures$rmsea <- sqrt( max(Tm - dfm,0) / (Ncons * dfm)) 338 | 339 | # Codes for rmsea confidence interval taken from lavaan: 340 | lower.lambda <- function(lambda) { 341 | (pchisq(Tm, df=dfm, ncp=lambda) - 0.95) 342 | } 343 | if(is.na(Tm) || is.na(dfm)) { 344 | Results$fitMeasures$rmsea.ci.lower <- NA 345 | } else if(dfm < 1 || lower.lambda(0) < 0.0) { 346 | Results$fitMeasures$rmsea.ci.lower <- 0 347 | } else { 348 | if (lower.lambda(0) * lower.lambda(Tm) > 0){ 349 | lambda.l <- NA 350 | } else { 351 | lambda.l <- try(uniroot(f=lower.lambda, lower=0, upper=Tm)$root, 352 | silent=TRUE) 353 | } 354 | Results$fitMeasures$rmsea.ci.lower <- sqrt( lambda.l/(sampleSize*dfm) ) 355 | } 356 | 357 | N.RMSEA <- max(sampleSize, Tm*4) 358 | upper.lambda <- function(lambda) { 359 | (pchisq(Tm, df=dfm, ncp=lambda) - 0.05) 360 | } 361 | if(is.na(Tm) || is.na(dfm)) { 362 | Results$fitMeasures$rmsea.ci.upper <- NA 363 | } else if(dfm < 1 || upper.lambda(N.RMSEA) > 0 || upper.lambda(0) < 0) { 364 | Results$fitMeasures$rmsea.ci.upper <- 0 365 | } else { 366 | 367 | if (upper.lambda(0) * upper.lambda(N.RMSEA) > 0){ 368 | lambda.u <- NA 369 | } else { 370 | 371 | lambda.u <- try(uniroot(f=upper.lambda, lower=0,upper=N.RMSEA)$root, 372 | silent=TRUE) 373 | } 374 | 375 | if(inherits(lambda.u, "try-error")) {lambda.u <- NA } 376 | 377 | Results$fitMeasures$rmsea.ci.upper <- sqrt( lambda.u/(sampleSize*dfm) ) 378 | } 379 | 380 | Results$fitMeasures$rmsea.pvalue <- 381 | 1 - pchisq(Tm, df=dfm, ncp=(sampleSize*dfm*0.05^2)) 382 | 383 | # RMR: 384 | sqrt.d <- 1/sqrt(diag(S)) 385 | D <- diag(sqrt.d, ncol=length(sqrt.d)) 386 | R <- D %*% (S - sigma) %*% D 387 | RR <- (S - sigma) 388 | e <- Nvar*(Nvar+1)/2 + Nvar 389 | 390 | Results$fitMeasures$rmr <- sqrt( sum(RR[lower.tri(RR, diag=TRUE)]^2) / e ) 391 | Results$fitMeasures$srmr <- sqrt( sum(R[lower.tri(R, diag=TRUE)]^2) / e ) 392 | 393 | 394 | # information criteria: 395 | # Saturated log-likelihood: 396 | c <- sampleSize*Nvar/2 * log(2 * pi) 397 | satLL <- ( -c -(sampleSize/2) * log(det(S)) - (sampleSize/2)*Nvar ) 398 | 399 | # log likelihood: 400 | LL <- -sampleSize * (Results$fitMeasures$fmin - satLL/sampleSize) 401 | 402 | Results$fitMeasures$logl <- LL 403 | Results$fitMeasures$unrestricted.logl <- satLL 404 | 405 | Results$fitMeasures$aic <- -2*LL + 2* Results$fitMeasures$npar 406 | 407 | BIC <- -2*LL + Results$fitMeasures$npar * log(sampleSize) 408 | Results$fitMeasures$bic <- BIC 409 | 410 | # add sample-size adjusted bic 411 | N.star <- (sampleSize + 2) / 24 412 | BIC2 <- -2*LL + Results$fitMeasures$npar * log(N.star) 413 | Results$fitMeasures$bic2 <- BIC2 414 | 415 | # Add extended bic: 416 | Results$fitMeasures$ebic <- -2*LL + Results$fitMeasures$npar * log(sampleSize) + 4 * Results$fitMeasures$npar * ebicTuning * log(sampleSize) 417 | 418 | Results$fitMeasures$ebicTuning <- ebicTuning 419 | 420 | class(Results) <- "lvnet" 421 | 422 | return(Results) 423 | } 424 | -------------------------------------------------------------------------------- /R/lvnetLasso.R: -------------------------------------------------------------------------------- 1 | # Fun: 2 | lassoSearchFun <- function(i, tuning, Init, args, verbose, lassoMatrix,nTuning,lassoTol, refitAll = FALSE){ 3 | 4 | if (verbose){ 5 | cat(paste("\rIteration",i, "of ",nTuning)) 6 | # flush.console() 7 | } 8 | 9 | t <- tuning[i] 10 | args$lasso <- t 11 | 12 | Res <- list() 13 | 14 | # Make output: 15 | Res <- list(tuning=t) 16 | 17 | # Fit model: 18 | Res$res <- suppressWarnings( 19 | do.call(lvnet,c(args,list(fitInd = Init$mxResults$independence, 20 | fitSat = Init$mxResults$saturated, 21 | startValues = Init, 22 | fitFunction = "penalizedML")))) 23 | 24 | #data,lassoMatrix=lassoMatrix,lassoTol=lassoTol,lasso=tuning, 25 | 26 | # Refit without LASSO 27 | if (refitAll){ 28 | 29 | newMod <- lapply(lassoMatrix, function(m){ 30 | mat <- Res$res$matrices[[m]] 31 | ifelse(abs(mat) > lassoTol,NA,0) 32 | }) 33 | names(newMod) <- lassoMatrix 34 | 35 | # Structure args: 36 | argsRefit <- args 37 | 38 | # Remove LASSO: 39 | # argsRefit$lasso <- 0 40 | argsRefit <- argsRefit[!names(argsRefit) %in% c("data","lassoMatrix","lassoTol","lasso")] 41 | # argsRefit$data <- NULL 42 | # argsRefit$lassoMatrix <- NULL 43 | # argsRefit$lassoTol <- NULL 44 | 45 | for (i in seq_along(lassoMatrix)){ 46 | argsRefit[[lassoMatrix[[i]]]] <- newMod[[lassoMatrix[[i]]]] 47 | } 48 | 49 | 50 | Res$res <- do.call(lvnet,c(list(data=args$data, 51 | fitInd = Init$mxResults$independence, 52 | fitSat = Init$mxResults$saturated, 53 | startValues = Init),argsRefit)) 54 | 55 | } 56 | 57 | 58 | # Extract fit indices: 59 | Res$fit <- Res$res$fitMeasures 60 | 61 | # Count free parameters in the model matrices: 62 | Res$nPar <- sum(sapply(lassoMatrix, function(m){ 63 | mat <- Res$res$matrices[[m]] 64 | if (m %in% c("lambda","beta")){ 65 | ix <- matrix(TRUE,nrow(mat),ncol(mat)) 66 | } else { 67 | ix <- upper.tri(mat,diag=FALSE) 68 | } 69 | sum(abs(mat[ix]) > lassoTol) 70 | })) 71 | 72 | return(Res) 73 | } 74 | 75 | ### Search function using mutiple lasso estimates: 76 | lvnetLasso <- function( 77 | data, # Data to use 78 | lassoMatrix, # vector of matrices to apply LASSO to 79 | lassoTol = 1e-4, 80 | nTuning = 20, 81 | tuning.min = 0.01, 82 | tuning.max = 0.5, 83 | criterion = c("bic","aic","ebic"), 84 | verbose = TRUE, 85 | refitFinal = TRUE, 86 | refitAll = FALSE, 87 | nCores = 1, # Set to > 1 to use parallel computing 88 | ... # lvnet arguments 89 | ){ 90 | if (any(names(list(...))=="refit")){ 91 | warning("Argument 'refit' has been deprecated, please use refitFinal instead.") 92 | refitFinal <- list(...)[['refit']] 93 | } 94 | refit <- refitFinal 95 | if (refitAll){ 96 | refit <- FALSE 97 | } 98 | 99 | criterion <- match.arg(criterion) 100 | criterion <- switch(criterion, 101 | bic = "bic", 102 | aic = "aic", 103 | ebic = "ebic") 104 | # Full results list: 105 | Results <- list() 106 | 107 | # Tuning sequence: 108 | tuning = exp(seq(log(tuning.min), log(tuning.max), length = nTuning)) 109 | 110 | # Fit inital model to obtain start values and ind/sat: 111 | if (verbose){ 112 | cat("Fitting initial model to obtain start-values and independence/saturated models.\n") 113 | } 114 | 115 | if (missing(lassoMatrix)){ 116 | stop("'lassoMatrix' must be assigned") 117 | } 118 | if (length(lassoMatrix) > 1){ 119 | warning("Multiple matrices in LASSO is not recommended. Use sequential estimation (e.g., first, omega_theta, then omega_psi).") 120 | } 121 | 122 | Init <- suppressWarnings(lvnet(data,...)) 123 | 124 | ### 125 | args <- c(list(data=data,lassoMatrix=lassoMatrix,lassoTol=lassoTol),list(...)) 126 | 127 | ### MAIN LOOP ### 128 | if (nCores == 1){ 129 | 130 | Results <- lapply(seq_len(nTuning),lassoSearchFun,tuning=tuning, Init=Init, args=args, verbose=verbose, lassoMatrix=lassoMatrix,nTuning=nTuning,lassoTol=lassoTol,refitAll=refitAll) 131 | 132 | } else { 133 | # Number of clusters: 134 | nClust <- nCores - 1 135 | 136 | # Make cluster: 137 | cl <- makePSOCKcluster(nClust) 138 | 139 | if (verbose){ 140 | cat("Estimating LASSO penalized models.\n") 141 | } 142 | 143 | # Run loop: 144 | Results <- parallel::parLapply(cl,seq_len(nTuning),lassoSearchFun,tuning=tuning, Init=Init, args=args, verbose=FALSE, lassoMatrix=lassoMatrix,nTuning=nTuning,lassoTol=lassoTol,refitAll=refitAll) 145 | 146 | # Stop cluster: 147 | stopCluster(cl) 148 | } 149 | 150 | 151 | # Create fit table: 152 | Fits <- as.data.frame(do.call(rbind,lapply(Results,function(x)unlist(x[['fit']])))) 153 | 154 | # Select best: 155 | if (!criterion %in% names(Fits)){ 156 | stop("Criterion is not supported") 157 | } 158 | best <- which.min(Fits[[criterion]][Fits[["df"]]>=0]) 159 | 160 | if (length(best) == 0){ 161 | stop("No identified model found.") 162 | } 163 | 164 | # Refit best model without lasso: 165 | dots <- args <- list(...) 166 | 167 | if (refit){ 168 | if (verbose){ 169 | cat("\nRe-fitting best model.\n") 170 | } 171 | newMod <- lapply(lassoMatrix, function(m){ 172 | mat <- Results[[best]]$res$matrices[[m]] 173 | ifelse(abs(mat) > lassoTol,NA,0) 174 | }) 175 | names(newMod) <- lassoMatrix 176 | 177 | for (i in seq_along(lassoMatrix)){ 178 | dots[[lassoMatrix[[i]]]] <- newMod[[lassoMatrix[[i]]]] 179 | } 180 | 181 | bestModel <- do.call(lvnet,c(list(data=data, 182 | fitInd = Init$mxResults$independence, 183 | fitSat = Init$mxResults$saturated, 184 | startValues = Init), 185 | dots)) 186 | 187 | } else { 188 | bestModel <- Results[[best]]$res 189 | } 190 | 191 | Output <- list( 192 | best = bestModel, 193 | modList = lapply(Results,'[[','res'), 194 | tuning = sapply(Results,'[[','tuning'), 195 | lassoMatrix = lassoMatrix, 196 | args = c(list(data=data, 197 | fitInd = Init$mxResults$independence, 198 | fitSat = Init$mxResults$saturated, 199 | startValues = Init), 200 | args), 201 | criterion = criterion, 202 | bestID = best 203 | ) 204 | 205 | class(Output) <- "lvnetLasso" 206 | 207 | return(Output) 208 | } -------------------------------------------------------------------------------- /R/lvnetSearch.R: -------------------------------------------------------------------------------- 1 | # Some helper functions: 2 | curMat2modMat <- function(x, matrix){ 3 | x <- ifelse(x,NA,0) 4 | if (grepl("omega",matrix)){ 5 | diag(x) <- 0 6 | } else { 7 | if (matrix=="psi"){ 8 | diag(x) <- 1 9 | } else { 10 | diag(x) <- NA 11 | } 12 | } 13 | return(x) 14 | } 15 | 16 | maxNull <- function(x){ 17 | if (length(x[!is.na(x)])==0) return(0) else return(max(x,na.rm=TRUE)) 18 | } 19 | 20 | # Search logic: TO DOCUMENT: 21 | # Start with initial maxChange 22 | # Change min(all, maxChange) improving edges. 23 | # Set maxChange to max(# changed edges - 1,1) 24 | # repeat until convergence 25 | 26 | lvnetSearch <- function( 27 | data, 28 | matrix = c("omega_theta","omega_psi","theta","psi"), # Matrix to optimize 29 | criterion = c("bic", "ebic","chisq","aic"), # Chisquare will attempt to remove edge with no sig difference, and otherwise add edge with sig difference. 30 | start = c("default","empty","full"), # CAN ALSO BE MATRIX "glasso" & "lvglasso" currently disabled. glasso runs glasso on Psi or misfit, after running CFA 31 | alpha = 0.05, 32 | lambda, 33 | sampleSize, 34 | maxIter, 35 | nCores = 1, # Set to > 1 to use parallel computing 36 | maxChange = 1, # Set by default to 1 if start = "empty" and all possible edges if start = "full". 37 | ..., # Arguments sent to lvnet 38 | # lvglassoArgs = list(gamma = 0, nRho = 20), # Arguments sent to ebiclvglasso 39 | # glassoArgs = list(gamma = 0.5, nlambda = 100), # Arguments sent to ebicglasso 40 | verbose = TRUE, 41 | file, # If not missing, reads file to continue and stores results to file. 42 | startValues = list() 43 | ){ 44 | if (!is.matrix(start)){ 45 | start <- start[1] 46 | stopifnot(start %in% c("default","empty","full")) 47 | } 48 | matrix <- match.arg(matrix) 49 | criterion <- match.arg(criterion) 50 | 51 | if (criterion %in% c("aic","bic","ebic")){ 52 | criterion <- toupper(criterion) 53 | } 54 | 55 | # start <- match.arg(start) 56 | 57 | if (ncol(data) == nrow(data) && isSymmetric(unname(data))){ 58 | if (missing(sampleSize)){ 59 | stop("sampleSize needs to be assigned if input is covariance matrix.") 60 | } 61 | 62 | covmat <- data * (sampleSize - 1)/sampleSize 63 | rownames(covmat) <- colnames(covmat) 64 | 65 | } else { 66 | sampleSize <- nrow(data) 67 | 68 | data <- as.matrix(data) 69 | covmat <- cov(data, use = "pairwise.complete.obs")* (sampleSize - 1)/sampleSize 70 | } 71 | 72 | if (missing(lambda)){ 73 | message("Fitting network without latent variables") 74 | lambda <- matrix(,ncol(covmat),0) 75 | } 76 | 77 | if (is.matrix(start)){ 78 | curMat <- start 79 | } else { 80 | if (start == "lvglasso" & matrix != "omega_theta"){ 81 | stop("start = 'lvglasso' only supports matrix = 'omega_theta'") 82 | } 83 | 84 | Nvar <- nrow(lambda) 85 | Nlat <- ncol(lambda) 86 | 87 | # Select start: 88 | if(start=="default"){ 89 | # if (matrix=="omega_theta"){ 90 | # start <- "empty" 91 | # # if (Nlat > 0){ 92 | # # start <- "lvglasso" 93 | # # } else { 94 | # # start <- "glasso" 95 | # # } 96 | # } else { 97 | if (matrix %in% c("psi","omega_psi")){ 98 | start <- "full" 99 | } else start <- "empty" 100 | # } 101 | } 102 | 103 | if (matrix %in% c("omega_theta","theta")){ 104 | 105 | curMat <- matrix(start == "full", Nvar, Nvar) 106 | 107 | } else { 108 | 109 | curMat <- matrix(start == "full", Nlat, Nlat) 110 | } 111 | } 112 | 113 | 114 | # if (start == "lvglasso"){ 115 | # stop("'lvglasso' start not supported") 116 | # if (verbose){ 117 | # message("Estimating optimal lvglasso result") 118 | # } 119 | # 120 | # lvglassoRes <- do.call("ebiclvglasso", c(list(S=covmat, n = sampleSize, nLatents = Nlat), lvglassoArgs )) 121 | # startValues$omega_theta <- lvglassoRes$omega_theta 122 | # curMat <- lvglassoRes$omega_theta!=0 123 | # 124 | # } else if (start == "glasso"){ 125 | # browser() 126 | # 127 | # if (matrix %in% c("theta","psi")){ 128 | # stop("'glasso' is not a valid start for optimizing theta or psi.") 129 | # } 130 | # 131 | # if (verbose){ 132 | # message("Estimating starting matrix") 133 | # } 134 | # 135 | # # Start args: 136 | # lvnetArgs_start <- list(...) 137 | # lvnetArgs_start$data <- covmat 138 | # lvnetArgs_start$sampleSize <- sampleSize 139 | # lvnetArgs_start$lambda <- lambda 140 | # lvnetArgs_start$startValues <- startValues 141 | # 142 | # if (verbose){ 143 | # message("Estimating initial lvnet model") 144 | # } 145 | # 146 | # 147 | # if (matrix == "omega_theta"){ 148 | # lvnetArgs_start[[matrix]] <- curMat2modMat(matrix(0, Nvar, Nvar), matrix) 149 | # startMod <- do.call("lvnet", lvnetArgs_start) 150 | # 151 | # # Misfit: 152 | # misFit <- startMod$sampleStats$covMat - startMod$matrices$sigma + startMod$matrices$theta 153 | # 154 | # # make positive definite: 155 | # if (any(eigen(misFit)$values < 0)){ 156 | # misFit <- misFit - diag(min(eigen(misFit)$values) - 0.0001, ncol(misFit)) 157 | # } 158 | # 159 | # # Run glasso: 160 | # glassoRes <- do.call(qgraph::ebicglasso, c(list(S=misFit, n = sampleSize), glassoArgs )) 161 | # 162 | # } 163 | # 164 | # 165 | # 166 | # 167 | # glassoRes <- do.call(qgraph::ebicglasso, c(list(S=covmat, n = sampleSize), glassoArgs )) 168 | # startValues$omega_theta <- glassoRes 169 | # curMat <- glassoRes!=0 170 | # 171 | # } else 172 | 173 | 174 | 175 | if (missing(maxIter)) maxIter <- ncol(curMat) * (ncol(curMat)-1) / 2 176 | # Empty model list: 177 | # modList <- list() 178 | 179 | # Compute first model: 180 | lvnetArgs <- list(...) 181 | lvnetArgs$data <- covmat 182 | lvnetArgs$sampleSize <- sampleSize 183 | lvnetArgs$lambda <- lambda 184 | lvnetArgs[[matrix]] <- curMat2modMat(curMat, matrix) 185 | lvnetArgs$startValues <- startValues 186 | 187 | if (verbose){ 188 | message("Estimating initial lvnet model") 189 | } 190 | 191 | curMod <- do.call("lvnet", lvnetArgs) 192 | it <- 0 193 | 194 | if (missing(maxChange)){ 195 | if (all(curMat)){ 196 | maxChange <- Inf 197 | } else { 198 | maxChange <- 1 199 | } 200 | } 201 | 202 | lvnetArgs$fitInd <- curMod$mxResults$independence 203 | lvnetArgs$fitSat <- curMod$mxResults$saturated 204 | 205 | upTriElements <- which(upper.tri(curMat, diag=FALSE), arr.ind=TRUE) 206 | 207 | repeat{ 208 | curEst <- curMod$matrices[[matrix]] 209 | it <- it + 1 210 | if (it > maxIter){ 211 | warning("Maximum number of iterations reached") 212 | break 213 | } 214 | # modList <- c(modList,list(curMod)) 215 | if (!missing(file)){ 216 | save(it,curMod,lvnetArgs,curMat,file=file) 217 | } 218 | 219 | propModels <- vector("list", nrow(upTriElements)) 220 | 221 | ### Now using lapply: 222 | if (nCores == 1){ 223 | if (verbose){ 224 | # message(paste("Iteration:",it)) 225 | pb <- txtProgressBar(0, nrow(upTriElements), style = 3) 226 | } 227 | 228 | for (i in seq_len(nrow(upTriElements))){ 229 | propMat <- curMat 230 | propMat[upTriElements[i,1],upTriElements[i,2]] <- propMat[upTriElements[i,2],upTriElements[i,1]] <- 231 | !curMat[upTriElements[i,1],upTriElements[i,2]] 232 | 233 | lvnetArgs[[matrix]] <- curMat2modMat(propMat, matrix) 234 | lvnetArgs$startValues[[matrix]] <- curEst * propMat 235 | propModels[[i]] <- try(do.call("lvnet", lvnetArgs),silent = TRUE) 236 | if (is(propModels[[i]],"try-error")){ 237 | propModels[[i]] <- curMod 238 | propModels[[i]]$fitMeasures[c("aic","bic","ebic")] <- Inf 239 | if (curMat[upTriElements[i,1],upTriElements[i,2]]){ 240 | propModels[[i]]$fitMeasures[c("chisq")] <- 0 241 | } else { 242 | propModels[[i]]$fitMeasures[c("chisq")] <- Inf 243 | } 244 | } 245 | 246 | 247 | if (verbose){ 248 | setTxtProgressBar(pb, i) 249 | } 250 | } 251 | if (verbose) close(pb) 252 | } else { 253 | if (verbose){ 254 | message(paste("Iteration:",it)) 255 | } 256 | # Number of clusters: 257 | nClust <- nCores - 1 258 | 259 | # Make cluster: 260 | cl <- makePSOCKcluster(nClust) 261 | 262 | # Export stuff: 263 | clusterExport(cl, c("curMat","upTriElements","lvnetArgs","curMat2modMat", 264 | "matrix","lvnet","curEst","lvnetArgs"), envir = environment()) 265 | 266 | propModels <- parLapply(cl, seq_len(nrow(upTriElements)), function(i){ 267 | propMat <- curMat 268 | propMat[upTriElements[i,1],upTriElements[i,2]] <- propMat[upTriElements[i,2],upTriElements[i,1]] <- 269 | !curMat[upTriElements[i,1],upTriElements[i,2]] 270 | 271 | lvnetArgs[[matrix]] <- curMat2modMat(propMat, matrix) 272 | lvnetArgs$startValues[[matrix]] <- curEst * propMat 273 | propModels[[i]] <- try(do.call("lvnet", lvnetArgs),silent = TRUE) 274 | if (is(propModels[[i]],"try-error")){ 275 | propModels[[i]] <- curMod 276 | propModels[[i]]$fitMeasures[c("aic","bic","ebic")] <- Inf 277 | if (curMat[upTriElements[i,1],upTriElements[i,2]]){ 278 | propModels[[i]]$fitMeasures[c("chisq")] <- 0 279 | } else { 280 | propModels[[i]]$fitMeasures[c("chisq")] <- Inf 281 | } 282 | } 283 | }) 284 | 285 | # Stop cluster: 286 | stopCluster(cl) 287 | } 288 | 289 | 290 | 291 | # Create table: 292 | origFit <- anova(curMod)[-1,,drop=FALSE] 293 | fits <- do.call(lvnetCompare,propModels)[-1,,drop=FALSE] 294 | 295 | 296 | if (criterion %in% c("AIC","BIC","EBIC")){ 297 | fits[[criterion]][is.na(fits[[criterion]])] <- Inf 298 | 299 | # Any is better? 300 | if (!any(fits[[criterion]] < origFit[[criterion]])){ 301 | break 302 | } else { 303 | 304 | # # Which best? 305 | # best <- which.min(fits[[criterion]]) 306 | # Select set of best edges: 307 | 308 | nImprove <- sum(fits[[criterion]] < origFit[[criterion]]) 309 | best <- order(fits[[criterion]],decreasing=FALSE)[1:min(nImprove,maxChange)] 310 | } 311 | } else { 312 | # Test if parameter is currently an edge or not: 313 | curEdge <- curMat[upper.tri(curMat,diag=FALSE)] 314 | 315 | # Obtain the Chi-square of current model: 316 | curChisq <- curMod$fitMeasures$chisq 317 | curDF <- curMod$fitMeasures$df 318 | 319 | # Obtain the chi-squares of proposed models: 320 | propChisq <- fits$Chisq 321 | propDF <- fits$Df 322 | 323 | # Compute the p-values of chi-square difference tests: 324 | Pvals <- pchisq(abs(curChisq-propChisq), abs(curDF - propDF), lower.tail=FALSE) 325 | 326 | # If not currently edge, adding an edge should significantly improve fit (p < 0.05). 327 | # If currently an edge, removing that edge should *not* significantly worsen fit (p > 0.05) 328 | # Prioritize removing edges 329 | 330 | PvalsNAmax <- ifelse(is.na(Pvals),1,Pvals) 331 | PvalsNAmin <- ifelse(is.na(Pvals),0,Pvals) 332 | 333 | # Edges that can be removed: 334 | improveRemoved <- which(curEdge & PvalsNAmin > alpha) 335 | 336 | # Relative rank how well they can be removed: 337 | scoreRemoved <- rank(-PvalsNAmin[improveRemoved],ties.method = "random") 338 | 339 | # edges that can be added: 340 | improveAdded <- which(!curEdge & PvalsNAmax < alpha) 341 | 342 | 343 | # Relative rank how well they can be added: 344 | scoreAdded <- rank(PvalsNAmax[improveAdded],ties.method = "random") + maxNull(scoreRemoved) 345 | 346 | # Combine: 347 | improve <- c(improveRemoved,improveAdded) 348 | score <- c(scoreRemoved,scoreAdded) 349 | 350 | # Number that can be improved: 351 | nImprove <- length(improve) 352 | 353 | if (nImprove==0){ 354 | break 355 | } 356 | best <- improve[order(score,decreasing=FALSE)][1:min(nImprove,maxChange)] 357 | } 358 | 359 | # Number of edges to change: 360 | nChange <- length(best) 361 | 362 | if (verbose){ 363 | if (nChange > 1) { 364 | message(paste("Changing",nChange,"edges")) 365 | } else { 366 | message(paste("Changing",nChange,"edge")) 367 | } 368 | } 369 | 370 | # Update the current matrix: 371 | for (b in best){ 372 | curMat[upTriElements[b,1],upTriElements[b,2]] <- curMat[upTriElements[b,2],upTriElements[b,1]] <- 373 | !curMat[upTriElements[b,1],upTriElements[b,2]] 374 | 375 | 376 | } 377 | 378 | # Set new model: 379 | if (nChange > 1){ 380 | lvnetArgs[[matrix]] <- curMat2modMat(curMat, matrix) 381 | lvnetArgs$startValues[[matrix]] <- curEst * curMat 382 | curMod <- do.call("lvnet", lvnetArgs) 383 | } else { 384 | # Compute new current model: 385 | curMod <- propModels[[best]] 386 | } 387 | 388 | 389 | # Set the maxChange counter: 390 | maxChange <- max(length(best)-1,1) 391 | 392 | } 393 | 394 | Results <- list( 395 | best = curMod, 396 | # modList = modList, 397 | niter = it, 398 | criterion = criterion) 399 | 400 | class(Results) <- c("lvnetSearch","list") 401 | return(Results) 402 | } 403 | -------------------------------------------------------------------------------- /R/methods.R: -------------------------------------------------------------------------------- 1 | summary.lvnet <- function(object, include = c('input','chisq','infcrit','fitindices','rmsea','parests'), digits = 3,...){ 2 | 3 | cat("========== lvnet ANALYSIS RESULTS ========== ") 4 | 5 | if ('input' %in% include){ 6 | cat( 7 | "\n\nInput:", 8 | "\n\tModel:\t\t\t",object$model, 9 | "\n\tNumber of manifests:\t",ncol(object$sampleStats$covMat), 10 | "\n\tNumber of latents:\t",ncol(object$matrices$lambda), 11 | "\n\tNumber of parameters:\t",object$fitMeasures$npar, 12 | "\n\tNumber of observations\t",object$sampleStats$sampleSize 13 | ) 14 | } 15 | 16 | if ('chisq' %in% include){ 17 | cat( 18 | "\n\nTest for exact fit:", 19 | "\n\tChi-square:\t\t",round(object$fitMeasures$chisq,digits), 20 | "\n\tDF:\t\t\t",round(object$fitMeasures$df,digits), 21 | "\n\tp-value:\t\t",round(object$fitMeasures$pvalue,digits) 22 | ) 23 | } 24 | 25 | if ('infcrit' %in% include){ 26 | cat( 27 | "\n\nInformation criteria:", 28 | "\n\tAIC:\t\t\t",round(object$fitMeasures$aic,digits), 29 | "\n\tBIC:\t\t\t",round(object$fitMeasures$bic,digits), 30 | "\n\tAdjusted BIC:\t\t",round(object$fitMeasures$bic2,digits), 31 | "\n\tExtended BIC:\t\t",round(object$fitMeasures$ebic,digits) 32 | ) 33 | } 34 | 35 | if ('fitindices' %in% include){ 36 | cat( 37 | "\n\nFit indices:", 38 | "\n\tCFI:\t\t\t",round(object$fitMeasures$cfi,digits), 39 | "\n\tNFI:\t\t\t",round(object$fitMeasures$nfi,digits), 40 | "\n\tTLI:\t\t\t",round(object$fitMeasures$tli,digits), 41 | "\n\tRFI:\t\t\t",round(object$fitMeasures$rfi,digits), 42 | "\n\tIFI:\t\t\t",round(object$fitMeasures$ifi,digits), 43 | "\n\tRNI:\t\t\t",round(object$fitMeasures$rni,digits), 44 | "\n\tRMR:\t\t\t",round(object$fitMeasures$rmr,digits), 45 | "\n\tSRMR:\t\t\t",round(object$fitMeasures$srmr,digits) 46 | ) 47 | 48 | } 49 | 50 | if ('rmsea' %in% include){ 51 | cat( 52 | "\n\nRMSEA:", 53 | "\n\tRMSEA:\t\t\t",round(object$fitMeasures$rmsea,digits), 54 | "\n\t90% CI lower bound:\t",round(object$fitMeasures$rmsea.ci.lower,digits), 55 | "\n\t90% CI upper bound:\t",round(object$fitMeasures$rmsea.ci.upper,digits), 56 | "\n\tp-value:\t\t",round(object$fitMeasures$rmsea.pvalue,digits) 57 | ) 58 | } 59 | 60 | if ('parests' %in% include){ 61 | cat("\n\nParameter estimates:\n") 62 | sum <- summary(object$mxResults$model) 63 | parMat <- sum$parameters 64 | 65 | # if theta_inverse in name, compute omega_theta and delta_theta: 66 | if (any(grepl("theta_inverse",parMat$name))){ 67 | 68 | theta_inverse <- parMat %>% filter_(~matrix == "theta_inverse") 69 | # Compute variance: 70 | theta_inverse <- theta_inverse %>% mutate_(var = ~Std.Error^2) 71 | # Obtain diagonals: 72 | diag_theta_inverse <- theta_inverse %>% filter(row==col) %>% select_(~row,diag=~Estimate) 73 | # Add to matrix: 74 | theta_inverse <- theta_inverse %>% left_join(diag_theta_inverse %>% rename_(diagI = ~diag), by = "row") %>% 75 | left_join(diag_theta_inverse %>% rename_(diagJ = ~diag), by = c("col" = "row")) 76 | 77 | # Compute pcors and standard deviations: 78 | theta_inverse <- theta_inverse %>% mutate_( 79 | Estimate = ~-Estimate / (sqrt(diagI)*sqrt(diagJ)), 80 | Std.Error = ~(-1/ (sqrt(diagI)*sqrt(diagJ)))^2 * Std.Error 81 | ) 82 | theta_inverse$matrix <- "omega_theta" 83 | theta_inverse <- theta_inverse %>% filter(row != col) 84 | 85 | # compute delta_theta: 86 | delta_theta <- parMat %>% filter_(~matrix == "theta_inverse") %>% 87 | filter_(~row==col) %>% mutate_(Estimate = ~1/sqrt(Estimate)) 88 | delta_theta$matrix <- "delta_theta" 89 | 90 | 91 | parMat <- dplyr::bind_rows(parMat[parMat$matrix != "theta_inverse",],theta_inverse,delta_theta) 92 | } 93 | 94 | parMat[['Estimate']] <- round(parMat[['Estimate']],digits) 95 | parMat[['Std.Error']] <- round(parMat[['Std.Error']],digits) 96 | print.data.frame(parMat[,c('matrix','row','col','name','Estimate')], row.names=FALSE) 97 | } 98 | 99 | } 100 | 101 | print.lvnet <- function(x,...){ 102 | name <- deparse(substitute(x))[[1]] 103 | if (nchar(name) > 10) name <- "object" 104 | if (name=="x") name <- "object" 105 | 106 | cat("\nlvnet estimation completed.:\n", 107 | paste0("\t- Chi-square (",x$fitMeasures$df,") = ",round(x$fitMeasures$chisq,2),", p = ",round(x$fitMeasures$pvalue,2),"\n"), 108 | paste0("\t- RMSEA = ",round(x$fitMeasures$rmsea,2)," (95% CI: ",round(x$fitMeasures$rmsea.ci.lower,2)," - ",round(x$fitMeasures$rmsea.ci.upper,2),")\n") 109 | ) 110 | 111 | ### Tips 112 | cat("\n", 113 | paste0("Use summary(",name,") to inspect more fitmeasures and parameter estimates (see ?summary.lvnet)"), 114 | "\n", 115 | paste0("Use plot(",name,") to plot estimated networks and factor structures (see ?plot.lvnet)"), 116 | "\n", 117 | paste0("Use lvnetCompare(object1, object2) to compare lvnet models (see ?lvnetCompare)") 118 | ) 119 | } 120 | 121 | 122 | 123 | # lasso and search print and summary: 124 | summary.lvnetSearch <- summary.lvnetLasso <- function(object,...){ 125 | summary(object$best,...) 126 | } 127 | 128 | print.lvnetLasso <- function(x,...){ 129 | name <- deparse(substitute(x))[[1]] 130 | if (nchar(name) > 10) name <- "object" 131 | if (name=="x") name <- "object" 132 | 133 | cat("\nlvnetLasso completed:\n", 134 | paste0("\t- Criterion used: ",x$criterion,"\n"), 135 | paste0("\t- # tuning parameters: ",length(x$tuning),"\n"), 136 | paste0("\t- # tuning parameter range: ",min(x$tuning)," - ",max(x$tuning), "\n") 137 | ) 138 | 139 | cat("\nBest model:\n", 140 | paste0("\t- Tuning: ",round(x$tuning[x$bestID],2)),"\n", 141 | paste0("\t- Chi-square (",x$best$fitMeasures$df,") = ",round(x$best$fitMeasures$chisq,2),", p = ",round(x$best$fitMeasures$pvalue,2),"\n"), 142 | paste0("\t- RMSEA = ",round(x$best$fitMeasures$rmsea,2)," (95% CI: ",round(x$best$fitMeasures$rmsea.ci.lower,2)," - ",round(x$best$fitMeasures$rmsea.ci.upper,2),")\n") 143 | ) 144 | 145 | ### Tips 146 | cat("\n", 147 | paste0("Best model is stored under ",name,"$best"), 148 | "\n", 149 | paste0("Use summary(",name,") to inspect best model (see ?summary.lvnet)"), 150 | "\n", 151 | paste0("Use plot(",name,") to plot best model (see ?plot.lvnet)"), 152 | "\n", 153 | paste0("Use lvnetCompare(object1, object2) to compare lvnet models (see ?lvnetCompare)") 154 | ) 155 | } 156 | 157 | 158 | 159 | print.lvnetSearch <- function(x,...){ 160 | name <- deparse(substitute(x))[[1]] 161 | if (nchar(name) > 10) name <- "object" 162 | if (name=="x") name <- "object" 163 | 164 | cat("\nlvnetSearch completed:\n", 165 | paste0("\t- Criterion used: ",x$criterion,"\n"), 166 | paste0("\t- # iterations: ",length(x$nIter),"\n") 167 | ) 168 | 169 | cat("\nBest model:\n", 170 | paste0("\t- Chi-square (",x$best$fitMeasures$df,") = ",round(x$best$fitMeasures$chisq,2),", p = ",round(x$best$fitMeasures$pvalue,2),"\n"), 171 | paste0("\t- RMSEA = ",round(x$best$fitMeasures$rmsea,2)," (95% CI: ",round(x$best$fitMeasures$rmsea.ci.lower,2)," - ",round(x$best$fitMeasures$rmsea.ci.upper,2),")\n") 172 | ) 173 | 174 | ### Tips 175 | cat("\n", 176 | paste0("Best model is stored under ",name,"$best"), 177 | "\n", 178 | paste0("Use summary(",name,") to inspect best model (see ?summary.lvnet)"), 179 | "\n", 180 | paste0("Use plot(",name,") to plot best model (see ?plot.lvnet)"), 181 | "\n", 182 | paste0("Use lvnetCompare(object1, object2) to compare lvnet models (see ?lvnetCompare)") 183 | ) 184 | } 185 | 186 | 187 | 188 | 189 | # Plot method: 190 | plot.lvnetSearch <- plot.lvnetLasso <- function(x,...) plot.lvnet(x$best,...) 191 | 192 | plot.lvnet <- function(x, 193 | what = c("factorStructure","residual","latent"), 194 | partial, # Should partial correlations be plotted? defaults to TRUE if partial correlations are modeled 195 | layout = "circle", 196 | ... # Arguments sent to qgraph 197 | ){ 198 | 199 | what <- match.arg(what) 200 | 201 | if (what == "factorStructure"){ 202 | # get Lambda: 203 | Lambda <- x$matrices$lambda 204 | 205 | # Get residual variances: 206 | residVar <- diag(x$matrices$theta) 207 | 208 | # Is omega_psi estimated? 209 | if (missing(partial)){ 210 | partial <- any(grepl("omega_psi",names(x$mxResults$model@output$matrices))) 211 | } 212 | 213 | if (!partial){ 214 | graph <- qgraph::qgraph.loadings(Lambda, model = "reflective", factorCors = x$matrices$psi, resid=residVar,layout = layout, ...) 215 | } else { 216 | graph <- qgraph::qgraph.loadings(Lambda, model = "reflective", factorCors = x$matrices$omega_psi, DoNotPlot=TRUE, layout = layout, ...) 217 | graph$Edgelist$bidirectional[] <- FALSE 218 | graph$Edgelist$directed[graph$Edgelist$to > nrow(Lambda)] <- FALSE 219 | plot(graph) 220 | } 221 | } else if (what == "latent"){ 222 | 223 | # Partial? 224 | if (missing(partial)){ 225 | partial <- any(grepl("omega_psi",names(x$mxResults$model@output$matrices))) 226 | } 227 | 228 | if (partial){ 229 | graph <- qgraph::qgraph(x$matrices$omega_psi,layout = layout,...) 230 | } else { 231 | graph <- qgraph::qgraph(cov2cor(x$matrices$psi),directed=TRUE,bidirectional=TRUE,layout = layout,...) 232 | } 233 | 234 | } else if (what == "residual"){ 235 | 236 | # Partial? 237 | if (missing(partial)){ 238 | partial <- any(grepl("theta_inverse",names(x$mxResults$model@output$matrices))) 239 | } 240 | 241 | if (partial){ 242 | graph <- qgraph::qgraph(x$matrices$omega_theta,layout = layout,...) 243 | } else { 244 | graph <- qgraph::qgraph(cov2cor(x$matrices$theta),directed=TRUE,bidirectional=TRUE,layout = layout,...) 245 | } 246 | 247 | } else stop("Graph not supported.") 248 | 249 | invisible(graph) 250 | } 251 | 252 | 253 | 254 | 255 | 256 | -------------------------------------------------------------------------------- /R/modelComparison.R: -------------------------------------------------------------------------------- 1 | lvnetCompare <- function(...){ 2 | 3 | dots <- list(...) 4 | 5 | # Combine lvnet objects: 6 | # LASSO objectS: 7 | lvnetLasObj <- dots[sapply(dots,is,"lvnetLasso")] 8 | lvnetObjects <- dots[sapply(dots,is,"lvnet")] 9 | 10 | if (length(lvnetLasObj) > 0){ 11 | for (i in seq_along(lvnetLasObj)){ 12 | lvnetObjects <- c(lvnetObjects,lvnetLasObj[[i]]$modList) 13 | } 14 | 15 | } 16 | 17 | if (length(lvnetObjects) == 0){ 18 | stop("No 'lvnet' models in input.") 19 | } 20 | 21 | if (is.null(names(lvnetObjects))){ 22 | names(lvnetObjects) <- paste("Model",seq_along(lvnetObjects)) 23 | } 24 | 25 | # Create rows: 26 | DF <- rbind(data.frame(Df = 0, AIC = NA, 27 | BIC = NA, 28 | EBIC = NA, 29 | Chisq = 0), 30 | do.call(rbind, lapply(lvnetObjects,function(x){ 31 | data.frame(Df = x$fitMeasures$df, AIC = x$fitMeasures$aic, 32 | BIC = x$fitMeasures$bic, 33 | EBIC = x$fitMeasures$ebic, 34 | Chisq = x$fitMeasures$chisq) 35 | })) 36 | ) 37 | 38 | rownames(DF) <- c("Saturated",names(lvnetObjects)) 39 | 40 | DF[['Chisq diff']] <- c(NA,abs(diff(DF[['Chisq']]))) 41 | DF[['Df diff']] <- c(NA,abs(diff(DF[['Df']]))) 42 | DF[['Pr(>Chisq)']] <- pchisq( DF[['Chisq diff']], DF[['Df diff']], lower.tail=FALSE) 43 | 44 | return(DF) 45 | } 46 | 47 | anova.lvnet <- function(object,...) lvnetCompare(object,...) 48 | -------------------------------------------------------------------------------- /R/plot.R: -------------------------------------------------------------------------------- 1 | # Plotting function: 2 | plot.lvglasso <- function( 3 | x, # lvglasso x 4 | plot = c("network","loadings","residcors","residpcors"), # "full" the full network, S" will plot the sparse network between items and "L" the latent loadings 5 | ask, 6 | rotation = promax, # A rotation function to be used. 7 | ... 8 | ){ 9 | 10 | if (missing(ask)) ask <- length(plot) > 1 11 | parOrig <- par() 12 | par(ask = ask) 13 | obs <- x$observed 14 | pcor <- x$pcor 15 | Res <- list() 16 | labs <- colnames(pcor) 17 | 18 | if ("network" %in% plot){ 19 | Res$network <- qgraph(pcor, ..., title = "Estimated network", shape = ifelse(obs,"square", "circle"), layout = "spring") 20 | } 21 | 22 | if ("residpcors" %in% plot){ 23 | Res$residpcors <- qgraph(x$pcor[x$observed,x$observed], ..., title = "Estimated residual partial correlations", shape = "square", layout = "spring", repulsion = 0.9) 24 | } 25 | 26 | if ("residcors" %in% plot){ 27 | Res$residcors <- qgraph(cov2cor(x$theta), ..., title = "Estimated residual correlations", shape = "square", layout = "spring", repulsion = 0.9) 28 | } 29 | 30 | if ("loadings" %in% plot){ 31 | fCovs <- x$psi 32 | load <- x$lambda 33 | 34 | # Rotate: 35 | rot <- rotation(load) 36 | if (is.matrix(rot)){ 37 | load <- rot 38 | rotmat <- matrix(1,1,1) 39 | } else { 40 | load <- rot$loadings 41 | rotmat <- rot$rotmat 42 | } 43 | fCovs <- solve(rotmat) %*% fCovs %*% t(solve(rotmat)) 44 | 45 | rownames(load) <- colnames(x$wi)[obs] 46 | Res$loadings <- qgraph.loadings(load, factorCors = fCovs, ..., title = "Estimated factor loadings", labels = colnames(x$wi)[obs], model = "reflective") 47 | } 48 | 49 | 50 | # 51 | # if ("full" %in% plot){ 52 | # Res$S <- qgraph(pcor, ..., title = "Full structure", shape = ifelse(obs,"square", "circle"), layout = "spring") 53 | # } 54 | # 55 | # if ("S" %in% plot){ 56 | # Res$S <- qgraph(pcor[obs,obs], ..., title = "Sparse structure", shape = "square", layout = "spring") 57 | # } 58 | # 59 | # if ("L" %in% plot){ 60 | # fCors <- as.matrix(pcor[!obs,!obs]) 61 | # load <- as.matrix(pcor[obs,!obs]) 62 | # 63 | # rownames(load) <- colnames(x$wi)[obs] 64 | # 65 | # Res$L <- qgraph.loadings(load, factorCors = fCors, arrows = FALSE,..., title = "Low-rank structure", labels = colnames(x$wi)[obs]) 66 | # } 67 | # 68 | 69 | 70 | 71 | invisible(Res) 72 | } 73 | -------------------------------------------------------------------------------- /R/refit.R: -------------------------------------------------------------------------------- 1 | lvnetRefit <- function( 2 | lvnetObject, # lvnet object 3 | data, # New covariance matrix 4 | sampleSize # New sample size 5 | ){ 6 | # If lvnetLasso or lvnetSearch, extract: 7 | if (is(lvnetObject,"lvnetLasso") | is(lvnetObject,"lvnetSearch")){ 8 | lvnetObject <- lvnetObject$best 9 | } 10 | 11 | # Check if proper: 12 | if (!is(lvnetObject,"lvnet")){ 13 | stop("Input must be a 'lvnet' object.") 14 | } 15 | 16 | # If dataset, compute cov: 17 | if (nrow(data) > ncol(data)){ 18 | if (missing(sampleSize)){ 19 | sampleSize <- nrow(data) 20 | } 21 | data <- cov(data, use = "pairwise.complete.obs") 22 | } 23 | 24 | # Check if samplesize is missing: 25 | if (missing(sampleSize)){ 26 | stop("sampleSize may not be missing") 27 | } 28 | 29 | # Extract inverse var-cov: 30 | sigmaInverse <- corpcor::pseudoinverse(lvnetObject$matrices$sigma_positive) 31 | 32 | # Obtain fit measures: 33 | Res <- ggmFit(covMat = data, # sample variance-covariance matrix 34 | sampleSize = sampleSize, # Sample sample-size 35 | invSigma = sigmaInverse, # inverse variance covariance matrix instead of pcor 36 | refit = FALSE,ebicTuning = lvnetObject$fitMeasures$ebicTuning, 37 | nPar = lvnetObject$fitMeasures$npar) 38 | 39 | return(Res) 40 | } -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(libname, pkgname) { 2 | packageStartupMessage("The lvnet package is deprecated and will no longer be supported. Most functionality has been moved to the psychonetrics package (psychonetrics.org).") 3 | } 4 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This package can be used to confirmatory test latent variable network models. See `?lvnet` for details. To install the package, use: 2 | 3 | ```r 4 | library("devtools") 5 | install_github("sachaepskamp/lvnet") 6 | ``` 7 | 8 | Requires OpenMx to be installed. 9 | 10 | #### Example: 11 | ```r 12 | # Load package: 13 | library("lvnet") 14 | 15 | # Load dataset: 16 | library("lavaan") 17 | data(HolzingerSwineford1939) 18 | Data <- HolzingerSwineford1939[,7:15] 19 | 20 | # Measurement model: 21 | Lambda <- matrix(0, 9, 3) 22 | Lambda[1:3,1] <- NA 23 | Lambda[4:6,2] <- NA 24 | Lambda[7:9,3] <- NA 25 | 26 | # Fit CFA model: 27 | CFA <- lvnet(Data, lambda = Lambda) 28 | 29 | # Latent network: 30 | Omega_psi <- matrix(c( 31 | 0,NA,NA, 32 | NA,0,0, 33 | NA,0,0 34 | ),3,3,byrow=TRUE) 35 | 36 | # Fit model: 37 | LNM <- lvnet(Data, lambda = Lambda, omega_psi=Omega_psi) 38 | 39 | # Compare fit: 40 | lvnetCompare(cfa=CFA,lnm=LNM) 41 | ``` 42 | -------------------------------------------------------------------------------- /inst/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SachaEpskamp/lvnet/88ec96c7b0dfb7c1898c6356ae813f0e560fae50/inst/.DS_Store -------------------------------------------------------------------------------- /inst/COPYING: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) year name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. -------------------------------------------------------------------------------- /inst/COPYRIGHTS: -------------------------------------------------------------------------------- 1 | COPYRIGHT STATUS 2 | ---------------- 3 | 4 | This code is 5 | 6 | Copyright (C) 2015 Sacha Epskamp 7 | 8 | All code is subject to the GNU General Public License, Version 2. See 9 | the file COPYING for the exact conditions under which you may 10 | redistribute it. 11 | -------------------------------------------------------------------------------- /man/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/SachaEpskamp/lvnet/88ec96c7b0dfb7c1898c6356ae813f0e560fae50/man/.DS_Store -------------------------------------------------------------------------------- /man/EBIClvglasso.Rd: -------------------------------------------------------------------------------- 1 | \name{EBIClvglasso} 2 | \alias{EBIClvglasso} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Latent variable graphical LASSO using EBIC to select optimal tuning parameter 6 | } 7 | \description{ 8 | This function minimizes the Extended Bayesian Information Criterion (EBIC; Chen and Chen, 2008) to choose the lvglasso tuning parameter. See \code{\link{lvglasso}} 9 | } 10 | \usage{ 11 | EBIClvglasso(S, n, nLatents, gamma = 0.5, nRho = 100, lambda, ...) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{S}{ 16 | Sample variance-covariance matrix 17 | } 18 | \item{n}{ 19 | Sample Size 20 | } 21 | \item{nLatents}{ 22 | Number of latent variables 23 | } 24 | \item{gamma}{ 25 | EBIC hyper-parameter 26 | } 27 | \item{nRho}{ 28 | Number of tuning parameters to test 29 | } 30 | \item{lambda}{ 31 | The lambda argument containing factor loadings, only used for starting values! 32 | } 33 | \item{\dots}{ 34 | Arguments sent to \code{\link{lvglasso}} 35 | } 36 | } 37 | 38 | \value{ 39 | The optimal result of \code{\link{lvglasso}}, with two more elements: 40 | \item{rho}{The selected tuning parameter} 41 | \item{ebic}{The optimal EBIC} 42 | } 43 | \references{ 44 | Chen, J., & Chen, Z. (2008). Extended Bayesian information criteria for model selection with large model spaces. Biometrika, 95(3), 759-771. 45 | } 46 | \author{ 47 | Sacha Epskamp 48 | } 49 | 50 | 51 | \seealso{ 52 | \code{\link{lvglasso}} 53 | } 54 | -------------------------------------------------------------------------------- /man/lassoSelect.Rd: -------------------------------------------------------------------------------- 1 | \name{lassoSelect} 2 | \alias{lassoSelect} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Update lvnatLasso results to select a different model 6 | } 7 | \description{ 8 | This function can be used to select a model using any fit index 9 | } 10 | \usage{ 11 | lassoSelect(object, select, minimize = TRUE, refit = TRUE, lassoTol = 1e-04) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{object}{ 16 | An \code{lvnetLasso} object 17 | } 18 | \item{select}{ 19 | A raw R expression using names used in the \code{object$fitMeasures} part of the output of \code{lvnet} 20 | } 21 | \item{minimize}{ 22 | Logical. Minimize or maximize? 23 | } 24 | \item{refit}{ 25 | Logical. Should the new best model be refitted. 26 | } 27 | \item{lassoTol}{ 28 | Tolerance for absolute values to be treated as zero in counting parameters. 29 | } 30 | } 31 | \author{ 32 | Sacha Epskamp 33 | } 34 | \examples{ 35 | \dontrun{ 36 | # Load dataset: 37 | library("lavaan") 38 | data(HolzingerSwineford1939) 39 | Data <- HolzingerSwineford1939[,7:15] 40 | 41 | # Measurement model: 42 | Lambda <- matrix(0, 9, 3) 43 | Lambda[1:3,1] <- NA 44 | Lambda[4:6,2] <- NA 45 | Lambda[7:9,3] <- NA 46 | 47 | # Search best fitting omega_theta: 48 | res <- lvnetLasso(Data, "omega_theta", lambda = Lambda) 49 | res$best 50 | summary(res) 51 | 52 | # Update to use EBIC: 53 | resEBIC <- lassoSelect(res, ebic) 54 | summary(resEBIC) 55 | 56 | # Update to use minimal fitting model with RMSEA < 0.05: 57 | resMinimal <- lassoSelect(res, df * (rmsea < 0.05), minimize = FALSE) 58 | summary(resMinimal) 59 | } 60 | } 61 | -------------------------------------------------------------------------------- /man/lav2lvnet.Rd: -------------------------------------------------------------------------------- 1 | \name{lav2lvnet} 2 | \alias{lav2lvnet} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Convert lavaan model to lvnet model matrices 6 | } 7 | \description{ 8 | This function can be used to easily generate input matrices for lvnet based on a lavaan model. 9 | } 10 | \usage{ 11 | lav2lvnet(model, data, std.lv = TRUE, lavaanifyOps = list(auto = TRUE, std.lv = std.lv)) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{model}{ 16 | Lavaan model syntax 17 | } 18 | \item{data}{ 19 | The dataset. Only used to extract order of variables names from the columnnames. 20 | } 21 | \item{std.lv}{ 22 | Should the model be identified by constraining latent variable variance to 1. Defaults to \code{TRUE} unlike lavaan! This is because the starting values work better for this identification. 23 | } 24 | \item{lavaanifyOps}{ 25 | A list with other options sent to \code{\link[lavaan]{lavaanify}} 26 | } 27 | } 28 | 29 | \value{ 30 | A list with the model matrices for \code{lambda}, \code{psi}, \code{theta} and \code{beta} 31 | } 32 | \author{ 33 | Sacha Epskamp 34 | } 35 | 36 | \examples{ 37 | \dontrun{ 38 | library("lavaan") 39 | 40 | # Load dataset: 41 | data(HolzingerSwineford1939) 42 | Data <- HolzingerSwineford1939[,7:15] 43 | 44 | # lavaan model 45 | HS.model <- ' 46 | visual =~ x1 + x2 + x3 47 | textual =~ x4 + x5 + x6 48 | speed =~ x7 + x8 + x9 ' 49 | 50 | # fit via lavaan: 51 | lavFit <- cfa(HS.model, HolzingerSwineford1939[7:15],std.lv=TRUE) 52 | 53 | # Fit via lvnet: 54 | mod <- lav2lvnet(HS.model, HolzingerSwineford1939[7:15]) 55 | lvnetFit <- lvnet(Data, lambda = mod$lambda, psi = mod$psi) 56 | 57 | # Compare: 58 | Compare <- data.frame( 59 | lvnet = round(unlist(lvnetFit$fitMeasures)[c("npar","df","chisq","fmin","aic","bic", 60 | "rmsea","cfi","tli","nfi","logl")],3), 61 | lavaan = round(fitMeasures(lavFit)[c("npar","df","chisq","fmin","aic","bic","rmsea", 62 | "cfi","tli","nfi","logl")],3)) 63 | 64 | Compare 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /man/lvglasso.Rd: -------------------------------------------------------------------------------- 1 | \name{lvglasso} 2 | \alias{lvglasso} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Latent variable graphical LASSO 6 | } 7 | \description{ 8 | The lvglasso algorithm to estimate network structures containing latent variables, as proposed by Yuan (2012). Uses the glasso package (Friedman, Hastie and Tibshirani, 2014) and mimics input and output of the \code{\link[glasso]{glasso}} function. 9 | } 10 | \usage{ 11 | lvglasso(S, nLatents, rho = 0, thr = 1e-04, maxit = 10000, lambda) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{S}{ 16 | Sample variance-covariance matrix 17 | } 18 | \item{nLatents}{ 19 | Number of latent variables. 20 | } 21 | \item{rho}{ 22 | The LASSO tuning parameter 23 | } 24 | \item{thr}{ 25 | The threshold to use for convergence 26 | } 27 | \item{maxit}{ 28 | Maximum number of iterations 29 | } 30 | \item{lambda}{ 31 | The lambda argument containing factor loadings, only used for starting values!} 32 | } 33 | 34 | \value{ 35 | A list of class \code{lvglasso} containing the following elements: 36 | \item{w}{The estimated variance-covariance matrix of both observed and latent variables} 37 | \item{wi}{The estimated inverse variance-covariance matrix of both observed and latent variables} 38 | \item{pcor}{Estimated partial correlation matrix of both observed and latent variables} 39 | \item{observed}{Logical vector indicating which elements of w, wi and pcor are observed} 40 | \item{niter}{The number of iterations used} 41 | \item{lambda}{The estimated lambda matrix, when result is transformed to EFA model} 42 | \item{theta}{The estimated theta matrix} 43 | \item{omega_theta}{The estimated omega_theta matrix} 44 | \item{psi}{The estimated psi matrix} 45 | } 46 | \references{ 47 | Yuan, M. (2012). Discussion: Latent variable graphical model selection via convex optimization.The Annals of Statistics,40, 1968-1972. 48 | 49 | Jerome Friedman, Trevor Hastie and Rob Tibshirani (2014). glasso: Graphical lasso-estimation of Gaussian graphical models. R package version 1.8. http://CRAN.R-project.org/package=glasso 50 | } 51 | \author{ 52 | Sacha Epskamp 53 | } 54 | -------------------------------------------------------------------------------- /man/lvnet.Rd: -------------------------------------------------------------------------------- 1 | \name{lvnet} 2 | \alias{lvnet} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Confirmatory Latent Variable Network Models 6 | } 7 | \description{ 8 | This function utilizes OpenMx (Boker et al., 2011, 2014) to confirmatory test latent variable network models between P manifests and M latents. See the details section for information about the modeling framework used. All the input matrices can be assigned R matrices with numbers indicating fixed values and NA indicating a value is free to estimate. 9 | } 10 | \usage{ 11 | lvnet(data, lambda, beta, omega_theta, delta_theta, omega_psi, delta_psi, psi, theta, 12 | sampleSize, fitInd, fitSat, startValues = list(), scale = FALSE, nLatents, 13 | lasso = 0, lassoMatrix, lassoTol = 1e-4, ebicTuning = 0.5, 14 | mimic = c("lavaan","lvnet"), fitFunction = c("penalizedML", "ML"), exogenous) 15 | } 16 | %- maybe also 'usage' for other objects documented here. 17 | \arguments{ 18 | \item{data}{ 19 | An N (sample size) x P matrix or data frame containing the raw data, or a P x P variance-covariance matrix. 20 | } 21 | \item{lambda}{ 22 | A P x M matrix indicating factor loadings. Defaults to a full NA P x M matrix if psi or omega_psi is not missing, or a P x 0 dummy matrix. 23 | } 24 | \item{beta}{ 25 | An M x M matrix indicating linear effects between latent variables. Defaults to an M x M matrix containing only zeroes. 26 | } 27 | \item{omega_theta}{ 28 | A P x P matrix encoding the residual network structure. By default, theta is modeled instead. 29 | } 30 | \item{delta_theta}{ 31 | A P x P diagonal scaling matrix. Defaults to NA on all diagonal elements. Only used if omega_theta is modeled. 32 | } 33 | \item{omega_psi}{ 34 | An M x M matrix containing the latent network structure. Dy default, psi is modeled instead. 35 | } 36 | \item{delta_psi}{ 37 | A diagonal M x M scaling matrix. Defaults to an identity matrix. Only used if omega_psi is modeled. 38 | } 39 | \item{psi}{ 40 | An M x M variance-covariance matrix between latents and latent residuals. Defaults to a full NA matrix. 41 | } 42 | \item{theta}{ 43 | A P x P variance-covariance matrix of residuals of the observed variables. Defaults to a diagonal matrix containing NAs 44 | } 45 | \item{sampleSize}{ 46 | The sample size, only used if \code{data} is assigned a variance-covariance matrix. 47 | } 48 | \item{fitInd}{ 49 | The fit of the independence model. Used to speed up estimation fitting multiple models. 50 | } 51 | \item{fitSat}{ 52 | The fit of the saturated model. Used to speed up estimation fitting multiple models. 53 | } 54 | \item{startValues}{ 55 | An optional named list containing starting values of each model. e.g., \code{list(lambda = matrix(1,9,3))} would set the starting values of a 10 x 3 lambda matrix to ones. 56 | } 57 | \item{scale}{ 58 | Logical, should data be standardized before running lvnet? 59 | } 60 | \item{nLatents}{ 61 | The number of latents. Allows for quick specification when \code{lambda} is missing. Not needed is \code{lambda} is assigned. 62 | } 63 | \item{lasso}{ 64 | The LASSO tuning parameter. 65 | } 66 | \item{lassoMatrix}{ 67 | Character vector indicating the names of matrices to apply LASSO regularization on. e.g., \code{"omega_psi"} or \code{"omega_theta"}. 68 | } 69 | \item{lassoTol}{ 70 | Tolerance for absolute values to be treated as zero in counting parameters. 71 | } 72 | \item{ebicTuning}{Tuning parameter used in extended Bayesian Information Criterion.} 73 | \item{mimic}{If set to \code{"lavaan"} (default), covariance matrix is rescaled and N is used rather than N - 1 in likelihood computation.} 74 | \item{fitFunction}{The fit function to be used. \code{penalizedML} will fit the penalized fit function and \code{ML} the maximum likelihood function.} 75 | \item{exogenous}{Numeric vector indicating which variables are exogenous.} 76 | } 77 | \details{ 78 | The modeling framework follows the all-y LISREL framework for Structural Equation Models (SEM; Hayduk, 1987) to model relationships between P observed variables and M latent variables: 79 | 80 | sigma = lambda * (I - beta)^(-1) psi (I - beta)^(-1 T) * lambda^T + theta 81 | 82 | Where Sigma is the P x P model-implied covariance matrix, lambda a P x M matrix of factor loadings, B an M x M matrix containing regression effects between latent variables, Psi a M x M covariance matrix of the latent variables/residuals and Theta a P x P covariance matrix of residuals of the observed indicators. 83 | 84 | The lvnet function allows for two extensions of this modeling framework. First, psi can be chosen to be modeled as follows: 85 | 86 | psi = delta_psi (I - omega_psi)^(-1) delta_psi 87 | 88 | In which delta_psi is a M x M diagonal scaling matrix and omega_psi a M x M matrix containing zeroes on the diagonal and partial correlation coefficients on the offdiagonal values of two latent variables conditioned on all other latent variables. omega_psi therefore corresponds to a Gaussian Graphical Model, or a network structure. 89 | 90 | Similarly, theta can be chosen to be modeled as follows: 91 | 92 | theta = delta_theta (I - omega_theta)^(-1) delta_theta 93 | 94 | In which delta_theta is a P x P diagonal scaling matrix and omega_theta a P x P matrix containing zeroes on the diagonal and partial correlation coefficients on the offdiagonal values of two residuals conditioned on all other residuals. 95 | 96 | Modeling omega_psi is termed Latent Network Modeling (LNM) and modeling omega_theta is termed Residual Network Modeling (RNM). lvnet automatically chooses the appropriate modeling framework based on the input. 97 | } 98 | \value{ 99 | An \code{lvnet} object, which is a list containing the following elements: 100 | \item{matrices}{A list containing thee estimated model matrices} 101 | \item{sampleStats}{A list containing the covariance matrix (\code{covMat}) and sample size {\code{sampleSize}}} 102 | \item{mxResults}{The OpenMx object of the fitted model} 103 | \item{fitMeasures}{A named list containing the fit measures of the fitted model} 104 | } 105 | \references{ 106 | Boker, S. M., Neale, M., Maes, H., Wilde, M., Spiegel, M., Brick, T., ... Fox, J. (2011). OpenMx: an open source extended structural equation modelingframework. Psychometrika, 76(2), 306-317 107 | 108 | Boker, S. M., Neale, M. C., Maes, H. H., Wilde, M. J., Spiegel, M., Brick, T. R., ..., Team OpenMx. (2014). Openmx 2.0 user guide [Computer software manual]. 109 | 110 | Hayduk, L. A. (1987).Structural equation modeling with LISREL: Essentials advances. Baltimore, MD, USA: Johns Hopkins University Press. 111 | } 112 | \author{ 113 | Sacha Epskamp 114 | } 115 | \seealso{ 116 | \code{\link{lvnetSearch}} 117 | } 118 | \examples{ 119 | # Load dataset: 120 | library("lavaan") 121 | data(HolzingerSwineford1939) 122 | Data <- HolzingerSwineford1939[,7:15] 123 | 124 | # Measurement model: 125 | Lambda <- matrix(0, 9, 3) 126 | Lambda[1:3,1] <- NA 127 | Lambda[4:6,2] <- NA 128 | Lambda[7:9,3] <- NA 129 | 130 | # Fit CFA model: 131 | CFA <- lvnet(Data, lambda = Lambda) 132 | 133 | # Latent network: 134 | Omega_psi <- matrix(c( 135 | 0,NA,NA, 136 | NA,0,0, 137 | NA,0,0 138 | ),3,3,byrow=TRUE) 139 | 140 | # Fit model: 141 | LNM <- lvnet(Data, lambda = Lambda, omega_psi=Omega_psi) 142 | 143 | # Compare fit: 144 | lvnetCompare(cfa=CFA,lnm=LNM) 145 | 146 | # Summary: 147 | summary(LNM) 148 | 149 | # Plot latents: 150 | plot(LNM, "factorStructure") 151 | } 152 | 153 | 154 | -------------------------------------------------------------------------------- /man/lvnetCompare.Rd: -------------------------------------------------------------------------------- 1 | \name{lvnetCompare} 2 | \alias{lvnetCompare} 3 | \alias{anova.lvnet} 4 | %- Also NEED an '\alias' for EACH other topic documented here. 5 | \title{ 6 | Compare lvnet objects 7 | } 8 | \description{ 9 | Compares several results of \code{\link{lvnet}} 10 | } 11 | \usage{ 12 | lvnetCompare(...) 13 | \method{anova}{lvnet}(object, ...) 14 | } 15 | %- maybe also 'usage' for other objects documented here. 16 | \arguments{ 17 | \item{object}{An \code{lvnet} object} 18 | \item{\dots}{ 19 | Any number of \code{lvnet} objects. Arguments can be named to make the resulting table named. 20 | } 21 | } 22 | \author{ 23 | Sacha Epskamp 24 | } 25 | 26 | \seealso{ 27 | \code{\link{lvnet}} 28 | } 29 | -------------------------------------------------------------------------------- /man/lvnetLasso.Rd: -------------------------------------------------------------------------------- 1 | \name{lvnetLasso} 2 | \alias{lvnetLasso} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | LASSO model selection 6 | } 7 | \description{ 8 | This function runs \code{lvnet} for a number of different tuning parameters, selects the best model based on some criterion and refits that model to obtain accurate parameter estimates. The \code{\link{lassoSelect}} function can afterwards be used to select a different model. 9 | } 10 | \usage{ 11 | lvnetLasso(data, lassoMatrix, lassoTol = 1e-04, nTuning = 20, 12 | tuning.min = 0.01, tuning.max = 0.5, criterion = c("bic", "aic", 13 | "ebic"), verbose = TRUE, refitFinal = TRUE, refitAll = FALSE, 14 | nCores = 1, ...) 15 | } 16 | %- maybe also 'usage' for other objects documented here. 17 | \arguments{ 18 | \item{data}{ 19 | The data argument as used in \code{\link{lvnet}} 20 | } 21 | \item{lassoMatrix}{ 22 | Vector indicating the matrix or matrices to use in LASSO optmimization 23 | } 24 | \item{lassoTol}{ 25 | Tolerance for absolute values to be treated as zero in counting parameters. 26 | } 27 | \item{nTuning}{ 28 | Number of tuning parameters to estimate. 29 | } 30 | \item{tuning.min}{ 31 | Minimal tuning parameter 32 | } 33 | \item{tuning.max}{ 34 | Maximal tuning parameter 35 | } 36 | \item{criterion}{ 37 | Criterion to use in model selection 38 | } 39 | \item{verbose}{ 40 | Should progress be printed to the console? 41 | } 42 | \item{refitFinal}{ 43 | Logical, should the best fitting model be refitted without LASSO regularization? 44 | } 45 | \item{refitAll}{ 46 | Logical, should *all* models be refitted without LASSO regularization (but with zeroes constrained) before evaluating fit criterium? 47 | } 48 | \item{nCores}{ 49 | Number of cores to use in parallel computing. 50 | } 51 | \item{\dots}{ 52 | Arguments sent to \code{\link{lvnet}} 53 | } 54 | } 55 | \author{ 56 | Sacha Epskamp 57 | } 58 | 59 | \examples{ 60 | # Load dataset: 61 | library("lavaan") 62 | data(HolzingerSwineford1939) 63 | Data <- HolzingerSwineford1939[,7:15] 64 | 65 | # Measurement model: 66 | Lambda <- matrix(0, 9, 3) 67 | Lambda[1:3,1] <- NA 68 | Lambda[4:6,2] <- NA 69 | Lambda[7:9,3] <- NA 70 | 71 | # Search best fitting omega_theta: 72 | \dontrun{ 73 | res <- lvnetLasso(Data, "omega_theta", lambda = Lambda) 74 | res$best 75 | summary(res) 76 | } 77 | } 78 | -------------------------------------------------------------------------------- /man/lvnetRefit.Rd: -------------------------------------------------------------------------------- 1 | \name{lvnetRefit} 2 | \alias{lvnetRefit} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Refit lvnet model to new data 6 | } 7 | \description{ 8 | Obtain fit indices from the estimated model parameters on a new dataset. 9 | } 10 | \usage{ 11 | lvnetRefit(lvnetObject, data, sampleSize) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{lvnetObject}{ 16 | Output of \code{\link{lvnet}}. 17 | } 18 | \item{data}{ 19 | New dataset or variance-covariance matrix. 20 | } 21 | \item{sampleSize}{ 22 | Sample size (if \code{data} is a variance-covariance matrix). 23 | } 24 | } 25 | \author{ 26 | Sacha Epskamp 27 | } -------------------------------------------------------------------------------- /man/lvnetSearch.Rd: -------------------------------------------------------------------------------- 1 | \name{lvnetSearch} 2 | \alias{lvnetSearch} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Step-wise exploratory search for optimal fitting model 6 | } 7 | \description{ 8 | Performs stepwise search to optimize the structure of omega_theta, omega_psi, theta or psi. Starts at empty or full structure and iteratively adds or removes edges to optimize the criterion. 9 | } 10 | \usage{ 11 | lvnetSearch(data, matrix = c("omega_theta", "omega_psi", "theta", "psi"), 12 | criterion = c("bic", "ebic","chisq","aic"), 13 | start = c("default","empty","full"), alpha = 0.05, lambda, sampleSize, 14 | maxIter, nCores = 1, maxChange = 1, ..., verbose = TRUE, file, 15 | startValues = list()) 16 | } 17 | %- maybe also 'usage' for other objects documented here. 18 | \arguments{ 19 | \item{data}{ 20 | The data argument as used in \code{\link{lvnet}} 21 | } 22 | \item{matrix}{ 23 | Character string indicating the matrix to be optimized. Can be \code{"omega_theta"}, \code{"omega_psi"}, \code{"theta"} and \code{"psi"}. 24 | } 25 | \item{criterion}{ 26 | Character string indicating the criterion to be used. \code{"AIC"} and \code{"BIC"} optimize the AIC or BIC respectively, and \code{"chisq"} performs chi-square tests to see if adding an edge significantly improves model fit or removing an edges does not significantly reduce model fit. 27 | } 28 | \item{start}{ 29 | A character string indicating the structure of the matrix at the start of the algorithm. \code{"empty"} starts with a matrix with only zeroes and \code{"full"} starts with a matrix in which all elements are free to estimate. \code{"lvglasso"} employs the lvglasso algorithm (\code{\link{EBIClvglasso}} to find a starting structure for omega_theta and \code{"glasso"} employs the glasso algorithm to find a starting point for omega_psi (\code{\link[qgraph]{EBICglasso}}). \code{"default"} will lead to a full matrix if omega_psi or psi is optimized, and an empty matrix if omega_theta or theta is optimized. 30 | } 31 | \item{alpha}{ 32 | The alpha level for chi-square significance testing. 33 | } 34 | \item{lambda}{ 35 | The lambda argument as used in \code{\link{lvnet}} 36 | } 37 | \item{sampleSize}{ 38 | The sample size, only used if \code{data} is a covariance matrix. 39 | } 40 | \item{maxIter}{ 41 | The maximum number of edges to test. Defaults to M(M-1)/2 42 | } 43 | \item{nCores}{ 44 | Number of cores to use in parallel estimation. 45 | } 46 | \item{maxChange}{ 47 | Set to higher than one to change multiple edges in each run. Each iteration, maxChange is reset to max(number of changed edges - 1, 1). Can result in instable results when searching \code{"omega_theta"}. 48 | } 49 | \item{\dots}{ 50 | Arguments sent to \code{\link{lvnet}} 51 | } 52 | \item{verbose}{ 53 | Logical if progress should be printed to the consile. 54 | } 55 | \item{file}{ 56 | An optional character string containing a file name to store temporary results in. 57 | } 58 | \item{startValues}{ 59 | A list containing start values as used in \code{\link{lvnet}} 60 | } 61 | } 62 | \value{ 63 | An object of class \code{lvnetSearch}, which is a list containing: 64 | \item{best}{The \code{lvnet} object of the best fitting model} 65 | \item{modList}{A list containing the chain of fitted models} 66 | \item{niter}{The number of iterations used} 67 | } 68 | \author{ 69 | Sacha Epskamp 70 | } 71 | 72 | \seealso{ 73 | \code{\link{lvnet}} 74 | } 75 | \examples{ 76 | # Load dataset: 77 | library("lavaan") 78 | data(HolzingerSwineford1939) 79 | Data <- HolzingerSwineford1939[,7:15] 80 | 81 | # Measurement model: 82 | Lambda <- matrix(0, 9, 3) 83 | Lambda[1:3,1] <- NA 84 | Lambda[4:6,2] <- NA 85 | Lambda[7:9,3] <- NA 86 | 87 | # Search best fitting omega_psi: 88 | \dontrun{ 89 | res <- lvnetSearch(Data, "omega_psi", lambda = Lambda) 90 | res$best 91 | } 92 | } 93 | 94 | -------------------------------------------------------------------------------- /man/plot.lvnet.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.lvnet} 2 | \alias{plot.lvnet} 3 | \alias{plot.lvnetSearch} 4 | \alias{plot.lvnetLasso} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | Plot model matrices 8 | } 9 | \description{ 10 | Plot method for \code{lvnet}. For \code{lvnetSearch} and \code{lvnetLasso} objects this is simply defined as \code{plot(object$best, ...)} 11 | } 12 | \usage{ 13 | \method{plot}{lvnet}(x, what = c("factorStructure", "residual", "latent"), partial, 14 | layout = "circle", ...) 15 | \method{plot}{lvnetLasso}(x, ...) 16 | \method{plot}{lvnetSearch}(x, ...) 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{x}{ 21 | An \code{lvnet} object. 22 | } 23 | \item{what}{ 24 | What to plot? \code{"factorStructure"} plots the factor loadings and latent correlations or network. \code{"residual"} the residual correlations or network and \code{"latent"} the latent correlations or network. 25 | } 26 | \item{partial}{ 27 | Plot partial correlations instead of correlations? Defaults to \code{TRUE} if \code{omega_psi} or \code{omega_theta} is estimated. 28 | } 29 | \item{layout}{ 30 | The layour argument as used in \code{\link[qgraph]{qgraph}} 31 | } 32 | \item{\dots}{ 33 | Arguments sent to \code{\link[qgraph]{qgraph}} 34 | } 35 | } 36 | 37 | \author{ 38 | Sacha Epskamp 39 | } 40 | -------------------------------------------------------------------------------- /man/summary.lvnet.Rd: -------------------------------------------------------------------------------- 1 | \name{summary.lvnet} 2 | \alias{summary.lvnet} 3 | \alias{summary.lvnetSearch} 4 | \alias{summary.lvnetLasso} 5 | %- Also NEED an '\alias' for EACH other topic documented here. 6 | \title{ 7 | Summary method for lvnet 8 | } 9 | \description{ 10 | Plot method for \code{lvnet}. For \code{lvnetSearch} and \code{lvnetLasso} objects this is simply defined as \code{summary(object$best, ...)} 11 | } 12 | \usage{ 13 | \method{summary}{lvnet}(object, include = c("input", "chisq", "infcrit", "fitindices", 14 | "rmsea", "parests"), digits = 3, ...) 15 | \method{summary}{lvnetLasso}(object, ...) 16 | \method{summary}{lvnetSearch}(object, ...) 17 | } 18 | %- maybe also 'usage' for other objects documented here. 19 | \arguments{ 20 | \item{object}{ 21 | An \code{lvnet} object 22 | } 23 | \item{include}{ 24 | Vector indicating what to include? \code{"input"} for the input used, \code{"chisq"} for the chi-square fit, \code{"infcrit"} for information criteria, \code{"fitindices"} for fit indices, \code{"rmsea"} for the RMSEA, ans \code{"parests"} for parameter estimates. 25 | } 26 | \item{digits}{ 27 | Number of digits to round to. 28 | } 29 | \item{\dots}{ 30 | Not used. 31 | } 32 | } 33 | \author{ 34 | Sacha Epskamp 35 | } 36 | 37 | --------------------------------------------------------------------------------