USGS-R · jordansread · Sep 10, 2015 · Sep 9, 2015 · Sep 9, 2015 · Sep 9, 2015
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -30,7 +30,8 @@ Imports:
     graphics,
     utils,
     methods,
-    yaml
+    yaml,
+    lazyeval
 Suggests:
     testthat,
     knitr

diff --git a/NAMESPACE b/NAMESPACE
@@ -34,6 +34,9 @@ importFrom(graphics,mtext)
 importFrom(graphics,par)
 importFrom(graphics,plot.new)
 importFrom(graphics,plot.xy)
+importFrom(lazyeval,lazy)
+importFrom(lazyeval,lazy_dots)
+importFrom(lazyeval,lazy_eval)
 importFrom(magrittr,"%>%")
 importFrom(methods,existsFunction)
 importFrom(stats,setNames)

diff --git a/R/calc_views.R b/R/calc_views.R
@@ -223,15 +223,16 @@ remove_field <- function(list, param){
 strip_pts <- function(list, param){
   out <- c()
   for (v in param){
-    if (v %in% names(list))
+    if (v %in% names(list) &&  !inherits(list[[v]], c('function','formula')))
       out <- append(out, list[[v]])
-    else {
+    else{
       u.list <- unname_c(list)
       if(v %in% names(u.list))
         out <- append(out, u.list[[v]])
       else
         out <- append(out, NA)
     }
+
   }
   return(out)
 }

diff --git a/R/curve.R b/R/curve.R
@@ -23,6 +23,7 @@
 #'    
 #' @rdname curve
 #' @export
+#' @importFrom lazyeval lazy lazy_eval
 #' @examples
 #' gs <- gsplot() %>%
 #'    points(x=c(1:5, 3.5), y=c(1:5, 6), legend.name="Stuff") %>%
@@ -42,16 +43,19 @@ curve <- function(object, ...) {
 
 curve.gsplot <- function(object, expr, ..., legend.name=NULL, side=c(1,2)){
 
-  arguments <- list(substitute(expr), ...)
-  expr <- arguments[which(names(arguments)=="")]
+  expr <- lazy(expr)
+  arguments = set_args('curve',...)
+  dots = lazy_dots(...)
+
   increment <- (arguments$to-arguments$from)/10000
   x <- seq(arguments$from, arguments$to, by=increment)
-  y <- eval(parse(text=expr))
+  y <- lazy_eval(expr, data.frame(x=x))
+  arguments = set_args(fun.name = 'lines', x=x, y=y,  lazy_eval(dots[!names(dots) %in% c('from','to')]))
 
-  arguments <- arguments[which(names(arguments)!="" & names(arguments)!="from" & names(arguments)!="to")]
-  arguments <- append(list(x=x, y=y), arguments)
+  to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>% 
+    setNames('lines')
 
-  object <- lines(object, arguments, legend.name=legend.name, side=side)
+  object <- gsplot(append(object, to.gsplot))
 
   return(object)
 }
diff --git a/R/embedded-functions.R b/R/embedded-functions.R
@@ -0,0 +1,27 @@
+is_in_package <- function(x){
+  if (is.symbol(x))
+    return(FALSE)
+
+  isTRUE(find(as.character(x[[1]]), mode = 'function') == paste0('package:',packageName()))
+}
+
+
+separate_args <- function(...){
+
+  dots <- lazy_dots(...)
+  args = list(args=dots,e.fun=c(),e.args=c())
+
+  embeds <- unname(sapply(dots, function(x) is_in_package(x$expr)))
+  if (sum(embeds) > 1)
+    stop('only one embedded function is currently supported')
+  else if (sum(embeds) == 0)
+    return(args)
+
+  embedded.funs <- dots[[which(embeds)]]
+  dots[[which(embeds)]] <- NULL
+  args$args = dots
+  args$e.fun = as.character(embedded.funs$expr[[1]])
+  embedded.funs$expr[[1]] <- NULL
+  args$e.args = embedded.funs$expr
+  return(args)
+}
diff --git a/R/error_bars.R b/R/error_bars.R
@@ -91,5 +91,8 @@ error_bar.gsplot <- function(object, x, y, ..., y.high=0, y.low=0, x.high=0, x.l
 
 }
 
+error_bar.default <- function(x, y, y.high, y.low, x.high, x.low, epsilon=0.1, ...){
+  return()
+}
 
 
diff --git a/R/function_args.R b/R/function_args.R
@@ -7,9 +7,10 @@
 #' @param object the first argument, which may have a class to match functions to
 #' @param \dots user arguments to be used for the list
 #' @param use.default use different function name other than <function>.default (optional)
+#' @param drop boolean for dropping all non-formal args passed in with \dots
 #' 
 #' @keywords internal
-function_args <- function(package, name, object, ..., use.default=paste0(name,'.default')){
+function_args <- function(package, name, object, ..., use.default=paste0(name,'.default'), drop=FALSE){
   params <- list(...)
 
   if (!missing(object)) {
@@ -51,5 +52,8 @@ function_args <- function(package, name, object, ..., use.default=paste0(name,'.
   sort.i[!is.na(match.i)] <- match.i[!is.na(match.i)]
   params <- params[sort(sort.i, index.return = TRUE)$ix]
 
+  if (drop)
+    params = params[names(params) %in% names(formals(defFun))]
+
   return(params)
 }
diff --git a/R/lines.R b/R/lines.R
@@ -44,32 +44,17 @@ lines <- function(object, ...) {
 
 lines.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
   fun.name <- "lines"
-  arguments <- list(...)
-
-  if (is.null(names(arguments))){
-    arguments_gsplot <- arguments
-  } else {
-    arguments_gsplot <- arguments[!names(arguments) %in% c("callouts", "error_bar")]
-  }
-
-  to.gsplot <- list(list(arguments = do.call(set_args, c(fun.name, arguments_gsplot)),  
-                         gs.config=list(legend.name = legend.name, side = side))) %>% 
+  dots = separate_args(...)
+  args = dots$args
+  e.fun = dots$e.fun
+  arguments = set_args(fun.name, lazy_eval(args))
+  to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>% 
     setNames(fun.name)
 
-  if (all(names(to.gsplot$lines$arguments) != "formula") && is.null(to.gsplot$lines$arguments$y)){
-    to.gsplot$lines$arguments$y <- to.gsplot$lines$arguments$x
-    to.gsplot$lines$arguments$x <- seq(length(to.gsplot$lines$arguments$x))
-    if (is.null(to.gsplot$lines$arguments$xlab)) to.gsplot$lines$arguments$xlab <- "Index" 
+  object <- gsplot(append(object, to.gsplot)) # append initial call
+  if (!is.null(e.fun)){
+    embed.args = set_inherited_args(e.fun, arguments, dots$e.args)
+    object <- do.call(e.fun, append(list(object=object), embed.args))
   }
-
-  if ("callouts" %in% names(arguments)){
-    object <- callouts(object, x=to.gsplot$lines$arguments$x, 
-                       y=to.gsplot$lines$arguments$y, arguments$callouts)
-  }
-  if ("error_bar" %in% names(arguments)){
-    object <- error_bar(object, x=to.gsplot$lines$arguments$x, 
-                        y=to.gsplot$lines$arguments$y, arguments$error_bar)
-  }
-
-  return(gsplot(append(object, to.gsplot)))
+  return(object)
 }
diff --git a/R/points.R b/R/points.R
@@ -36,39 +36,28 @@
 #'          axis(side=c(2,4), labels=FALSE, n.minor=4)
 #'          
 #' gs2
+#' 
+#' gs <- points(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats')))
+#' gs
+#' @importFrom lazyeval lazy_dots lazy_eval
 #' @export
 points <- function(object, ...) {
   override("graphics", "points", object, ...)
 }
 
 points.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
   fun.name <- "points"
-  arguments <- list(...)
-
-  if (is.null(names(arguments))){
-    arguments_gsplot <- arguments
-  } else {
-    arguments_gsplot <- arguments[!names(arguments) %in% c("callouts", "error_bar")]
-  }
-
-  to.gsplot <- list(list(arguments = do.call(set_args, c(fun.name, arguments_gsplot)), 
-                         gs.config=list(legend.name = legend.name, side = side))) %>% 
+  dots = separate_args(...)
+  args = dots$args
+  e.fun = dots$e.fun
+  arguments = set_args(fun.name, lazy_eval(args))
+  to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>% 
     setNames(fun.name)
-
-  if (all(names(to.gsplot$points$arguments) != "formula") && is.null(to.gsplot$points$arguments[['y']])){
-    to.gsplot$points$arguments$y <- to.gsplot$points$arguments$x
-    to.gsplot$points$arguments$x <- seq(length(to.gsplot$points$arguments$x))
-    if (is.null(to.gsplot$points$arguments$xlab)) to.gsplot$points$arguments$xlab <- "Index" 
-  }
-
-  if ("callouts" %in% names(arguments)){
-    object <- callouts(object, x=to.gsplot$points$arguments$x, 
-                       y=to.gsplot$points$arguments$y, arguments$callouts)
-  }
-  if ("error_bar" %in% names(arguments)){
-    object <- error_bar(object, x=to.gsplot$points$arguments$x, 
-                        y=to.gsplot$points$arguments$y, arguments$error_bar)
+
+  object <- gsplot(append(object, to.gsplot)) # append initial call
+  if (!is.null(e.fun)){
+    embed.args = set_inherited_args(e.fun, arguments, dots$e.args)
+    object <- do.call(e.fun, append(list(object=object), embed.args))
   }
-
-  return(gsplot(append(object, to.gsplot)))
+  return(object)
 }
diff --git a/R/set_args.R b/R/set_args.R
@@ -16,4 +16,10 @@ set_args <- function(fun.name, ..., package='graphics'){
   indicesToAdd <- !(names(config_args) %in% names(user_args))
   arguments <- append(user_args, config_args[indicesToAdd])
   return(arguments)
+}
+
+set_inherited_args <- function(fun.name, inherited.args, ..., package='gsplot'){
+  # // shed non-formals
+  inherited.args = function_args(package, fun.name, inherited.args, drop=TRUE)
+  return(c(inherited.args, set_args(fun.name, ..., package = package)))
 }
diff --git a/man/function_args.Rd b/man/function_args.Rd
@@ -5,7 +5,7 @@
 \title{get matched argument list for a given function}
 \usage{
 function_args(package, name, object, ..., use.default = paste0(name,
-  ".default"))
+  ".default"), drop = FALSE)
 }
 \arguments{
 \item{package}{the package to use to get the function from}
@@ -16,6 +16,8 @@ function_args(package, name, object, ..., use.default = paste0(name,
 
 \item{use.default}{use different function name other than <function>.default (optional)}
 
+\item{drop}{boolean for dropping all non-formal args passed in with \dots}
+
 \item{\dots}{user arguments to be used for the list}
 }
 \description{

diff --git a/man/points.Rd b/man/points.Rd
@@ -46,5 +46,8 @@ gs2 <- gsplot() \%>\%
          axis(side=c(2,4), labels=FALSE, n.minor=4)
 
 gs2
+
+gs <- points(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats')))
+gs
 }
 
diff --git a/tests/testthat/tests-embed_function.R b/tests/testthat/tests-embed_function.R
@@ -0,0 +1,24 @@
+context("embedding functions")
+
+test_that("points to callouts", {
+
+  gs <- points(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats')))
+  expect_equal(names(gs$view),c('points','callouts','window'))
+
+})
+
+test_that("lines to callouts", {
+
+  gs <- lines(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats')))
+  expect_equal(names(gs$view),c('lines','callouts','window'))
+
+})
+
+test_that("usr args aren't overidden", {
+
+  gs <- lines(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats'), col='yellow'))
+  expect_equal(gs$view$callouts$col, 'yellow')
+  gs <- points(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats'), col='yellow'))
+  expect_equal(gs$view$callouts$col, 'yellow')
+
+})
diff --git a/tests/testthat/tests-error_bars.R b/tests/testthat/tests-error_bars.R
@@ -30,12 +30,9 @@ test_that("testing content of gsplot list for NA given", {
 
 test_that("testing content of gsplot list for embedded error bar", {
 
-  gs <- gsplot()
-
-  expect_is(gs,"gsplot")
 
-  gs <- points(gs, c(0,3), c(2,4),  
-               error_bar=list(x.low=c(NA,1))) 
+  gs <- points(gsplot(), c(0,3), c(2,4),  
+               error_bar(x.low=c(NA,1))) 
 
   expect_true(all(names(gs[['view']]) != "error_bar"))
 

diff --git a/tests/testthat/tests-lines.R b/tests/testthat/tests-lines.R
@@ -27,4 +27,13 @@ test_that("testing content of gsplot list", {
 
    expect_less_than(gs$view$lines$y[1], 34)
 
+})
+
+test_that("curve function uses lines", {
+
+  gs <- gsplot() %>%
+    curve(sin(x), from=-2*pi, to=2*pi, legend.name="sin(x)", col='red')
+
+  expect_equal(gs$view$lines$col, 'red')
+
 })
-Original file line number
+Diff line change
@@ Expand Up @@
     }
+    error_bar.default <- function(x, y, y.high, y.low, x.high, x.low, epsilon=0.1, ...){
+      return()
+    }