Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Add addin
  • Loading branch information
malcolmbarrett committed Aug 7, 2019
1 parent f287be2 commit 9089564
Show file tree
Hide file tree
Showing 8 changed files with 662 additions and 10 deletions.
4 changes: 3 additions & 1 deletion DESCRIPTION
Expand Up @@ -38,13 +38,15 @@ Suggests:
bookdown,
covr,
knitr,
miniUI,
pkgdown,
prettydoc,
roxygen2,
shiny,
spelling,
testthat,
xaringan
xaringan,
readr
VignetteBuilder:
knitr
Encoding: UTF-8
Expand Down
1 change: 1 addition & 0 deletions NAMESPACE
Expand Up @@ -121,3 +121,4 @@ export(yml_toplevel)
export(yml_verbatim)
export(yml_vignette)
importFrom(magrittr,"%>%")
importFrom(utils,getFromNamespace)
18 changes: 9 additions & 9 deletions R/addins.R
@@ -1,10 +1,10 @@
insert_yml <- function(.yml) {
.yml %>%
capture_yml() %>%
paste(collapse = "\n") %>%
rstudioapi::insertText()
}

swap_yml <- function() {

#' @importFrom utils getFromNamespace
launch_yaml_addin <- function() {
addin_dir <- system.file("addin", "new_yaml", package = "ymlthis")
app <- shiny::shinyAppDir(addin_dir)
shiny::runGadget(
app,
viewer = shiny::dialogViewer("New YAML")
)
#sys.source(system.file("addin", "new_yaml", "new_yaml.R", package = "ymlthis"))
}
1 change: 1 addition & 0 deletions R/utils.R
Expand Up @@ -25,6 +25,7 @@ stop_if_blogdown_not_installed <- function() {
}

stop_if_not_type <- function(x, type) {
if (is_yml_blank(x)) return(invisible(x))
if (!inherits(x, type)) {
x_text <- rlang::quo_text(rlang::quo(x))
stop_must_be_type(x_text, type)
Expand Down
242 changes: 242 additions & 0 deletions inst/addin/new_yaml/global.R
@@ -0,0 +1,242 @@
# Resources ---------------------------------------------------------------
library(ymlthis)
shiny::addResourcePath("sbs", system.file("www", package = "shinyBS"))
# Functions ---------------------------------------------------------------
author_name <- function() {
tryCatch(
ymlthis:::get_author_name(),
error = function(e) ""
)
}

args_as_char <- function(x) {
if (is.null(x)) return("NULL")
if (is.call(x)) return(rlang::quo_text(x))
as.character(x)
}

arg_textInput <- function(arg_name, arg_val, f_name, id = NULL) {
if (is.null(id)) id <- f_name
input_id <- glue::glue("{id}_{arg_name}")
ph <- args_as_char(arg_val)
shiny::textInput(input_id, arg_name, placeholder = ph)
}

ui_function_args <- function(f_name, id = NULL, ns = "rmarkdown") {
args <- rlang::fn_fmls(utils::getFromNamespace(f_name, ns))
if (ns == "shiny") args[c("inputId", "label", "value")] <- NULL
tags <- purrr::map2(
names(args),
args,
arg_textInput,
f_name = f_name,
id = id
)
shiny::tagList(tags)
}

output_buttons <- function(f_name, short_name) {
if (is.na(f_name)) return(NULL)
id <- glue::glue("button_{f_name}")
txt <- glue::glue("Set {short_name} options")
shiny::conditionalPanel(
condition = glue::glue("input.output_function.includes('{f_name}')"),
shiny::actionButton(id, txt, style = "margin-top:4px; margin-right:2px"),
style = "display:inline-block"
)
}

output_modal <- function(f_name, modal_name = NULL, title = "Output options", id = NULL, ns = "rmarkdown") {
if (is.null(modal_name)) modal_name <- f_name
shinyBS::bsModal(
glue::glue("modal_{modal_name}"),
glue::glue("{title}: {f_name}"),
glue::glue("button_{modal_name}"),
ui_function_args(f_name, id = id, ns = ns),
size = "small"
)
}

ui_output_action_buttons <- function(x) {
tags <- purrr::map2(x, names(x), output_buttons)
shiny::tagList(tags)
}

ui_output_modals <- function(x) {
tags <- purrr::map(x, output_modal)
shiny::tagList(tags)
}

param_label <- function(label, x) {
if (x == "" || is.null(x)) return(NULL)
p_html <- "<code style = 'color:black;background-color:#F0F0F0;'><label>{label}:</label>{x}</code>"
shiny::div(shiny::HTML(glue::glue(p_html)))
}

ui_param <- function(param, value, shiny_function, label) {
input_button <- shiny::actionButton(
glue::glue("button_param_{param}"),
glue::glue("options")
)
if ((shiny_function == "" || is.null(shiny_function))) input_button <- NULL
param_row <- shiny::fillRow(
param_label("param", param),
param_label("value", value),
param_label("label", label),
input_button,
shiny::actionButton(glue::glue("remove_param_{param}"), "Remove"),
height = 70
)
shiny::tags$div(param_row, id = glue::glue("param_{param}"))
}

rmarkdown_outputs <- c(
"html" = "html_document",
"pdf" = "pdf_document",
"word" = "word_document",
"odt" = "odt_document",
"rtf" = "rtf_document",
"md" = "md_document",
"ioslides" = "ioslides_presentation",
"slidy" = "slidy_presentation",
"beamer" = "beamer_presentation",
"powerpoint" = "powerpoint_presentation"
)

shiny_functions <- c(
"",
"checkbox" = "shiny_checkbox",
"date" = "shiny_date",
"file" = "shiny_file",
"numeric" = "shiny_numeric",
"password" = "shiny_password",
"radio" = "shiny_radio",
"select" = "shiny_select",
"slider" = "shiny_slider",
"text" = "shiny_text"
)

shiny_switch <- function(x) {
switch(
x,
"shiny_checkbox" = "checkboxInput",
"shiny_numeric" = "numericInput",
"shiny_slider" = "sliderInput",
"shiny_date" = "dateInput",
"shiny_text" = "textInput",
"shiny_file" = "fileInput",
"shiny_radio" = "radioButtons",
"shiny_select" = "selectInput",
"shiny_password" = "passwordInput"
)
}

swap_arg <- function(x, .default = NULL) {
if (purrr::is_empty(x) || x == "") return(yml_blank())
if (identical(.default, x)) return(yml_blank())
x
}

pass_if <- function(x, pred, .f, ...) {
if (pred) return(x)
.f(x, ...)
}

input_starts_with <- function(input, .match) {
matches <- names(input)[startsWith(names(input), .match)]
matched_inputs <- purrr::map(matches, ~input[[.x]])
names(matched_inputs) <- matches
matched_inputs
}

capture_arg <- function(x) {
if (x == "" || stringr::str_detect(x, "[\"\']{2}")) return(x)
readr_installed <- requireNamespace("readr", quietly = TRUE)
if (readr_installed && is.character(x)) {
arg_guess <- readr::parse_guess(x, guess_integer = TRUE)
if (is.character(arg_guess)) arg_guess <- glue::glue("\"{arg_guess}\"")
return(arg_guess)
}
if (is.numeric(x) || is.logical(x)) return(x)
evaluated_arg <- tryCatch(
rlang::eval_tidy(rlang::parse_expr(x)),
error = function(e) ""
)
if (is.numeric(evaluated_arg) || is.logical(evaluated_arg)) return(evaluated_arg)
glue::glue("\"{x}\"")
}

parse_arguments <- function(x) {
if (purrr::is_empty(x) || x == "") return("")
args <- purrr::map2_chr(x, names(x), ~glue::glue("{.y} = {capture_arg(.x)}"))
glue::glue_collapse(args, ", ")
}
parse_dots <- function(fn_args) {
dot_col <- stringr::str_detect(names(fn_args), "\\.\\.\\.")
if (!any(dot_col)) return(fn_args)
dot_txt <- fn_args[[which(dot_col)]]
dot_list <- glue::glue("list({dot_txt})") %>%
rlang::parse_expr() %>%
rlang::eval_tidy()
x <- fn_args[!dot_col]
x[names(dot_list)] <- dot_list
x
}

parse_output <- function(input, .f, .match = NULL, value = NULL, label = NULL) {
if (is.null(.match)) .match <- .f
fn_args <- input_starts_with(input, .match) %>%
purrr::map(swap_arg) %>%
purrr::discard(is_yml_blank) %>%
parse_dots()
fn_args <- fn_args[names(fn_args) != .match]
names(fn_args) <- stringr::str_remove_all(names(fn_args), glue::glue("{.match}_?"))
if (.f %in% shiny_functions) {
fn_args <- c(value = value, label = label, fn_args)
}
.call <- glue::glue("{.f}({parse_arguments(fn_args)})")
.call
}

capture_output_functions <- function(.yml, input) {
.fs <- input$output_function
if (purrr::is_empty(.fs) || .fs == "") return(.yml)
fn_calls <- purrr::map_chr(.fs, parse_output, input = input) %>%
glue::glue_collapse(sep = ", ")
glue::glue(".yml %>% yml_output({fn_calls})") %>%
rlang::parse_expr() %>%
rlang::eval_tidy()
}

parse_param <- function(param, value, shiny_input, input, label) {
if (is_yml_blank(swap_arg(shiny_input))) {
return(glue::glue("{param} = {capture_arg(value)}"))
}
.match <- glue::glue("modal_param_{param}")
shiny_call <- parse_output(
input,
shiny_input,
.match = .match,
value = value,
label = label
)
glue::glue("{param} = {shiny_call}")
}

capture_params <- function(.yml, params_handlers, input) {
if (purrr::is_empty(params_handlers$params)) {
return(.yml)
}
index <- c("params", "value", "input", "label")
rv_list <- shiny::reactiveValuesToList(params_handlers)[index]
names(rv_list) <- c("param", "value", "shiny_input", "label")
param_list <- purrr::pmap_chr(
rv_list,
parse_param,
input = input
) %>%
glue::glue_collapse(sep = ", ")
glue::glue(".yml %>% yml_params({param_list})") %>%
rlang::parse_expr() %>%
rlang::eval_tidy()
}

0 comments on commit 9089564

Please sign in to comment.