diff --git a/R/params.R b/R/params.R index cbef0331a4..a239f18f37 100644 --- a/R/params.R +++ b/R/params.R @@ -185,6 +185,56 @@ params_namedList <- function() { empty } + +params_html_head <- function(html_head_style = c(), + html_head_script = c(), + html_head_style_link = c(), + html_head_script_link = c()) { + + default_style <- shiny::tags$style( + # Our controls are wiiiiide. + ".container-fluid .shiny-input-container { width: auto; }", + # Prevent the save/cancel buttons from squashing together. + ".navbar button { margin-left: 10px; }", + # Style for the navbar footer. + # http://getbootstrap.com/components/#navbar-fixed-bottom + "body { padding-bottom: 70px; }" + ) + ## Escape is "cancel" and Enter is "save". + default_script <- shiny::tags$script(shiny::HTML("$(document).keyup(function(e) {\n", + "if (e.which == 13) { $('#save').click(); } // enter\n", + "if (e.which == 27) { $('#cancel').click(); } // esc\n", + "});" + )) + + html_head_style <- as.vector(html_head_style) + custom_styles <- lapply(html_head_style, shiny::tags$style) + + html_head_script <- as.vector(html_head_script) + custom_scripts <- lapply(html_head_script, function(x) shiny::tags$script(shiny::HTML(x))) + + html_head_style_link <- as.vector(html_head_style_link) + custom_style_links <- lapply(html_head_style_link, function(x) shiny::tags$link(href = x)) + + html_head_script_link <- as.vector(html_head_script_link) + custom_script_links <- lapply(html_head_script_link, function(x) shiny::tags$script(src = x)) + + return (do.call( + shiny::tags$head, + append( + list(default_style, default_script), + c( + custom_style_links, + custom_styles, + custom_script_links, + custom_scripts + ) + ) + )) + # default_style, custom_styles[0], default_script)) +} + + #' Run a shiny application asking for parameter configuration for the given document. #' #' @param file Path to the R Markdown document with configurable parameters. @@ -193,6 +243,13 @@ params_namedList <- function() { #' @param shiny_args Additional arguments to \code{\link[shiny:runApp]{runApp}}. #' @param save_caption Caption to use use for button that saves/confirms parameters. #' @param encoding The encoding of the input file; see \code{\link{file}}. +#' @param html_head_style a string or a list/vector of strings representing CSS style that will be injected in the HTML HEAD. +#' @param html_head_script a string or a list/vector of strings representing JS scripts that will be injected in the HTML HEAD. +#' @param html_head_style_link same as above except that these are interpreted as HREF attributes in LINK tags. +#' You must take care to unsure that the URL is absolute. +#' @param html_head_script_link same as above except that these are interpreted as SRC attributes in SCRIPT tags. +#' You must take care to unsure that the URL is absolute. +#' @param disable_bootstrap if true, does not inject boostrap scripts and styles in the HTML HEAD. #' #' @return named list with overridden parameter names and value. #' @@ -202,7 +259,12 @@ knit_params_ask <- function(file = NULL, params = NULL, shiny_args = NULL, save_caption = "Save", - encoding = getOption("encoding")) { + encoding = getOption("encoding"), + html_head_style = c(), + html_head_script = c(), + html_head_style_link = c(), + html_head_script_link = c(), + disable_bootstrap = FALSE) { if (is.null(input_lines)) { if (is.null(file)) { @@ -402,23 +464,15 @@ knit_params_ask <- function(file = NULL, class = "container-fluid"), class = "navbar navbar-default navbar-fixed-bottom") - style <- shiny::tags$style( - # Our controls are wiiiiide. - ".container-fluid .shiny-input-container { width: auto; }", - # Prevent the save/cancel buttons from squashing together. - ".navbar button { margin-left: 10px; }", - # Style for the navbar footer. - # http://getbootstrap.com/components/#navbar-fixed-bottom - "body { padding-bottom: 70px; }" - ) - ## Escape is "cancel" and Enter is "save". - script <- shiny::tags$script(shiny::HTML("$(document).keyup(function(e) {\n", - "if (e.which == 13) { $('#save').click(); } // enter\n", - "if (e.which == 27) { $('#cancel').click(); } // esc\n", - "});" - )) - ui <- shiny::bootstrapPage( - shiny::tags$head(style, script), + buildPage <- ifelse((is.null(disable_bootstrap) | !isTruthy(disable_bootstrap)), shiny::bootstrapPage, shiny::tagList) + + ui <- buildPage( + params_html_head( + html_head_style = html_head_style, + html_head_script = html_head_script, + html_head_style_link = html_head_style_link, + html_head_script_link = html_head_script_link + ), contents, footer) diff --git a/man/knit_params_ask.Rd b/man/knit_params_ask.Rd index 9af145ec19..87430e881c 100644 --- a/man/knit_params_ask.Rd +++ b/man/knit_params_ask.Rd @@ -6,7 +6,9 @@ \usage{ knit_params_ask(file = NULL, input_lines = NULL, params = NULL, shiny_args = NULL, save_caption = "Save", - encoding = getOption("encoding")) + encoding = getOption("encoding"), html_head_style = c(), + html_head_script = c(), html_head_style_link = c(), + html_head_script_link = c(), disable_bootstrap = FALSE) } \arguments{ \item{file}{Path to the R Markdown document with configurable parameters.} @@ -20,6 +22,18 @@ knit_params_ask(file = NULL, input_lines = NULL, params = NULL, \item{save_caption}{Caption to use use for button that saves/confirms parameters.} \item{encoding}{The encoding of the input file; see \code{\link{file}}.} + +\item{html_head_style}{a string or a list/vector of strings representing CSS style that will be injected in the HTML HEAD.} + +\item{html_head_script}{a string or a list/vector of strings representing JS scripts that will be injected in the HTML HEAD.} + +\item{html_head_style_link}{same as above except that these are interpreted as HREF attributes in LINK tags. +You must take care to unsure that the URL is absolute.} + +\item{html_head_script_link}{same as above except that these are interpreted as SRC attributes in SCRIPT tags. +You must take care to unsure that the URL is absolute.} + +\item{disable_bootstrap}{if true, does not inject boostrap scripts and styles in the HTML HEAD.} } \value{ named list with overridden parameter names and value. diff --git a/tests/testthat/test-params.R b/tests/testthat/test-params.R new file mode 100644 index 0000000000..bc5f90d474 --- /dev/null +++ b/tests/testthat/test-params.R @@ -0,0 +1,76 @@ +context("params_html_head") + +anyHeadParams <- list( + html_head_style="style", + html_head_style_link = "link", + html_head_script = "script", + html_head_script_link = "scriptjs" +) + +test_that("adds default style and script", { + result <- params_html_head()$children + expect_equal(length(result), 2) + expect_equal(result[[1]]$name, "style") + expect_equal(result[[2]]$name, "script") +}) + +test_that("adds custom style after default style", { + result <- do.call(params_html_head, anyHeadParams)$children + expect_equal(length(result), 6) + expect_equal(result[[4]], shiny::tags$style("style")) +}) + +test_that("adds custom style links after default but before inline custom styles", { + result <- do.call(params_html_head, anyHeadParams)$children + expect_equal(length(result), 6) + expect_equal(result[[3]], shiny::tags$link(href = "link")) + expect_equal(result[[4]], shiny::tags$style("style")) +}) + +test_that("adds custom script links after default but before inline custom scripts", { + result <- do.call(params_html_head, anyHeadParams)$children + expect_equal(length(result), 6) + expect_equal(result[[5]], shiny::tags$script(src = "scriptjs")) + expect_equal(result[[6]], shiny::tags$script(shiny::HTML("script"))) +}) + +test_that("can pass string as style link", { + result <- params_html_head(html_head_style_link="link")$children + expect_equal(result[[3]], shiny::tags$link(href = "link")) +}) + +test_that("can pass vector of strings as style link", { + result <- params_html_head(html_head_style_link=c("link"))$children + expect_equal(result[[3]], shiny::tags$link(href = "link")) +}) + +test_that("can pass string as style", { + result <- params_html_head(html_head_style="style")$children + expect_equal(result[[3]], shiny::tags$style("style")) +}) + +test_that("can pass vector of strings as style", { + result <- params_html_head(html_head_style=c("style"))$children + expect_equal(result[[3]], shiny::tags$style("style")) +}) + +test_that("can pass string as script", { + result <- params_html_head(html_head_script="script")$children + expect_equal(result[[3]], shiny::tags$script(shiny::HTML("script"))) +}) + +test_that("can pass vector of strings as script", { + result <- params_html_head(html_head_script=c("script"))$children + expect_equal(result[[3]], shiny::tags$script(shiny::HTML("script"))) +}) + +test_that("can pass string as script link", { + result <- params_html_head(html_head_script_link="script")$children + expect_equal(result[[3]], shiny::tags$script(src = "script")) +}) + +test_that("can pass vector of strings as script link", { + result <- params_html_head(html_head_script_link=c("script"))$children + expect_equal(result[[3]], shiny::tags$script(src = "script")) +}) +