R/results-table_results.R

Defines functions format_with_na can_be_numeric table_results.character table_results.blavaan table_results.lavaan .table_cor_internal table_cors.default table_cors rbind_tables param_label conf_int.mplus.params conf_int.default conf_int est_sig.mplus.params est_sig.default est_sig lavaan_labels mplus_to_lavaan_labels internal_table_mplusmodel table_results.mplus.model table_results.mplusObject table_results report_columns table_results.rma

Documented in conf_int est_sig table_cors table_results

# @title Print results of different types of analyses
# @description Takes an object, and prints the results as an 'APA' table.
# @param x Object to be printed
# @param columns Character vector, indicating the columns to retain.
# Default: c("label", "est_sig", "confint").
# @param digits Integet. Number of digits to round to when formatting;
# Default: 2.
# @param ... Other arguments passed to and from other functions.
# @return data.frame
# @rdname table_results
# @export
# table_results <- function(x, columns = c("label",
#                                          "est_sig", "confint"), digits = 2, ...){
#   UseMethod("table_results", x)
# }
#' @method table_results rma
#' @export
table_results.rma <-  function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){

  results <- do.call(cbind, x[c("b", "se", "zval", "pval", "ci.lb", "ci.ub")])
  results <- data.frame(label = rownames(results), results)
  names(results)[2] <- c("est")
  value_columns <- c("est", "se", "zval", "pval", "ci.lb", "ci.ub")
  value_columns <- value_columns[which(value_columns %in%
                                         colnames(results))]
  add_cis <- TRUE
  results$est_sig <- est_sig(results, digits)

  results$confint <- conf_int(results, digits)
  if(format_numeric){
    results[, value_columns] <- lapply(results[, value_columns],
                                       format_with_na, digits = digits, format = "f")
  }
  rownames(results) <- NULL
  if(!all){
    results <- results[, c("b", "se", "zval", "pval", "ci.lb", "ci.ub")]
  } else {
    results
  }
}

# Change which columns table_results reports
#
# Sets a global option to control which columns table_results reports when
# \code{all = FALSE}.
# @param x A character vector with column names for
# \code{\link[tidySEM]{table_results}}.
# @author Caspar J. van Lissa
# @family Reporting tools
# @keywords reporting
# @export
# @examples
# report_columns(c("label", "est_sig", "se", "pval", "confint", "group"))
report_columns <- function(x = c("label", "est_sig", "se", "pval", "confint", "group", "level")){
  x <- list("report_columns" = x)
  do.call(options, x)
}

#' Print results table formatted for publication
#'
#' Takes a model object, and formats it as a publication-ready table.
#' @param x A model object for which a method exists.
# @param standardized Logical. Return standardized parameters, or not.
# Defaults to TRUE.
# @param all Logical. Whether to return all available results columns
# (including columns generated by \code{table_results}, or whether to return a
# simplified table containing the essential columns for 'APA'-style reporting.
# Defaults to FALSE. If set to TRUE, you can manually select the desired
# columns.
#' @param columns A character vector of columns to retain from the results
#' section. If this is set to \code{NULL}, all available columns are returned.
#' Defaults to \code{c("label", "est_sig", "se", "pval", "confint", "group",
#' "level")}. These correspond to 1) the parameter label, 2) estimate column
#' with significance asterisks appended
#' (* <.05, ** < .01, *** < .001); 3) standard error, 4) p-value, 5) a
#' formatted confidence interval, 6) grouping variable (if available), 7) level
#' variable for multilevel models, if available.
#' @param digits Number of digits to round to when formatting numeric columns.
#' @param format_numeric Logical, indicating whether or not to format numeric
#' columns. Defaults to `TRUE`.
#' @param ... Logical expressions used to filter the rows of results returned.
#' @return A data.frame of formatted results.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @keywords reporting
#' @export
#' @examples
#' library(lavaan)
#' HS.model <- '  visual =~ x1 + x2 + x3
#'                textual =~ x4 + x5 + x6
#'                speed   =~ x7 + x8 + x9 '
#' fit <- cfa(HS.model,
#'            data = HolzingerSwineford1939,
#'            group = "school")
#' table_results(fit)
table_results <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  UseMethod("table_results")
}

