work on string interpolation

make wrapr pipe a bit stricter on piping into values / code
WinVector · Mar 17, 2020 · 19ab67b · 19ab67b
1 parent 0330b99
commit 19ab67b
Show file tree

Hide file tree

Showing 41 changed files with 663 additions and 98 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -2,7 +2,7 @@ Package: wrapr
 Type: Package
 Title: Wrap R Tools for Debugging and Parametric Programming
 Version: 2.0.0
-Date: 2020-03-16
+Date: 2020-03-17
 Authors@R: c(
     person("John", "Mount", email = "[email protected]", role = c("aut", "cre")),
     person("Nina", "Zumel", email = "[email protected]", role = c("aut")),

diff --git a/NAMESPACE b/NAMESPACE
@@ -32,14 +32,15 @@ export("%.%")
 export("%.>%")
 export("%.|%")
 export("%:=%")
+export("%<s%")
 export("%>.%")
 export("%?%")
 export("%c%")
 export("%dot%")
 export("%in_block%")
 export("%p%")
 export("%qc%")
-export("%s%")
+export("%s>%")
 export("%|.%")
 export(":=")
 export(DebugFn)

diff --git a/NEWS.md b/NEWS.md
@@ -1,15 +1,17 @@
 
-# wrapr 2.0.0 2020-03-16
+# wrapr 2.0.0 2020-03-17
 
  * Allow as_named_list to choose new names.
  * Update references.
  * Stricter tests on unpack/to.
+ * Stricter wrapr-pipe value checks.
  * := for names.
  * := for to/unpack.
  * Don't use := for anonymous function construction.
  * Update evalb, and bquote uses including adding .(-) notation.
  * Remove some obsolete methods such as CapturePipeine, as_dot_fn, UnaryFunctions/ApplyTo, and locum.
- * Make pipe_impl not internal and document more.
+ * Make pipe_impl public, and document more.
+ * Vectorize string interpolation and add operator versions.
  * Fix description.
 
 # wrapr 1.9.6 2020-01-26

diff --git a/R/bpipe.R b/R/bpipe.R
@@ -76,7 +76,9 @@ forbidden_pipe_destination_names <- c("else",
                                       "?",
                                       "...",
                                       ".",
-                                      ";", ",")
+                                      ";", ",",
+                                      "list", "c", ":",
+                                      "for")
 
 #' S3 dispatch on class of pipe_left_arg.
 #'

