R/c_partables.R

In modelbpp: Model BIC Posterior Probability

#' @title Manipulate Parameter Tables
#'
#' @description Functions to manipulate
#' a `partables`-class object
#'
#' @name manipulate_partables
NULL

#'
#' @details
#' The `partables`-class objects have
#' a `c()` method that can be used to
#' combine parameter tables.
#' Each object must be
#'
#' a. a `partables`-class object,
#' b. a `model_set`-class object,
#' c. a `lavaan`-class object, or
#' d. a parameter table of
#' the class `lavaan.data.frame()`,
#' usually generated by
#' [lavaan::parameterTable()].
#' Other objects will be discarded.
#'
#' Names will be used when combining
#' objects. If two objects have the same
#' names, then only the first one will be
#' retained. No warning message will be
#' issued. Users are encouraged to
#' explicitly name all objects carefully.
#'
#' Note that, to invoke this method,
#' the first object must be a
#' `partables` object.
#'
#' @return
#' A `partables`-class objects with
#' all the objects supplied combined
#' together. If an object is
#' a `lavaan`-class object, its
#' parameter table will be retrieved
#' by [lavaan::parameterTable()].
#' If an object is a `model_set`-class
#' object, the stored `partables`-class
#' object will be retrieved.
#'
#' @param ... An arbitrary number of
#' objects. All invalid objects (see
#' details) will be discarded. If an
#' object is named and is not
#' `partables` object, its name will be
#' used.
#'
#' @param x A `partables`-class object.
#'
#' @param model_names A character vector
#' of the names of models in a
#' `partables`-class object.
#'
#' @author Shu Fai Cheung <https://orcid.org/0000-0002-9871-9448>
#'
#' @examples
#'
#' library(lavaan)
#'
#' moda <-
#' "
#' x3 ~ a*x1 + b*x2
#' x4 ~ a*x1
#' ab := a*b
#' "
#'
#' fita <- sem(moda, dat_path_model, fixed.x = TRUE)
#'
#' outa <- model_set(fita,
#'                   progress = FALSE,
#'                   parallel = FALSE)
#'
#' modb <-
#' "
#' x3 ~ a*x1 + b*x2
#' x4 ~ a*x2
#' ab := a*b
#' "
#'
#' fitb <- sem(modb, dat_path_model, fixed.x = TRUE)
#'
#' outb <- model_set(fitb,
#'                   progress = FALSE,
#'                   parallel = FALSE)
#'
#' mod2 <-
#' "
#' x2 ~ 0*x3 + 0*x4
#' x1 ~ 0*x3
#' "
#' fit2 <- sem(mod2, dat_path_model)
#'
#' mod3 <-
#' "
#' x2 ~ x3 + 0*x4
#' x1 ~ x3
#' "
#' fit3 <- sem(mod3, dat_path_model)
#'
#' out <- c(outa$models, user2 = fit2, outb$models, user3 = fit3)
#' out
#'
#' out2 <- c(outa, user2 = fit2, outb$models, user3 = fit3)
#' out2
#'
#' out3 <- c(outa, user2 = fit2, outb, user3 = fit3)
#' out3
#'
#' @rdname manipulate_partables
#' @order 1
#' @export

c.partables <- function(...) {
    ddd <- list(...)
    ddd_names <- sapply(as.list(match.call()[-1]), deparse)
    if (!is.null(names(ddd_names))) {
        i <- which(sapply(names(ddd_names), function(x) {nchar(x) > 0}))
        if (length(i) > 0) {
            ddd_names[i] <- names(ddd_names)[i]
            ddd_names <- unname(ddd_names)
          }
      }
    is_partables <- sapply(ddd,
                           inherits,
                           what = "partables")
    is_lavaan <- sapply(ddd,
                        inherits,
                        what = "lavaan")
    is_ptable <- sapply(ddd,
                        inherits,
                        what = "lavaan.data.frame")
    is_model_set <- sapply(ddd,
                           inherits,
                           what = "model_set")
    if (any(is_lavaan)) {
        p <- which(is_lavaan)
        for (i in p) {
            tmp <- list(lavaan::parameterTable(ddd[[i]]))
            names(tmp) <- ddd_names[i]
            ddd[[i]] <- tmp
          }
      }
    if (any(is_ptable)) {
        p <- which(is_ptable)
        for (i in p) {
            tmp <- list(ddd[[i]])
            names(tmp) <- ddd_names[i]
            class(tmp) <- c("partables", class(tmp))
            ddd[[i]] <- tmp
          }
      }
    if (any(is_model_set)) {
        p <- which(is_model_set)
        for (i in p) {
            ddd[[i]] <- ddd[[i]]$models
          }
      }
    is_valid <- is_ptable |
                is_lavaan |
                is_partables |
                is_model_set
    ddd <- ddd[is_valid]
    out <- c_partables(ddd)
  }

#' @details
#' The `model_set` class also has a
#' `c`-method. It
#' will replace the first object by the stored
#' partables and then call the `c`-method of `partables` objects.
#'
#' @rdname manipulate_partables
#' @order 2
#' @export

c.model_set <- function(...) {
    ddd <- list(...)
    ddd[[1]] <- ddd[[1]]$models
    ddd_names <- sapply(as.list(match.call()[-1]), deparse)
    if (!is.null(names(ddd_names))) {
        i <- which(sapply(names(ddd_names), function(x) {nchar(x) > 0}))
        if (length(i) > 0) {
            ddd_names[i] <- names(ddd_names)[i]
            ddd_names <- unname(ddd_names)
          }
      }
    names(ddd) <- ddd_names
    do.call(c.partables, ddd)
  }

#' @details
#' The function [partables_drop()] is
#' for dropping models from a
#' `partables`-class object.
#'
#' @rdname manipulate_partables
#' @order 2
#'
#' @export

partables_drop <- function(x,
                           model_names = NULL) {
    if (!inherits(x, "partables")) {
        stop("The input is not a partables-class object.")
      }
    model_names <- intersect(model_names, names(x))
    if (length(model_names) == 0) {
        return(x)
      }
    x[model_names] <- NULL
    return(x)
  }


#' @noRd

c_partables <- function(ddd) {
    if (length(ddd) == 1) {
        return(ddd[[1]])
      }
    out <- ddd[[1]]
    for (i in seq_along(ddd)[-1]) {
        ddd_i <- ddd[[i]]
        i_names <- names(ddd_i)
        i_names <- setdiff(i_names, names(out))
        if (length(i_names) == 0) next
        for (j in i_names) {
            out[[j]] <- ddd_i[[j]]
          }
      }
    out
  }