mutatem.r

#' Multivariate mutate
#' Mutate multiple columns
#' 
#' @param .df A tbl
#' @param ... Name-value pairs of expressions that return one or more columns with 1 or nrow(.df) observations
#' @param .dots A list of formulas used to work around non-standard evaluation.
#' @export 
#' @aliases mutatem_
#' @examples
#' df <- tibble(x=1:5, y=5:1)
#' m <- function(x) tibble(xx=seq(1, 5, along=x), 
#'                         yy=xx+10)

#' mi <- function(x) {
#'   setNames(m(x), NULL)
#' }

#' mutatem(df, mi(y))
#' mutatem_(df, list(h=~m(y)))

#' mutatem(df, m(y), a=x*3)
#' mutatem(df, m(y), a=`m(y)_xx`*3)
#' mutatem(df, m=m(y), a=m_xx + x *3)
#' mutatem(df, mi(y))

#' data.frame(text=c("a b c", "c i a", "r p g", "x y z", "r m d", "r e m")) %>%
#'   mutatem(split=reshape2::colsplit(text, " ", 1:3))
mutatem_ <- function(.df, args) {
  args <- lazyeval::as_f_list(args) %>%
    lazyeval::auto_name()
  
  for(nm in names(args)) {
    o <- lazyeval::f_eval(args[[nm]], .df)
    if(length(dim(o)) > 1) {
      if(!has_valid_names(names(o))) {
        stop(lazyeval::f_label(args[[nm]], 
                   " must return a named list or data.frame."), call. = FALSE)
      }
      o <- setNames(o, paste0(nm, "_", names(o)))
      .df <- bind_cols(.df, o)
    } else {
      .df[[nm]] <- o
    }
  }
  
  .df
}

# there must be something in dplyr
has_valid_names <- function(x) {
  if(is.null(x)) {
    return(FALSE)
  }
  
  if(any(is.na(x))) {
    return(FALSE)
  }
  
  if(any(x == "")) {
    return(FALSE)
  }
  
  if(!all(is.character(as.character(x)))) {
    return(FALSE)
  }
  
  return(TRUE)
}

#' @export
#' @rdname mutatem_
mutatem <- function(.df, ...) {
  mutatem_(.df, lazyeval::dots_capture(...))
}