update decorate functions

r-for-educators · Jan 29, 2020 · 617099c · 617099c
1 parent 7a576df
commit 617099c
Show file tree

Hide file tree

Showing 14 changed files with 89 additions and 251 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -2,7 +2,6 @@
 
 S3method(flair_rx,default)
 S3method(flair_rx,with_flair)
-S3method(print,decorate_code)
 S3method(print,with_flair)
 export("%>%")
 export(decorate)
@@ -15,7 +14,6 @@ export(flair_funs)
 export(flair_input_vals)
 export(flair_quick)
 export(flair_rx)
-export(knit_print.decorate_code)
 export(knit_print.with_flair)
 export(mask)
 export(mask_regexp)

diff --git a/R/decorate.R b/R/decorate.R
@@ -1,29 +1,26 @@
-#' Builds a \code{\link{decorate_code}} object from either a code chunk or a string object containing source code.
-#'
-#' \code{decorate_code} objects are evaluated R code, returned from \code{evaluate::evaluate}, with an attached attribute called \code{print_string} which sets up fancy formatting for knitting.
+#' Builds a \code{\link{with_flair}} object from either a code chunk or a string object containing source code.
 #'
 #' \code{decorate} does its best to guess if it has been given a code string or a chunk name, based on the presence of special characters.
 #'
 #' @param x A string, containing either a chunk label or R code.
-#' @param eval Should this be immediately evaluated, in addition to creating the \code{decorate_code} object? (Defaults to \code{TRUE})
-#' @param collapse Should the source code be printed in one block, before the output is printed? (Defaults to \code{FALSE})
+#' @param ... Chunk options to pass along
 #'
-#' @return A \code{decorate_code} object.
+#' @return A \code{with_flair} object.
 #'
 #' @seealso \code{\link{decorate_chunk}}, \code{\link{decorate_code}}
 #'
 #' @importFrom stringr str_detect
 #'
 #' @export
