Skip to content

Commit 2561491

Browse files
author
Jordan S Read
committed
Merge pull request #235 from jread-usgs/embed-function
Embed function
2 parents d16db91 + 36f805f commit 2561491

15 files changed

Lines changed: 125 additions & 67 deletions

‎DESCRIPTION‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,8 @@ Imports:
3030
graphics,
3131
utils,
3232
methods,
33-
yaml
33+
yaml,
34+
lazyeval
3435
Suggests:
3536
testthat,
3637
knitr

‎NAMESPACE‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,9 @@ importFrom(graphics,mtext)
3434
importFrom(graphics,par)
3535
importFrom(graphics,plot.new)
3636
importFrom(graphics,plot.xy)
37+
importFrom(lazyeval,lazy)
38+
importFrom(lazyeval,lazy_dots)
39+
importFrom(lazyeval,lazy_eval)
3740
importFrom(magrittr,"%>%")
3841
importFrom(methods,existsFunction)
3942
importFrom(stats,setNames)

‎R/calc_views.R‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -223,15 +223,16 @@ remove_field <- function(list, param){
223223
strip_pts <- function(list, param){
224224
out <- c()
225225
for (v in param){
226-
if (v %in% names(list))
226+
if (v %in% names(list) && !inherits(list[[v]], c('function','formula')))
227227
out <- append(out, list[[v]])
228-
else {
228+
else{
229229
u.list <- unname_c(list)
230230
if(v %in% names(u.list))
231231
out <- append(out, u.list[[v]])
232232
else
233233
out <- append(out, NA)
234234
}
235+
235236
}
236237
return(out)
237238
}

‎R/curve.R‎

Lines changed: 10 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@
2323
#'
2424
#' @rdname curve
2525
#' @export
26+
#' @importFrom lazyeval lazy lazy_eval
2627
#' @examples
2728
#' gs <- gsplot() %>%
2829
#' points(x=c(1:5, 3.5), y=c(1:5, 6), legend.name="Stuff") %>%
@@ -42,16 +43,19 @@ curve <- function(object, ...) {
4243

4344
curve.gsplot <- function(object, expr, ..., legend.name=NULL, side=c(1,2)){
4445

45-
arguments <- list(substitute(expr), ...)
46-
expr <- arguments[which(names(arguments)=="")]
46+
expr <- lazy(expr)
47+
arguments = set_args('curve',...)
48+
dots = lazy_dots(...)
49+
4750
increment <- (arguments$to-arguments$from)/10000
4851
x <- seq(arguments$from, arguments$to, by=increment)
49-
y <- eval(parse(text=expr))
52+
y <- lazy_eval(expr, data.frame(x=x))
53+
arguments = set_args(fun.name = 'lines', x=x, y=y, lazy_eval(dots[!names(dots) %in% c('from','to')]))
5054

51-
arguments <- arguments[which(names(arguments)!="" & names(arguments)!="from" & names(arguments)!="to")]
52-
arguments <- append(list(x=x, y=y), arguments)
55+
to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>%
56+
setNames('lines')
5357

54-
object <- lines(object, arguments, legend.name=legend.name, side=side)
58+
object <- gsplot(append(object, to.gsplot))
5559

5660
return(object)
5761
}

‎R/embedded-functions.R‎

Lines changed: 27 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
is_in_package <- function(x){
2+
if (is.symbol(x))
3+
return(FALSE)
4+
5+
isTRUE(find(as.character(x[[1]]), mode = 'function') == paste0('package:',packageName()))
6+
}
7+
8+
9+
separate_args <- function(...){
10+
11+
dots <- lazy_dots(...)
12+
args = list(args=dots,e.fun=c(),e.args=c())
13+
14+
embeds <- unname(sapply(dots, function(x) is_in_package(x$expr)))
15+
if (sum(embeds) > 1)
16+
stop('only one embedded function is currently supported')
17+
else if (sum(embeds) == 0)
18+
return(args)
19+
20+
embedded.funs <- dots[[which(embeds)]]
21+
dots[[which(embeds)]] <- NULL
22+
args$args = dots
23+
args$e.fun = as.character(embedded.funs$expr[[1]])
24+
embedded.funs$expr[[1]] <- NULL
25+
args$e.args = embedded.funs$expr
26+
return(args)
27+
}

‎R/error_bars.R‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -91,5 +91,8 @@ error_bar.gsplot <- function(object, x, y, ..., y.high=0, y.low=0, x.high=0, x.l
9191

9292
}
9393

94+
error_bar.default <- function(x, y, y.high, y.low, x.high, x.low, epsilon=0.1, ...){
95+
return()
96+
}
9497

9598

‎R/function_args.R‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,9 +7,10 @@
77
#' @param object the first argument, which may have a class to match functions to
88
#' @param \dots user arguments to be used for the list
99
#' @param use.default use different function name other than <function>.default (optional)
10+
#' @param drop boolean for dropping all non-formal args passed in with \dots
1011
#'
1112
#' @keywords internal
12-
function_args <- function(package, name, object, ..., use.default=paste0(name,'.default')){
13+
function_args <- function(package, name, object, ..., use.default=paste0(name,'.default'), drop=FALSE){
1314
params <- list(...)
1415

1516
if (!missing(object)) {
@@ -51,5 +52,8 @@ function_args <- function(package, name, object, ..., use.default=paste0(name,'.
5152
sort.i[!is.na(match.i)] <- match.i[!is.na(match.i)]
5253
params <- params[sort(sort.i, index.return = TRUE)$ix]
5354

55+
if (drop)
56+
params = params[names(params) %in% names(formals(defFun))]
57+
5458
return(params)
5559
}

‎R/lines.R‎

Lines changed: 10 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -44,32 +44,17 @@ lines <- function(object, ...) {
4444

4545
lines.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
4646
fun.name <- "lines"
47-
arguments <- list(...)
48-
49-
if (is.null(names(arguments))){
50-
arguments_gsplot <- arguments
51-
} else {
52-
arguments_gsplot <- arguments[!names(arguments) %in% c("callouts", "error_bar")]
53-
}
54-
55-
to.gsplot <- list(list(arguments = do.call(set_args, c(fun.name, arguments_gsplot)),
56-
gs.config=list(legend.name = legend.name, side = side))) %>%
47+
dots = separate_args(...)
48+
args = dots$args
49+
e.fun = dots$e.fun
50+
arguments = set_args(fun.name, lazy_eval(args))
51+
to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>%
5752
setNames(fun.name)
5853

59-
if (all(names(to.gsplot$lines$arguments) != "formula") && is.null(to.gsplot$lines$arguments$y)){
60-
to.gsplot$lines$arguments$y <- to.gsplot$lines$arguments$x
61-
to.gsplot$lines$arguments$x <- seq(length(to.gsplot$lines$arguments$x))
62-
if (is.null(to.gsplot$lines$arguments$xlab)) to.gsplot$lines$arguments$xlab <- "Index"
54+
object <- gsplot(append(object, to.gsplot)) # append initial call
55+
if (!is.null(e.fun)){
56+
embed.args = set_inherited_args(e.fun, arguments, dots$e.args)
57+
object <- do.call(e.fun, append(list(object=object), embed.args))
6358
}
64-
65-
if ("callouts" %in% names(arguments)){
66-
object <- callouts(object, x=to.gsplot$lines$arguments$x,
67-
y=to.gsplot$lines$arguments$y, arguments$callouts)
68-
}
69-
if ("error_bar" %in% names(arguments)){
70-
object <- error_bar(object, x=to.gsplot$lines$arguments$x,
71-
y=to.gsplot$lines$arguments$y, arguments$error_bar)
72-
}
73-
74-
return(gsplot(append(object, to.gsplot)))
59+
return(object)
7560
}

‎R/points.R‎

Lines changed: 15 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -36,39 +36,28 @@
3636
#' axis(side=c(2,4), labels=FALSE, n.minor=4)
3737
#'
3838
#' gs2
39+
#'
40+
#' gs <- points(gsplot(), c(0,3), c(2,4), callouts(labels=c('dogs','cats')))
41+
#' gs
42+
#' @importFrom lazyeval lazy_dots lazy_eval
3943
#' @export
4044
points <- function(object, ...) {
4145
override("graphics", "points", object, ...)
4246
}
4347

4448
points.gsplot <- function(object, ..., legend.name=NULL, side=c(1,2)){
4549
fun.name <- "points"
46-
arguments <- list(...)
47-
48-
if (is.null(names(arguments))){
49-
arguments_gsplot <- arguments
50-
} else {
51-
arguments_gsplot <- arguments[!names(arguments) %in% c("callouts", "error_bar")]
52-
}
53-
54-
to.gsplot <- list(list(arguments = do.call(set_args, c(fun.name, arguments_gsplot)),
55-
gs.config=list(legend.name = legend.name, side = side))) %>%
50+
dots = separate_args(...)
51+
args = dots$args
52+
e.fun = dots$e.fun
53+
arguments = set_args(fun.name, lazy_eval(args))
54+
to.gsplot <- list(list(arguments = arguments, gs.config=list(legend.name = legend.name, side = side))) %>%
5655
setNames(fun.name)
57-
58-
if (all(names(to.gsplot$points$arguments) != "formula") && is.null(to.gsplot$points$arguments[['y']])){
59-
to.gsplot$points$arguments$y <- to.gsplot$points$arguments$x
60-
to.gsplot$points$arguments$x <- seq(length(to.gsplot$points$arguments$x))
61-
if (is.null(to.gsplot$points$arguments$xlab)) to.gsplot$points$arguments$xlab <- "Index"
62-
}
63-
64-
if ("callouts" %in% names(arguments)){
65-
object <- callouts(object, x=to.gsplot$points$arguments$x,
66-
y=to.gsplot$points$arguments$y, arguments$callouts)
67-
}
68-
if ("error_bar" %in% names(arguments)){
69-
object <- error_bar(object, x=to.gsplot$points$arguments$x,
70-
y=to.gsplot$points$arguments$y, arguments$error_bar)
56+
57+
object <- gsplot(append(object, to.gsplot)) # append initial call
58+
if (!is.null(e.fun)){
59+
embed.args = set_inherited_args(e.fun, arguments, dots$e.args)
60+
object <- do.call(e.fun, append(list(object=object), embed.args))
7161
}
72-
73-
return(gsplot(append(object, to.gsplot)))
62+
return(object)
7463
}

‎R/set_args.R‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,4 +16,10 @@ set_args <- function(fun.name, ..., package='graphics'){
1616
indicesToAdd <- !(names(config_args) %in% names(user_args))
1717
arguments <- append(user_args, config_args[indicesToAdd])
1818
return(arguments)
19+
}
20+
21+
set_inherited_args <- function(fun.name, inherited.args, ..., package='gsplot'){
22+
# // shed non-formals
23+
inherited.args = function_args(package, fun.name, inherited.args, drop=TRUE)
24+
return(c(inherited.args, set_args(fun.name, ..., package = package)))
1925
}

0 commit comments

Comments
 (0)