R/07_summarize_ifx.R

In moodymudskipper/tidyx: modified tidyverse functions for interractive use

#' generalized summarize_if / summarize_at / summarize_all
#'
#' takes the features of \code{summarize_if} and \code{summarize_at},
#' in case we want to combine
#' both, and supports a formula or function for the .at parameter, which will
#' be applied on names. Also supports grouping through \code{.by}.
#'
#' @inheritParams dplyr::summarize_if
#' @param .at equivalent of .vars in mutate_at, but enhanced
#' @param .if equivalent of .predicate in mutate_if
#' @param .by a vector or list of variables as characters or given by \code{vars}
#'
#' @export
summarize_ifx <- function(.tbl, .funs, ..., .at = names(.tbl), .if = ~TRUE, .by = NULL)
{
  # store names of by calls that were not created with an explicit name
  # they will be removed in the ends
  tmp_by_cols <- get_tmp_by_cols(.tbl, .by)

  .at <- switch(mode(.at),
                list = names(.tbl) %in% dplyr:::tbl_at_vars(.tbl, .at),
                logical = .at,
                numeric = `[<-`(rep(FALSE,length(.tbl)), .at, value = TRUE),
                character = names(.tbl) %in% .at,
                call = mapx(names(.tbl), .at, .t = "lgl"),
                `function` = mapx(names(.tbl), .at, .t = "lgl"))
  .if        <- if (is.logical(.if)) .if else  mapx(.tbl, .if, .t = "lgl")
  .predicate <- .if & .at
  funs <- dplyr:::manip_if(.tbl, .predicate, .funs,
                           rlang::enquo(.funs), rlang::caller_env(), ...)

  for (i in seq_along(funs)) {
    .f <- funs[[i]][[2]][[1]]
    if (is.name(.f)) .f <- eval.parent(.f)
    if (!".i" %in% formalArgs(.f))
      formals(.f) <- c(formals(.f), list(.i = i))
    else message(".f already has a .i formal, the `.i` ",
                 "feature will be disabled for this function")
    if (!".n" %in% formalArgs(.f))
      formals(.f) <- c(formals(.f),list(.n = rlang::names2(funs)[i]))
    else message(".f already has a .n formal, the `.n` ",
                 "feature will be disabled for this function")
    funs[[i]][[2]][[1]] <- .f
  }

  if (is.null(.by))
    x <- dplyr::summarize(.tbl, !!!funs)
  else  {
    groups <- dplyr::group_vars(.tbl)
    x <- dplyr::group_by(.tbl,.by, add = TRUE)
    x <- dplyr::summarize(x, !!!funs)
    x <- dplyr::group_by(x, !!!rlang::syms(groups))
    # remove temporary by cols
    if (length(tmp_by_cols)) x <- select(x,-!!sym(tmp_by_cols))
  }
  x
}