#' @method table_results mplusObject
#' @export
table_results.mplusObject <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  cl <- match.call()
  cl$x <- x$results
  cl[[1L]] <- quote(table_results)
  eval.parent(cl)
}


#' @method table_results mplus.model
#' @importFrom MplusAutomation SummaryTable
#' @export
table_results.mplus.model <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  Args <- list(x = x)
  cl <- match.call()
  get_res <- c("unstandardized", "stdyx.standardized")[which( c("unstandardized", "stdyx.standardized") %in% names(x$parameters))]

  all_res <- lapply(get_res, function(which_par){do.call(internal_table_mplusmodel, c(Args, list(parameters = which_par, digits = digits)))})
  if(length(all_res) == 1){
    results <- all_res[[1]]
    if(is.null(results)){
      message("No valid results found.")
      invisible(return(NULL))
    }
  } else {
    all_res[[2]][c("paramHeader", "param", "est_se", "Group", "betweenwithin", "label")] <- NULL
    names(all_res[[2]])[-ncol(all_res[[2]])] <- paste0(names(all_res[[2]])[-ncol(all_res[[2]])], "_std")
    results <- merge(all_res[[1]], all_res[[2]], by = "id", all.x = TRUE)
    results["id"] <- NULL
  }
  results <- data.frame(mplus_to_lavaan_labels(results$paramHeader, results$param), results, stringsAsFactors = FALSE)
  if(any(results$paramHeader == "New.Additional.Parameters")){
    results$rhs[results$op == ":="] <- sapply(results$lhs[results$op == ":="], function(constr){
      trimws(gsub("^.+?=(.+);", "\\1", x$input$model.constraint[grepl(paste0("(?<=\\s)", tolower(constr), "(?=[= ])"), tolower(x$input$model.constraint), perl = TRUE)]))
    })
  }
  names(results) <- tolower(names(results))
  if("betweenwithin" %in% names(results)) names(results)[names(results) == "betweenwithin"] <- "level"
  # Drop id column
  results[["id"]] <- NULL
  if(!is.null(columns)){
    results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
  } else {
    first_cols <- c("lhs", "op", "rhs", "paramheader", "param", "est", "se", "est_se",
      "pval", "est_sig", "confint", "est_std", "se_std", "pval_std",
      "est_sig_std", "confint_std")
    last_cols <- c("group", "level", "label")
    order_cols <- c(names(results)[names(results) %in% first_cols],
                    names(results)[!names(results) %in% c(first_cols, last_cols)],
                    names(results)[names(results) %in% last_cols])
    results <- results[, order_cols, drop = FALSE]
  }

  class(results) <- c("tidy_results", class(results))
  results
}

