per #6, use #. file$decorator syntax to refer to a decorator functi…

…on found in a separate file

R/source-decoratees.R

@@ -50,6 +50,14 @@ source_decoratees <- function(file, into = parent.frame()) {
     stop('path specified by `file` does not exist', call. = FALSE)
   }
 
+  # if (!is.null(include) && !is.character(include)) {
+  #   stop('argument `include` must be character', call. = FALSE)
+  # }
+
+  if (!is.environment(into)) {
+    stop('argument `into` must be environment', call. = FALSE)
+  }
+
   src <- new.env()
   contents <- readLines(file)
 
@@ -60,6 +68,15 @@ source_decoratees <- function(file, into = parent.frame()) {
     }
   )
 
+  # for (f in include) {
+  #   tryCatch(
+  #     source(file = f, local = src, keep.source = FALSE),
+  #     error = function(e) {
+  #       stop('problem including file "', f, '", ', e$message, call. = FALSE)
+  #     }
+  #   )
+  # }
+
   fileitr <- itr(contents)
   decor <- NULL
 
@@ -87,7 +104,19 @@ source_decoratees <- function(file, into = parent.frame()) {
       as_text <- f
       for (d in decor) {
         split_at <- first_of(d, '(')
+
         dname <- substr(d, 1, split_at - 1)
+        if (grepl('$', dname, fixed = TRUE)) {
+          dfile <- re_search(dname, '^[^$]+')
+          dsrc <- file.path(dirname(file), paste0(dfile, '.R'))
+          dname <- re_search(dname, '[^$]+$')
+
+          if (!file.exists(dsrc)) {
+            stop('could not find decorator file "', dsrc, '"', call. = FALSE)
+          }
+          source(dsrc, local = src, keep.source = FALSE)
+        }
+
         dargs <- substr(d, split_at + 1, nchar(d))
         if (!grepl('^\\s*\\)\\s*$', dargs)) {
           dargs <- paste(',', dargs)

tests/testfiles/includes-files.R

@@ -0,0 +1,4 @@
+#. sample-utils$ramp_to(5)
+div_scale <- function() {
+  cm.colors(3)
+}

tests/testfiles/sample-utils.R

@@ -0,0 +1,13 @@
+# A decorator which will ramp up a color scale, expects `f()` to return colors
+# to interpolate.
+ramp_to <- function(f, n) {
+  function(...) {
+    colorRampPalette(f(...))(n)
+  }
+}
+
+as_double <- function(f) {
+  function(...) {
+    vapply(f(...), as.double, double(1))
+  }
+}

tests/testfiles/simple-functions.R

@@ -65,32 +65,23 @@ if_warning <- function(f, default) {
 #. if_warning(Inf)
 mean_inf <- mean
 
-bare_variable <- 'necessities'
-
 #. if_warning('whoops!')
 one_fish <-
   function(two_fish = NULL) {
     'red fish, blue fish'
   }
 
+# emphasize text
+emph <- function(f, begin = '**', end = begin) {
+  function(...) {
+    paste(begin, f(...), end)
+  }
+}
 
- # emphasize text
- emph <- function(f, m = '**') {
-   function(...) {
-     if (is.na(m[2])) m <- rep(m, 2)
-     paste(m[1], f(...), m[2])
-   }
- }
-
- #. emph
- my_name <- function() 'Nathan Teetor'
-
- my_name()
-
- #. emph(c('<b>', '</b>'))
- cats <- function(n) {
-   paste(rep('cats', n), collapse = ' ')
- }
-
- cats(5)
+#. emph
+my_name <- function() 'Nathan Teetor'
 
+#. emph('<b>', '</b>')
+cats <- function(n) {
+  paste(rep('cats', n), collapse = ' ')
+}