From 617099c86538a14e70ac9caf063aed480781716e Mon Sep 17 00:00:00 2001 From: "Kelly N. Bodwin" Date: Wed, 29 Jan 2020 01:54:23 -0800 Subject: [PATCH] update decorate functions --- NAMESPACE | 2 - R/decorate.R | 15 +-- R/decorate_chunk.R | 27 ++++- R/decorate_code.R | 208 +++++--------------------------- R/flair.R | 4 +- R/with_flair.R | 2 +- man/decorate_chunk.Rd | 6 +- man/decorate_code.Rd | 19 ++- man/knit_print.decorate_code.Rd | 11 -- man/prep_source.Rd | 11 ++ man/print.decorate_code.Rd | 14 --- man/wrap_source.Rd | 15 --- tests/testthat/test-decorate.R | 2 +- tests/testthat/test-flair.R | 4 +- 14 files changed, 89 insertions(+), 251 deletions(-) delete mode 100644 man/knit_print.decorate_code.Rd create mode 100644 man/prep_source.Rd delete mode 100644 man/print.decorate_code.Rd delete mode 100644 man/wrap_source.Rd diff --git a/NAMESPACE b/NAMESPACE index c64e8e1..4c5525f 100644 --- 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 index b178962..c70974e 100644 --- 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 index 4e7281e..9537b82 100644 --- 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 index 76b2000..899e8ca 100644 --- 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"), "
") + # 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("
", txt_tocode(x), "
") - - } else if (doc_type == "ioslides_presentation") { - - x <- paste0("
", txt_tocode(x), "
") - } else if (doc_type == "xaringan::moon_reader") { + # Check for flair = FALSE option + if (!is.null(my_opts$flair) && !my_opts$flair) { - x <- paste0("", x, "") + placeholder <- list(NULL) + attr(placeholder, "class") = "with_flair" - } else if (doc_type == "slidy_presentation") { - - x <- paste0("
", x, "
") - - # } else if (doc_type == "revealjs::revealjs_presentation") { - # - # x <- + return(placeholder) } else { - x <- paste0("
", txt_tocode(x), "
") + 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 index fc1b1ed..2d1e83c 100644 --- 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 index 7bc8944..27b46bd 100644 --- 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 = "
") diff --git a/man/decorate_chunk.Rd b/man/decorate_chunk.Rd index 8486b87..b542e2f 100644 --- a/man/decorate_chunk.Rd +++ b/man/decorate_chunk.Rd @@ -4,7 +4,7 @@ \alias{decorate_chunk} \title{Builds a \code{\link{with_flair}} object from a code chunk} \usage{ -decorate_chunk(chunk_name, eval = TRUE, echo = TRUE) +decorate_chunk(chunk_name, eval = TRUE, echo = TRUE, include = TRUE, ...) } \arguments{ \item{chunk_name}{The label name of the chunk we plan to add \code{\link{flair}} to.} @@ -12,6 +12,10 @@ decorate_chunk(chunk_name, eval = TRUE, echo = TRUE) \item{eval}{Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{eval}} \item{echo}{Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{echo}} + +\item{include}{Evaluation options for chunk; behaves identically to ordinary \code{knitr} code chunk option \code{include}} + +\item{...}{Any number of other chunk options to override.} } \value{ An object of class \code{\link{with_flair}} diff --git a/man/decorate_code.Rd b/man/decorate_code.Rd index c6f10a9..7dead41 100644 --- a/man/decorate_code.Rd +++ b/man/decorate_code.Rd @@ -2,35 +2,30 @@ % Please edit documentation in R/decorate_code.R \name{decorate_code} \alias{decorate_code} -\title{Creates an object of the class \code{decorate_code}} +\title{Creates an object of the class \code{with_flair}} \usage{ -decorate_code(text, eval = TRUE, collapse = FALSE) +decorate_code(text, ...) } \arguments{ \item{text}{A string, presumably representing R code.} -\item{eval}{A boolean specifying whether the code should be immediately evaluated, in addition to creating the \code{decorate_code} object. (Defaults to \code{TRUE})} - -\item{collapse}{Should the source code be printed in one block, before the output is printed? (Defaults to \code{FALSE})} +\item{...}{Any number of default chunk options to override.} } \value{ -A \code{decorate_code} object. +A \code{with_flair} object. } \description{ -\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} } \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. diff --git a/man/knit_print.decorate_code.Rd b/man/knit_print.decorate_code.Rd deleted file mode 100644 index 6a8ed18..0000000 --- a/man/knit_print.decorate_code.Rd +++ /dev/null @@ -1,11 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/decorate_code.R -\name{knit_print.decorate_code} -\alias{knit_print.decorate_code} -\title{S3 method for knitting a \code{decorate_code} object} -\usage{ -knit_print.decorate_code(x, ...) -} -\description{ -S3 method for knitting a \code{decorate_code} object -} diff --git a/man/prep_source.Rd b/man/prep_source.Rd new file mode 100644 index 0000000..16e04f2 --- /dev/null +++ b/man/prep_source.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/with_flair.R +\name{prep_source} +\alias{prep_source} +\title{Helper for \code{knit_print.with_flair}} +\usage{ +prep_source(x, doc_type, ...) +} +\description{ +Helper for \code{knit_print.with_flair} +} diff --git a/man/print.decorate_code.Rd b/man/print.decorate_code.Rd deleted file mode 100644 index 93b06c5..0000000 --- a/man/print.decorate_code.Rd +++ /dev/null @@ -1,14 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/decorate_code.R -\name{print.decorate_code} -\alias{print.decorate_code} -\title{S3 method for printing a \code{decorate_code} object} -\usage{ -\method{print}{decorate_code}(x, ...) -} -\description{ -Prints nothing directly; \code{decorate_code} objects should be seen and not heard. -} -\details{ -However, when \code{eval = TRUE} was specified, the original source code should be run and output printed. -} diff --git a/man/wrap_source.Rd b/man/wrap_source.Rd deleted file mode 100644 index 684e368..0000000 --- a/man/wrap_source.Rd +++ /dev/null @@ -1,15 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/decorate_code.R, R/with_flair.R -\name{wrap_source} -\alias{wrap_source} -\title{Helper for \code{knit_print.decorate_code}} -\usage{ -wrap_source(x, doc_type, ...) - -wrap_source(x, doc_type, ...) -} -\description{ -Helper for \code{knit_print.decorate_code} - -Helper for \code{knit_print.with_flair} -} diff --git a/tests/testthat/test-decorate.R b/tests/testthat/test-decorate.R index cba2407..a63b69b 100644 --- a/tests/testthat/test-decorate.R +++ b/tests/testthat/test-decorate.R @@ -1,5 +1,5 @@ test_that("code is scoped and run", { - decorate("foo <- 10") + decorate_code("foo <- 10") expect_equal(foo+10, 20) }) diff --git a/tests/testthat/test-flair.R b/tests/testthat/test-flair.R index f5c6a61..b6191b0 100644 --- a/tests/testthat/test-flair.R +++ b/tests/testthat/test-flair.R @@ -18,7 +18,7 @@ test_that("flair_rx works with dots", { }) -test_that("flair_rx works for decorated code", { +test_that("flair_rx works for with_flair object", { good_str = "ggplot(iris, aes(x = Sepal.Length)) + geom_histogram()" @@ -27,5 +27,5 @@ test_that("flair_rx works for decorated code", { test_result <- flair_rx(test_dc, test_regexp, color = "red", size = "30px") expect_equal(test_result[[1]], good_str) - expect_equal(class(test_result), "decorate_code") + expect_equal(class(test_result), "with_flair") })