internal_table_mplusmodel <- function(x, parameters, digits = 2, format_numeric = TRUE){
  results <- x$parameters[[parameters]]
  if(is.null(results[["se"]])){
    return(NULL)
  }

  add_cis <- FALSE
  if(!is.null(x$parameters[[paste0("ci.", parameters)]])){
    if(dim(results)[1]==dim(x$parameters[[paste0("ci.", parameters)]])[1]){
      add_cis <- TRUE
      results <- cbind(results, x$parameters[[paste0("ci.", parameters)]][, c("low2.5", "up2.5")])
    }
  }

  if(!is.null(x$indirect[[parameters]])){
    overall <- x$indirect[[parameters]]$overall
    if(!is.null(overall)){
      if(!is.null(overall[["summary"]])){
        paramHeader <- gsub("\\s+", "\\.", overall[["summary"]])
      } else {
        paramHeader <- "Sum.of.indirect"
      }
      param <- paste(overall$outcome, overall$pred, sep = ".")
      overall$pred <- paramHeader
      overall$outcome <- param
      names(overall)[c(1, 2)] <- c("paramHeader", "param")
      if(add_cis){
        overall <- cbind(overall, x$indirect[[paste0("ci.", parameters)]]$overall[, c("low2.5", "up2.5")])
      }
      names(overall)[match(tolower(names(results)), tolower(names(overall)))] <- names(results)[na.omit(match(tolower(names(overall)), tolower(names(results))))]
      results <- rbind(results, overall[, match(names(results), names(overall))])
    }

    specific <- x$indirect[[parameters]]$specific
    if(!is.null(specific)){
      paramHeader <- "Specific.indirect"
      param <- paste(specific$pred, specific$intervening, specific$outcome, sep = ".")
      specific$pred <- paramHeader
      specific$intervening <- param
      names(specific)[c(1, 2)] <- c("paramHeader", "param")
      if(add_cis){
        specific <- cbind(specific, x$indirect[[paste0("ci.", parameters)]]$specific[, c("low2.5", "up2.5")])
      }
      names(specific)[match(tolower(names(results)), tolower(names(specific)))] <- names(results)[na.omit(match(tolower(names(specific)), tolower(names(results))))]
      results <- rbind(results, specific[, match(names(results), names(specific))])
    }
  }

  # CHeck which columns can be numeric
  value_columns <- names(results)[can_be_numeric(results)]
  var_classes <- sapply(results[value_columns], class)
  results[value_columns[which(var_classes == "character")]] <- lapply(results[value_columns[which(var_classes == "character")]], as.numeric)
  results[value_columns[which(var_classes == "factor")]] <- lapply(results[value_columns[which(var_classes == "factor")]], as_numeric_factor)

  constrained_rows <- results$pval == 999

  results$label <- param_label(results)
  if(all(c("est", "pval") %in% names(results))){
    # Call est_sig
    cl <- match.call()
    cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
    cl[["x"]] <- results$est
    cl[["sig"]] <- results$pval
    cl[[1L]] <- quote(est_sig)
    results$est_sig <- eval.parent(cl)
  }

  # Call conf_int
  cl <- match.call()
  cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
  cl[["x"]] <- results
  cl[[1L]] <- quote(conf_int)
  results$confint <- eval.parent(cl)
  if(format_numeric){
    results[, value_columns] <- lapply(results[, value_columns], format_with_na, digits = digits, format = "f")
  }
  results[constrained_rows, which(names(results) %in% c("se", "pval", "est_se", "confint"))] <- NA
  id_cols <- c("paramHeader", "param", "Group", "betweenwithin", "LatentClass")
  results$id <- do.call(paste0, results[which(names(results) %in% id_cols)])
  results
}

mplus_to_lavaan_labels <- function(paramHeader, param){
  op <- paramHeader
  op[grepl("^.+?\\.\\|$", op)] <- "=~"
  op[op == "New.Additional.Parameters"] <- ":="
  op[op == "Thresholds"] <- "|"
  op[op %in% c("Residual.Variances", "Variances")] <- "~~"
  with_statements <- grepl("^.+?\\.WITH$", op)
  op[with_statements] <- "~~"
  op[op %in% c("Means", "Intercepts")] <- "~1"
  op[grepl("^.+?\\.ON$", op)] <- "~"
  op[grepl("^.+?\\.BY$", op)] <- "=~"

  rhs <- lhs <- param
  rhs[op == "~1"] <- ""
  lhs[op %in% c("~", "=~")] <- unlist(sapply(strsplit(paramHeader[op %in% c("~", "=~")], "\\."), `[`, 1))
  lhs[with_statements] <- unlist(sapply(strsplit(paramHeader[with_statements], "\\."), `[`, 1))
  cbind(lhs, op, rhs)
}

lavaan_labels <- function(x){
  x$left <- x$mid <- ""
  x$mid[x$op == "=~"] <- "BY"
  x$mid[x$op == ":="] <- ":="
  x$left[x$op == "|"] <- "Thresholds"
  #x$rhs[x$op == "|"] <- paste0(".", x$rhs[x$op == "|"])
  x$mid[x$op == "~~" & !(x$lhs == x$rhs)] <- "WITH"
  x$left[x$op == "~1"] <- "Means"
  x$mid[x$op == "~"] <- "ON"
  x$left[x$op %in% c("~~", "~*~") & x$lhs == x$rhs] <- "Variances"
  x$rhs[x$op %in% c("~~", "~*~") & x$lhs == x$rhs] <- ""

  apply(x[c("left", "lhs", "mid", "rhs")], 1, function(i){
    paste0(i[!i==""], collapse = ".")
  })
}