-decorate <- function(x, eval = TRUE, collapse = FALSE) {
+decorate <- function(x, ...) {
 
   if (!str_detect(x, "[^A-z0-9 \\-\\_]")) {
 
-    decorate_chunk(x)
+    decorate_chunk(x, ...)
 
   } else {
 
-    decorate_code(x, eval, collapse)
+    decorate_code(x, ...)
 
   }
 

diff --git a/R/decorate_chunk.R b/R/decorate_chunk.R
@@ -9,6 +9,9 @@
 #' @param chunk_name The label name of the chunk we plan to add \code{\link{flair}} to.
 #' @param eval Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{eval}
 #' @param echo Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{echo}
+#' @param include Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{include}
+#'
+#' @param ...  Any number of other chunk options to override.
 #'
 #' @return An object of class \code{\link{with_flair}}
 #'
@@ -17,7 +20,9 @@
 #' @export
 decorate_chunk <- function(chunk_name,
                         eval = TRUE,
-                        echo = TRUE) {
+                        echo = TRUE,
+                        include = TRUE,
+                        ...) {
 
     my_code <- NULL
 
@@ -72,10 +77,6 @@ decorate_chunk <- function(chunk_name,
 
   } else {
 
-    # Replace OG chunk options with flairing options
-    my_opts[["eval"]] <- eval
-    my_opts[["echo"]] <- echo
-
     my_code <- paste0("```{r}\n", my_code, "\n```")
 
     # knit just the chunk of interest
@@ -86,6 +87,20 @@ decorate_chunk <- function(chunk_name,
 
     } else {
 
+      # Replace OG chunk options with flairing options
+      my_opts[["eval"]] <- eval
+      my_opts[["echo"]] <- echo
+      my_opts[["include"]] <- include
+
+      # Combine with dots
+      new_opts <- list(...)
+
+      if (length(new_opts) > 0) {
+
+        my_opts <- c(my_opts[!(names(my_opts) %in% names(new_opts))], new_opts)
+
+      }
+
       knitted <- knitr::knit_child(text = my_code,
                                  options = my_opts,
                                  quiet = TRUE)
@@ -117,6 +132,8 @@ src_to_list <- function(knitted) {
 
   before_code <- which(knitted == "```r")
 
+  knitted[before_code + 1] <- stringr::str_trim(knitted[before_code + 1])
+
   knitted[before_code + 1] <- purrr::map(knitted[before_code + 1], function(x) structure(list(src = x), class = "source"))
 
   knitted <- knitted[-c(before_code, before_code + 2)]

diff --git a/R/decorate_code.R b/R/decorate_code.R
@@ -1,29 +1,22 @@
-#' Creates an object of the class \code{decorate_code}
-#'
-#' \code{decorate_code} objects are evaluated R code, returned from \code{evaluate::evaluate}, with an attached attribute called \code{print_string} which sets up fancy formatting for knitting.
-#'
+#' Creates an object of the class \code{with_flair}
 #'
 #' @param text A string, presumably representing R code.
-#' @param eval A boolean specifying whether the code should be immediately evaluated, in addition to creating the \code{decorate_code} object. (Defaults to \code{TRUE})
-#' @param collapse Should the source code be printed in one block, before the output is printed? (Defaults to \code{FALSE})
+#' @param ...  Any number of default chunk options to override.
 #'
 #'
-#' @return A \code{decorate_code} object.
+#' @return A \code{with_flair} object.
 #'
 #' @seealso \code{\link{flair}}
 #'
 #' @examples
 #'
-#' # When run in console, this will print only the results of mean(1:10)
+#' # When run in console, this will print the results of mean(1:10)
 #' my_code <- decorate_code(text = 'mean(1:10)') %>% flair_funs()
 #'
-#' # The decorate_code object itself has no output
+#' # The object itself, when printed, previews your code with flair
 #'
 #' my_code
 #'
-#' # However, it comes with an attribute with the decorated source code.
-#'
-#' attr(my_code, "print_string")
 #'
 #' # Objects defined by decorate_code are created in the current environment for later use.
 #'
@@ -35,193 +28,56 @@
 #' @importFrom purrr map map_lgl quietly
 #'
 #' @export
-decorate_code <- function(text, eval = TRUE, collapse = FALSE) {
-
-  #### Initial processing ####
+decorate_code <- function(text, ...) {
 
   # remove trailing whitespace
   text <- str_trim(text)
 
-  # evaluate code
-  my_deco_code <- quietly(evaluate::evaluate)(text)$result
-
-  # drop blank lines or invalid code
-  valid <- map_lgl(my_deco_code, ~ (class(.x) != "source") || str_detect(.x, "[^\\s]+"))
-
-  my_deco_code <- my_deco_code[valid]
-
-  # detect source strings
-  is_src <- map(my_deco_code, class) == "source"
-
-  # scope and run it
-
-  if (eval) {
-
-    map(my_deco_code[is_src],
-        ~quietly(scope_and_run)(.x))
-
-  }
-
-
-  # unlist sources and drop classes
-
-   my_deco_code[is_src] <- my_deco_code[is_src] %>%
-     unlist()
-
-
-  attributes(my_deco_code) <- NULL
-
-  #### Shatter code into segments ####
-
-  if (collapse) {
-
-    my_deco_code <- c(text,
-                       my_deco_code[!is_src])
-
-    attr(my_deco_code, "where_sources") <- 1
-
-  } else {
-
-
-    attr(my_deco_code, "where_sources") <- which(is_src)
-
-  }
-
-  #### Assign class and attributes ####
-
-
-  attr(my_deco_code, "class") <- "decorate_code"
-
-  #attr(my_deco_code, "origin") <- "direct_string"
-
-  attr(my_deco_code, "eval") <- eval
-
-  get_doc_type <- purrr::safely(rmarkdown::all_output_formats)(knitr::current_input())
-
-  if (!is.null(get_doc_type$error)) {
-
-    attr(my_deco_code, "doc_type") <- "active_source"
-
-  } else {
-
-    attr(my_deco_code, "doc_type") <- get_doc_type$result
-
-  }
-
-  return(my_deco_code)
-
-}
-
+  # get options
+  my_opts <- knitr::opts_chunk$merge(list(...))
 
+  # check context
+  is_live <- !isTRUE(getOption('knitr.in.progress'))
 
-#' S3 method for knitting a \code{decorate_code} object
-#'
-#' @importFrom purrr map
-#'
-#' @export
-knit_print.decorate_code <- function(x, ...) {
-
-  eval <- attr(x, "eval")
-
-  where_sources <- attr(x, "where_sources")
-
-  x[-where_sources] <- purrr::map(x[-where_sources], function(val) knitr_wrap(val, ...))
-
-  x[where_sources] <- purrr::map(x[where_sources], function(val) wrap_source(val, attr(x, "doc_type"), ...))
-
-  if (!eval) {
-
-    x <- x[where_sources]
-
-  }
-
-  x <- x %>%
-    str_c(collapse = " ")
-
-
-  knitr::asis_output(x)
-
-  #knitr::knit_print(unclass(x))
-
-}
-
-#' Helper for \code{knit_print.decorate_code}
-wrap_source <- function(x, doc_type, ...) {
-
-  #### reformat line breaks ####
-
-  if (doc_type == "pdf_document") {
-
-    x <- str_replace_all(x, fixed("\n"), "\\")
-
-  } else if (doc_type == "word_document") {
-
-    # word is dumb
-
-  } else {
-
-    x <- str_replace_all(x, fixed("\n"), "<br>")
+  # evaluate code
+  if (my_opts$eval & is_live) {
 
+      scope_and_run(text)
+      print(eval(parse(text = text)))
   }
 
-  #### Wrap source in appropriate code formatting tags ####
-
-  if (doc_type == "pdf_document") {
-    # figure this out
-  } else if (doc_type == "word_document") {
-
-    # also this
-
-  } else if (doc_type == "html_document") {
-
-    x <- paste0("<pre class='prettyprint'>", txt_tocode(x), "</pre>")
-
-  } else if (doc_type == "ioslides_presentation") {
-
-    x <- paste0("<pre class='prettyprint lang-r'>", txt_tocode(x), "</pre>")
 
-  } else if (doc_type == "xaringan::moon_reader") {
+  # Check for flair = FALSE option
+  if (!is.null(my_opts$flair) && !my_opts$flair) {
 
-    x <- paste0("<code class ='r hljs remark-code'>", x, "</code>")
+    placeholder <- list(NULL)
+    attr(placeholder, "class") = "with_flair"
 
-  } else if (doc_type == "slidy_presentation") {
-
-    x <- paste0("<pre class='sourceCode r'><code class='sourceCode r'>", x, "</code></pre>")
-
-    # } else if (doc_type == "revealjs::revealjs_presentation") {
-    #
-    #   x <-
+    return(placeholder)
 
   } else {
 
-    x <- paste0("<pre><code class='language-r'>", txt_tocode(x), "</code></pre>")
+    my_code <- paste0("```{r}\n", text, "\n```")
 
-  }
+    if (is_live) {
 
-  return(x)
+      knitted <- knitr::knit(text = my_code,
+                             quiet = TRUE)
 
-}
+    } else {
 
-#' S3 method for printing a \code{decorate_code} object
-#'
-#' Prints nothing directly; \code{decorate_code} objects should be seen and not heard.
-#'
-#' However, when \code{eval = TRUE} was specified, the original source code should be run and output printed.
-#'
-#' @export
-print.decorate_code <- function(x, ...) {
-
-  # if code is being supplied as an input object, run things, with objects defined in global environment
+      knitted <- knitr::knit_child(text = my_code,
+                                   options = my_opts,
+                                   quiet = TRUE)
+    }
 
-  if (attr(x, "eval") && !isTRUE(getOption('knitr.in.progress'))) {
+    # convert knitted string to a list with sources separate from output
+    knitted <- knitted %>% src_to_list()
 
-    where_sources <- attr(x, "where_sources")
+    attr(knitted, "class") <- "with_flair"
 
-    purrr::map(x[-where_sources], print)
+    return(knitted)
 
   }
 
-  #print(x)
-
 }
-
diff --git a/R/flair.R b/R/flair.R
@@ -52,7 +52,7 @@ flair_rx.with_flair = function(x, pattern,
 
   x[where_sources] <- purrr::map(x[where_sources], function(x) structure(list(src = x), class = "source"))
 
-  x <- c(x, script)
+  #x <- c(x, script)
 
   attr(x, "class") <- "with_flair"
 
@@ -89,7 +89,7 @@ flair_rx.default <- function(x, pattern,
     unlist() %>%
     str_c(collapse = "")
 
-  x <- paste0(x, "\n", script)
+  #x <- paste0(x, "\n", script)
 
   return(x)
 }

diff --git a/R/with_flair.R b/R/with_flair.R
@@ -103,7 +103,7 @@ print.with_flair <- function(x, ...) {
 
   x <- x[where_sources]
 
-  x <- map(x, function(src) wrap_source(src, doc_type = "unknown", ...))
+  x <- map(x, function(src) prep_source(src, doc_type = "unknown", ...))
 
   x <- stringr::str_c(unlist(x), collapse = "</br>")