marginC: Create a multi-factor vector of weights

#' Create a multi-factor vector of weights
#'
#' Create a vector of weights for use in 'contrast()' by specifying marginal weights per factor. Use this function instead of step 3 in \emph{Follow-Up Contrasts and Post-Hoc Tests} in \code{\link[afex]{aov_car}}.
#'
#' @author Mattan S. Ben-Shachar
#' @param x a list, made of tag-value pairs (see \code{\link[base]{list}}), each pair corresponding to a factor: \itemize{
#'   \item tag - must match an existing factor name (rg is used to confirm this).
#'   \item value - a vector of marginal weights, the length of which must match the number of levels of the specified factor.
#' }
#' @param rg a ref.grid object made with \code{\link[lsmeans]{lsmeans}}.
#' @param con.name a charecter vector with the name of the contrast (as will appear in the output of \code{\link[lsmeans]{contrast}}).
#' @return a vector of weights, to be used in \code{\link[lsmeans]{contrast}}.
#' @export
#' @importFrom  magrittr %>%

margin.c <- function(x, .grid, con.name = "contrast1") {
  warning("OLD: use better 'get_marginal_weights' instead.")

  con1 <- do.call(margin.w, c(.grid,x)) %>%
    unname() %>%
    list()
  names(con1) <- con.name
  return(con1)
}

#' Create a multi-factor vector of weights
#'
#' Create a named vector of weights for use in 'contrast()' by specifying marginal weights per factor. Use this function instead of step 3 in \emph{Follow-Up Contrasts and Post-Hoc Tests} in \code{\link[afex]{aov_car}}.
#'
#' @author Mattan S. Ben-Shachar
#' @param .grid an ref.grid object made with \code{\link[lsmeans]{lsmeans}}.
#' @param ... vector(s) of marginal weights, the length of which must match the number of levels of the specified factor, and the name of which match the factor in rg (see example).
#' @return a vector of weights, to be used in \code{\link[lsmeans]{contrast}}.
#' @export
#' @importFrom  magrittr %>%
margin.w <- function(.grid, ...) {
  warning("OLD: use better 'get_marginal_weights' instead.")
  x <- list(...)

  # Get Factor names
  rg.names <- names(.grid@levels) # get factor names from '.grid'
  x.names  <- names(x) # get factor names from 'x'

  if(any(is.na(match(x.names,rg.names))))
    stop("List contains an unidentified factor")

  x.names <- x.names[match(rg.names, x.names)]  # reorder factor names to match '.grid'

  if(any(is.na(x.names))) {
    warning("Some factor(s) missing from list.")
    x.names <- x.names[!is.na(x.names)] # remove missing
  }

  # Get number and size of factors
  get_f_len <- function(i) {
    if (length(.grid@levels[[x.names[i]]])!=length(x[[x.names[i]]]))
      stop(paste0(x.names[i],": Mismatch between length of marginal weights and number of levels"))

    return(length(x[[x.names[i]]]))
  }
  ndims <- length(x.names)
  ldims <- lapply(1:ndims, get_f_len) %>% unlist()

  # function that circles through a vector:
  shifter <- function(vex,n){
    if (n==0) {
      vex
    } else {
      if (n>0) by <- n
      else     by <- length(vex)+n

      c(vex[-seq_len(by)],vex[seq_len(by)])
    }
  }


  # Fill array according to the given weights:
  ar.weights <- array(1,ldims)
  ar.levels <- ""
  for (i in 1:ndims) {
    ar.weights <- x[[x.names[i]]] %>%
      rep(times = prod(ldims[-i])) %>%
      array(dim = shifter(ldims, i-1)) %>%
      aperm(perm = shifter(1:ndims,1-i)) %>%
      multiply_by(ar.weights)

    ar.levels  <- .grid@levels[[x.names[i]]] %>%
      outer(ar.levels, ., paste, sep = ".") %>%
      as.vector()
  }

  vex <- as.vector(ar.weights)
  names(vex) <- substring(ar.levels, 2)
  return(vex)
}

#' Create a multi-factor vector of weights
#'
#' Create a vector of weights for use in 'contrast()' by specifying marginal weights per factor.
#'
#' @author Mattan S. Ben-Shachar
#' @param x not used (internal for `contrast()').
#' @param .mweights a list (or list of list) of vector(s) of marginal weights, the length of which must match the number of levels of the specified factor, and the name of which match the factor in .grid.
#' @param .grid optional grid object made with \code{\link[emmeans]{emmeans}}.
#' @param ... not used.

#' @return a  data frame of weights, to be used in \code{\link[emmeans]{contrast}}.
#' @export
#' @importFrom magrittr %>%
#' @import purrr
marginal_weights.emmc <- function(x, .mweights = NULL, .grid = NULL, ...){
  warning('marginal_weights is deprecated, and should not be used')

  if(is.null(.mweights))
    stop("Oops! Did you forget to set .mweights?")

  if(all(map_lgl(.mweights,is.list))){
    marginal_w <- map(.mweights,~invoke(get_marginal_weights, ., .grid = .grid))
    df <- as.data.frame(marginal_w)
  } else if (all(!map_lgl(.mweights,is.list))) {
    marginal_w <- invoke(get_marginal_weights, .mweights, .grid = .grid)
    df <- data.frame(mw = marginal_w)
  }

  if (nrow(df)!=length(x)) {
    if (is.null(.grid))
      stop("When using 'marginal_weights' with other methods (via interaction), '.grid. is a required argument!")

    # stop("Weights are not well defined (wrong number of weights).")
    marginal_w <- suppressWarnings(
      map(seq_along(.mweights),
          ~invoke(get_marginal_weights, .mweights[.x], .grid = .grid))
    )

    ind <- suppressWarnings(
      map_lgl(marginal_w,~all(`==`(names(.x),x))) %>% which()
    )
    if (length(ind)==0)
      stop("Cannot match weights to factor")

    df <- data.frame(mw = marginal_w[[ind]])
  }

  return(df)
}