#' Add significance asterisks to object
#'
#' Takes an object, and adds significance asterisks.
#' @param x An object for which a method exists. This will be treated as numeric
#' by the default method.
#' @param digits Integer. The number of digits to round the estimate column to.
#' @param sig Optional, a vector of p-values for the default method.
#' @return A character vector of formatted estimates.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @seealso table_results
#' @export
#' @examples
#' est_sig(c(.222, .3333), sig = c(.054, .045))
est_sig <- function(x, digits = 2, sig = NULL){
  UseMethod("est_sig")
}

#' @method est_sig default
#' @export
est_sig.default <- function(x, digits = 2, sig = NULL){
  out <- format_with_na(x, digits = digits, format = "f")
  out[which(sig<.05)] <- paste0(out[which(sig<.05)], "*")
  out[which(sig<.01)] <- paste0(out[which(sig<.01)], "*")
  out[which(sig<.001)] <- paste0(out[which(sig<.001)], "*")
  out
}

#' @method est_sig mplus.params
#' @export
est_sig.mplus.params <- function(x, digits = 2, sig = NULL){
  Args <- list(x = x[["est"]],
               sig = x[["pval"]])
  do.call(est_sig, Args)
}



#' Format confidence intervals
#'
#' Creates 'APA'-formatted confidence intervals, either from an object for which
#' a method exists, or from the arguments \code{lb} and \code{ub}. When argument
#' \code{x} is a numeric vector, it is also possible to construct a confidence
#' interval using the standard error (\code{se}) and a percentile interval
#' (\code{ci}).
#' @param x Optional. An object for which a method exists.
#' @param digits Integer. The number of digits to round the confidence
#' boundaries to.
#' @param se Optional, numeric. Standard error of the parameters.
#' @param lb Optional, numeric. Lower boundary of confidence intervals.
#' @param ub Optional, numeric. Upper boundary of confidence intervals.
#' @param ci Optional, numeric. What percentage CI to use (only used when
#' computing CI from a numeric vector \code{x}, and the standard error
#' \code{se}, based on a normal distribution).
#' @return A character vector of formatted confidence intervals.
#' @author Caspar J. van Lissa
#' @family Reporting tools
#' @seealso table_results est_sig
#' @export
#' @examples
#' conf_int(x = c(1.325, 2.432), se = c(.05336, .00325))
conf_int <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
  UseMethod("conf_int")
}

#' @method conf_int default
#' @export
#' @importFrom stats qnorm
conf_int.default <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
  if(!is.null(se) & !is.null(lb) & !is.null(ub)) {
    message("Both se and lb/ub provided. Used lb/ub to construct confidence interval.", call. = FALSE)
    se <- NULL
  }
  if(!is.null(lb) & !is.null(ub)){
    formatlb <- format_with_na(lb, digits = digits, format = "f")
    formatub <- format_with_na(ub, digits = digits, format = "f")
  } else {
    if(!(ci>0 & ci < 100)) stop("Argument 'ci' must have a value between 0-100.", call. = FALSE)
    bound <- qnorm((1-(ci/100))/2)
    formatlb <- format_with_na(x+(bound*se), digits = digits, format = "f")
    formatub <- format_with_na(x-(bound*se), digits = digits, format = "f")
  }
  out <- paste0("[", formatlb, ", ", formatub, "]")
  out[is.na(formatlb) & is.na(formatub)] <- NA
  return(out)
}

#' @method conf_int mplus.params
#' @export
conf_int.mplus.params <- function(x, digits = 2, se = NULL, lb = NULL, ub = NULL, ci = 95){
  if("low2.5" %in% names(x) | "lower_2.5ci" %in% names(x)){
    if("low2.5" %in% names(x)){
      message("Used bootstrapped confidence intervals.")
      confint <- paste0("[", format_with_na(x$low2.5, digits = digits, format = "f"), ", ", format_with_na(x$up2.5, digits = digits, format = "f"), "]")
    } else {
      confint <- paste0("[", format_with_na(x$lower_2.5ci, digits = digits, format = "f"), ", ", format_with_na(x$upper_2.5ci, digits = digits, format = "f"), "]")
    }
  } else {
    message("Calculated confidence intervals from est and se.")
    confint <- paste0("[", format_with_na(x$est-(1.96*x$se), digits = digits, format = "f"), ", ", format_with_na(x$est+(1.96*x$se), digits = digits, format = "f"), "]")
  }
  gsub("^ \\[", "\\[ ", gsub("([^-]\\d\\.\\d{2})", " \\1", confint))
}

