ggloop: Create 'ggplot2' Plots in a Loop

#' @include utilities.eval2.R

# Suprres "No visible binding for global variable "."" NOTE
#
if(getRversion() >= "2.15.1")  utils::globalVariables(c("."))


# is_c() ------------------------------------------------------------------
#
#' @title
#' Determine if the first element of a parse tree is identical to the \code{c}
#' function.
#'
#' @description
#' This provides a quick way to evaluate whether the \code{x} or \code{y}
#' vectors have a \code{c()} wrapping. This is important for subsequent
#' subsetting of the respective vectors. Those vectors without a \code{c()}
#' wrapping will be wrapped by \code{list()}. Symbols are not passed to
#' \code{is_c()} due to the subsetting of the first element of the parse-tree.
#'
#' @param expr A parse tree generated by \code{substitute()}.

is_c <- function(expr) {
  if (is.symbol(expr)) FALSE
  else identical(expr[[1L]], quote(c))
}





# is_dplyr ----------------------------------------------------------------
#
#' Determine if an input expression is a dplyr-like call.
#'
#' @param expr A vector of substituted variables or functions. Either a call to
#'   multiple variables with the outer \code{c()} wrapper stripped, a single
#'   variable call wrapped in a \code{list()}, or a \code{:} expression.

is_dplyr <- function(expr) {
  expr <- expr %>% as.list()

  is_single_var <- expr %>%
    sapply(function(x) x %>% as.list() %>% length() %>% `==`(1))

  has_colon <- expr %>%
    as.list() %>%
    sapply(function(y) y %>% as.list() %>% grepl(":", .) %>% any())
}





# is_op() ----------------------------------------------------------------
#
#' @title
#' Determine if an input uses an arithmetical operator (\code{/}, \code{+},
#' \code{-}, \code{*}, \code{^}).
#'
#' @description
#' Matches the arugment the \code{ops} string using \code{grep}. Any matches are
#' subsequently noted and the unique list is returned.
#'
#' @param expr An expression to be tested.

is_op <- function(expr) {
  ops <- c("/|\\+|-|\\*|\\^")

  logic <- ops %>%
    grep(expr) %>%
    unlist() %>%
    `names<-`(NULL) %>%
    unique()

  return(logic)
}





# is_fun() ----------------------------------------------------------------
#
#' @title
#' Is it a function?
#'
#' @description
#' Attempts to decipher if a function other than \code{c()} has been supplied as
#' input. Returns the position of the possible non-\code{c} functions in
#' \code{lst}.
#'
#' @param lst A list of inputs wrapped in \code{substitute()} and coerced to a
#' list using \code{as.list()}.

is_fun <- function(lst) {
  funRegEx <- c("^[A-Za-z\\.][A-Za-z0-9\\._]+\\(.+\\)")

  funs <- funRegEx %>%
    grep(lst) %>%
    `names<-`(NULL) %>%
    unique()
  funs <- if (is.list(funs)) unlist(funs) else funs
  return(funs)
}





# which_gg2() ----------------------------------------------------------------
#
#' @title
#' Remove \code{ggplot2} style and stand-alone aesthetic arguments (i.e.
#' \code{y}, \code{x:z}, etc).
#'
#' @description
#' Expression aesthetics (variables wrapped in functions or using prefix/infix
#' operators) need to be handled differently than just standalone variable
#' aesthetics (i.e. \code{mpg}) or \pkg{dplyr}-like variable calls (i.e.
#' \code{mpg:hp}).
#'
#' @param expr A parse tree generated by \code{substitute()}. If the tree is not
#'   wrapped by \code{c()} then it is advised to wrap \code{x} with
#'   \code{list()}.
#'
#' @details
#' The reason it is advised wrap \code{x} in a \code{list} is due to the way
#' \code{x} will be indexed/subsetted. The \code{c} function wrapping is
#' assumed, so therefore the \code{list} wrapping is needed.

which_gg2 <- function(expr) {
  ops <- if (is.list(expr)) is_op(expr[[1L]]) else is_op(expr)
  funs <- is_fun(expr)
  return(c(ops, funs))
}





# messy_eval --------------------------------------------------------------
#
#' Reduce the amount of code by turning this sequence into a function.
#'
#' @param expr Lazy dots.
#' @param vars Variable names
#' @param names_list List of names built from \code{vars}.
#'
#' @details
#' The bulk of this code was taken from the \code{dplyr} package.

messy_eval <- function(expr, vars, names_list){

  eval.index <- lazyeval::lazy_dots(eval(expr)) %>%
    lazyeval::as.lazy_dots() %>%
    lazyeval::lazy_eval(c(names_list, select_helpers))

  eval.index <- eval.index[[1]]

  vars[eval.index]
}