diff --git a/R/string_interpolation.R b/R/string_interpolation.R
@@ -67,7 +67,7 @@ strsplit_capture <- function(x, split,
 #' and \url{https://CRAN.R-project.org/package=glue}.
 #'
 #'
-#' @param str charater string to be substituted into
+#' @param str charater string(s) to be substituted into
 #' @param ... force later arguments to bind by name
 #' @param envir environemnt to look for values
 #' @param enclos enclosing evaluation environment
@@ -91,7 +91,7 @@ strsplit_capture <- function(x, split,
 #'
 #' # We can also change the delimiters,
 #' # in this case to !! through the first whitespace.
-#' sinterp(c("x is !!x , x+1 is !!x+1\n!!x  is odd is !!x%%2==1"),
+#' sinterp(c("x is !!x , x+1 is !!x+1 \n!!x  is odd is !!x%%2==1"),
 #'         match_pattern = '!![^[:space:]]+[[:space:]]?',
 #'         removal_patterns = c("^!!", "[[:space:]]?$"))
 #'
@@ -115,27 +115,37 @@ sinterp <- function(str,
   if(!is.character(str)) {
     stop("wrapr::sinterp str must be of class character")
   }
-  if(length(str)!=1) {
-    stop("wrapr::sinterp str length must be 1")
+  if(length(str) <= 0) {
+    stop("wrapr::sinterp str must be of length at least 1")
   }
-  pi <- strsplit_capture(str, match_pattern)
-  npi <- length(pi)
-  xlated <- list()
-  for(j in seq_len(npi)) {
-    pij <- pi[[j]]
-    if(!isTRUE(attr(pij, "is_sep", exact = TRUE))) {
-      xlated <- c(xlated, list(as.character(pij))) # strip attributes.
-    } else {
-      expr <- as.character(pij) # strip attributes.
-      for(rp in removal_patterns) {
-        expr <- as.character(gsub(rp, "", expr))
+  orig_names <- names(str)
+  res <- vapply(
+    str,
+    function(stri) {
+      pi <- strsplit_capture(stri, match_pattern)
+      npi <- length(pi)
+      xlated <- list()
+      for(j in seq_len(npi)) {
+        pij <- pi[[j]]
+        if(!isTRUE(attr(pij, "is_sep", exact = TRUE))) {
+          xlated <- c(xlated, list(as.character(pij))) # strip attributes.
+        } else {
+          expr <- as.character(pij) # strip attributes.
+          for(rp in removal_patterns) {
+            expr <- as.character(gsub(rp, "", expr))
+          }
+          val <- eval(parse(text = expr), envir = envir, enclos = enclos)
+          val <- deparse(val)
+          xlated <- c(xlated, list(val))
+        }
       }
-      val <- eval(parse(text = expr), envir = envir, enclos = enclos)
-      val <- as.character(val)
-      xlated <- c(xlated, list(val))
-    }
+      do.call(paste0, xlated)
+    },
+    character(1))
+  if(length(orig_names) <= 0) {
+    names(res) <- NULL
   }
-  do.call(paste0, xlated)
+  return(res)
 }
 
 
@@ -174,14 +184,16 @@ sinterp <- function(str,
 #'
 #' # We can also change the delimiters,
 #' # in this case to !! through the first whitespace.
-#' si(c("x is !!x , x+1 is !!x+1\n!!x  is odd is !!x%%2==1"),
-#'       match_pattern = '!![^[:space:]]+[[:space:]]?',
-#'       removal_patterns = c("^!!", "[[:space:]]?$"))
+#' si(c("x is !!x , x+1 is !!x+1 \n!!x  is odd is !!x%%2==1"),
+#'    match_pattern = '!![^[:space:]]+[[:space:]]?',
+#'    removal_patterns = c("^!!", "[[:space:]]?$"))
+#'
 #'
 #' @export
 #'
 si <- sinterp
 
+
 #' Dot substitution string interpolation.
 #'
 #' String interpolation using \code{bquote}-stype .() notation. Pure R, no C/C++ code called.
@@ -200,12 +212,41 @@ si <- sinterp
 #'
 #' @examples
 #'
-#' "x is .(x), x+1 is .(x+1)\n.(x) is odd is .(x%%2 == 1)" %s% list(x = 7)
+#' "x is .(x)" %<s% list(x = 7)
+#'
+#'
+#' @export
+#'
+`%<s%` <- function(str, envir) {
+  force(envir)
+  sinterp(str, envir = envir, enclos = envir)
+}
+
+#' Dot substitution string interpolation.
+#'
+#' String interpolation using \code{bquote}-stype .() notation. Pure R, no C/C++ code called.
+#'
+#' See also
+#' \url{https://CRAN.R-project.org/package=R.utils},
+#' \url{https://CRAN.R-project.org/package=rprintf},
+#' and \url{https://CRAN.R-project.org/package=glue}.
+#'
+#'
+#' @param envir environemnt to look for values
+#' @param str charater string to be substituted into
+#' @return modified strings
+#'
+#' @seealso \code{\link{strsplit_capture}}, \code{\link{si}}
+#'
+#' @examples
+#'
+#' list(x = 7) %s>% "x is .(x)"
 #'
 #'
 #' @export
 #'
-`%s%` <- function(str, envir) {
+`%s>%` <- function(envir, str) {
   force(envir)
   sinterp(str, envir = envir, enclos = envir)
 }
+
diff --git a/README.md b/README.md
@@ -62,7 +62,7 @@ library(wrapr)
 packageVersion("wrapr")
  #  [1] '2.0.0'
 date()
- #  [1] "Mon Mar 16 22:01:15 2020"
+ #  [1] "Tue Mar 17 05:47:19 2020"
 ```
 
 ## [`%.>%` (dot pipe or dot arrow)](https://winvector.github.io/wrapr/articles/dot_pipe.html)
@@ -516,7 +516,7 @@ evalb(
 
 # alter string
 si("plot(x = .(variable), y = .(variable))")
- #  [1] "plot(x = angle, y = angle)"
+ #  [1] "plot(x = \"angle\", y = \"angle\")"
 ```
 
 The extra `.(-x)` form is a shortcut for

diff --git a/docs/articles/CornerCases.html b/docs/articles/CornerCases.html
diff --git a/docs/articles/DebugFnW.html b/docs/articles/DebugFnW.html
diff --git a/docs/articles/FrameTools.html b/docs/articles/FrameTools.html
diff --git a/docs/articles/Named_Arguments.html b/docs/articles/Named_Arguments.html
diff --git a/docs/articles/QuotingConcatinate.html b/docs/articles/QuotingConcatinate.html
diff --git a/docs/articles/SubstitutionModes.html b/docs/articles/SubstitutionModes.html
diff --git a/docs/articles/bquote.html b/docs/articles/bquote.html
diff --git a/docs/articles/dot_pipe.html b/docs/articles/dot_pipe.html
diff --git a/docs/articles/lambda.html b/docs/articles/lambda.html
diff --git a/docs/articles/let.html b/docs/articles/let.html
diff --git a/docs/articles/multi_assign.html b/docs/articles/multi_assign.html
diff --git a/docs/articles/named_map_builder.html b/docs/articles/named_map_builder.html
diff --git a/docs/articles/unpack_multiple_assignment.html b/docs/articles/unpack_multiple_assignment.html
diff --git a/docs/articles/wrapr_Eager.html b/docs/articles/wrapr_Eager.html
diff --git a/docs/articles/wrapr_applicable.html b/docs/articles/wrapr_applicable.html
diff --git a/docs/index.html b/docs/index.html