# Add parameter labels to Mplus output
#
# Sometimes a single parameter label is more convenient than the two (or more)
# columns returned by \code{readModels}. This function constructs parameter
# labels by concatenating the paramHeader and param columns, or other relevant
# label columns
# @param mplusresults An mplusModel object, as returned by \code{readModels}.
# @return A character vector of parameter labels.
# @author Caspar J. van Lissa
# @family Mplus functions
# @seealso \code{\link[MplusAutomation]{readModels}}.
# @export
# @examples
# data <- data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B"))
# param_label(data)
param_label <- function(mplusresults){
  label_columns <- c("paramheader", "param", "pred", "intervening", "summary", "outcome", "group", "betweenwithin")
  label_columns <- names(mplusresults)[which(tolower(names(mplusresults)) %in% label_columns)]
  return(apply(mplusresults[label_columns], 1, paste0, collapse = "."))
  if(!is.null(mplusresults[["paramHeader"]])&!is.null(mplusresults[["param"]])){
    return(paste(mplusresults$paramHeader, mplusresults$param, sep = "."))
  }
  if(!is.null(mplusresults[["pred"]])&!is.null(mplusresults[["intervening"]])&!is.null(mplusresults[["outcome"]])){
    return(paste("IND", mplusresults$pred, mplusresults$intervening, mplusresults$outcome, sep = "."))
  }
  if(!is.null(mplusresults[["pred"]])&!is.null(mplusresults[["summary"]])&!is.null(mplusresults[["outcome"]])){
    return(paste(gsub("\\s", "\\.", mplusresults$summary), mplusresults$outcome, mplusresults$pred, sep = "."))
  }
}


# Row-binds tables for publication
#
# Converts tables (data.frames, matrices) to character, and row-binds them,
# inserting a label into the first column for each sub-table.
# @param table_list A list of tables.
# @return A table.
# @author Caspar J. van Lissa
# @family Mplus functions
# @export
# @examples
# table_list <- list(
#   table_f = data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B")),
#   table_g = data.frame(paramHeader = c("G.BY", "G.BY"), param = c("A", "B")))
# table_list <- list(
#   data.frame(paramHeader = c("F.BY", "F.BY"), param = c("A", "B")),
#   data.frame(paramHeader = c("G.BY", "G.BY"), param = c("A", "B")))
# rbind_tables(table_list)
rbind_tables <- function(table_list){
  if(length(unique(sapply(table_list, ncol))) > 1) stop("Not all tables have the same number of columns.")
  if(is.null(names(table_list))) names(table_list) <- 1:length(table_list)
  do.call(rbind,
          lapply(names(table_list), function(x){
            rbind(
              c(x, rep("", (ncol(table_list[[x]])-1))), sapply(table_list[[x]], as.character))
          })
  )
}

#' Extract correlation tables
#'
#' Extracts a publication-ready covariance or correlation matrix from an object
#' for which a method exists.
#' @param x An object for which a method exists.
#' @param value_column Character. Name of the column to use to propagate the
#' matrix. Defaults to "est_sig_std", the standardized estimate with
#' significance asterisks.
#' @param digits Number of digits to round to when formatting values.
#' @param ... Additional arguments passed to and from methods.
#' @return A Matrix or a list of matrices (in case there are between/within
#' correlation matrices).
#' @author Caspar J. van Lissa
#' @export
#' @examples
#' library(lavaan)
#' HS.model <- '  visual =~ x1 + x2 + x3
#'                textual =~ x4 + x5 + x6
#'                speed   =~ x7 + x8 + x9 '
#' fit <- cfa(HS.model,
#'            data = HolzingerSwineford1939,
#'            group = "school")
#' table_cors(fit)
table_cors <- function(x, value_column = "est_sig_std", digits = 2, ...){
  UseMethod("table_cors", x)
}

