R/utilities.eval.R

In ggloop: Create 'ggplot2' Plots in a Loop

#' @include utilities.eval2.R

# ops ---------------------------------------------------------------------
#
#' Arithmetic operators to search for.

ops <- c("/", "\\+", "-", "\\*", "\\^")


# 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 lst A list object to be tested.

is.op <- function(lst) {
  has.ops <- sapply(ops, function(expr) grep(expr, lst))
  has.ops <- unlist(has.ops)
  names(has.ops) <- NULL
  unique(has.ops)
}


# fun.par -----------------------------------------------------------------
#
#' Regular expression pattern for determing if possible function parenthesis
#' are present. Searches for \code{"("} and \code{")"} preceeded by any number
#' of characters.

fun.par <- c("[A-Za-z]+\\(.+\\)")


# 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) {
  funs <- sapply(fun.par, function(expr) grep(expr, lst))
  names(funs) <- NULL
  funs <- unique(funs)
  if (is.list(funs)) funs <- unlist(funs)
  funs
}


# 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))
  }


# rm.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.

rm.gg2 <- function(expr) {
  ops <- if (is.list(expr)) is.op(expr[[1L]]) else is.op(expr)
  funs <- is.fun(expr)
  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{dply} 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]
}