|
| 1 | +#' @export |
| 2 | +model_parameters.lavaan.mi <- function( |
| 3 | + model, |
| 4 | + ci = 0.95, |
| 5 | + standardize = FALSE, |
| 6 | + component = c("regression", "correlation", "loading", "defined"), |
| 7 | + keep_parameters = NULL, |
| 8 | + drop_parameters = NULL, |
| 9 | + verbose = TRUE, |
| 10 | + ... |
| 11 | +) { |
| 12 | + params <- .extract_parameters_lavaan_mi( |
| 13 | + model, |
| 14 | + ci = ci, |
| 15 | + standardize = standardize, |
| 16 | + keep_parameters = keep_parameters, |
| 17 | + drop_parameters = drop_parameters, |
| 18 | + verbose = verbose, |
| 19 | + ... |
| 20 | + ) |
| 21 | + |
| 22 | + # Filter |
| 23 | + if (all(component == "all")) { |
| 24 | + component <- c("regression", "correlation", "loading", "variance", "defined", "mean") |
| 25 | + } |
| 26 | + params <- params[tolower(params$Component) %in% component, ] |
| 27 | + |
| 28 | + # add class-attribute for printing |
| 29 | + class(params) <- c("parameters_sem", "see_parameters_sem", class(params)) |
| 30 | + attr(params, "ci") <- ci |
| 31 | + attr(params, "model") <- model |
| 32 | + params |
| 33 | +} |
| 34 | + |
| 35 | + |
| 36 | +.extract_parameters_lavaan_mi <- function( |
| 37 | + model, |
| 38 | + ci = 0.95, |
| 39 | + standardize = FALSE, |
| 40 | + keep_parameters = NULL, |
| 41 | + drop_parameters = NULL, |
| 42 | + verbose = TRUE, |
| 43 | + ... |
| 44 | +) { |
| 45 | + insight::check_if_installed("lavaan.mi") |
| 46 | + |
| 47 | + if (is.null(ci)) { |
| 48 | + ci <- 0.95 |
| 49 | + } |
| 50 | + |
| 51 | + # set proper default |
| 52 | + if (is.null(standardize)) { |
| 53 | + standardize <- FALSE |
| 54 | + } |
| 55 | + |
| 56 | + # check for valid parameters |
| 57 | + valid_std_options <- c("all", "std.all", "latent", "std.lv", "no_exogenous", "std.nox") |
| 58 | + if (!is.logical(standardize) && !(standardize %in% valid_std_options)) { |
| 59 | + if (verbose) { |
| 60 | + insight::format_alert( |
| 61 | + "`standardize` should be one of `TRUE`, \"all\", \"std.all\", \"latent\", \"std.lv\", \"no_exogenous\" or \"std.nox\".", # nolint |
| 62 | + "Returning unstandardized solution." |
| 63 | + ) |
| 64 | + } |
| 65 | + standardize <- FALSE |
| 66 | + } |
| 67 | + |
| 68 | + # CI |
| 69 | + if (length(ci) > 1L) { |
| 70 | + ci <- ci[1] |
| 71 | + if (verbose) { |
| 72 | + insight::format_alert(paste0( |
| 73 | + "lavaan models only accept one level of CI. Keeping the first one: `ci = ", |
| 74 | + ci, |
| 75 | + "`." |
| 76 | + )) |
| 77 | + } |
| 78 | + } |
| 79 | + |
| 80 | + # collect dots |
| 81 | + dot_args <- list(...) |
| 82 | + |
| 83 | + # list all argument names from the `lavaan` function |
| 84 | + # fmt: skip |
| 85 | + dot_args <- dot_args[names(dot_args) %in% c( |
| 86 | + "zstat", "pvalue", "standardized", "fmi", "level", "boot.ci.type", "cov.std", |
| 87 | + "fmi.options", "rsquare", "remove.system.eq", "remove.eq", "remove.ineq", |
| 88 | + "remove.def", "remove.nonfree", "add.attributes", "output", "header" |
| 89 | + )] |
| 90 | + |
| 91 | + # Get estimates |
| 92 | + sem_data <- do.call( |
| 93 | + lavaan.mi::parameterEstimates.mi, |
| 94 | + c(list(object = model, se = TRUE, ci = TRUE, level = ci), dot_args) |
| 95 | + ) |
| 96 | + |
| 97 | + label <- sem_data$label |
| 98 | + |
| 99 | + # check if standardized estimates are requested, and if so, which type |
| 100 | + if (isTRUE(standardize) || !is.logical(standardize)) { |
| 101 | + if (is.logical(standardize)) { |
| 102 | + standardize <- "all" |
| 103 | + } |
| 104 | + |
| 105 | + type <- switch( |
| 106 | + standardize, |
| 107 | + all = , |
| 108 | + std.all = "std.all", |
| 109 | + latent = , |
| 110 | + std.lv = "std.lv", |
| 111 | + no_exogenous = , |
| 112 | + std.nox = "std.nox", |
| 113 | + "std.all" |
| 114 | + ) |
| 115 | + |
| 116 | + # this function errors on unknown arguments |
| 117 | + f <- utils::getFromNamespace("standardizedSolution.mi", "lavaan.mi") |
| 118 | + valid <- names(formals(f)) |
| 119 | + dots <- list(...) |
| 120 | + dots <- dots[names(dots) %in% valid] |
| 121 | + fun_args <- c(list(model, se = TRUE, level = ci, type = type), dots) |
| 122 | + sem_data <- do.call(f, fun_args) |
| 123 | + names(sem_data)[names(sem_data) == "est.std"] <- "est" |
| 124 | + } |
| 125 | + |
| 126 | + # extract statistic column - different to normal lavaan objects |
| 127 | + if (!is.null(sem_data$t)) { |
| 128 | + statistic <- sem_data$t |
| 129 | + stat_col <- "t" |
| 130 | + } else if (!is.null(sem_data$z)) { |
| 131 | + statistic <- sem_data$z |
| 132 | + stat_col <- "z" |
| 133 | + } else { |
| 134 | + statistic <- NULL |
| 135 | + } |
| 136 | + |
| 137 | + params <- data.frame( |
| 138 | + To = sem_data$lhs, |
| 139 | + Operator = sem_data$op, |
| 140 | + From = sem_data$rhs, |
| 141 | + Coefficient = sem_data$est, |
| 142 | + SE = sem_data$se, |
| 143 | + CI_low = sem_data$ci.lower, |
| 144 | + CI_high = sem_data$ci.upper, |
| 145 | + stringsAsFactors = FALSE |
| 146 | + ) |
| 147 | + |
| 148 | + if (!is.null(statistic)) { |
| 149 | + params[[stat_col]] <- statistic |
| 150 | + } |
| 151 | + |
| 152 | + params$p <- sem_data$pvalue |
| 153 | + |
| 154 | + if (!is.null(label)) { |
| 155 | + params$Label <- label |
| 156 | + } |
| 157 | + |
| 158 | + params$Component <- NA_character_ |
| 159 | + params$Component[params$Operator == "=~"] <- "Loading" |
| 160 | + params$Component[params$Operator == "~"] <- "Regression" |
| 161 | + params$Component[params$Operator == "~~"] <- "Correlation" |
| 162 | + params$Component[params$Operator == ":="] <- "Defined" |
| 163 | + params$Component[params$Operator == "~1"] <- "Mean" |
| 164 | + |
| 165 | + params$Component[as.character(params$From) == as.character(params$To)] <- "Variance" |
| 166 | + |
| 167 | + if ("p" %in% colnames(params)) { |
| 168 | + params$p[is.na(params$p)] <- 0 |
| 169 | + } |
| 170 | + |
| 171 | + if ("group" %in% names(sem_data)) { |
| 172 | + params$Group <- sem_data$group |
| 173 | + } |
| 174 | + |
| 175 | + # filter parameters, if requested |
| 176 | + if (!is.null(keep_parameters) || !is.null(drop_parameters)) { |
| 177 | + params <- .filter_parameters( |
| 178 | + params, |
| 179 | + keep = keep_parameters, |
| 180 | + drop = drop_parameters, |
| 181 | + verbose = verbose |
| 182 | + ) |
| 183 | + } |
| 184 | + |
| 185 | + params |
| 186 | +} |
0 commit comments