#' @method table_cors default
#' @export
table_cors.default <- function(x, value_column = "est_sig_std", digits = 2, ...){
  correlations <- table_results(x, columns = NULL, digits = digits)
  grouping_cols <- c("group", "level")[c("group", "level") %in% names(correlations)]
  if(length(grouping_cols) > 0){
    if(length(grouping_cols) > 1){
      correlations$split_id <- do.call(paste0, c(list(sep = "_"), correlations[, grouping_cols]))
    } else {
      correlations$split_id <- correlations[[grouping_cols]]
    }
  }
  .table_cor_internal(correlations = correlations, value_column = value_column)
}

.table_cor_internal <- function(correlations, value_column){
  if("split_id" %in% names(correlations)){
    outlist <- lapply(unique(correlations$split_id), function(i){
      .table_cor_internal(correlations = correlations[correlations$split_id == i, -which(names(correlations) == "split_id")],
                value_column = value_column)
    })
    names(outlist) <- unique(correlations$split_id)
    return(outlist)
  }
  # End recursion
  cors <- correlations[is_cor(correlations), c("lhs", "rhs", value_column)]
  cor_order <- unique(c(rbind(cors$lhs, cors$rhs)))
  names(cors)[3] <- "value"
  cors <- rbind(cors, data.frame(lhs = cors$rhs, rhs = cors$lhs, value = cors$value))
  vars <- t(sapply(unique(cors$lhs), function(x){unlist(correlations[correlations$lhs == x & correlations$rhs == x & correlations$op == "~~", c("lhs", "rhs", value_column)])}))
  colnames(vars)[3] <- "value"
  cors <- rbind(cors, vars)
  should_have <- expand.grid(cor_order, cor_order, stringsAsFactors = FALSE)
  for(i in 1:nrow(should_have)){
    if(!any(apply(cors[, 1:2], 1, function(x){ all(x == should_have[i, ])}))){
      cors[(nrow(cors)+1), ] <-  c(unlist(should_have[i, , drop = TRUE]), NA)
    }
  }
  cors <- cors[order(cors$lhs, cors$rhs),]
  out <- matrix(cors$value, ncol = length(unique(cors$lhs)))
  rownames(out) <- colnames(out) <- unique(cors$lhs)
  out[is.na(out)] <- ""
  out
}


#' @importFrom utils getFromNamespace
#' @importFrom lavaan parametertable lavInspect standardizedsolution
lav_getParameterLabels <-
  getFromNamespace("getParameterLabels", "lavaan")

