R/internal.R

In mattansb/marginC: Create a multi-factor vector of weights

#' Combine factor weights
#'
#' @author Mattan S. Ben-Shachar
#' @param fw a list of factor weights
#'
#' @importFrom  magrittr %>%
build_mw <- function(fw){
  expand.grid(fw) %>%
    apply(.,1,prod)
}

#' Test if factor weights are compatible with a reference-grid
#'
#' @author Mattan S. Ben-Shachar
#' @param factor_weights a list of factor weights
#' @param grid grid object made with \code{\link[emmeans]{emmeans}}.
#'
#' @import purrr
test_grid <- function(factor_weights,grid){
  if(!is.null(grid)){
    # reorder factor names to match 'grid'
    factor_names <- names(factor_weights)
    grid_names <- names(grid@levels) # get factor names from 'grid'
    if(any(is.na(match(factor_names,grid_names))))
      stop("List contains an unidentified factor")
    factor_weights <- factor_weights[match(grid_names, factor_names)]

    # remove missing factors
    missing_factors <- map_lgl(factor_weights,is.null)
    if(any(missing_factors)) {
      warning("Some factor(s) missing from list.")
      factor_weights <- factor_weights[!missing_factors]
    }

    # test factor lengths
    test_factor_lengths <- function(fname){
      length_from_weights <- length(factor_weights[[fname]])
      length_from_grid <- length(grid@levels[[fname]])
      if (length_from_grid!=length_from_weights) {
        stop(paste0(fname,": Mismatch between length of marginal weights and number of levels"))
      }
      return(length_from_grid!=length_from_weights)
    }
    test_fl <- map_lgl(names(factor_weights),test_factor_lengths)
  } else {
    warning("Assuming factors are in the correct order!")
  }
  return(factor_weights)
}