#' @importFrom lavaan parameterEstimates lavInspect standardizedsolution partable
#' @method table_results lavaan
#' @export
table_results.lavaan <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  # Rename dictionary for consistency with mplus
  user_specified <- partable(x)
  remthese <- which(
      (user_specified$op == "==" & user_specified$user != 1L) |
        (user_specified$op == "==" & user_specified$user == 1L) |
        (user_specified$op %in% c("<", ">")))
  if(length(remthese > 0)) user_specified <- user_specified[-remthese, , drop = FALSE]
  user_specified <- (user_specified$free != 0 | !is.na(user_specified$ustart))

  rename_dict <- c("pvalue" = "pval")
  pars_unst <- parameterEstimates(x)
  if("label" %in% names(pars_unst)){
     names(pars_unst)[names(pars_unst) == "label"] <- "lavaan_label"
  }
  # Rename columns for consistency with mplus
  names(pars_unst)[match(names(rename_dict), names(pars_unst))] <- rename_dict[names(rename_dict) %in% names(pars_unst)]
  pars_unst$label <- lavaan_labels(pars_unst)

  num_groups <- lavInspect(x, what = "ngroups")
  if(num_groups > 1){
    group_labels <- lavInspect(x, what = "group.label")
    if(!all(group_labels %in% unique(pars_unst$group))){
      if(is.numeric(pars_unst$group)){
        pars_unst$group[pars_unst$group > 0] <- group_labels[pars_unst$group]
        pars_unst$group[pars_unst$group == 0] <- NA
      }
    }
    pars_unst$label <- paste2(pars_unst$label, pars_unst$group, sep = ".")
  }
  if("level" %in% names(pars_unst)){
    pars_unst$label <- paste2(pars_unst$label, pars_unst$level, sep = ".")
  }
  # Unst
  # Call conf_int
  cl <- match.call()
  cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
  cl[["x"]] <- pars_unst$est
  cl[["lb"]] <- pars_unst$ci.lower
  cl[["ub"]] <-  pars_unst$ci.upper
  cl[[1L]] <- quote(conf_int)
  pars_unst$confint <- eval(cl)
  # Call est_sig
  cl <- match.call()
  cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
  cl[["x"]] <- pars_unst$est
  cl[["sig"]] <- pars_unst$pval
  cl[[1L]] <- quote(est_sig)
  pars_unst$est_sig <- eval(cl)
  pars_unst[c("z", "ci.lower", "ci.upper")] <- NULL

  # Std
  pars_std <- standardizedsolution(x)
  names(pars_std)[match(names(rename_dict), names(pars_std))] <- rename_dict[names(rename_dict) %in% names(pars_std)]
  # Call conf_int
  cl <- match.call()
  cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "se", "lb", "ub", "ci")))]
  cl[["x"]] <- pars_std$est
  cl[["lb"]] <- pars_std$ci.lower
  cl[["ub"]] <-  pars_std$ci.upper
  cl[[1L]] <- quote(conf_int)
  pars_std$confint <- eval(cl)
  # Call est_sig
  cl <- match.call()
  cl <- cl[c(1, which(names(cl) %in% c("x", "digits", "sig")))]
  cl[["x"]] <- pars_std$est
  cl[["sig"]] <- pars_std$pval
  cl[[1L]] <- quote(est_sig)
  pars_std$est_sig <- eval(cl)
  # Remove redundant columns


  pars_std[c("lhs", "op", "rhs", "group", "z", "ci.lower", "ci.upper")] <- NULL

  names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))] <- paste0(names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))], "_std")
  if("est.std" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "est.std")] <- "est_std"
  if("label" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "label")] <- "lavaan_label"
  results <- cbind(pars_unst, pars_std)
  results <- two_to_one(results)
  # Apply digits
  fixed_parameters <- is.na(results$z)
  value_columns <- names(results)[can_be_numeric(results)]
  if(format_numeric){
    results[, value_columns] <- lapply(results[, value_columns],
                                       format_with_na, digits = digits, format = "f")
  }
  results[fixed_parameters, c("z", "se", "pval", "se_std", "pval_std")[which(c("z", "se", "pval", "se_std", "pval_std") %in% names(results))]] <- ""

  if(!is.null(columns)){
    results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
  } else {
    first_cols <- c("lhs", "op", "rhs", "est", "se", "pval", "est_sig", "confint",
                    "est_std", "se_std", "pval_std", "est_sig_std", "confint_std")
    last_cols <- c("block", "group", "level", "lavaan_label", "mplus_label", "label")
    order_cols <- c(names(results)[names(results) %in% first_cols],
                    names(results)[!names(results) %in% c(first_cols, last_cols)],
                    names(results)[names(results) %in% last_cols])
    results <- results[, order_cols, drop = FALSE]
  }
  class(results) <- c("tidy_results", class(results))
  if(length(user_specified) == nrow(results)) attr(results, "user_specified") <- user_specified
  results
}

#' @importFrom lavaan parameterEstimates standardizedsolution
#' @importFrom blavaan blavInspect
#' @method table_results blavaan
#' @export
table_results.blavaan <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  # Rename dictionary for consistency with mplus
  user_specified <- blavInspect(x, "list")
  remthese <- which(
    (user_specified$op == "==" & user_specified$user != 1L) |
      (user_specified$op == "==" & user_specified$user == 1L) |
      (user_specified$op %in% c("<", ">")))
  if(length(remthese > 0)) user_specified <- user_specified[-remthese, , drop = FALSE]
  user_specified <- (user_specified$free != 0 | !is.na(user_specified$ustart))

  pars_unst <- parameterEstimates(x)
  if("label" %in% names(pars_unst)){
    names(pars_unst)[names(pars_unst) == "label"] <- "lavaan_label"
  }
  # Rename columns for consistency with mplus
  pars_unst$label <- lavaan_labels(pars_unst)

  num_groups <- blavInspect(x, what = "ngroups")
  if(num_groups > 1){
    group_labels <- blavInspect(x, what = "group.label")
    if(!all(group_labels %in% unique(pars_unst$group))){
      if(is.numeric(pars_unst$group)){
        pars_unst$group[pars_unst$group > 0] <- group_labels[pars_unst$group]
        pars_unst$group[pars_unst$group == 0] <- NA
      }
    }
    pars_unst$label <- paste2(pars_unst$label, pars_unst$group, sep = ".")
  }
  if("level" %in% names(pars_unst)){
    pars_unst$label <- paste2(pars_unst$label, pars_unst$level, sep = ".")
  }

  pars_unst$est_sig <- pars_unst$est
  pars_unst[c("z", "ci.lower", "ci.upper")] <- NULL

  # Std
  pars_std <- standardizedsolution(x)

  pars_std$est_sig <- pars_std$est
  # Remove redundant columns
  pars_std[c("lhs", "op", "rhs", "group", "z", "ci.lower", "ci.upper")] <- NULL

  names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))] <- paste0(names(pars_std)[na.omit(match(c("se", "pval", "est_sig", "confint"), names(pars_std)))], "_std")
  if("est.std" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "est.std")] <- "est_std"
  if("label" %in% names(pars_std)) names(pars_std)[which(names(pars_std) == "label")] <- "lavaan_label"
  results <- cbind(pars_unst, pars_std)
  results <- two_to_one(results)
  # Apply digits
  fixed_parameters <- is.na(results$z)
  value_columns <- names(results)[can_be_numeric(results)]
  if(format_numeric){
    results[, value_columns] <- lapply(results[, value_columns],
                                       format_with_na, digits = digits, format = "f")
  }

  results[fixed_parameters, c("z", "se", "pval", "se_std", "pval_std")[which(c("z", "se", "pval", "se_std", "pval_std") %in% names(results))]] <- ""

  if(!is.null(columns)){
    results <- results[, na.omit(match(columns, names(results))), drop = FALSE]
  } else {
    first_cols <- c("lhs", "op", "rhs", "est", "se", "pval", "est_sig", "confint",
                    "est_std", "se_std", "pval_std", "est_sig_std", "confint_std")
    last_cols <- c("block", "group", "level", "lavaan_label", "mplus_label", "label")
    order_cols <- c(names(results)[names(results) %in% first_cols],
                    names(results)[!names(results) %in% c(first_cols, last_cols)],
                    names(results)[names(results) %in% last_cols])
    results <- results[, order_cols, drop = FALSE]
  }
  class(results) <- c("tidy_results", class(results))
  if(length(user_specified) == nrow(results)) attr(results, "user_specified") <- user_specified
  results
}


#' @method table_results character
#' @export
table_results.character <- function(x, columns = c("label", "est_sig", "se", "pval", "confint", "group", "level"), digits = 2, format_numeric = TRUE, ...){
  cl <- match.call()
  cl <- cl[-which(names(cl) %in% c("x", "columns", "digits"))]
  cl[[1L]] <- str2lang("lavaan::lavaanify")
  cl[["model"]] <- x
  results <- eval.parent(cl)
  class(results) <- c("tidy_results", class(results))
  results
}
# table_results.character("y ~ x", ngroups = 2)

can_be_numeric <- function(x){
  out <- sapply(x, function(col){ tryCatch(expr = {as.numeric(col); return(TRUE)}, warning= function(w){ return(FALSE) }) })
  out & !sapply(x, inherits, what = "logical")
}

format_with_na <- function(x, ...){
  cl <- match.call()
  missings <- is.na(x)
  out <- rep(NA, length(x))
  cl$x <- na.omit(x)
  cl[[1L]] <- quote(formatC)
  out[!missings] <- eval.parent(cl)
  out
}

Try the tidySEM package in your browser

Any scripts or data that you put into this service are public.

tidySEM documentation built on Oct. 25, 2023, 1:06 a.m.