diff --git a/DESCRIPTION b/DESCRIPTION index d3d9d9c..27888a1 100755 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: periscope Type: Package Title: Enterprise Streamlined 'Shiny' Application Framework -Version: 0.6.3 +Version: 1.0.0 Authors@R: c( person("Constance", "Brett", email="connie@aggregate-genius.com", role = c("aut", "cre")), person("Isaac", "Neuhaus", role = "aut", comment = "canvasXpress JavaScript Library Maintainer"), @@ -20,7 +20,7 @@ Language: en-US Depends: R (>= 3.5) Imports: - shiny (>= 1.1), + shiny (>= 1.5), shinydashboard (>= 0.5), shinyBS (>= 0.61), lubridate (>= 1.6), @@ -28,7 +28,10 @@ Imports: writexl (>= 1.3), ggplot2 (>= 2.2), methods, - utils + utils, + fresh, + yaml, + grDevices RoxygenNote: 7.1.1 Suggests: knitr, @@ -36,5 +39,6 @@ Suggests: shinydashboardPlus, testthat (>= 3.0), canvasXpress, - openxlsx (>= 3.0) + openxlsx (>= 3.0), + colourpicker VignetteBuilder: knitr diff --git a/NEWS.md b/NEWS.md index 7d923e9..4721301 100755 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,14 @@ #Revisions and Change Log +### v1.0.0 **major version release** +* Updated to the latest shiny modules paradigm from the old one +* Support for downloadableTable DT options +* Styling changed to use the fresh package +* Updated example applications, documentation, vignettes, etc. +* Ensured apps created with the older version of this package will work when the package is upgraded + +--- + ### v0.6.3 * Bugfix for the framework to not require shinydashboardPlus unless a right sidebar is in use * Bugfixes for the sample applications diff --git a/R/appReset.R b/R/appReset.R index fe99f89..03bbf84 100755 --- a/R/appReset.R +++ b/R/appReset.R @@ -25,21 +25,57 @@ } # Module Server Function -.appReset <- function(input, output, session, logger) { +.appReset <- function(..., logger) { + call <- match.call() + params <- list(...) + param_index <- 1 + params_length <- length(params) + old_style_call <- call[[1]] == "module" || "periscope" %in% as.character(call[[1]]) + + if (old_style_call) { + input <- params[[param_index]] + param_index <- param_index + 1 + output <- params[[param_index]] + param_index <- param_index + 1 + session <- params[[param_index]] + param_index <- param_index + 1 + } else { + id <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(logger) && params_length >= param_index) { + logger <- params[[param_index]] + } + + if (old_style_call) { + app_reset(input, output, session, logger) + } + else { + shiny::moduleServer( + id, + function(input, output, session) { + app_reset(input, output, session, logger) + }) + } +} + + +app_reset <- function(input, output, session, logger) { shiny::observe({ pending <- shiny::isolate(input$resetPending) waittime <- shiny::isolate(.g_opts$reset_wait) - + if (is.null(pending)) { return() # there is no reset button on the UI for the app } - + if (input$resetButton && !(pending)) { # reset initially requested logwarn(paste("Application Reset requested by user. ", - "Resetting in ", (waittime / 1000), - "seconds."), - logger = logger) + "Resetting in ", (waittime / 1000), + "seconds."), + logger = logger) shinyBS::createAlert( session, "sidebarAdvancedAlert", style = "danger", @@ -60,8 +96,8 @@ else if (!input$resetButton && pending) { # reset cancelled by pushing the button again loginfo("Application Reset cancelled by user.", - logger = logger) - + logger = logger) + shinyBS::createAlert( session, "sidebarAdvancedAlert", style = "success", @@ -82,4 +118,5 @@ session$reload() } }) -} + +} diff --git a/R/bodyFooter.R b/R/bodyFooter.R index d413fad..0c2684d 100755 --- a/R/bodyFooter.R +++ b/R/bodyFooter.R @@ -19,27 +19,62 @@ # Module Server Function -.bodyFooter <- function(input, output, session, logdata) { - output$dt_userlog <- shiny::renderTable({ +.bodyFooter <- function(..., logdata) { + call <- match.call() + params <- list(...) + param_index <- 1 + params_length <- length(params) + old_style_call <- call[[1]] == "module" || "periscope" %in% as.character(call[[1]]) + + if (old_style_call) { + input <- params[[param_index]] + param_index <- param_index + 1 + output <- params[[param_index]] + param_index <- param_index + 1 + session <- params[[param_index]] + param_index <- param_index + 1 + } else { + id <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(logdata) && params_length >= param_index) { + logdata <- params[[param_index]] + } + + if (old_style_call) { + body_footer(input, output, session, logdata) + } + else { + shiny::moduleServer( + id, + function(input, output, session) { + body_footer(input, output, session, logdata) + }) + } +} +body_footer <- function(input, output, session, logdata) { + output$dt_userlog <- shiny::renderTable({ + lines <- logdata() if (is.null(lines) || length(lines) == 0) { return() } - + out1 <- data.frame(orig = lines, stringsAsFactors = F) loc1 <- regexpr("\\[", out1$orig) loc2 <- regexpr("\\]", out1$orig) - + out1$logname <- substr(out1$orig, 1, loc1 - 1) - + out1$timestamp <- substr(out1$orig, loc1 + 1, loc2 - 1) out1$timestamp <- lubridate::parse_date_time(out1$timestamp, "YmdHMS") - + out1$action <- substring(out1$orig, loc2 + 1) out1$action <- trimws(out1$action, "both") - + data.frame(action = out1$action, time = format(out1$timestamp, format = .g_opts$datetime.fmt)) - }) + }) } diff --git a/R/downloadFile.R b/R/downloadFile.R index ff3ff5d..ff652d9 100755 --- a/R/downloadFile.R +++ b/R/downloadFile.R @@ -26,7 +26,7 @@ #' @section Shiny Usage: #' Call this function at the place in ui.R where the button should be placed. #' -#' It is paired with a call to \code{shiny::callModule(downloadFile, id, ...)} +#' It is paired with a call to \code{downloadFile(id, ...)} #' in server.R #' #' @seealso \link[periscope]{downloadFile} @@ -52,7 +52,7 @@ downloadFileButton <- function(id, hovertext = NULL) { ns <- shiny::NS(id) output <- "" - + if (length(downloadtypes) > 1) { # create dropdown list dropdown <- list() @@ -60,30 +60,30 @@ downloadFileButton <- function(id, dropdown <- list(dropdown, shiny::tags$li( shiny::downloadLink( - ns(item), - label = item, - class = "periscope-download-choice"))) + ns(item), + label = item, + class = "periscope-download-choice"))) } dropdown <- shiny::tagList(dropdown) - + # button with dropdown list output <- shiny::span( - class = "btn-group", - shinyBS::bsButton( - inputId = ns("downloadFileList"), - label = NULL, - icon = shiny::icon("files-o", lib = "font-awesome"), - type = "action", - class = "dropdown-toggle periscope-download-btn", - `data-toggle` = "dropdown", - `aria-haspopup` = "true", - `aria-expanded` = "false"), - shiny::tags$ul(class = "dropdown-menu", - id = ns("testList"), - dropdown), - shinyBS::bsTooltip(id = ns("downloadFileList"), - hovertext, - placement = "top")) + class = "btn-group", + shinyBS::bsButton( + inputId = ns("downloadFileList"), + label = NULL, + icon = shiny::icon("files-o", lib = "font-awesome"), + type = "action", + class = "dropdown-toggle periscope-download-btn", + `data-toggle` = "dropdown", + `aria-haspopup` = "true", + `aria-expanded` = "false"), + shiny::tags$ul(class = "dropdown-menu", + id = ns("testList"), + dropdown), + shinyBS::bsTooltip(id = ns("downloadFileList"), + hovertext, + placement = "top")) } else { # single button - no dropdown @@ -103,11 +103,8 @@ downloadFileButton <- function(id, #' Server-side function for the downloadFileButton. This is a custom #' high-functionality button for file downloads supporting single or multiple #' download types. The server function is used to provide the data for download. -#' -#' @param input provided by \code{shiny::callModule} -#' @param output provided by \code{shiny::callModule} -#' @param session provided by \code{shiny::callModule} -#' \cr \cr +#' @param ... free parameters list for shiny to pass session variables based on the module call(session, input, output) +#' variables. \emph{Note}: The first argument of this function must be the ID of the Module's UI element #' @param logger logger to use #' @param filenameroot the base text used for user-downloaded file - can be #' either a character string or a reactive expression that returns a character @@ -123,72 +120,139 @@ downloadFileButton <- function(id, #' This function is not called directly by consumers - it is accessed in #' server.R using the same id provided in \code{downloadFileButton}: #' -#' \strong{\code{callModule(downloadFile, id, logger, filenameroot, datafxns)}} +#' \strong{\code{downloadFile(id, logger, filenameroot, datafxns)}} #' #' @seealso \link[periscope]{downloadFileButton} #' @seealso \link[periscope]{downloadFile_ValidateTypes} #' @seealso \link[periscope]{downloadFile_AvailableTypes} -#' @seealso \link[shiny]{callModule} #' #' @examples #' # Inside server_local.R #' #' #single download type -#' # callModule(downloadFile, -#' # "object_id1", -#' # logger = ss_userAction.Log, -#' # filenameroot = "mydownload1", -#' # datafxns = list(csv = mydatafxn1), -#' # aspectratio = 1) +#' # downloadFile("object_id1", +#' # logger = ss_userAction.Log, +#' # filenameroot = "mydownload1", +#' # datafxns = list(csv = mydatafxn1), +#' # aspectratio = 1) #' #' #multiple download types -#' # callModule(downloadFile, -#' # "object_id2", -#' # logger = ss_userAction.Log, -#' # filenameroot = "mytype2", -#' # datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), -#' # aspectratio = 1) +#' # downloadFile("object_id2", +#' # logger = ss_userAction.Log, +#' # filenameroot = "mytype2", +#' # datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), +#' # aspectratio = 1) #' #' @export -downloadFile <- function(input, output, session, logger, - filenameroot, datafxns = list(), +downloadFile <- function(..., + logger, + filenameroot, + datafxns = list(), aspectratio = 1) { + call <- match.call() + params <- list(...) + param_index <- 1 + params_length <- length(params) + old_style_call <- call[[1]] == "module" || "periscope" %in% as.character(call[[1]]) + + if (old_style_call) { + input <- params[[param_index]] + param_index <- param_index + 1 + output <- params[[param_index]] + param_index <- param_index + 1 + session <- params[[param_index]] + param_index <- param_index + 1 + } else { + id <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(logger) && params_length >= param_index) { + logger <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(filenameroot) && params_length >= param_index) { + filenameroot <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(datafxns) && params_length >= param_index) { + datafxns <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(aspectratio) && params_length >= param_index) { + aspectratio <- params[[param_index]] + param_index <- param_index + 1 + } + + if (old_style_call) { + download_file(input, + output, + session, + logger, + filenameroot, + datafxns, + aspectratio) + } + else { + shiny::moduleServer( + id, + function(input, output, session) { + download_file(input, + output, + session, + logger, + filenameroot, + datafxns, + aspectratio) + }) + } +} +download_file <- function(input, + output, + session, + logger, + filenameroot, + datafxns = list(), + aspectratio = 1) { rootname <- filenameroot if ("character" %in% class(filenameroot)) { rootname <- shiny::reactive({filenameroot}) } - + # --- DATA processing - + output$csv <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "csv", sep = ".")}), content = function(file) { writeFile("csv", datafxns$csv(), file, logger, shiny::reactive({paste(rootname(), "csv", sep = ".")})) - }) - + }) + output$xlsx <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "xlsx", sep = ".")}), content = function(file) { writeFile("xlsx", datafxns$xlsx(), file, logger, shiny::reactive({paste(rootname(), "xlsx", sep = ".")})) - }) - + }) + output$tsv <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "tsv", sep = ".")}), content = function(file) { writeFile("tsv", datafxns$tsv(), file, logger, shiny::reactive({paste(rootname(), "tsv", sep = ".")})) - }) - + }) + output$txt <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "txt", sep = ".")}), content = function(file) { writeFile("txt", datafxns$txt(), file, logger, shiny::reactive({paste(rootname(), "txt", sep = ".")})) - }) - + }) + # filename is expected to be a reactive expression writeFile <- function(type, data, file, logger, filename) { # tabular values @@ -214,9 +278,9 @@ downloadFile <- function(input, output, session, logger, openxlsx::saveWorkbook(data, file) } else { show_rownames <- attr(data, "show_rownames") - openxlsx::write.xlsx(data, file, - asTable = TRUE, - row.names = !is.null(show_rownames) && show_rownames) + openxlsx::write.xlsx(data, file, + asTable = TRUE, + row.names = !is.null(show_rownames) && show_rownames) } } else { writexl::write_xlsx(data, file) @@ -243,42 +307,42 @@ downloadFile <- function(input, output, session, logger, warning(msg) } loginfo(paste("File downloaded in browser: <", - filename(), ">"), logger = logger) + filename(), ">"), logger = logger) } - + # --- IMAGE processing - + output$png <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "png", sep = ".")}), content = function(file) { writeImage("png", datafxns$png(), file, aspectratio, logger, shiny::reactive({paste(rootname(), "png", sep = ".")})) }) - + output$jpeg <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "jpeg", sep = ".")}), content = function(file) { writeImage("jpeg", datafxns$jpeg(), file, aspectratio, logger, shiny::reactive({paste(rootname(), "jpeg", sep = ".")})) }) - + output$tiff <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "tiff", sep = ".")}), content = function(file) { writeImage("tiff", datafxns$tiff(), file, aspectratio, logger, shiny::reactive({paste(rootname(), "tiff", sep = ".")})) }) - + output$bmp <- shiny::downloadHandler( filename = shiny::reactive({paste(rootname(), "bmp", sep = ".")}), content = function(file) { writeImage("bmp", datafxns$bmp(), file, aspectratio, logger, shiny::reactive({paste(rootname(), "bmp", sep = ".")})) }) - + writeImage <- function(type, data, file, aspectratio, logger, filename) { dim <- list(width = 7, height = 7/aspectratio, units = "in") - + #ggplot processing if (inherits(data, c("ggplot", "ggmatrix", "grob"))) { if (type %in% c("png", "jpeg", "tiff", "bmp")) { @@ -322,7 +386,7 @@ downloadFile <- function(input, output, session, logger, warning(msg) } loginfo(paste("File downloaded in browser: <", - filename(), ">"), logger = logger) + filename(), ">"), logger = logger) } } @@ -347,7 +411,7 @@ downloadFile_ValidateTypes <- function(types) { if ( !(type %in% shiny::isolate(.g_opts$data_download_types)) && !(type %in% shiny::isolate(.g_opts$plot_download_types)) ) { warning(paste0("file download list contains an invalid type <", - type, ">")) + type, ">")) } } types diff --git a/R/downloadablePlot.R b/R/downloadablePlot.R index a3448ba..a5baed9 100755 --- a/R/downloadablePlot.R +++ b/R/downloadablePlot.R @@ -28,9 +28,7 @@ #' #' @section Notes: #' When there is nothing to download in any of the linked downloadfxns the -#' button will be hidden as there is nothing to download. The linked -#' downloadfxns are set in the paired callModule (see the \strong{Shiny Usage} -#' section) +#' button will be hidden as there is nothing to download. #' #' This module is NOT compatible with the built-in (base) graphics \emph{(such as #' basic plot, etc.)} because they cannot be saved into an object and are directly @@ -39,7 +37,7 @@ #' @section Shiny Usage: #' Call this function at the place in ui.R where the plot should be placed. #' -#' Paired with a call to \code{shiny::callModule(downloadablePlot, id, ...)} +#' Paired with a call to \code{downloadablePlot(id, ...)} #' in server.R #' #' @seealso \link[periscope]{downloadablePlot} @@ -132,10 +130,8 @@ downloadablePlotUI <- function(id, #' Server-side function for the downloadablePlotUI. This is a custom #' plot output paired with a linked downloadFile button. #' -#' @param input provided by \code{shiny::callModule} -#' @param output provided by \code{shiny::callModule} -#' @param session provided by \code{shiny::callModule} -#' \cr \cr +#' @param ... free parameters list for shiny to pass session variables based on the module call(session, input, output) +#' variables. \emph{Note}: The first argument of this function must be the ID of the Module's UI element #' @param logger logger to use #' @param filenameroot the base text used for user-downloaded file - can be #' either a character string or a reactive expression returning a character @@ -157,36 +153,111 @@ downloadablePlotUI <- function(id, #' This function is not called directly by consumers - it is accessed in #' server.R using the same id provided in \code{downloadablePlotUI}: #' -#' \strong{\code{callModule(downloadablePlot, id, logger, filenameroot, +#' \strong{\code{downloadablePlot(id, logger, filenameroot, #' downloadfxns, visibleplot)}} #' #' @seealso \link[periscope]{downloadablePlotUI} -#' @seealso \link[shiny]{callModule} #' #' @examples #' # Inside server_local.R #' -#' # callModule(downloadablePlot, -#' # "object_id1", -#' # logger = ss_userAction.Log, -#' # filenameroot = "mydownload1", -#' # aspectratio = 1.33, -#' # downloadfxns = list(png = myplotfxn, tsv = mydatafxn), -#' # visibleplot = myplotfxn) +#' # downloadablePlot("object_id1", +#' # logger = ss_userAction.Log, +#' # filenameroot = "mydownload1", +#' # aspectratio = 1.33, +#' # downloadfxns = list(png = myplotfxn, tsv = mydatafxn), +#' # visibleplot = myplotfxn) #' #' @export -downloadablePlot <- function(input, output, session, logger, +downloadablePlot <- function(..., + logger, filenameroot, aspectratio = 1, downloadfxns = list(), visibleplot) { + call <- match.call() + params <- list(...) + param_index <- 1 + params_length <- length(params) + + old_style_call <- call[[1]] == "module" || "periscope" %in% as.character(call[[1]]) + + if (old_style_call) { + input <- params[[param_index]] + param_index <- param_index + 1 + output <- params[[param_index]] + param_index <- param_index + 1 + session <- params[[param_index]] + param_index <- param_index + 1 + } else { + id <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(logger) && params_length >= param_index) { + logger <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(filenameroot) && params_length >= param_index) { + filenameroot <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(aspectratio) && params_length >= param_index) { + aspectratio <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(downloadfxns) && params_length >= param_index) { + downloadfxns <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(visibleplot) && params_length >= param_index) { + visibleplot <- params[[param_index]] + param_index <- param_index + 1 + } + + if (old_style_call) { + download_plot(input, + output, + session, + logger, + filenameroot, + aspectratio, + downloadfxns, + visibleplot) + } + else { + shiny::moduleServer( + id, + function(input, output, session) { + download_plot(input, + output, + session, + logger, + filenameroot, + aspectratio, + downloadfxns, + visibleplot) + }) + } +} - shiny::callModule(downloadFile, "dplotButtonID", - logger, filenameroot, downloadfxns, aspectratio) - +download_plot <- function(input, + output, + session, + logger, + filenameroot, + aspectratio = 1, + downloadfxns = list(), + visibleplot) { + downloadFile("dplotButtonID", logger, filenameroot, downloadfxns, aspectratio) + dpInfo <- shiny::reactiveValues(visibleplot = NULL, downloadfxns = NULL) - + shiny::observe({ dpInfo$visibleplot <- visibleplot() output$dplotOutputID <- shiny::renderPlot({ @@ -197,17 +268,16 @@ downloadablePlot <- function(input, output, session, logger, plot }) }) - + shiny::observe({ if (!is.null(downloadfxns) && (length(downloadfxns) > 0)) { dpInfo$downloadfxns <- lapply(downloadfxns, do.call, list()) - + rowct <- lapply(dpInfo$downloadfxns, is.null) session$sendCustomMessage( "downloadbutton_toggle", message = list(btn = session$ns("dplotButtonDiv"), rows = sum(unlist(rowct) == FALSE)) ) } - }) - + }) } diff --git a/R/downloadableTable.R b/R/downloadableTable.R index edf77af..650bfc4 100755 --- a/R/downloadableTable.R +++ b/R/downloadableTable.R @@ -32,14 +32,12 @@ #' #' @section Notes: #' When there are no rows to download in any of the linked downloaddatafxns the -#' button will be hidden as there is nothing to download. The linked -#' downloaddatafxns are set in the paired callModule (see the \strong{Shiny Usage} -#' section) +#' button will be hidden as there is nothing to download. #' #' @section Shiny Usage: #' Call this function at the place in ui.R where the table should be placed. #' -#' Paired with a call to \code{shiny::callModule(downloadableTable, id, ...)} +#' Paired with a call to \code{downloadableTable(id, ...)} #' in server.R #' #' @seealso \link[periscope]{downloadableTable} @@ -89,11 +87,22 @@ downloadableTableUI <- function(id, #' Server-side function for the downloadableTableUI. This is a custom #' high-functionality table paired with a linked downloadFile #' button. +#' +#' Generated table can highly customized using function \code{?DT::datatable} same arguments +#' except for `options` and `selection` parameters. +#' +#' For `options` user can pass the same \code{?DT::datatable} options using the same names and +#' values one by one separated by comma. +#' +#' For `selection` parameter it can be either a function or reactive expression providing the row_ids of the +#' rows that should be selected. +#' +#' Also, user can apply the same provided \code{?DT::formatCurrency} columns formats on passed +#' dataset using format functions names as keys and their options as a list. +#' #' -#' @param input provided by \code{shiny::callModule} -#' @param output provided by \code{shiny::callModule} -#' @param session provided by \code{shiny::callModule} -#' \cr \cr +#' @param ... free parameters list to pass table customization options. See example below. +#' \emph{Note}: The first argument of this function must be the ID of the Module's UI element #' @param logger logger to use #' @param filenameroot the base text used for user-downloaded file - can be #' either a character string or a reactive expression returning a character @@ -103,64 +112,158 @@ downloadableTableUI <- function(id, #' when the table UI was created. #' @param tabledata function or reactive expression providing the table display #' data as a return value. This function should require no input parameters. -#' @param rownames whether or not to show the rownames in the table -#' @param caption table caption #' @param selection function or reactive expression providing the row_ids of the -#' rows that should be selected. +#' rows that should be selected #' #' @return Reactive expression containing the currently selected rows in the #' display table #' #' @section Notes: -#' When there are no rows to download in any of the linked downloaddatafxns the -#' button will be hidden as there is nothing to download. +#' \itemize{ +#' \item When there are no rows to download in any of the linked downloaddatafxns +#' the button will be hidden as there is nothing to download. +#' \item \code{selection} parameter has different usage than DT::datatable \code{selection} option. +#' See parameters usage section. +#' \item DT::datatable options \code{editable}, \code{width} and \code{height} are not supported +#' } #' #' @section Shiny Usage: #' This function is not called directly by consumers - it is accessed in #' server.R using the same id provided in \code{downloadableTableUI}: #' -#' \strong{\code{callModule(downloadableTable, id, logger, filenameroot, +#' \strong{\code{downloadableTable(id, logger, filenameroot, #' downloaddatafxns, tabledata, rownames, caption, selection)}} #' -#' \emph{Note}: callModule returns the reactive expression containing the +#' \emph{Note}: calling module server returns the reactive expression containing the #' currently selected rows in the display table. #' #' @seealso \link[periscope]{downloadableTableUI} -#' @seealso \link[shiny]{callModule} #' #' @examples #' # Inside server_local.R #' -#' # selectedrows <- callModule(downloadableTable, -#' # "object_id1", -#' # logger = ss_userAction.Log, -#' # filenameroot = "mydownload1", -#' # downloaddatafxns = list(csv = mydatafxn1, tsv = mydatafxn2), -#' # tabledata = mydatafxn3, -#' # rownames = FALSE, -#' # caption = "This is a great table! By: Me", -#' # selection = mydataRowIds) +#' # selectedrows <- downloadableTable( +#' # "object_id1", +#' # logger = ss_userAction.Log, +#' # filenameroot = "mydownload1", +#' # downloaddatafxns = list(csv = mydatafxn1, tsv = mydatafxn2), +#' # tabledata = mydatafxn3, +#' # rownames = FALSE, +#' # caption = "This is a great table! By: Me", +#' # selection = mydataRowIds, +#' # colnames = c("Area", "Delta", "Increase"), +#' # filter = "bottom", +#' # width = "150px", +#' # height = "50px", +#' # extensions = 'Buttons', +#' # plugins = 'natural', +#' # editable = TRUE, +#' # dom = 'Bfrtip', +#' # buttons = c('copy', 'csv', 'excel', 'pdf', 'print'), +#' # formatStyle = list(columns = c('Area'), color = 'red'), +#' # formatStyle = list(columns = c('Increase'), color = DT::styleInterval(0, c('red', 'green'))), +#' # formatCurrency = list(columns = c('Delta'))) #' #' # selectedrows is the reactive return value, captured for later use #' #' @export -downloadableTable <- function(input, output, session, logger, - filenameroot, downloaddatafxns = list(), - tabledata, rownames = TRUE, caption = NULL, +downloadableTable <- function(..., + logger, + filenameroot, + downloaddatafxns = list(), + tabledata, selection = NULL) { + call <- match.call() + params <- list(...) + param_index <- 1 + params_length <- length(params) + old_style_call <- call[[1]] == "module" || "periscope" %in% as.character(call[[1]]) + + if (old_style_call) { + input <- params[[param_index]] + param_index <- param_index + 1 + output <- params[[param_index]] + param_index <- param_index + 1 + session <- params[[param_index]] + param_index <- param_index + 1 + } + else { + id <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(logger) && params_length >= param_index) { + logger <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(filenameroot) && params_length >= param_index) { + filenameroot <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(downloaddatafxns) && params_length >= param_index) { + downloaddatafxns <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(tabledata) && params_length >= param_index) { + tabledata <- params[[param_index]] + param_index <- param_index + 1 + } + + if (missing(selection)) { + selection <- params[["selection"]] + params[["selection"]] <- NULL + } + + if (old_style_call) { + download_table(input, output, session, + logger, + filenameroot, + downloaddatafxns, + tabledata, + selection, + params[param_index:params_length]) + } + else { + shiny::moduleServer(id = params[[1]], + function(input, output, session) { + download_table(input, output, session, + logger, + filenameroot, + downloaddatafxns, + tabledata, + selection, + params[param_index:params_length]) + }) + } +} - shiny::callModule(downloadFile, "dtableButtonID", - logger, filenameroot, downloaddatafxns) +download_table <- function(input, output, session, + logger, + filenameroot, + downloaddatafxns = list(), + tabledata, + selection, + table_options) { + if (all(!is.null(selection), + is.character(selection))) { + message("'selection' parameter must be a function or reactive expression. Setting default value NULL.") + selection <- NULL + } + + downloadFile("dtableButtonID", logger, filenameroot, downloaddatafxns) session$sendCustomMessage("downloadbutton_toggle", message = list(btn = session$ns("dtableButtonDiv"), rows = -1)) - + dtInfo <- shiny::reactiveValues(selection = NULL, selected = NULL, tabledata = NULL, downloaddatafxns = NULL) - + shiny::observe({ result <- list(mode = ifelse(input$dtableSingleSelect == "TRUE", "single", "multiple")) if (!is.null(selection)) { @@ -177,61 +280,145 @@ downloadableTable <- function(input, output, session, logger, shiny::observe({ dtInfo$selected <- input$dtableOutputID_rows_selected }) - + shiny::observe({ dtInfo$tabledata <- tabledata() }) - + shiny::observe({ dtInfo$downloaddatafxns <- lapply(downloaddatafxns, do.call, list()) - + rowct <- lapply(dtInfo$downloaddatafxns, nrow) session$sendCustomMessage("downloadbutton_toggle", message = list(btn = session$ns("dtableButtonDiv"), rows = sum(unlist(rowct)))) }) - + output$dtableOutputID <- DT::renderDataTable({ sourcedata <- dtInfo$tabledata - + if (!is.null(sourcedata) && nrow(sourcedata) > 0) { row.names <- rownames(sourcedata) row.ids <- as.character(seq(1:nrow(sourcedata))) if (is.null(row.names) || identical(row.names, row.ids)) { DT_RowId <- paste0("rowid_", row.ids) - sourcedata <- cbind(DT_RowId, sourcedata) - } else { - col.names <- colnames(sourcedata) - sourcedata <- cbind(row.names, sourcedata) - colnames(sourcedata) <- c(" ", col.names) + rownames(sourcedata) <- DT_RowId } } - DT::datatable(data = sourcedata, - options = list( - deferRender = FALSE, - scrollY = input$dtableOutputHeight, - paging = FALSE, - scrollX = TRUE, - dom = '<"periscope-downloadable-table-header"f>tr', - processing = TRUE, - rowId = 1, - columnDefs = list(list(targets = 0, - visible = FALSE, - searchable = FALSE)), - searchHighlight = TRUE ), - class = paste("periscope-downloadable-table table-condensed", - "table-striped table-responsive"), - rownames = rownames, - selection = dtInfo$selection, - caption = caption, - escape = FALSE, - style = "bootstrap") + + if (is.null(table_options[["scrollY"]])) { + table_options[["scrollY"]] <- input$dtableOutputHeight + } + + table_options[["selection"]] <- dtInfo$selection + + if (is.null(table_options[["escape"]])) { + table_options[["escape"]] <- FALSE + } + + if (is.null(table_options[["rownames"]])) { + table_options[["rownames"]] <- FALSE + } + + # get format functions + format_options_idx <- which(startsWith(names(table_options), "format")) + format_options <- table_options[format_options_idx] + if (length(format_options_idx) > 0) { + dt_args <- build_datatable_arguments(table_options[-format_options_idx]) + } else { + dt_args <- build_datatable_arguments(table_options) + } + + if (is.null(sourcedata)) { + sourcedata <- data.frame() + } + + dt_args[["data"]] <- sourcedata + + tryCatch({ + dt <- do.call(DT::datatable, dt_args) + + if (length(format_options) > 0) { + dt <- format_columns(dt, format_options) + } + dt + }, + error = function(e) { + message("Could not apply DT options due to: ", e$message) + DT::datatable(sourcedata) + }) }) - - - selectedrows <- shiny::reactive({ + + + shiny::reactive({ return(shiny::isolate(dtInfo$tabledata)[dtInfo$selected, ]) - }) + }) +} + +build_datatable_arguments <- function(table_options) { + dt_args <- list() + formal_dt_args <- methods::formalArgs(DT::datatable) + dt_args[["rownames"]] <- TRUE + dt_args[["class"]] <- paste("periscope-downloadable-table table-condensed", + "table-striped table-responsive") + options <- list() + for (option in names(table_options)) { + if (option %in% c("editable", "width", "height")) { + message("DT option '", option ,"' is not supported. Ignoring it.") + next + } + + if (option %in% formal_dt_args) { + dt_args[[option]] <- table_options[[option]] + } else { + options[[option]] <- table_options[[option]] + } + } + + if (is.null(options[["deferRender"]])) { + options[["deferRender"]] <- FALSE + } + + if (is.null(options[["paging"]]) && is.null(table_options[["pageLength"]])) { + options[["paging"]] <- FALSE + } + + if (is.null(options[["scrollX"]])) { + options[["scrollX"]] <- TRUE + } + + if (is.null(options[["dom"]]) && is.null(table_options[["pageLength"]])) { + options[["dom"]] <- '<"periscope-downloadable-table-header"f>tr' + } + + if (is.null(options[["processing"]])) { + options[["processing"]] <- TRUE + } + + if (is.null(options[["rowId"]])) { + options[["rowId"]] <- 1 + } + + if (is.null(options[["searchHighlight"]])) { + options[["searchHighlight"]] <- TRUE + } + dt_args[["options"]] <- options + dt_args +} - return(selectedrows) +format_columns <- function(dt, format_options) { + for (format_idx in 1:length(format_options)) { + format_args <- format_options[[format_idx]] + format_args[["table"]] <- dt + format <- tolower(names(format_options)[format_idx]) + dt <- switch(format, + "formatstyle" = do.call(DT::formatStyle, format_args), + "formatdate" = do.call(DT::formatDate, format_args), + "formatsignif" = do.call(DT::formatSignif, format_args), + "formatround" = do.call(DT::formatRound, format_args), + "formatpercentage" = do.call(DT::formatPercentage, format_args), + "formatstring" = do.call(DT::formatString, format_args), + "formatcurrency" = do.call(DT::formatCurrency, format_args)) + } + dt } diff --git a/R/fw_helpers_external.R b/R/fw_helpers_external.R index b520cbc..15c46cb 100755 --- a/R/fw_helpers_external.R +++ b/R/fw_helpers_external.R @@ -5,9 +5,9 @@ # Framework Server Setup fw_server_setup <- function(input, output, session, logger) { logfile <- shiny::isolate(.setup_logging(session, logger)) - shiny::callModule(.bodyFooter, "footerId", logfile) + .bodyFooter("footerId", logfile) if (shiny::isolate(.g_opts$reset_button)) { - shiny::callModule(.appReset, "appResetId", logger) + .appReset("appResetId", logger) } } @@ -145,6 +145,22 @@ fw_create_right_sidebar <- function() { # Framework UI Body Creation fw_create_body <- function() { + header_color_style <- "$('.logo').css('background-color', $('.navbar').css('background-color'))" + update_right_side_bar_width <- "$('.navbar-custom-menu').on('click', + function() { + main_width = $('.main-sidebar').css('width'); + if ($('.control-sidebar-open').length != 0) { + $('.control-sidebar-open').css('width', main_width); + $('.control-sidebar-bg').css('width', main_width); + $('.control-sidebar-bg').css('right', '0px' ); + $('.control-sidebar').css('right', '0px'); + } else { + $('.control-sidebar-bg').css('right', '-' + main_width); + $('.control-sidebar').css('right', '-' + main_width); + $('.control-sidebar').css('width', '-' + main_width); + } + });" + app_info <- shiny::isolate(.g_opts$app_info) info_content <- NULL @@ -157,16 +173,97 @@ fw_create_body <- function() { app_info) } - return( - shinydashboard::dashboardBody( - shiny::tags$head( - shiny::tags$style(.framework_css()), - shiny::tags$script(.framework_js())), - info_content, - shiny::isolate(.g_opts$body_elements), - if (shiny::isolate(.g_opts$show_userlog)) { - .bodyFooterOutput("footerId") } - else {NULL} + shinydashboard::dashboardBody( + fresh::use_theme(create_theme()), + shiny::tags$head( + shiny::tags$style(.framework_css()), + shiny::tags$script(.framework_js())), + shiny::tags$script(update_right_side_bar_width), + shiny::tags$script(header_color_style), + info_content, + shiny::isolate(.g_opts$body_elements), + if (shiny::isolate(.g_opts$show_userlog)) { + .bodyFooterOutput("footerId") + } else { + NULL + } + ) + +} + +create_theme <- function() { + theme_settings <- NULL + primary_color <- NULL + sidebar_width <- NULL + sidebar_background_color <- NULL + sidebar_hover_color <- NULL + sidebar_text_color <- NULL + body_background_color <- NULL + box_color <- NULL + infobox_color <- NULL + theme_colors_keys <- c("primary_color", "sidebar_background_color", "sidebar_hover_color", + "sidebar_text_color", "body_background_color", "box_color", + "infobox_color") + + if (file.exists("www/periscope_style.yaml")) { + theme_settings <- tryCatch({ + yaml::read_yaml("www/periscope_style.yaml") + }, + error = function(e){ + warning("Could not parse 'periscope_style.yaml' due to: ", e$message) + NULL + }) + + if (!is.null(theme_settings) && is.list(theme_settings)) { + for (color in theme_colors_keys) { + if (!is_valid_color(theme_settings[[color]])) { + warning(color, " has invalid color value. Setting default color.") + theme_settings[[color]] <- NULL + } + } + + primary_color <- theme_settings[["primary_color"]] + sidebar_width <- theme_settings[["sidebar_width"]] + sidebar_background_color <- theme_settings[["sidebar_background_color"]] + sidebar_hover_color <- theme_settings[["sidebar_hover_color"]] + sidebar_text_color <- theme_settings[["sidebar_text_color"]] + body_background_color <- theme_settings[["body_background_color"]] + box_color <- theme_settings[["box_color"]] + infobox_color <- theme_settings[["infobox_color"]] + if (!is.null(sidebar_width)) { + if (any(!is.numeric(sidebar_width), sidebar_width <= 0)) { + warning("'sidebar_width' must be positive value. Setting default value.") + } else { + sidebar_width <- paste0(sidebar_width, "px") + } + } + } + } + + fresh::create_theme( + fresh::adminlte_color( + light_blue = primary_color + ), + fresh::adminlte_sidebar( + width = sidebar_width, + dark_bg = sidebar_background_color, + dark_hover_bg = sidebar_hover_color, + dark_color = sidebar_text_color + ), + fresh::adminlte_global( + content_bg = body_background_color, + box_bg = box_color, + info_box_bg = infobox_color ) ) } + +is_valid_color <- function(color) { + tryCatch({ + grDevices::col2rgb(color) + TRUE + }, + error = function(e) { + FALSE + }) +} diff --git a/R/fw_helpers_internal.R b/R/fw_helpers_internal.R index 68f9b5d..edb0c33 100755 --- a/R/fw_helpers_internal.R +++ b/R/fw_helpers_internal.R @@ -69,8 +69,7 @@ } .remove_sidebar_toggle <- function() { - shiny::tags$script(shiny::HTML("$('[class~=\"sidebar-toggle\"]').remove(); - $('[class~=\"logo\"]').css('background-color', '#3c8dbc');")) + shiny::tags$script(shiny::HTML("$('[class~=\"sidebar-toggle\"]').remove();")) } # Returns the custom css as HTML diff --git a/R/generate_template.R b/R/generate_template.R index d75e3df..9c1ddde 100755 --- a/R/generate_template.R +++ b/R/generate_template.R @@ -16,7 +16,7 @@ #' @param rightsidebar parameter to set the right sidebar. It can be TRUE/FALSE or a character #' containing the name of a shiny::icon(). #' @param leftsidebar whether the left sidebar should be enabled. -#' @param style list containing application styling properties. By default the skin is blue. +#' @param custom_theme_file location of custom theme settings yaml file. Default value is NULL. #' #' @section Name: #' The \code{name} directory must not exist in \code{location}. If the code @@ -76,6 +76,10 @@ #' inside of the call to \code{shinyServer(...)}. Anything placed in this #' file will be accessible only within a single user session.\cr #' \cr +#' \strong{\emph{name}/www/periscope_style.yaml} :\cr +#' This is the application custom styling yaml file. User can update +#' application different parts style using this file.\cr +#' \cr #' \cr #' \strong{Do not modify the following files}: \cr #' \preformatted{ @@ -108,12 +112,18 @@ #' # blank app named 'myblankapp' created in a temp dir #' create_new_application(name = 'myblankapp', location = tempdir()) #' # blank app named 'myblankapp' with a green skin created in a temp dir -#' create_new_application(name = 'myblankapp', location = tempdir(), style = list(skin = "green")) +#' create_new_application(name = 'myblankapp', location = tempdir()) #' # blank app named 'myblankapp' without a left sidebar created in a temp dir #' create_new_application(name = 'myblankapp', location = tempdir(), leftsidebar = FALSE) #' #' @export -create_new_application <- function(name, location, sampleapp = FALSE, resetbutton = TRUE, rightsidebar = FALSE, leftsidebar = TRUE, style = list(skin = "blue")) { +create_new_application <- function(name, + location, + sampleapp = FALSE, + resetbutton = TRUE, + rightsidebar = FALSE, + leftsidebar = TRUE, + custom_theme_file = NULL) { usersep <- .Platform$file.sep newloc <- paste(location, name, sep = usersep) @@ -138,22 +148,22 @@ create_new_application <- function(name, location, sampleapp = FALSE, resetbutto stop("Framework creation could not proceed, invalid type for rightsidebar, only logical or character allowed") } } - if (!is.null(style)) { - if (class(style) == "list") { - if (!identical(intersect("skin", names(style)), character(0)) && !identical(class(style$skin), "character")) { - stop("Framework creation could not proceed, invalid type for skin, only character allowed. See ?shinydashboard::dashboardPage for supported colors.") - } - } else { - stop("Framework creation could not proceed, invalid type for style, only list allowed") - } - } if (!(.g_sdp_installed) && dashboard_plus) { stop('shinyDashboardPlus is not currently installed -- it is required to generate an application with a right sidebar.') } .create_dirs(newloc, usersep) - .copy_fw_files(newloc, usersep, resetbutton, dashboard_plus, leftsidebar, right_sidebar_icon, style) + if (!is.null(custom_theme_file)) { + if (any(!is.character(custom_theme_file), + length(custom_theme_file) != 1, + custom_theme_file == "", + !file.exists(custom_theme_file))) { + warning("'custom_theme_file' must be single character value pointing to valid yaml file location. Using default values.") + custom_theme_file <- NULL + } + } + .copy_fw_files(newloc, usersep, resetbutton, dashboard_plus, leftsidebar, right_sidebar_icon, custom_theme_file, sampleapp) .copy_program_files(newloc, usersep, sampleapp, resetbutton, leftsidebar, dashboard_plus) message("Framework creation was successful.") @@ -185,7 +195,14 @@ create_new_application <- function(name, location, sampleapp = FALSE, resetbutto } # Create Framework Files ---------------------------- -.copy_fw_files <- function(newloc, usersep, resetbutton = TRUE, dashboard_plus = FALSE, leftsidebar = TRUE, right_sidebar_icon = NULL, style = list(skin = "blue")) { +.copy_fw_files <- function(newloc, + usersep, + resetbutton = TRUE, + dashboard_plus = FALSE, + leftsidebar = TRUE, + right_sidebar_icon = NULL, + custom_theme_file, + sampleapp = FALSE) { files <- c("global.R", "server.R") if (dashboard_plus) { @@ -233,19 +250,20 @@ create_new_application <- function(name, location, sampleapp = FALSE, resetbutto writeLines(ui_content, con = ui_file) close(ui_file) } - # styling - if (!is.null(style) && identical(class(style), "list") && length(style) > 0 && - !identical(intersect("skin", names(style)), character(0)) && !identical(style, list(skin = "blue"))) { - skin_value <- style$skin - ui_file <- file(paste(newloc, "ui.R", sep = usersep), open = "r+") - ui_content <- readLines(con = ui_file) - ui_content[length(ui_content)] <- paste0(substr(ui_content[length(ui_content)], 1, nchar(ui_content[length(ui_content)]) - 1), ",") - white_space <- paste(rep(" ", ifelse(dashboard_plus, nchar("dashboardPagePlus"), nchar("dashboardPage"))), collapse = "") - ui_content[length(ui_content) + 1] <- sprintf("%s skin = '%s')", white_space, skin_value) + + if (sampleapp) { + ui_file <- file(paste(newloc, "ui.R", sep = usersep), open = "r") + ui_content <- readLines(con = ui_file) + close(ui_file) + ui_content <- gsub("periscope:::fw_create_body()", + "uiOutput('body')", + ui_content, + fixed = TRUE) + ui_file <- file(paste(newloc, "ui.R", sep = usersep), open = "w") writeLines(ui_content, con = ui_file) close(ui_file) } - + #subdir copies imgs <- c("loader.gif", "tooltip.png") for (file in imgs) { @@ -256,7 +274,14 @@ create_new_application <- function(name, location, sampleapp = FALSE, resetbutto con = paste(newloc, "www", "img", file, sep = usersep)) } - return() + if (!is.null(custom_theme_file)) { + file.copy(custom_theme_file, paste(newloc, "www", "periscope_style.yaml", sep = usersep)) + } else if (sampleapp) { + file.copy(system.file("fw_templ", "www", "periscope_style.yaml", package = "periscope"), + paste(newloc, "www", "periscope_style.yaml", sep = usersep)) + } else { + create_default_theme_file(paste(newloc, "www", "periscope_style.yaml", sep = usersep)) + } } # Create Program Files ---------------------------- @@ -310,6 +335,54 @@ create_new_application <- function(name, location, sampleapp = FALSE, resetbutto con = paste(targetdir, unlist(supporting_files[file], use.names = F), file, sep = usersep)) } } +} - return() +create_default_theme_file <- function(theme_file) { + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "primary_color: \n\n", + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + "sidebar_width: \n", + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_background_color: \n", + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "body_background_color: \n", + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "box_color: \n", + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: \n") + writeLines(lines, theme_file) } diff --git a/README.md b/README.md index 23399d4..91e678a 100644 --- a/README.md +++ b/README.md @@ -10,7 +10,7 @@ output: [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/periscope?color=9bc2cf)](https://cran.r-project.org/package=periscope) [![CRAN_Downloads_Badge](https://cranlogs.r-pkg.org/badges/grand-total/periscope?color=9bc2cf)](https://cran.r-project.org/package=periscope) -[![Travis-CI Build Status](https://travis-ci.com/cb4ds/periscope.svg?branch=master)](https://travis-ci.com/cb4ds/periscope) +[![Travis-CI Build Status](https://app.travis-ci.com/cb4ds/periscope.svg?branch=master)](https://app.travis-ci.com/cb4ds/periscope) [![Coverage Status](https://img.shields.io/codecov/c/github/cb4ds/periscope/master.svg)](https://codecov.io/github/cb4ds/periscope?branch=master) @@ -64,12 +64,3 @@ create_new_application("sampleapp2", location = tempdir(), sampleapp = TRUE, rig runApp('sampleapp2') ``` - -#### Sample application - custom styling - -```r -library(periscope) -create_new_application("sampleapp3", location = tempdir(), sampleapp = TRUE, style = list(skin = "green")) -runApp('sampleapp3') - -``` diff --git a/cran-comments.md b/cran-comments.md index 5e412ec..ce03cef 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,10 +1,11 @@ ## Comments from Maintainer -* LazyData removed from Description to fix Note on CRAN check page +Resubmission comments: +Updated travis link in Readme file -* Bugfix for situation where the user wants to generate an app but does not have shinydashboardPlus installed and does not need a right sidebar (which requires sdp) - -* There may be a NOTE due to the short time between submissions, this is an important bugfix release and I kindly ask for your exception to allow this release. +Initial comments: +This is a major functionality update including changing the shiny module paradigm, supporting additional DT options in downloadableTables and updating the styling paradigm to allow more flexibility when customizing periscope applications. This release is compatible with apps created with the 0.x version of the package and +documentation including the sample applications, examples, vignettes, tests, etc. were also updated. --- @@ -14,13 +15,14 @@ RStudio Server Pro (Ubuntu 18.04.2) * R 3.6.3 -* R 4.0.4 +* R 4.0.5 +* R 4.1.1 Travis-CI (Ubuntu 16.04.6) * R 3.6.3 * R 4.0.2 -* R devel (2021-03-29 r80130) +* R devel (2021-09-29 r80990) WinBuilder @@ -29,7 +31,7 @@ WinBuilder RHub -* devtools::check_rhub(interactive = F) +* devtools::check_rhub(interactive = F, env_vars = c("R_CHECK_FORCE_SUGGESTS" = "false")) --- @@ -49,9 +51,9 @@ devtools::check() **NONE** ``` -pdb <- available.packages() tools::package_dependencies(packages = c('periscope'), - db = pdb, reverse = TRUE) + db = available.packages(), + reverse = TRUE) $periscope character(0) diff --git a/inst/fw_templ/p_blank/global.R b/inst/fw_templ/p_blank/global.R index 7f73254..212e893 100755 --- a/inst/fw_templ/p_blank/global.R +++ b/inst/fw_templ/p_blank/global.R @@ -9,6 +9,9 @@ # to server, UI and session scopes # ---------------------------------------- +library(shiny) +library(periscope) + # -- Setup your Application -- set_app_parameters(title = "Set title in global.R using set_app_parameters()", diff --git a/inst/fw_templ/p_example/global.R b/inst/fw_templ/p_example/global.R index 52cfc13..9e74719 100755 --- a/inst/fw_templ/p_example/global.R +++ b/inst/fw_templ/p_example/global.R @@ -12,6 +12,7 @@ # -- IMPORTS -- library(canvasXpress) + # -- Setup your Application -- set_app_parameters(title = "Sample Title (click for an info pop-up)", titleinfo = HTML("

Application Information Pop-Up

", diff --git a/inst/fw_templ/p_example/program_helpers.R b/inst/fw_templ/p_example/program_helpers.R index 209068e..2140772 100755 --- a/inst/fw_templ/p_example/program_helpers.R +++ b/inst/fw_templ/p_example/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/inst/fw_templ/p_example/server_global.R b/inst/fw_templ/p_example/server_global.R index bcc8a3d..571c128 100755 --- a/inst/fw_templ/p_example/server_global.R +++ b/inst/fw_templ/p_example/server_global.R @@ -23,6 +23,10 @@ # ---------------------------------------- # -- IMPORTS -- +library(colourpicker) +library(DT) +library(htmltools) +library(htmlwidgets) # -- VARIABLES -- diff --git a/inst/fw_templ/p_example/server_local.R b/inst/fw_templ/p_example/server_local.R index d4fd8e0..0da3686 100755 --- a/inst/fw_templ/p_example/server_local.R +++ b/inst/fw_templ/p_example/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -54,7 +54,7 @@ output$proginfo <- renderUI({ "application-wide functionality is useful across all users that ", "should be added into server_global.R. Scoping information is in ", "the top comment of all program example files.") ) - }) +}) output$tooltips <- renderUI({ list(hr(), @@ -63,7 +63,7 @@ output$tooltips <- renderUI({ text = "Example tooltip text"), "can be added with the following code in the UI:"), p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) - }) +}) output$busyind <- renderUI({ list(hr(), @@ -73,7 +73,7 @@ output$busyind <- renderUI({ bsButton("showWorking", label = "Show application busy indicator for 5 seconds", style = "primary")) ) - }) +}) output$download <- renderUI({ list( @@ -83,13 +83,13 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", downloadFileButton("exampleDownload2", c("csv", "xlsx", "tsv"), "Download options")) ) - }) +}) output$alerts <- renderUI({ list(hr(), @@ -112,7 +112,7 @@ output$alerts <- renderUI({ label = "Body", style = "info", width = "25%")) ) - }) +}) output$loginfo <- renderUI({ list(p("The collapsed ", @@ -129,7 +129,7 @@ output$loginfo <- renderUI({ "the log is kept as 'actions.log.last"), p("See the ", em("logging"), "documentation for more information ", "on functions and other options") ) - }) +}) output$hover_info <- renderUI({ hover <- input$examplePlot2_hover @@ -142,21 +142,68 @@ output$hover_info <- renderUI({ else { left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) - + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) - + style <- paste0("position:absolute;", "z-index:100;", "background-color: rgba(245, 245, 245, 0.85); ", "left:", left_px + 2, "px; top:", top_px + 2, "px;") - + return(wellPanel(class = "well-sm", style = style, HTML(" Car: ", rownames(point))) ) } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -167,33 +214,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2ggplot, - csv = plot2ggplot_data), - aspectratio = 1.5, - visibleplot = plot2ggplot) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3lattice, - tiff = plot3lattice, - txt = plot3lattice_data, - tsv = plot3lattice_data), - visibleplot = plot3lattice) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2ggplot, + csv = plot2ggplot_data), + aspectratio = 1.5, + visibleplot = plot2ggplot) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3lattice, + tiff = plot3lattice, + txt = plot3lattice_data, + tsv = plot3lattice_data), + visibleplot = plot3lattice) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -210,7 +298,7 @@ observeEvent(input$exampleAdvancedAlert, { createAlert(session, "sidebarAdvancedAlert", style = "warning", content = "Example Advanced Sidebar Alert") - + }) observeEvent(input$exampleBodyAlert, { @@ -226,3 +314,78 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list(periscope:::fw_create_body(), + init_js_command()) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + init_js_command()) + }) +}) + +init_js_command <- function() { + list(shiny::tags$script("setTimeout(function() {$('div.navbar-custom-menu').click()}, 1000);"), + shiny::tags$script("$('div.navbar-custom-menu').click();"), + shiny::tags$script("$('#examplePlot2-dplotButtonDiv').css('display', 'inherit')"), + shiny::tags$script("$('#examplePlot3-dplotButtonDiv').css('display', 'inherit')")) +} diff --git a/inst/fw_templ/p_example/server_local_no_left.R b/inst/fw_templ/p_example/server_local_no_left.R index ed5d67c..b75b4d2 100755 --- a/inst/fw_templ/p_example/server_local_no_left.R +++ b/inst/fw_templ/p_example/server_local_no_left.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -54,7 +54,7 @@ output$proginfo <- renderUI({ "application-wide functionality is useful across all users that ", "should be added into server_global.R. Scoping information is in ", "the top comment of all program example files.") ) - }) +}) output$tooltips <- renderUI({ list(hr(), @@ -63,7 +63,7 @@ output$tooltips <- renderUI({ text = "Example tooltip text"), "can be added with the following code in the UI:"), p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) - }) +}) output$busyind <- renderUI({ list(hr(), @@ -73,7 +73,7 @@ output$busyind <- renderUI({ bsButton("showWorking", label = "Show application busy indicator for 5 seconds", style = "primary")) ) - }) +}) output$download <- renderUI({ list( @@ -83,13 +83,13 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", downloadFileButton("exampleDownload2", c("csv", "xlsx", "tsv"), "Download options")) ) - }) +}) output$alerts <- renderUI({ list(hr(), @@ -103,7 +103,7 @@ output$alerts <- renderUI({ label = "Body", style = "info", width = "25%")) ) - }) +}) output$loginfo <- renderUI({ list(p("The collapsed ", @@ -120,7 +120,7 @@ output$loginfo <- renderUI({ "the log is kept as 'actions.log.last"), p("See the ", em("logging"), "documentation for more information ", "on functions and other options") ) - }) +}) output$hover_info <- renderUI({ hover <- input$examplePlot2_hover @@ -133,21 +133,69 @@ output$hover_info <- renderUI({ else { left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) - + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) - + style <- paste0("position:absolute;", "z-index:100;", "background-color: rgba(245, 245, 245, 0.85); ", "left:", left_px + 2, "px; top:", top_px + 2, "px;") - + return(wellPanel(class = "well-sm", style = style, HTML(" Car: ", rownames(point))) ) } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) + # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -158,33 +206,75 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2ggplot, - csv = plot2ggplot_data), - aspectratio = 1.5, - visibleplot = plot2ggplot) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3lattice, - tiff = plot3lattice, - txt = plot3lattice_data, - tsv = plot3lattice_data), - visibleplot = plot3lattice) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) + +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2ggplot, + csv = plot2ggplot_data), + aspectratio = 1.5, + visibleplot = plot2ggplot) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3lattice, + tiff = plot3lattice, + txt = plot3lattice_data, + tsv = plot3lattice_data), + visibleplot = plot3lattice) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -201,7 +291,6 @@ observeEvent(input$exampleAdvancedAlert, { createAlert(session, "sidebarAdvancedAlert", style = "warning", content = "Example Advanced Sidebar Alert") - }) observeEvent(input$exampleBodyAlert, { @@ -217,3 +306,78 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list(periscope:::fw_create_body(), + init_js_command()) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + init_js_command()) + }) +}) + +init_js_command <- function() { + list(shiny::tags$script("setTimeout(function() {$('div.navbar-custom-menu').click()}, 1000);"), + shiny::tags$script("$('div.navbar-custom-menu').click();"), + shiny::tags$script("$('#examplePlot2-dplotButtonDiv').css('display', 'inherit')"), + shiny::tags$script("$('#examplePlot3-dplotButtonDiv').css('display', 'inherit')")) +} diff --git a/inst/fw_templ/p_example/server_local_plus.R b/inst/fw_templ/p_example/server_local_plus.R index 963d96d..2f422ce 100755 --- a/inst/fw_templ/p_example/server_local_plus.R +++ b/inst/fw_templ/p_example/server_local_plus.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -85,7 +85,7 @@ output$proginfo <- renderUI({ "application-wide functionality is useful across all users that ", "should be added into server_global.R. Scoping information is in ", "the top comment of all program example files.") ) - }) +}) output$tooltips <- renderUI({ list(hr(), @@ -94,7 +94,7 @@ output$tooltips <- renderUI({ text = "Example tooltip text"), "can be added with the following code in the UI:"), p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) - }) +}) output$busyind <- renderUI({ list(hr(), @@ -104,7 +104,7 @@ output$busyind <- renderUI({ bsButton("showWorking", label = "Show application busy indicator for 5 seconds", style = "primary")) ) - }) +}) output$download <- renderUI({ list( @@ -114,13 +114,13 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", downloadFileButton("exampleDownload2", c("csv", "xlsx", "tsv"), "Download options")) ) - }) +}) output$alerts <- renderUI({ list(hr(), @@ -147,7 +147,7 @@ output$alerts <- renderUI({ label = "Sidebar - Right", style = "danger", width = "20%") ) ) - }) +}) output$loginfo <- renderUI({ list(p("The collapsed ", @@ -164,7 +164,7 @@ output$loginfo <- renderUI({ "the log is kept as 'actions.log.last"), p("See the ", em("logging"), "documentation for more information ", "on functions and other options") ) - }) +}) output$hover_info <- renderUI({ hover <- input$examplePlot2_hover @@ -177,21 +177,68 @@ output$hover_info <- renderUI({ else { left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) - + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) - + style <- paste0("position:absolute;", "z-index:100;", "background-color: rgba(245, 245, 245, 0.85); ", "left:", left_px + 2, "px; top:", top_px + 2, "px;") - + return(wellPanel(class = "well-sm", style = style, HTML(" Car: ", rownames(point))) ) } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -206,33 +253,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2, - csv = plot2_data), - aspectratio = 1.5, - visibleplot = plot2) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3, - tiff = plot3, - txt = plot3_data, - tsv = plot3_data), - visibleplot = plot3) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2, + csv = plot2_data), + aspectratio = 1.5, + visibleplot = plot2) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3, + tiff = plot3, + txt = plot3_data, + tsv = plot3_data), + visibleplot = plot3) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -249,7 +337,6 @@ observeEvent(input$exampleAdvancedAlert, { createAlert(session, "sidebarAdvancedAlert", style = "warning", content = "Example Advanced Sidebar Alert") - }) observeEvent(input$exampleRightAlert, { @@ -274,3 +361,78 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list(periscope:::fw_create_body(), + init_js_command()) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + init_js_command()) + }) +}) + +init_js_command <- function() { + list(shiny::tags$script("setTimeout(function() {$('div.navbar-custom-menu').click()}, 1000);"), + shiny::tags$script("$('div.navbar-custom-menu').click();"), + shiny::tags$script("$('#examplePlot2-dplotButtonDiv').css('display', 'inherit')"), + shiny::tags$script("$('#examplePlot3-dplotButtonDiv').css('display', 'inherit')")) +} diff --git a/inst/fw_templ/p_example/server_local_plus_no_left.R b/inst/fw_templ/p_example/server_local_plus_no_left.R index 6dc6840..f2088bf 100755 --- a/inst/fw_templ/p_example/server_local_plus_no_left.R +++ b/inst/fw_templ/p_example/server_local_plus_no_left.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -85,7 +85,7 @@ output$proginfo <- renderUI({ "application-wide functionality is useful across all users that ", "should be added into server_global.R. Scoping information is in ", "the top comment of all program example files.") ) - }) +}) output$tooltips <- renderUI({ list(hr(), @@ -94,7 +94,7 @@ output$tooltips <- renderUI({ text = "Example tooltip text"), "can be added with the following code in the UI:"), p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) - }) +}) output$busyind <- renderUI({ list(hr(), @@ -104,7 +104,7 @@ output$busyind <- renderUI({ bsButton("showWorking", label = "Show application busy indicator for 5 seconds", style = "primary")) ) - }) +}) output$download <- renderUI({ list( @@ -114,13 +114,13 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", downloadFileButton("exampleDownload2", c("csv", "xlsx", "tsv"), "Download options")) ) - }) +}) output$alerts <- renderUI({ list(hr(), @@ -155,7 +155,7 @@ output$loginfo <- renderUI({ "the log is kept as 'actions.log.last"), p("See the ", em("logging"), "documentation for more information ", "on functions and other options") ) - }) +}) output$hover_info <- renderUI({ hover <- input$examplePlot2_hover @@ -168,21 +168,68 @@ output$hover_info <- renderUI({ else { left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) - + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) - + style <- paste0("position:absolute;", "z-index:100;", "background-color: rgba(245, 245, 245, 0.85); ", "left:", left_px + 2, "px; top:", top_px + 2, "px;") - + return(wellPanel(class = "well-sm", style = style, HTML(" Car: ", rownames(point))) ) } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -197,33 +244,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2, - csv = plot2_data), - aspectratio = 1.5, - visibleplot = plot2) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3, - tiff = plot3, - txt = plot3_data, - tsv = plot3_data), - visibleplot = plot3) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) + )) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2, + csv = plot2_data), + aspectratio = 1.5, + visibleplot = plot2) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3, + tiff = plot3, + txt = plot3_data, + tsv = plot3_data), + visibleplot = plot3) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -240,7 +328,6 @@ observeEvent(input$exampleAdvancedAlert, { createAlert(session, "sidebarAdvancedAlert", style = "warning", content = "Example Advanced Sidebar Alert") - }) observeEvent(input$exampleRightAlert, { @@ -265,3 +352,78 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list(periscope:::fw_create_body(), + init_js_command()) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + init_js_command()) + }) +}) + +init_js_command <- function() { + list(shiny::tags$script("setTimeout(function() {$('div.navbar-custom-menu').click()}, 1000);"), + shiny::tags$script("$('div.navbar-custom-menu').click();"), + shiny::tags$script("$('#examplePlot2-dplotButtonDiv').css('display', 'inherit')"), + shiny::tags$script("$('#examplePlot3-dplotButtonDiv').css('display', 'inherit')")) +} diff --git a/inst/fw_templ/p_example/ui_body.R b/inst/fw_templ/p_example/ui_body.R index 8a15e22..6f13fc1 100755 --- a/inst/fw_templ/p_example/ui_body.R +++ b/inst/fw_templ/p_example/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/inst/fw_templ/www/periscope_style.yaml b/inst/fw_templ/www/periscope_style.yaml new file mode 100644 index 0000000..03ab446 --- /dev/null +++ b/inst/fw_templ/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: "#4F718F" + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: "#A0B89E" + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: "#EDECE8" + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: "#DAE0D9" + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/man/create_new_application.Rd b/man/create_new_application.Rd index 042b202..3a66101 100644 --- a/man/create_new_application.Rd +++ b/man/create_new_application.Rd @@ -11,7 +11,7 @@ create_new_application( resetbutton = TRUE, rightsidebar = FALSE, leftsidebar = TRUE, - style = list(skin = "blue") + custom_theme_file = NULL ) } \arguments{ @@ -28,7 +28,7 @@ containing the name of a shiny::icon().} \item{leftsidebar}{whether the left sidebar should be enabled.} -\item{style}{list containing application styling properties. By default the skin is blue.} +\item{custom_theme_file}{location of custom theme settings yaml file. Default value is NULL.} } \description{ Creates ready-to-use templated application files using the periscope @@ -101,6 +101,10 @@ Use this location for code that would have previously resided in server.R inside of the call to \code{shinyServer(...)}. Anything placed in this file will be accessible only within a single user session.\cr \cr +\strong{\emph{name}/www/periscope_style.yaml} :\cr +This is the application custom styling yaml file. User can update +application different parts style using this file.\cr +\cr \cr \strong{Do not modify the following files}: \cr \preformatted{ @@ -133,7 +137,7 @@ rightsidebar = "table") # blank app named 'myblankapp' created in a temp dir create_new_application(name = 'myblankapp', location = tempdir()) # blank app named 'myblankapp' with a green skin created in a temp dir -create_new_application(name = 'myblankapp', location = tempdir(), style = list(skin = "green")) +create_new_application(name = 'myblankapp', location = tempdir()) # blank app named 'myblankapp' without a left sidebar created in a temp dir create_new_application(name = 'myblankapp', location = tempdir(), leftsidebar = FALSE) diff --git a/man/downloadFile.Rd b/man/downloadFile.Rd index 3517e71..1b8c6d6 100644 --- a/man/downloadFile.Rd +++ b/man/downloadFile.Rd @@ -4,23 +4,11 @@ \alias{downloadFile} \title{downloadFile Module} \usage{ -downloadFile( - input, - output, - session, - logger, - filenameroot, - datafxns = list(), - aspectratio = 1 -) +downloadFile(..., logger, filenameroot, datafxns = list(), aspectratio = 1) } \arguments{ -\item{input}{provided by \code{shiny::callModule}} - -\item{output}{provided by \code{shiny::callModule}} - -\item{session}{provided by \code{shiny::callModule} -\cr \cr} +\item{...}{free parameters list for shiny to pass session variables based on the module call(session, input, output) +variables. \emph{Note}: The first argument of this function must be the ID of the Module's UI element} \item{logger}{logger to use} @@ -46,27 +34,25 @@ download types. The server function is used to provide the data for download. This function is not called directly by consumers - it is accessed in server.R using the same id provided in \code{downloadFileButton}: -\strong{\code{callModule(downloadFile, id, logger, filenameroot, datafxns)}} +\strong{\code{downloadFile(id, logger, filenameroot, datafxns)}} } \examples{ # Inside server_local.R #single download type -# callModule(downloadFile, -# "object_id1", -# logger = ss_userAction.Log, -# filenameroot = "mydownload1", -# datafxns = list(csv = mydatafxn1), -# aspectratio = 1) +# downloadFile("object_id1", +# logger = ss_userAction.Log, +# filenameroot = "mydownload1", +# datafxns = list(csv = mydatafxn1), +# aspectratio = 1) #multiple download types -# callModule(downloadFile, -# "object_id2", -# logger = ss_userAction.Log, -# filenameroot = "mytype2", -# datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), -# aspectratio = 1) +# downloadFile("object_id2", +# logger = ss_userAction.Log, +# filenameroot = "mytype2", +# datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), +# aspectratio = 1) } \seealso{ @@ -75,6 +61,4 @@ server.R using the same id provided in \code{downloadFileButton}: \link[periscope]{downloadFile_ValidateTypes} \link[periscope]{downloadFile_AvailableTypes} - -\link[shiny]{callModule} } diff --git a/man/downloadFileButton.Rd b/man/downloadFileButton.Rd index eeffd92..a7be35d 100644 --- a/man/downloadFileButton.Rd +++ b/man/downloadFileButton.Rd @@ -38,7 +38,7 @@ for the button. Call this function at the place in ui.R where the button should be placed. -It is paired with a call to \code{shiny::callModule(downloadFile, id, ...)} +It is paired with a call to \code{downloadFile(id, ...)} in server.R } diff --git a/man/downloadablePlot.Rd b/man/downloadablePlot.Rd index f8525e7..46b7f41 100644 --- a/man/downloadablePlot.Rd +++ b/man/downloadablePlot.Rd @@ -5,9 +5,7 @@ \title{downloadablePlot Module} \usage{ downloadablePlot( - input, - output, - session, + ..., logger, filenameroot, aspectratio = 1, @@ -16,12 +14,8 @@ downloadablePlot( ) } \arguments{ -\item{input}{provided by \code{shiny::callModule}} - -\item{output}{provided by \code{shiny::callModule}} - -\item{session}{provided by \code{shiny::callModule} -\cr \cr} +\item{...}{free parameters list for shiny to pass session variables based on the module call(session, input, output) +variables. \emph{Note}: The first argument of this function must be the ID of the Module's UI element} \item{logger}{logger to use} @@ -55,24 +49,21 @@ button will be hidden as there is nothing to download. This function is not called directly by consumers - it is accessed in server.R using the same id provided in \code{downloadablePlotUI}: -\strong{\code{callModule(downloadablePlot, id, logger, filenameroot, +\strong{\code{downloadablePlot(id, logger, filenameroot, downloadfxns, visibleplot)}} } \examples{ # Inside server_local.R -# callModule(downloadablePlot, -# "object_id1", -# logger = ss_userAction.Log, -# filenameroot = "mydownload1", -# aspectratio = 1.33, -# downloadfxns = list(png = myplotfxn, tsv = mydatafxn), -# visibleplot = myplotfxn) +# downloadablePlot("object_id1", +# logger = ss_userAction.Log, +# filenameroot = "mydownload1", +# aspectratio = 1.33, +# downloadfxns = list(png = myplotfxn, tsv = mydatafxn), +# visibleplot = myplotfxn) } \seealso{ \link[periscope]{downloadablePlotUI} - -\link[shiny]{callModule} } diff --git a/man/downloadablePlotUI.Rd b/man/downloadablePlotUI.Rd index b8effec..58bf661 100644 --- a/man/downloadablePlotUI.Rd +++ b/man/downloadablePlotUI.Rd @@ -58,9 +58,7 @@ produced graphics. \section{Notes}{ When there is nothing to download in any of the linked downloadfxns the -button will be hidden as there is nothing to download. The linked -downloadfxns are set in the paired callModule (see the \strong{Shiny Usage} -section) +button will be hidden as there is nothing to download. This module is NOT compatible with the built-in (base) graphics \emph{(such as basic plot, etc.)} because they cannot be saved into an object and are directly @@ -71,7 +69,7 @@ output by the system at the time of creation. Call this function at the place in ui.R where the plot should be placed. -Paired with a call to \code{shiny::callModule(downloadablePlot, id, ...)} +Paired with a call to \code{downloadablePlot(id, ...)} in server.R } diff --git a/man/downloadableTable.Rd b/man/downloadableTable.Rd index 2b3e406..84b94ec 100644 --- a/man/downloadableTable.Rd +++ b/man/downloadableTable.Rd @@ -5,25 +5,17 @@ \title{downloadableTable Module} \usage{ downloadableTable( - input, - output, - session, + ..., logger, filenameroot, downloaddatafxns = list(), tabledata, - rownames = TRUE, - caption = NULL, selection = NULL ) } \arguments{ -\item{input}{provided by \code{shiny::callModule}} - -\item{output}{provided by \code{shiny::callModule}} - -\item{session}{provided by \code{shiny::callModule} -\cr \cr} +\item{...}{free parameters list to pass table customization options. See example below. +\emph{Note}: The first argument of this function must be the ID of the Module's UI element} \item{logger}{logger to use} @@ -38,12 +30,8 @@ when the table UI was created.} \item{tabledata}{function or reactive expression providing the table display data as a return value. This function should require no input parameters.} -\item{rownames}{whether or not to show the rownames in the table} - -\item{caption}{table caption} - \item{selection}{function or reactive expression providing the row_ids of the -rows that should be selected.} +rows that should be selected} } \value{ Reactive expression containing the currently selected rows in the @@ -54,10 +42,28 @@ Server-side function for the downloadableTableUI. This is a custom high-functionality table paired with a linked downloadFile button. } +\details{ +Generated table can highly customized using function \code{?DT::datatable} same arguments + except for `options` and `selection` parameters. + +For `options` user can pass the same \code{?DT::datatable} options using the same names and +values one by one separated by comma. + +For `selection` parameter it can be either a function or reactive expression providing the row_ids of the +rows that should be selected. + +Also, user can apply the same provided \code{?DT::formatCurrency} columns formats on passed +dataset using format functions names as keys and their options as a list. +} \section{Notes}{ -When there are no rows to download in any of the linked downloaddatafxns the -button will be hidden as there is nothing to download. + \itemize{ + \item When there are no rows to download in any of the linked downloaddatafxns + the button will be hidden as there is nothing to download. + \item \code{selection} parameter has different usage than DT::datatable \code{selection} option. + See parameters usage section. + \item DT::datatable options \code{editable}, \code{width} and \code{height} are not supported +} } \section{Shiny Usage}{ @@ -65,31 +71,41 @@ button will be hidden as there is nothing to download. This function is not called directly by consumers - it is accessed in server.R using the same id provided in \code{downloadableTableUI}: -\strong{\code{callModule(downloadableTable, id, logger, filenameroot, +\strong{\code{downloadableTable(id, logger, filenameroot, downloaddatafxns, tabledata, rownames, caption, selection)}} -\emph{Note}: callModule returns the reactive expression containing the +\emph{Note}: calling module server returns the reactive expression containing the currently selected rows in the display table. } \examples{ # Inside server_local.R -# selectedrows <- callModule(downloadableTable, -# "object_id1", -# logger = ss_userAction.Log, -# filenameroot = "mydownload1", -# downloaddatafxns = list(csv = mydatafxn1, tsv = mydatafxn2), -# tabledata = mydatafxn3, -# rownames = FALSE, -# caption = "This is a great table! By: Me", -# selection = mydataRowIds) +# selectedrows <- downloadableTable( +# "object_id1", +# logger = ss_userAction.Log, +# filenameroot = "mydownload1", +# downloaddatafxns = list(csv = mydatafxn1, tsv = mydatafxn2), +# tabledata = mydatafxn3, +# rownames = FALSE, +# caption = "This is a great table! By: Me", +# selection = mydataRowIds, +# colnames = c("Area", "Delta", "Increase"), +# filter = "bottom", +# width = "150px", +# height = "50px", +# extensions = 'Buttons', +# plugins = 'natural', +# editable = TRUE, +# dom = 'Bfrtip', +# buttons = c('copy', 'csv', 'excel', 'pdf', 'print'), +# formatStyle = list(columns = c('Area'), color = 'red'), +# formatStyle = list(columns = c('Increase'), color = DT::styleInterval(0, c('red', 'green'))), +# formatCurrency = list(columns = c('Delta'))) # selectedrows is the reactive return value, captured for later use } \seealso{ \link[periscope]{downloadableTableUI} - -\link[shiny]{callModule} } diff --git a/man/downloadableTableUI.Rd b/man/downloadableTableUI.Rd index b0443ba..c0a1f37 100644 --- a/man/downloadableTableUI.Rd +++ b/man/downloadableTableUI.Rd @@ -52,16 +52,14 @@ sorting by columns and returns a reactive dataset of selected items. \section{Notes}{ When there are no rows to download in any of the linked downloaddatafxns the -button will be hidden as there is nothing to download. The linked -downloaddatafxns are set in the paired callModule (see the \strong{Shiny Usage} -section) +button will be hidden as there is nothing to download. } \section{Shiny Usage}{ Call this function at the place in ui.R where the table should be placed. -Paired with a call to \code{shiny::callModule(downloadableTable, id, ...)} +Paired with a call to \code{downloadableTable(id, ...)} in server.R } diff --git a/tests/testthat/_snaps/downloadable_table.md b/tests/testthat/_snaps/downloadable_table.md index 61468e7..fb28b22 100644 --- a/tests/testthat/_snaps/downloadable_table.md +++ b/tests/testthat/_snaps/downloadable_table.md @@ -20,3 +20,84 @@ +# build_datatable_arguments + + Code + build_datatable_arguments(table_options) + Message + DT option 'width' is not supported. Ignoring it. + DT option 'height' is not supported. Ignoring it. + DT option 'editable' is not supported. Ignoring it. + Output + $rownames + [1] FALSE + + $class + [1] "periscope-downloadable-table table-condensed table-striped table-responsive" + + $callback + [1] "table.order([2, 'asc']).draw();" + + $caption + [1] " Very Important Information" + + $colnames + [1] "Area" "Delta" "Increase" + + $filter + [1] "bottom" + + $extensions + [1] "Buttons" + + $plugins + [1] "natural" + + $options + $options$order + $options$order[[1]] + $options$order[[1]][[1]] + [1] 2 + + $options$order[[1]][[2]] + [1] "asc" + + + $options$order[[2]] + $options$order[[2]][[1]] + [1] 3 + + $options$order[[2]][[2]] + [1] "desc" + + + + $options$deferRender + [1] FALSE + + $options$paging + [1] FALSE + + $options$scrollX + [1] TRUE + + $options$dom + [1] "<\"periscope-downloadable-table-header\"f>tr" + + $options$processing + [1] TRUE + + $options$rowId + [1] 1 + + $options$searchHighlight + [1] TRUE + + + +# format_columns + + Code + format_columns(DT::datatable(dt), list(formatCurrency = list(columns = c("A", + "C")), formatPercentage = list(columns = c("D"), 2))) + diff --git a/tests/testthat/_snaps/ui_functions.md b/tests/testthat/_snaps/ui_functions.md new file mode 100644 index 0000000..6843671 --- /dev/null +++ b/tests/testthat/_snaps/ui_functions.md @@ -0,0 +1,195 @@ +# fw_create_header + +
+ + +
+ +# fw_create_sidebar no sidebar + + + +# fw_create_sidebar empty + + + +# fw_create_sidebar only basic + + + +# fw_create_sidebar only advanced + + + +# fw_create_body app_info + +
+
+ + + +
+
+
+

User Action Log

+
+ +
+
+
+
+
+
+
+
+
+ +# fw_create_body no log + +
+
+ + +
+
+ +# ui_tooltip + + + mylabel + + + + +# fw_create_header_plus + +
+ + +
+ +# fw_create_right_sidebar + + +
+ +# fw_create_right_sidebar SDP>=2 + + +
+ diff --git a/tests/testthat/sample_app/program/data/.gitignore b/tests/testthat/sample_app/program/data/.gitignore index 0a4bafe..94548af 100644 --- a/tests/testthat/sample_app/program/data/.gitignore +++ b/tests/testthat/sample_app/program/data/.gitignore @@ -1,4 +1,3 @@ * */ !.gitignore -!example.csv diff --git a/tests/testthat/sample_app/program/fxn/program_helpers.R b/tests/testthat/sample_app/program/fxn/program_helpers.R index 209068e..2140772 100644 --- a/tests/testthat/sample_app/program/fxn/program_helpers.R +++ b/tests/testthat/sample_app/program/fxn/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/tests/testthat/sample_app/program/server_local.R b/tests/testthat/sample_app/program/server_local.R index d4fd8e0..4d2c34e 100644 --- a/tests/testthat/sample_app/program/server_local.R +++ b/tests/testthat/sample_app/program/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -83,7 +83,7 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", @@ -157,6 +157,53 @@ output$hover_info <- renderUI({ } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -167,33 +214,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2ggplot, - csv = plot2ggplot_data), - aspectratio = 1.5, - visibleplot = plot2ggplot) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3lattice, - tiff = plot3lattice, - txt = plot3lattice_data, - tsv = plot3lattice_data), - visibleplot = plot3lattice) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2ggplot, + csv = plot2ggplot_data), + aspectratio = 1.5, + visibleplot = plot2ggplot) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3lattice, + tiff = plot3lattice, + txt = plot3lattice_data, + tsv = plot3lattice_data), + visibleplot = plot3lattice) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -226,3 +314,75 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list( + periscope:::fw_create_body(), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();")) + ) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();"))) + }) +}) diff --git a/tests/testthat/sample_app/program/ui_body.R b/tests/testthat/sample_app/program/ui_body.R index 8a15e22..6f13fc1 100644 --- a/tests/testthat/sample_app/program/ui_body.R +++ b/tests/testthat/sample_app/program/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/tests/testthat/sample_app/ui.R b/tests/testthat/sample_app/ui.R index 3864fcd..207ed89 100644 --- a/tests/testthat/sample_app/ui.R +++ b/tests/testthat/sample_app/ui.R @@ -19,4 +19,4 @@ source(paste("program", "ui_body.R", sep = .Platform$file.sep), dashboardPage(periscope:::fw_create_header(), periscope:::fw_create_sidebar(), - periscope:::fw_create_body()) + uiOutput('body')) diff --git a/tests/testthat/sample_app/www/periscope_style.yaml b/tests/testthat/sample_app/www/periscope_style.yaml new file mode 100644 index 0000000..334f142 --- /dev/null +++ b/tests/testthat/sample_app/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: "#31A5CC" + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: "#00FF00" + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: "#C7DFE8" + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: "#FDFFF5" + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/tests/testthat/sample_app_both_sidebar/program/data/.gitignore b/tests/testthat/sample_app_both_sidebar/program/data/.gitignore index 0a4bafe..94548af 100644 --- a/tests/testthat/sample_app_both_sidebar/program/data/.gitignore +++ b/tests/testthat/sample_app_both_sidebar/program/data/.gitignore @@ -1,4 +1,3 @@ * */ !.gitignore -!example.csv diff --git a/tests/testthat/sample_app_both_sidebar/program/fxn/program_helpers.R b/tests/testthat/sample_app_both_sidebar/program/fxn/program_helpers.R index 209068e..2140772 100644 --- a/tests/testthat/sample_app_both_sidebar/program/fxn/program_helpers.R +++ b/tests/testthat/sample_app_both_sidebar/program/fxn/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/tests/testthat/sample_app_both_sidebar/program/server_local.R b/tests/testthat/sample_app_both_sidebar/program/server_local.R index 2354393..514b773 100644 --- a/tests/testthat/sample_app_both_sidebar/program/server_local.R +++ b/tests/testthat/sample_app_both_sidebar/program/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -114,7 +114,7 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", @@ -135,18 +135,18 @@ output$alerts <- renderUI({ label = "Sidebar - Basic", style = "success", width = "20%"), - bsButton( "exampleAdvancedAlert", - label = "Sidebar - Advanced", - style = "warning", - width = "20%"), bsButton( "exampleBodyAlert", label = "Body", style = "info", width = "20%"), + bsButton( "exampleAdvancedAlert", + label = "Sidebar - Advanced", + style = "warning", + width = "20%"), bsButton( "exampleRightAlert", label = "Sidebar - Right", style = "danger", - width = "20%")) ) + width = "20%") ) ) }) output$loginfo <- renderUI({ @@ -192,6 +192,53 @@ output$hover_info <- renderUI({ } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -206,33 +253,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2, - csv = plot2_data), - aspectratio = 1.5, - visibleplot = plot2) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3, - tiff = plot3, - txt = plot3_data, - tsv = plot3_data), - visibleplot = plot3) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2, + csv = plot2_data), + aspectratio = 1.5, + visibleplot = plot2) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3, + tiff = plot3, + txt = plot3_data, + tsv = plot3_data), + visibleplot = plot3) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -274,3 +362,75 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list( + periscope:::fw_create_body(), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();")) + ) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();"))) + }) +}) diff --git a/tests/testthat/sample_app_both_sidebar/program/ui_body.R b/tests/testthat/sample_app_both_sidebar/program/ui_body.R index 8a15e22..6f13fc1 100644 --- a/tests/testthat/sample_app_both_sidebar/program/ui_body.R +++ b/tests/testthat/sample_app_both_sidebar/program/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/tests/testthat/sample_app_both_sidebar/program/ui_sidebar_right.R b/tests/testthat/sample_app_both_sidebar/program/ui_sidebar_right.R index 6742ad0..e804c40 100644 --- a/tests/testthat/sample_app_both_sidebar/program/ui_sidebar_right.R +++ b/tests/testthat/sample_app_both_sidebar/program/ui_sidebar_right.R @@ -23,23 +23,50 @@ # -- Create Elements -tab1 <- rightSidebarTabContent( - id = 1, - icon = "desktop", - title = "Tab 1 - Plots", - active = TRUE, - checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), - checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), - checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE)) - -tab2 <- rightSidebarTabContent( - id = 2, - title = "Tab 2 - Datatable") - -tab3 <- rightSidebarTabContent( - id = 3, - title = "Tab 3 - Other", - icon = "paint-brush") +if (utils::packageVersion('shinydashboardPlus') < 2) { + tab1 <- rightSidebarTabContent( + id = 1, + icon = "desktop", + title = "Tab 1 - Plots", + active = TRUE, + checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), + checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), + checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE)) + + tab2 <- rightSidebarTabContent( + id = 2, + title = "Tab 2 - Datatable") + + tab3 <- rightSidebarTabContent( + id = 3, + title = "Tab 3 - Other", + icon = "paint-brush") + + plus_fxn <- list(tab1, tab2, tab3) +} else { + tab1 <- controlbarItem( + id = 1, + title = icon("desktop"), + "Tab 1 - Plots", + checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), + checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), + checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE) + ) + + tab2 <- controlbarItem( + id = 2, + title = icon("database"), + "Tab 2 - Datatable", + ) + + tab3 <- controlbarItem( + id = 3, + title = icon("paint-brush"), + "Tab 3 - Other", + ) + + plus_fxn <- controlbarMenu(tab1, tab2, tab3) +} # -- Register Basic Elements in the ORDER SHOWN in the UI -add_ui_sidebar_right(list(tab1, tab2, tab3)) +add_ui_sidebar_right(plus_fxn) diff --git a/tests/testthat/sample_app_both_sidebar/ui.R b/tests/testthat/sample_app_both_sidebar/ui.R index c5227de..af8ae0e 100644 --- a/tests/testthat/sample_app_both_sidebar/ui.R +++ b/tests/testthat/sample_app_both_sidebar/ui.R @@ -19,8 +19,16 @@ source(paste("program", "ui_body.R", sep = .Platform$file.sep), local = TRUE) -dashboardPagePlus(periscope:::fw_create_header_plus(), - periscope:::fw_create_sidebar(), - periscope:::fw_create_body(), - periscope:::fw_create_right_sidebar(), - sidebar_fullCollapse = TRUE) +addl_opts <- list() +if (utils::packageVersion('shinydashboardPlus') < 2) { + plus_fxn <- getExportedValue("shinydashboardPlus", "dashboardPagePlus") + addl_opts <- list(sidebar_fullCollapse = TRUE) +} else { + plus_fxn <- getExportedValue("shinydashboardPlus", "dashboardPage") +} + +do.call(plus_fxn, c(list(periscope:::fw_create_header_plus(), + periscope:::fw_create_sidebar(), + uiOutput('body'), + periscope:::fw_create_right_sidebar()), + addl_opts)) diff --git a/tests/testthat/sample_app_both_sidebar/www/periscope_style.yaml b/tests/testthat/sample_app_both_sidebar/www/periscope_style.yaml new file mode 100644 index 0000000..334f142 --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: "#31A5CC" + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: "#00FF00" + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: "#C7DFE8" + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: "#FDFFF5" + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/tests/testthat/sample_app_no_sidebar/program/data/.gitignore b/tests/testthat/sample_app_no_sidebar/program/data/.gitignore index 0a4bafe..94548af 100644 --- a/tests/testthat/sample_app_no_sidebar/program/data/.gitignore +++ b/tests/testthat/sample_app_no_sidebar/program/data/.gitignore @@ -1,4 +1,3 @@ * */ !.gitignore -!example.csv diff --git a/tests/testthat/sample_app_no_sidebar/program/fxn/program_helpers.R b/tests/testthat/sample_app_no_sidebar/program/fxn/program_helpers.R index 209068e..2140772 100644 --- a/tests/testthat/sample_app_no_sidebar/program/fxn/program_helpers.R +++ b/tests/testthat/sample_app_no_sidebar/program/fxn/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/tests/testthat/sample_app_no_sidebar/program/server_local.R b/tests/testthat/sample_app_no_sidebar/program/server_local.R index 06920ce..0656ace 100644 --- a/tests/testthat/sample_app_no_sidebar/program/server_local.R +++ b/tests/testthat/sample_app_no_sidebar/program/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -83,7 +83,7 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", @@ -93,7 +93,7 @@ output$download <- renderUI({ output$alerts <- renderUI({ list(hr(), - p("There is one standardized location for alerts. To create ", + p("There is one standardized location for alerts in this app. To create ", "an alert call the following on the server: ", pre('S: createAlert(session, location, content = "Alert Text", ...)'), 'LOCATION can be: "bodyAlert", See the ', em("alertBS"), @@ -148,6 +148,54 @@ output$hover_info <- renderUI({ } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) + # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -158,33 +206,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2ggplot, - csv = plot2ggplot_data), - aspectratio = 1.5, - visibleplot = plot2ggplot) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3lattice, - tiff = plot3lattice, - txt = plot3lattice_data, - tsv = plot3lattice_data), - visibleplot = plot3lattice) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) + +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2ggplot, + csv = plot2ggplot_data), + aspectratio = 1.5, + visibleplot = plot2ggplot) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3lattice, + tiff = plot3lattice, + txt = plot3lattice_data, + tsv = plot3lattice_data), + visibleplot = plot3lattice) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -217,3 +306,75 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list( + periscope:::fw_create_body(), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();")) + ) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();"))) + }) +}) diff --git a/tests/testthat/sample_app_no_sidebar/program/ui_body.R b/tests/testthat/sample_app_no_sidebar/program/ui_body.R index 8a15e22..6f13fc1 100644 --- a/tests/testthat/sample_app_no_sidebar/program/ui_body.R +++ b/tests/testthat/sample_app_no_sidebar/program/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/tests/testthat/sample_app_no_sidebar/ui.R b/tests/testthat/sample_app_no_sidebar/ui.R index c0206da..6b96e75 100644 --- a/tests/testthat/sample_app_no_sidebar/ui.R +++ b/tests/testthat/sample_app_no_sidebar/ui.R @@ -17,4 +17,4 @@ source(paste("program", "ui_body.R", sep = .Platform$file.sep), dashboardPage(periscope:::fw_create_header(), periscope:::fw_create_sidebar(showsidebar = FALSE), - periscope:::fw_create_body()) + uiOutput('body')) diff --git a/tests/testthat/sample_app_no_sidebar/www/periscope_style.yaml b/tests/testthat/sample_app_no_sidebar/www/periscope_style.yaml new file mode 100644 index 0000000..334f142 --- /dev/null +++ b/tests/testthat/sample_app_no_sidebar/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: "#31A5CC" + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: "#00FF00" + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: "#C7DFE8" + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: "#FDFFF5" + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/data/.gitignore b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/data/.gitignore index 0a4bafe..94548af 100644 --- a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/data/.gitignore +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/data/.gitignore @@ -1,4 +1,3 @@ * */ !.gitignore -!example.csv diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/fxn/program_helpers.R b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/fxn/program_helpers.R index 209068e..2140772 100644 --- a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/fxn/program_helpers.R +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/fxn/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/server_local.R b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/server_local.R index 06920ce..0656ace 100644 --- a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/server_local.R +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -83,7 +83,7 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", @@ -93,7 +93,7 @@ output$download <- renderUI({ output$alerts <- renderUI({ list(hr(), - p("There is one standardized location for alerts. To create ", + p("There is one standardized location for alerts in this app. To create ", "an alert call the following on the server: ", pre('S: createAlert(session, location, content = "Alert Text", ...)'), 'LOCATION can be: "bodyAlert", See the ', em("alertBS"), @@ -148,6 +148,54 @@ output$hover_info <- renderUI({ } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) + # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -158,33 +206,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2ggplot, - csv = plot2ggplot_data), - aspectratio = 1.5, - visibleplot = plot2ggplot) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3lattice, - tiff = plot3lattice, - txt = plot3lattice_data, - tsv = plot3lattice_data), - visibleplot = plot3lattice) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) + +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2ggplot, + csv = plot2ggplot_data), + aspectratio = 1.5, + visibleplot = plot2ggplot) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3lattice, + tiff = plot3lattice, + txt = plot3lattice_data, + tsv = plot3lattice_data), + visibleplot = plot3lattice) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -217,3 +306,75 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list( + periscope:::fw_create_body(), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();")) + ) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();"))) + }) +}) diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/ui_body.R b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/ui_body.R index 8a15e22..6f13fc1 100644 --- a/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/ui_body.R +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/program/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/ui.R b/tests/testthat/sample_app_no_sidebar_no_resetbutton/ui.R index 4f070d1..6ccf32b 100644 --- a/tests/testthat/sample_app_no_sidebar_no_resetbutton/ui.R +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/ui.R @@ -17,4 +17,4 @@ source(paste("program", "ui_body.R", sep = .Platform$file.sep), dashboardPage(periscope:::fw_create_header(), periscope:::fw_create_sidebar(showsidebar = FALSE, resetbutton = FALSE), - periscope:::fw_create_body()) + uiOutput('body')) diff --git a/tests/testthat/sample_app_no_sidebar_no_resetbutton/www/periscope_style.yaml b/tests/testthat/sample_app_no_sidebar_no_resetbutton/www/periscope_style.yaml new file mode 100644 index 0000000..b17949b --- /dev/null +++ b/tests/testthat/sample_app_no_sidebar_no_resetbutton/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: '#CC316F' + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: '#2200FF' + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: '#C7DFE8' + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: '#FDFFF5' + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/tests/testthat/sample_app_r_sidebar/program/data/.gitignore b/tests/testthat/sample_app_r_sidebar/program/data/.gitignore index 0a4bafe..94548af 100644 --- a/tests/testthat/sample_app_r_sidebar/program/data/.gitignore +++ b/tests/testthat/sample_app_r_sidebar/program/data/.gitignore @@ -1,4 +1,3 @@ * */ !.gitignore -!example.csv diff --git a/tests/testthat/sample_app_r_sidebar/program/fxn/program_helpers.R b/tests/testthat/sample_app_r_sidebar/program/fxn/program_helpers.R index 209068e..2140772 100644 --- a/tests/testthat/sample_app_r_sidebar/program/fxn/program_helpers.R +++ b/tests/testthat/sample_app_r_sidebar/program/fxn/program_helpers.R @@ -23,7 +23,13 @@ load_data2 <- function() { load_data3 <- function() { ldf <- df %>% - select(1:3) - + select(1:3) %>% + mutate(Total.Population.Change = as.numeric(gsub(",", "", Total.Population.Change)), + Natural.Increase = as.numeric(gsub(",", "", Natural.Increase))) + as.data.frame(ldf) } + +read_themes <- function() { + yaml::read_yaml("www/periscope_style.yaml") +} diff --git a/tests/testthat/sample_app_r_sidebar/program/server_local.R b/tests/testthat/sample_app_r_sidebar/program/server_local.R index b88be81..e4a11d6 100644 --- a/tests/testthat/sample_app_r_sidebar/program/server_local.R +++ b/tests/testthat/sample_app_r_sidebar/program/server_local.R @@ -25,8 +25,8 @@ # -- IMPORTS -- - # -- VARIABLES -- +load_themes <- reactiveValues(themes = NULL) # -- FUNCTIONS -- @@ -114,7 +114,7 @@ output$download <- renderUI({ "extensions and corresponding data functions with the ", "following code:"), p(pre("U: downloadFileButton('uiID', list(extensions))"), - pre("S: callModule(downloadFile, 'uiID', logger, 'filenameroot', list(datafxns)"), + pre("S: downloadFile('uiID', logger, 'filenameroot', list(datafxns)"), "Single Download: ", downloadFileButton("exampleDownload1", c("csv"), "csv"), "Multiple-choice Download: ", @@ -124,15 +124,19 @@ output$download <- renderUI({ output$alerts <- renderUI({ list(hr(), - p("There is one standardized location for alerts. To create ", + p("There are two standardized locations for alerts in this app. To create ", "an alert call the following on the server: ", pre('S: createAlert(session, location, content = "Alert Text", ...)'), - 'LOCATION can be: "bodyAlert", See the ', em("alertBS"), + 'LOCATION can be: "bodyAlert" and "sidebarRightAlert", See the ', em("alertBS"), "documentation for more information on styles and other options"), div(align = "center", bsButton( "exampleBodyAlert", label = "Body", style = "info", + width = "25%"), + bsButton( "exampleRightAlert", + label = "Sidebar - Right", + style = "danger", width = "25%")) ) }) @@ -179,6 +183,53 @@ output$hover_info <- renderUI({ } }) +output$styles <- renderUI({ + load_themes$themes <- read_themes() + list(p("User can control primary aspects of the application's styles by modifying the www/periscope_style.yaml file.\n This interactive example can be used to explore those parameters."), + p("Color values can be specified as:", + tags$ul(tags$li("Hex Value:", HTML(" "), tags$b(tags$i("i.e. '#31A5CC'"))), + tags$li("RGB Value:", HTML(" "), tags$b(tags$i("i.e. 'rgb(49, 165, 204)'"))), + tags$li("Color Name:", HTML(" "), tags$b(tags$i("i.e. 'green', 'red', ..."))))), + fluidRow( + column(width = 6, + colourpicker::colourInput("primary_color", + ui_tooltip("primary_tip", + "Primary Color", + "Sets the primary status color that affects the color of the header, valueBox, infoBox and box."), + load_themes$themes[["primary_color"]])), + column(width = 6, + numericInput("sidebar_width", + ui_tooltip("sidebar_width_tip", + "Sidebar Width", + "Change the default sidebar width"), + load_themes$themes[["sidebar_width"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("sidebar_background_color", + ui_tooltip("sidebar_background_color_tip", + "Sidebar Background Color", + "Change the default sidebar background color"), + load_themes$themes[["sidebar_background_color"]])), + column(width = 6, + colourpicker::colourInput("body_background_color", + ui_tooltip("body_background_color_tip", + "Body Background Color", + "Change body background color"), + load_themes$themes[["body_background_color"]]))), + fluidRow( + column(width = 6, + colourpicker::colourInput("box_color", + ui_tooltip("box_color_tip", + "Box Color", + "Change box default color"), + load_themes$themes[["box_color"]])), + column(width = 6, + br(), + bsButton("updateStyles", + label = "Update Application Theme"), + style = "margin-top: 5px;"))) + +}) # -- CanvasXpress Plot Example output$examplePlot1 <- renderCanvasXpress({ @@ -193,33 +244,74 @@ loginfo("Be Sure to Remember to Log ALL user actions", logger = ss_userAction.Log) # -- Setup Download Modules with Functions we want called -callModule(downloadFile, "exampleDownload1", ss_userAction.Log, - "examplesingle", - list(csv = load_data1)) -callModule(downloadFile, "exampleDownload2", ss_userAction.Log, - "examplemulti", - list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) -callModule(downloadableTable, "exampleDT1", ss_userAction.Log, - "exampletable", - list(csv = load_data3, tsv = load_data3), - load_data3, - rownames = FALSE) - -callModule(downloadablePlot, "examplePlot2", ss_userAction.Log, - filenameroot = "plot2_ggplot", - downloadfxns = list(jpeg = plot2, - csv = plot2_data), - aspectratio = 1.5, - visibleplot = plot2) - -callModule(downloadablePlot, "examplePlot3", ss_userAction.Log, - filenameroot = "plot3_lattice", - aspectratio = 2, - downloadfxns = list(png = plot3, - tiff = plot3, - txt = plot3_data, - tsv = plot3_data), - visibleplot = plot3) +downloadFile("exampleDownload1", + ss_userAction.Log, + "examplesingle", + list(csv = load_data1)) +downloadFile("exampleDownload2", + ss_userAction.Log, + "examplemulti", + list(csv = load_data2, xlsx = load_data2, tsv = load_data2)) +sketch <- htmltools::withTags( + table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics")), + tr( + th("Change"), + th("Increase"))) +)) + +downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval(c(7614, 15914, 34152), + c("lightgray", "gray", "cadetblue", "#808000")))) + +output$table_info <- renderUI({ + list( + tags$ul(tags$li("User can customize downloadableTable modules using DT options such as:", + tags$ul(tags$li("labels:", HTML(" "), + tags$b(tags$i("i.e. 'colnames', 'caption', ..."))), + tags$li("layout and columns styles:", HTML(" "), + tags$b(tags$i("i.e. 'container', 'formatStyle', ..."))), + tags$li("other addons:", HTML(" "), + tags$b(tags$i("i.e. 'filter', 'callback', ..."))))), + tags$li("For more information about table options please visit the", + tags$a("DT documentation", target = "_blank", href = "https://rstudio.github.io/DT/"), + "site") + )) +}) + + +downloadablePlot("examplePlot2", + ss_userAction.Log, + filenameroot = "plot2_ggplot", + downloadfxns = list(jpeg = plot2, + csv = plot2_data), + aspectratio = 1.5, + visibleplot = plot2) + +downloadablePlot("examplePlot3", + ss_userAction.Log, + filenameroot = "plot3_lattice", + aspectratio = 2, + downloadfxns = list(png = plot3, + tiff = plot3, + txt = plot3_data, + tsv = plot3_data), + visibleplot = plot3) # -- Observe UI Changes observeEvent(input$exampleBasicAlert, { @@ -261,3 +353,75 @@ observeEvent(input$showWorking, { logger = ss_userAction.Log) Sys.sleep(5) }) + +output$body <- renderUI({ + list( + periscope:::fw_create_body(), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();")) + ) +}) + +observeEvent(input$updateStyles, { + req(input$primary_color) + req(input$sidebar_width) + req(input$sidebar_background_color) + req(input$body_background_color) + req(input$box_color) + + lines <- c("### primary_color", + "# Sets the primary status color that affects the color of the header, valueBox, infoBox and box.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("primary_color: '", input$primary_color, "'\n\n"), + + + "# Sidebar variables: change the default sidebar width, colors:", + "### sidebar_width", + "# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only.", + "# Valid possible value are 200, 350, 425, ...", + "# Blank/empty value will use default value", + paste0("sidebar_width: ", input$sidebar_width, "\n"), + + "### sidebar_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("sidebar_background_color: '", input$sidebar_background_color, "'\n"), + + "### sidebar_hover_color", + "# The color of sidebar menu item upon hovring with mouse.", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_hover_color: \n", + + "### sidebar_text_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "sidebar_text_color: \n\n", + + "# body variables", + "### body_background_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("body_background_color: '", input$body_background_color, "'\n"), + + "# boxes variables", + "### box_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + paste0("box_color: '", input$box_color, "'\n"), + + "### infobox_color", + "# Valid values are names of the color or hex-decimal value of the color (i.e,: \"blue\", \"#086A87\").", + "# Blank/empty value will use default value", + "infobox_color: ") + + write(lines, "www/periscope_style.yaml", append = F) + load_themes$themes <- read_themes() + output$body <- renderUI({ + list(periscope:::fw_create_body(), + shiny::tags$script("$('#app_styling').closest('.box').find('[data-widget=collapse]').click();"), + shiny::tags$script(shiny::HTML("setTimeout(function (){$('div.navbar-custom-menu').click()}, 1000);")), + shiny::tags$script(shiny::HTML("$('div.navbar-custom-menu').click();"))) + }) +}) diff --git a/tests/testthat/sample_app_r_sidebar/program/ui_body.R b/tests/testthat/sample_app_r_sidebar/program/ui_body.R index 8a15e22..6f13fc1 100644 --- a/tests/testthat/sample_app_r_sidebar/program/ui_body.R +++ b/tests/testthat/sample_app_r_sidebar/program/ui_body.R @@ -40,12 +40,22 @@ body2 <- shinydashboard::box( id = "bodyElement2", collapsed = TRUE, htmlOutput("proginfo") ) +app_styling <- shinydashboard::box(id = "app_styling", + title = "Application Styling", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("styles")) + body3 <- shinydashboard::box( id = "bodyElement3", title = "Downloadable Table", width = 12, status = "primary", collapsible = TRUE, collapsed = TRUE, + htmlOutput("table_info"), + hr(), downloadableTableUI("exampleDT1", list("csv", "tsv"), "Download table data") ) @@ -90,4 +100,4 @@ body6 <- shinydashboard::box( id = "bodyElement6", # -- Register Elements in the ORDER SHOWN in the UI # -- Note: Will be added before the standard framework footer -add_ui_body(list(body1, body2, body3, body4, body5, body6), append = FALSE) +add_ui_body(list(body1, body2, app_styling, body3, body4, body5, body6), append = FALSE) diff --git a/tests/testthat/sample_app_r_sidebar/program/ui_sidebar_right.R b/tests/testthat/sample_app_r_sidebar/program/ui_sidebar_right.R index 6742ad0..e804c40 100644 --- a/tests/testthat/sample_app_r_sidebar/program/ui_sidebar_right.R +++ b/tests/testthat/sample_app_r_sidebar/program/ui_sidebar_right.R @@ -23,23 +23,50 @@ # -- Create Elements -tab1 <- rightSidebarTabContent( - id = 1, - icon = "desktop", - title = "Tab 1 - Plots", - active = TRUE, - checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), - checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), - checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE)) - -tab2 <- rightSidebarTabContent( - id = 2, - title = "Tab 2 - Datatable") - -tab3 <- rightSidebarTabContent( - id = 3, - title = "Tab 3 - Other", - icon = "paint-brush") +if (utils::packageVersion('shinydashboardPlus') < 2) { + tab1 <- rightSidebarTabContent( + id = 1, + icon = "desktop", + title = "Tab 1 - Plots", + active = TRUE, + checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), + checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), + checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE)) + + tab2 <- rightSidebarTabContent( + id = 2, + title = "Tab 2 - Datatable") + + tab3 <- rightSidebarTabContent( + id = 3, + title = "Tab 3 - Other", + icon = "paint-brush") + + plus_fxn <- list(tab1, tab2, tab3) +} else { + tab1 <- controlbarItem( + id = 1, + title = icon("desktop"), + "Tab 1 - Plots", + checkboxInput("enableGGPlot", "Enable GGPlot", value = TRUE), + checkboxInput("enableLatticePlot", "Enable Lattice Plot", value = TRUE), + checkboxInput("enableCXPlot", "Enable CanvasXpress Plot", value = TRUE) + ) + + tab2 <- controlbarItem( + id = 2, + title = icon("database"), + "Tab 2 - Datatable", + ) + + tab3 <- controlbarItem( + id = 3, + title = icon("paint-brush"), + "Tab 3 - Other", + ) + + plus_fxn <- controlbarMenu(tab1, tab2, tab3) +} # -- Register Basic Elements in the ORDER SHOWN in the UI -add_ui_sidebar_right(list(tab1, tab2, tab3)) +add_ui_sidebar_right(plus_fxn) diff --git a/tests/testthat/sample_app_r_sidebar/ui.R b/tests/testthat/sample_app_r_sidebar/ui.R index cfdc2ad..6f610ee 100644 --- a/tests/testthat/sample_app_r_sidebar/ui.R +++ b/tests/testthat/sample_app_r_sidebar/ui.R @@ -17,8 +17,16 @@ source(paste("program", "ui_body.R", sep = .Platform$file.sep), local = TRUE) -dashboardPagePlus(periscope:::fw_create_header_plus(), - periscope:::fw_create_sidebar(showsidebar = FALSE), - periscope:::fw_create_body(), - periscope:::fw_create_right_sidebar(), - sidebar_fullCollapse = TRUE) +addl_opts <- list() +if (utils::packageVersion('shinydashboardPlus') < 2) { + plus_fxn <- getExportedValue("shinydashboardPlus", "dashboardPagePlus") + addl_opts <- list(sidebar_fullCollapse = TRUE) +} else { + plus_fxn <- getExportedValue("shinydashboardPlus", "dashboardPage") +} + +do.call(plus_fxn, c(list(periscope:::fw_create_header_plus(), + periscope:::fw_create_sidebar(showsidebar = FALSE, resetbutton = FALSE), + uiOutput('body'), + periscope:::fw_create_right_sidebar()), + addl_opts)) diff --git a/tests/testthat/sample_app_r_sidebar/www/periscope_style.yaml b/tests/testthat/sample_app_r_sidebar/www/periscope_style.yaml new file mode 100644 index 0000000..334f142 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/www/periscope_style.yaml @@ -0,0 +1,47 @@ +### primary_color +# Sets the primary status color that affects the color of the header, valueBox, infoBox and box. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +primary_color: "#31A5CC" + + +# Sidebar variables: change the default sidebar width, colors: +### sidebar_width +# Width is to be specified as a numeric value in pixels. Must be greater than 0 and include numbers only. +# Valid possible value are 200, 350, 425, ... +# Blank/empty value will use default value +sidebar_width: 300 + +### sidebar_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_background_color: "#00FF00" + +### sidebar_hover_color +# The color of sidebar menu item upon hovring with mouse. +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_hover_color: + +### sidebar_text_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +sidebar_text_color: + + +# body variables +### body_background_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +body_background_color: "#C7DFE8" + +# boxes variables +### box_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +box_color: "#FDFFF5" + +### infobox_color +# Valid values are names of the color or hex-decimal value of the color (i.e,: "blue", "#086A87"). +# Blank/empty value will use default value +infobox_color: diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 4cca672..a913d95 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -2,6 +2,7 @@ require(testthat) require(shiny) require(periscope) require(shinydashboardPlus) +require(ggplot2) if (interactive()) { test_source_path <- "periscope/R" diff --git a/tests/testthat/test_app_reset.R b/tests/testthat/test_app_reset.R index 9d557cc..2ee9407 100755 --- a/tests/testthat/test_app_reset.R +++ b/tests/testthat/test_app_reset.R @@ -5,37 +5,61 @@ test_that(".appResetButton", { expect_snapshot_output(.appResetButton("myid")) }) -test_that(".appReset - no reset button", { - # there is no reset button on the UI for the app - testServer(.appReset, - {session$setInputs(resetPending = NULL) - expect_silent(.appReset)}) +test_that("app_reset - no reset button", { + testServer(app_reset, + expr = { + session$setInputs(resetPending = NULL, logger = periscope:::fw_get_user_log()) + expect_null(session$getReturned()) + }) }) -test_that(".appReset - reset button - no pending", { - # there is no reset button on the UI for the app - suppressWarnings(testServer(.appReset, - {session$setInputs(resetButton = TRUE, resetPending = FALSE) - expect_silent(.appReset)})) +test_that("app_reset - reset button - no pending", { + expect_silent(app_reset(input = list(resetButton = TRUE, resetPending = FALSE), + output = list(), + session = MockShinySession$setInputs(resetButton = TRUE, + resetPending = FALSE), + logger = periscope:::fw_get_user_log())) }) -test_that(".appReset - no reset button - with pending", { - # there is no reset button on the UI for the app - suppressWarnings(testServer(.appReset, - {session$setInputs(resetButton = FALSE, resetPending = TRUE) - expect_silent(.appReset)})) +test_that("app_reset - no reset button - with pending", { + expect_silent(app_reset(input = list(resetButton = FALSE, resetPending = TRUE), + output = list(), + session = MockShinySession$setInputs(resetButton = TRUE, + resetPending = FALSE), + logger = periscope:::fw_get_user_log())) }) -test_that(".appReset - reset button - with pending", { - suppressWarnings(testServer(.appReset, - {session$setInputs(resetButton = TRUE, resetPending = TRUE) - expect_silent(.appReset)})) +test_that("app_reset - reset button - with pending", { + expect_silent(app_reset(input = list(resetButton = TRUE, resetPending = TRUE), + output = list(), + session = MockShinySession$setInputs(resetButton = TRUE, + resetPending = FALSE), + logger = periscope:::fw_get_user_log())) }) -test_that(".appReset", { - expect_silent(.appReset(input = list(resetButton = TRUE, resetPending = FALSE), - output = list(), +test_that("app_reset", { + expect_silent(app_reset(input = list(resetButton = FALSE, resetPending = FALSE), + output = list(), session = MockShinySession$setInputs(resetButton = TRUE, resetPending = FALSE), logger = periscope:::fw_get_user_log())) }) + +test_that(".appReset", { + reset <- shiny::callModule(.appReset, + "reset", + input = list(), + output = list(), + session = MockShinySession$new(), + periscope:::fw_get_user_log()) + expect_equal(class(reset)[[1]], "Observer") + expect_equal(class(reset)[[2]], "R6") +}) + +test_that(".appReset - new call", { + expect_error(.appReset("reset", + input = list(), + output = list(), + session = MockShinySession$new(), + logger = periscope:::fw_get_user_log())) +}) diff --git a/tests/testthat/test_body_footer.R b/tests/testthat/test_body_footer.R index ec2d180..0be54e7 100755 --- a/tests/testthat/test_body_footer.R +++ b/tests/testthat/test_body_footer.R @@ -1,10 +1,37 @@ context("periscope - Body footer") +# Helper functions +data <- function(){ + c("line 1", "line 2", "line 3") +} +data2 <- function(){ + NULL +} + +# UI unit tests test_that(".bodyFooterOutput", { local_edition(3) expect_snapshot_output(.bodyFooterOutput("myid")) }) + +# Server unit tests test_that(".bodyFooter", { - testServer(.bodyFooter, {expect_silent(.bodyFooter)}) + footer <- shiny::callModule(.bodyFooter, "footer", input = list(), + output = list(), + session = MockShinySession$new(), + logdata = data) + expect_equal(class(footer)[[1]], "shiny.render.function") +}) + +test_that("body_footer ", { + expect_silent(body_footer(input = list(), + output = list(), + session = MockShinySession$new(), + logdata = data)) + + expect_silent(body_footer(input = list(), + output = list(), + session = MockShinySession$new(), + logdata = data2)) }) diff --git a/tests/testthat/test_convert_application.R b/tests/testthat/test_convert_application.R index 91a02f4..555ae23 100644 --- a/tests/testthat/test_convert_application.R +++ b/tests/testthat/test_convert_application.R @@ -223,7 +223,7 @@ test_that("remove_reset_button both sidebar", { test_that("remove_reset_button r sidebar", { app_location <- create_app_tmp_dir(left_sidebar = FALSE, right_sidebar = TRUE) - expect_message(remove_reset_button(location = app_location), "Left sidebar not available, reset button cannot be removed") + expect_message(remove_reset_button(location = app_location), "Reset button already removed, no conversion needed") }) ## add_reset_button tests diff --git a/tests/testthat/test_create_new_application.R b/tests/testthat/test_create_new_application.R index f122b81..91023a5 100755 --- a/tests/testthat/test_create_new_application.R +++ b/tests/testthat/test_create_new_application.R @@ -1,7 +1,7 @@ context("periscope create new application") - -expect_cleanup_create_new_application <- function(fullname, sampleapp = FALSE, dashboard_plus = FALSE, leftsidebar = TRUE, skin = NULL) { +expect_cleanup_create_new_application <- function(fullname, sampleapp = FALSE, dashboard_plus = FALSE, leftsidebar = TRUE) { + local_edition(3) expect_true(dir.exists(fullname)) expect_true(file.exists(paste0(fullname, "/global.R"))) expect_true(file.exists(paste0(fullname, "/server.R"))) @@ -9,6 +9,7 @@ expect_cleanup_create_new_application <- function(fullname, sampleapp = FALSE, d expect_true(dir.exists(paste0(fullname, "/www"))) expect_true(dir.exists(paste0(fullname, "/www/css"))) expect_true(dir.exists(paste0(fullname, "/www/js"))) + expect_true(file.exists(paste0(fullname, "/www/periscope_style.yaml"))) expect_true(dir.exists(paste0(fullname, "/www/img"))) expect_true(file.exists(paste0(fullname, "/www/img/loader.gif"))) expect_true(file.exists(paste0(fullname, "/www/img/tooltip.png"))) @@ -37,13 +38,6 @@ expect_cleanup_create_new_application <- function(fullname, sampleapp = FALSE, d } else { expect_true(!file.exists(paste0(fullname, "/program/ui_sidebar_right.R"))) } - if (!is.null(skin)) { - ui_file <- file(paste0(fullname, "/ui.R"), open = "r") - ui_content <- readLines(con = ui_file) - close(ui_file) - expect_true(any(grepl(skin, ui_content))) - } - # clean up unlink(fullname, TRUE) } @@ -141,43 +135,26 @@ test_that("create_new_application no reset button, no left sidebar", { expect_cleanup_create_new_application(appTemp, sampleapp = TRUE, leftsidebar = FALSE) }) -test_that("create_new_application custom style", { - appTemp.dir <- tempdir() - appTemp <- tempfile(pattern = "TestThatApp", tmpdir = appTemp.dir) - appTemp.name <- gsub('\\\\|/', '', (gsub(appTemp.dir, "", appTemp, fixed = T))) - - expect_message(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = NULL, style = list(skin = "green")), - "Framework creation was successful.") - expect_cleanup_create_new_application(appTemp, skin = "green") -}) -test_that("create_new_application bad style", { +test_that("create_new_application invalid yaml file", { appTemp.dir <- tempdir() appTemp <- tempfile(pattern = "TestThatApp", tmpdir = appTemp.dir) appTemp.name <- gsub('\\\\|/', '', (gsub(appTemp.dir, "", appTemp, fixed = T))) - expect_error(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = NULL, style = list("green")), - "Framework creation could not proceed, invalid type for skin, only character allowed") + expect_warning(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = NULL, custom_theme_file = ""), + "'custom_theme_file' must be single character value pointing to valid yaml file location. Using default values.") }) -test_that("create_new_application custom style right sidebar", { +test_that("create_new_application with valid yaml file", { appTemp.dir <- tempdir() appTemp <- tempfile(pattern = "TestThatApp", tmpdir = appTemp.dir) appTemp.name <- gsub('\\\\|/', '', (gsub(appTemp.dir, "", appTemp, fixed = T))) + yaml_loc <- "sample_app/www/periscope_style.yaml" - expect_message(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = TRUE, style = list(skin = "green")), + expect_message(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = NULL, custom_theme_file = yaml_loc), "Framework creation was successful.") - expect_cleanup_create_new_application(appTemp, dashboard_plus = TRUE, skin = "green") }) -test_that("create_new_application invalid style", { - appTemp.dir <- tempdir() - appTemp <- tempfile(pattern = "TestThatApp", tmpdir = appTemp.dir) - appTemp.name <- gsub('\\\\|/', '', (gsub(appTemp.dir, "", appTemp, fixed = T))) - - expect_error(create_new_application(name = appTemp.name, location = appTemp.dir, sampleapp = FALSE, rightsidebar = NULL, style = mtcars), - "Framework creation could not proceed, invalid type for style, only list allowed") -}) test_that("create_new_application invalid location", { expect_warning(create_new_application(name = "Invalid", location = tempfile(), sampleapp = FALSE), diff --git a/tests/testthat/test_download_file.R b/tests/testthat/test_download_file.R index db442c0..98a82c1 100755 --- a/tests/testthat/test_download_file.R +++ b/tests/testthat/test_download_file.R @@ -1,6 +1,31 @@ context("periscope - download file") +# helper functions +download_plot <- function() { + ggplot2::ggplot(data = mtcars, aes(x = wt, y = mpg)) + + geom_point(aes(color = cyl)) + + theme(legend.justification = c(1, 1), + legend.position = c(1, 1), + legend.title = element_blank()) + + ggtitle("GGPlot Example w/Hover") + + xlab("wt") + + ylab("mpg") +} +download_data <- function() { + mtcars +} + +download_data_show_row_names <- function() { + attr(mtcars, "show_rownames") <- TRUE + mtcars +} + +download_string_list <- function() { + c("test1", "test2", "tests") +} + +# UI Testing test_that("downloadFileButton", { local_edition(3) expect_snapshot_output(downloadFileButton(id = "myid", @@ -15,6 +40,7 @@ test_that("downloadFileButton multiple types", { hovertext = "myhovertext")) }) +# Server Testing test_that("downloadFile_ValidateTypes invalid", { result <- downloadFile_ValidateTypes(types = "csv") @@ -31,10 +57,52 @@ test_that("downloadFile_AvailableTypes", { expect_equal(result, c("csv", "xlsx", "tsv", "txt", "png", "jpeg", "tiff", "bmp")) }) -test_that("downloadFile", { - expect_silent(downloadFile(input = list(), - output = list(), - session = MockShinySession$new(), - logger = periscope:::fw_get_user_log(), - filenameroot = "mydownload1")) +test_that("download_file", { + session <- MockShinySession$new() + session$env$filenameroot <- "mydownload1" + expect_silent( + periscope:::download_file( + input = list(), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + datafxns = list(csv = download_data, + xlsx = download_data, + tsv = download_data, + txt = download_data, + png = download_plot, + jpeg = download_plot, + tiff = download_plot, + bmp = download_plot)) + ) + +}) + +test_that("downloadFile_callModule", { + session <- MockShinySession$new() + session$env$filenameroot <- "mydownload1" + session$env$datafxns = list(csv = download_data, + xlsx = download_data, + tsv = download_data, + txt = download_data, + png = download_plot, + jpeg = download_plot, + tiff = download_plot, + bmp = download_plot) + expect_silent(shiny::callModule(downloadFile, + "download", + input = list(), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + datafxns = list(csv = download_data, + xlsx = download_data, + tsv = download_data, + txt = download_data, + png = download_plot, + jpeg = download_plot, + tiff = download_plot, + bmp = download_plot))) }) diff --git a/tests/testthat/test_downloadable_plot.R b/tests/testthat/test_downloadable_plot.R index 0ce1946..8900049 100755 --- a/tests/testthat/test_downloadable_plot.R +++ b/tests/testthat/test_downloadable_plot.R @@ -63,11 +63,32 @@ test_that("downloadablePlotUI invalid btn_valign", { }) test_that("downloadablePlot", { - expect_error(downloadablePlot(input = list(), + download_plot <- function() { + ggplot2::ggplot(data = mtcars, aes(x = wt, y = mpg)) + + geom_point(aes(color = cyl)) + + theme(legend.justification = c(1, 1), + legend.position = c(1, 1), + legend.title = element_blank()) + + ggtitle("GGPlot Example w/Hover") + + xlab("wt") + + ylab("mpg") + } + + download_data <- function() { + mtcars + } + + expect_silent(shiny::callModule(downloadablePlot, + "download", + input = list(), output = list(), session = MockShinySession$new(), logger = periscope:::fw_get_user_log(), filenameroot = "mydownload1", - visibleplot = NULL)) + aspectratio = 2, + downloadfxns = list(png = download_plot, + tiff = download_plot, + txt = download_data, + tsv = download_data), + visibleplot = download_plot)) }) - diff --git a/tests/testthat/test_downloadable_table.R b/tests/testthat/test_downloadable_table.R index d48deac..f3ce299 100755 --- a/tests/testthat/test_downloadable_table.R +++ b/tests/testthat/test_downloadable_table.R @@ -8,11 +8,153 @@ test_that("downloadableTableUI", { hovertext = "myHoverText")) }) -test_that("downloadableTable", { - expect_error(downloadableTable(input = list(), - output = list(), - session = MockShinySession$new(), - logger = periscope:::fw_get_user_log(), - filenameroot = "mydownload1", - tabledata = NULL)) +# helper functions +data <- reactive({ + c(1,2) +}) + +mydataRowIds <- function(){ + rownames(mtcars) +} + +test_that("downloadableTable - singleSelect_FALSE_selection_enabled", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = FALSE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_silent(shiny::callModule(downloadableTable, + "download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + downloaddatafxns = list(csv = data, tsv = data), + tabledata = data, + selection = mydataRowIds)) + }) +}) + +test_that("downloadableTable - free_parameters", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = FALSE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_silent(shiny::callModule(downloadableTable, + "download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + periscope:::fw_get_user_log(), + "mydownload1", + list(csv = data, tsv = data), + data, + selection = mydataRowIds)) + }) +}) + +test_that("downloadableTable - new module call", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = FALSE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_error(downloadableTable("download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + downloaddatafxns = list(csv = data, tsv = data), + tabledata = data, + selection = mydataRowIds)) + + }) +}) + +test_that("downloadableTable - singleSelect_TRUE_selection_enabled", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = TRUE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_silent(shiny::callModule(downloadableTable, + "download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + downloaddatafxns = list(csv = data, tsv = data), + tabledata = data, + selection = mydataRowIds)) + }) +}) + +test_that("downloadableTable - singleSelect and selection disabled", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = TRUE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_silent(shiny::callModule(downloadableTable, + "download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + downloaddatafxns = list(csv = data, tsv = data), + tabledata = data)) + }) +}) + +test_that("downloadableTable - invalid_selection", { + suppressWarnings({ + session <- MockShinySession$new() + session$setInputs(dtableSingleSelect = TRUE) + session$env$filenameroot <- "mydownload1" + session$env$downloaddatafxns = list(csv = data, tsv = data) + expect_message(shiny::callModule(downloadableTable, + "download", + input = list(dtableSingleSelect = "FALSE"), + output = list(), + session = session, + logger = periscope:::fw_get_user_log(), + filenameroot = "mydownload1", + downloaddatafxns = list(csv = data, tsv = data), + tabledata = data, + selection = "single")) + }) +}) + +test_that("build_datatable_arguments", { + local_edition(3) + table_options <- list(rownames = FALSE, + callback = "table.order([2, 'asc']).draw();", + caption = " Very Important Information", + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + width = "150px", + height = "50px", + extensions = 'Buttons', + plugins = 'natural', + editable = TRUE, + order = list(list(2, 'asc'), list(3, 'desc'))) + expect_snapshot(build_datatable_arguments(table_options)) +}) + + +test_that("format_columns", { + local_edition(3) + set.seed(123) + dt <- cbind(matrix(rnorm(60, 1e5, 1e6), 20), runif(20), rnorm(20, 100)) + dt[, 1:3] = round(dt[, 1:3]) + dt[, 4:5] = round(dt[, 4:5], 7) + colnames(dt) = head(LETTERS, ncol(dt)) + expect_snapshot(format_columns(DT::datatable(dt), + list(formatCurrency = list(columns = c("A", "C")), + formatPercentage = list(columns = c("D"), 2)))) }) diff --git a/tests/testthat/test_ui_functions.R b/tests/testthat/test_ui_functions.R index bb7d188..49dd79d 100755 --- a/tests/testthat/test_ui_functions.R +++ b/tests/testthat/test_ui_functions.R @@ -1,24 +1,8 @@ context("periscope - UI functionality") - +local_edition(3) test_that("fw_create_header", { - result <- periscope:::fw_create_header() - expect_equal(result$name, "header") - expect_equal(result$attribs, list(class = "main-header")) - - result.children <- result$children - expect_equal(length(result.children), 3) - expect_equal(result.children[[1]], NULL) ## ? - - expect_equal(result.children[[2]]$name, "span") - expect_equal(result.children[[2]]$attribs$class, "logo") - expect_equal(length(result.children[[2]]$children), 1) - - expect_equal(result.children[[2]]$children[[1]]$name, "div") - expect_equal(result.children[[2]]$children[[1]]$attribs, list(class = "periscope-busy-ind")) - - expect_equal(length(result.children[[2]]$children[[1]]$children), 2) - expect_equal(result.children[[2]]$children[[1]]$children[[1]], "Working") + expect_snapshot_output(periscope:::fw_create_header()) }) check_sidebar_result <- function(result, showsidebar = TRUE, basic_existing = FALSE, advanced_existing = FALSE) { @@ -32,7 +16,7 @@ check_sidebar_result <- function(result, showsidebar = TRUE, basic_existing = F expect_equal(result$attribs, list(id = "sidebarCollapsed", class = "main-sidebar", 'data-collapsed' = "true")) } } - + result.children <- result$children expect_equal(length(result.children), 2) if (showsidebar) { @@ -43,14 +27,14 @@ check_sidebar_result <- function(result, showsidebar = TRUE, basic_existing = F expect_equal(class(result.children[[1]][[2]]), "list") expect_equal(class(result.children[[1]][[3]]), "list") } - + expect_equal(result.children[[2]]$name, "section") expect_equal(result.children[[2]]$attribs$class, "sidebar") expect_equal(result.children[[2]][[2]]$id, "sidebarItemExpanded") - + result.subchilds <- result.children[[2]]$children[[1]] expect_equal(length(result.subchilds), 3) - + expect_equal(result.subchilds[[1]][[1]]$name, "script") expect_true(grepl("Set using set_app_parameters\\() in program/global.R", result.subchilds[[1]][[1]]$children[[1]])) @@ -65,16 +49,13 @@ check_sidebar_result <- function(result, showsidebar = TRUE, basic_existing = F } } + test_that("fw_create_sidebar no sidebar", { - result <- periscope:::fw_create_sidebar(showsidebar = F, resetbutton = F) - - check_sidebar_result(result, showsidebar = FALSE) + expect_snapshot_output(periscope:::fw_create_sidebar(showsidebar = F, resetbutton = F)) }) test_that("fw_create_sidebar empty", { - result <- periscope:::fw_create_sidebar(showsidebar = T, resetbutton = F) - - check_sidebar_result(result, showsidebar = TRUE) + expect_snapshot_output(periscope:::fw_create_sidebar(showsidebar = T, resetbutton = F)) }) test_that("fw_create_sidebar only basic", { @@ -83,11 +64,9 @@ test_that("fw_create_sidebar only basic", { .g_opts$side_basic <- list(tags$p()) side_advanced <- shiny::isolate(.g_opts$side_advanced) .g_opts$side_advanced <- NULL - - result <- periscope:::fw_create_sidebar(showsidebar = T, resetbutton = F) - - check_sidebar_result(result, showsidebar = TRUE, basic_existing = TRUE, advanced_existing = FALSE) - + + expect_snapshot_output(periscope:::fw_create_sidebar(showsidebar = T, resetbutton = F)) + # teardown .g_opts$side_basic <- side_basic .g_opts$side_advanced <- side_advanced @@ -99,11 +78,9 @@ test_that("fw_create_sidebar only advanced", { .g_opts$side_basic <- NULL side_advanced <- shiny::isolate(.g_opts$side_advanced) .g_opts$side_advanced <- list(tags$p()) - - result <- periscope:::fw_create_sidebar() - - check_sidebar_result(result, showsidebar = TRUE, basic_existing = FALSE, advanced_existing = TRUE) - + + expect_snapshot_output(periscope:::fw_create_sidebar()) + # teardown .g_opts$side_basic <- side_basic .g_opts$side_advanced <- side_advanced @@ -115,100 +92,34 @@ test_that("fw_create_sidebar basic and advanced", { .g_opts$side_basic <- list(tags$p()) side_advanced <- shiny::isolate(.g_opts$side_advanced) .g_opts$side_advanced <- list(tags$p()) - + result <- periscope:::fw_create_sidebar() - + check_sidebar_result(result, showsidebar = TRUE, basic_existing = TRUE, advanced_existing = TRUE) - + # teardown .g_opts$side_basic <- side_basic .g_opts$side_advanced <- side_advanced }) -check_body_result <- function(result, logging = TRUE) { - expect_equal(result$name, "div") - expect_equal(result$attribs, list(class = "content-wrapper")) - - result.children <- result$children - expect_equal(length(result.children), 1) - - expect_equal(result.children[[1]]$name, "section") - expect_equal(result.children[[1]]$attribs$class, "content") - - result.subchilds <- result.children[[1]]$children - expect_equal(length(result.subchilds), 4) - - expect_equal(result.subchilds[[1]]$name, "head") - # check if tab title is set in javascript - expect_true(grepl("document.title = 'Set using set_app_parameters\\() in program/global.R'", result.subchilds[[1]]$children[[2]]$children)) - - if (logging) { - expect_equal(class(result.subchilds[[2]]), "shiny.tag") - expect_equal(result.subchilds[[2]]$name, "div") - expect_equal(result.subchilds[[2]]$attribs$class, "modal sbs-modal fade") - expect_equal(result.subchilds[[2]]$attribs$id, "titleinfobox") - expect_equal(result.subchilds[[2]]$attribs$tabindex, "-1") - expect_equal(result.subchilds[[2]]$attribs$`data-sbs-trigger`, "titleinfobox_trigger") - - expect_equal(length(result.subchilds[[4]]), 3) - - expect_equal(result.subchilds[[4]]$name, "div") - expect_equal(result.subchilds[[4]]$attribs$class, "col-sm-12") - result.subsubchilds <- result.subchilds[[4]]$children - - expect_equal(result.subsubchilds[[1]]$name, "div") - expect_equal(result.subsubchilds[[1]]$attribs$class, "box collapsed-box") - - result.subsubsubchilds <- result.subsubchilds[[1]]$children - expect_equal(length(result.subsubsubchilds), 3) - expect_equal(result.subsubsubchilds[[1]]$name, "div") - expect_equal(result.subsubsubchilds[[1]]$attribs$class, "box-header") - - result.subsubsubsubchilds <- result.subsubsubchilds[[1]]$children - expect_equal(length(result.subsubsubsubchilds), 2) - expect_equal(result.subsubsubsubchilds[[1]]$name, "h3") - expect_equal(result.subsubsubsubchilds[[1]]$attribs$class, "box-title") - - result.subsubsubsubsubchilds <- result.subsubsubsubchilds[[1]]$children - expect_equal(result.subsubsubsubsubchilds[[1]], "User Action Log") - - result.subsubsubsubsubchilds <- result.subsubsubsubchilds[[2]]$children - expect_equal(result.subsubsubsubsubchilds[[1]]$name, "button") - expect_equal(result.subsubsubsubsubchilds[[1]]$attribs, list(class = "btn btn-box-tool", 'data-widget' = "collapse")) - expect_equal(length(result.subsubsubsubsubchilds[[1]]$children), 1) - - expect_equal(result.subsubsubsubsubchilds[[1]]$children[[1]]$name, "i") - expect_equal(result.subsubsubsubsubchilds[[1]]$children[[1]]$attribs$class, "fa fa-plus") - expect_equal(result.subsubsubsubsubchilds[[1]]$children[[1]]$children, list()) - } else { - expect_equal(result.subchilds[[2]], NULL) - expect_equal(result.subchilds[[3]], NULL) - expect_equal(result.subchilds[[4]], NULL) - } -} - test_that("fw_create_body app_info", { - # setup app_info <- shiny::isolate(.g_opts$app_info) .g_opts$app_info <- HTML("app_info") - - result <- periscope:::fw_create_body() - check_body_result(result) - + + expect_snapshot_output(periscope:::fw_create_body()) + # teardown .g_opts$app_info <- app_info }) test_that("fw_create_body no log", { - # setup show_userlog <- shiny::isolate(.g_opts$show_userlog) .g_opts$show_userlog <- FALSE - - result <- periscope:::fw_create_body() - check_body_result(result, logging = FALSE) - + + expect_snapshot_output(periscope:::fw_create_body()) + # teardown .g_opts$show_userlog <- show_userlog }) @@ -244,12 +155,7 @@ test_that("add_ui_body", { }) test_that("ui_tooltip", { - result <- ui_tooltip(id = "id", label = "mylabel", text = "mytext") - expect_equal(result$name, "span") - expect_equal(result$attribs, list(class = "periscope-input-label-with-tt")) - result.children <- result$children - expect_equal(length(result.children), 3) - expect_equal(result.children[[1]], "mylabel") + expect_snapshot_output(ui_tooltip(id = "id", label = "mylabel", text = "mytext")) }) test_that("ui_tooltip no text", { @@ -257,152 +163,26 @@ test_that("ui_tooltip no text", { }) test_that("fw_create_header_plus", { - result <- periscope:::fw_create_header_plus() - expect_equal(result$name, "header") - expect_equal(result$attribs, list(class = "main-header")) - - result.children <- result$children - expect_equal(length(result.children), 3) - expect_equal(result.children[[1]], NULL) ## ? - - expect_equal(result.children[[2]]$name, "span") - expect_equal(result.children[[2]]$attribs$class, "logo") - expect_equal(length(result.children[[2]]$children), 1) - - expect_equal(result.children[[2]]$children[[1]]$name, "div") - expect_equal(result.children[[2]]$children[[1]]$attribs, list(class = "periscope-busy-ind")) - - expect_equal(length(result.children[[2]]$children[[1]]$children), 2) - expect_equal(result.children[[2]]$children[[1]]$children[[1]], "Working") - - expect_equal(result.children[[3]]$name, "nav") - expect_equal(result.children[[3]]$attribs$class, "navbar navbar-static-top") - expect_equal(length(result.children[[3]]$children), 4) - - expect_equal(result.children[[3]]$children[[1]]$name, "span") - expect_equal(result.children[[3]]$children[[1]]$attribs, list(style = "display:none;")) - - expect_equal(result.children[[3]]$children[[2]]$name, "a") - expect_equal(result.children[[3]]$children[[2]]$attribs, list(href = "#", class = "sidebar-toggle", `data-toggle` = "offcanvas", role = "button")) - - expect_equal(result.children[[3]]$children[[3]]$name, "div") - expect_equal(result.children[[3]]$children[[3]]$attribs, list(class = "navbar-custom-menu", style = "float: left; margin-left: 10px;")) - - expect_equal(result.children[[3]]$children[[4]]$name, "div") - expect_equal(result.children[[3]]$children[[4]]$attribs, list(class = "navbar-custom-menu")) + expect_snapshot_output(periscope:::fw_create_header_plus()) }) test_that("fw_create_right_sidebar", { - result <- periscope:::fw_create_right_sidebar() - - expect_equal(length(result), 2) - expect_equal(result[[1]]$name, "head") - expect_equal(length(result[[1]]$attribs), 0) - expect_equal(length(result[[1]]$children), 1) - - result1.children <- result[[1]]$children[[1]] - - expect_equal(result1.children$name, "style") - expect_equal(length(result1.children$attribs), 0) + expect_snapshot_output(periscope:::fw_create_right_sidebar()) }) test_that("fw_create_right_sidebar SDP<2", { skip_if_not(t_sdp_old) - result <- periscope:::fw_create_right_sidebar() - - expect_equal(result[[2]]$name, "div") - expect_equal(result[[2]]$attribs, list(id = "controlbar")) - expect_equal(length(result[[2]]$children), 2) - - result2.children <- result[[2]]$children - - expect_equal(result2.children[[1]]$name, "aside") - expect_equal(length(result2.children[[1]]$children), 2) - - expect_equal(result2.children[[1]]$children[[1]]$name, "ul") - expect_equal(result2.children[[1]]$children[[1]]$attribs, list(class = "nav nav-tabs nav-justified control-sidebar-tabs")) - - expect_equal(result2.children[[1]]$children[[2]]$name, "div") - expect_equal(result2.children[[1]]$children[[2]]$attribs, list(class = "controlbar tab-content")) - - expect_equal(result2.children[[2]]$name, "div") - expect_equal(result2.children[[2]]$attribs, list(class = "control-sidebar-bg", style = "width: 230px;")) - - add_ui_sidebar_right(elementlist = list(selectInput(inputId = "id", choices = 1:3, label = "Input widget"))) - result <- periscope:::fw_create_right_sidebar() - - expect_equal(length(result), 2) - expect_equal(result[[1]]$name, "head") - expect_equal(length(result[[1]]$attribs), 0) - expect_equal(length(result[[1]]$children), 1) - - result1.children <- result[[1]]$children[[1]] - - expect_equal(result1.children$name, "style") - expect_equal(length(result1.children$attribs), 0) - - expect_equal(result[[2]]$name, "div") - expect_equal(result[[2]]$attribs, list(id = "controlbar")) - expect_equal(length(result[[2]]$children), 2) - - result2.children <- result[[2]]$children - - expect_equal(result2.children[[1]]$name, "aside") - expect_equal(length(result2.children[[1]]$children), 2) - - expect_equal(result2.children[[1]]$children[[1]]$name, "ul") - expect_equal(result2.children[[1]]$children[[1]]$attribs, list(class = "nav nav-tabs nav-justified control-sidebar-tabs")) - - expect_equal(result2.children[[1]]$children[[2]]$name, "div") - expect_equal(result2.children[[1]]$children[[2]]$attribs, list(class = "controlbar tab-content")) - - result2.1.2.children <- result2.children[[1]]$children[[2]]$children - - expect_equal(result2.1.2.children[[1]]$name, "div") - expect_equal(length(result2.1.2.children[[1]]$children), 1) - - expect_equal(result2.1.2.children[[2]]$name, "div") - expect_equal(result2.1.2.children[[2]]$attribs, list(class = "form-group shiny-input-container")) - expect_equal(length(result2.1.2.children[[2]]$children), 2) - - expect_equal(result2.1.2.children[[2]]$children[[1]]$name, "label") - expect_equal(result2.1.2.children[[2]]$children[[1]]$attribs$class, "control-label") - - expect_equal(result2.1.2.children[[2]]$children[[2]]$name, "div") - expect_equal(length(result2.1.2.children[[2]]$children[[2]]$children), 2) - - expect_equal(result2.1.2.children[[2]]$children[[2]]$children[[1]]$name, "select") - expect_equal(result2.1.2.children[[2]]$children[[2]]$children[[1]]$attribs, list(id = "id")) - - expect_equal(result2.1.2.children[[2]]$children[[2]]$children[[2]]$name, "script") - expect_equal(result2.1.2.children[[2]]$children[[2]]$children[[2]]$attribs, list(type = "application/json", `data-for` = "id", `data-nonempty` = "")) - - expect_equal(result2.children[[2]]$name, "div") - expect_equal(result2.children[[2]]$attribs, list(class = "control-sidebar-bg", style = "width: 230px;")) + expect_snapshot_output(periscope:::fw_create_right_sidebar()) + expect_snapshot_output(add_ui_sidebar_right(elementlist = list(selectInput(inputId = "id", choices = 1:3, label = "Input widget")))) + expect_snapshot_output(periscope:::fw_create_right_sidebar()) }) test_that("fw_create_right_sidebar SDP>=2", { skip_if(t_sdp_old) - result <- periscope:::fw_create_right_sidebar() - result2 <- result[[2]] - - expect_equal(length(result2), 2) - expect_equal(result2[[1]]$name, "aside") - expect_equal(result2[[1]]$attribs$id, "controlbarId") - - result2.1child <- result2[[1]]$children - - expect_equal(length(result2.1child), 1) - - expect_equal(length(result2.1child[[1]][[1]]), 3) - expect_equal(result2.1child[[1]][[1]]$name, "div") - expect_equal(result2.1child[[1]][[1]]$attribs$id, "sidebarRightAlert") - - result2.2child <- result2[[2]]$children - expect_equal(length(result2.2child), 0) - }) + expect_snapshot_output(periscope:::fw_create_right_sidebar()) +}) test_that("add_ui_sidebar_right", { result <- add_ui_sidebar_right(elementlist = NULL) @@ -412,7 +192,7 @@ test_that("add_ui_sidebar_right", { test_that("add_ui_sidebar_right with append", { result <- add_ui_sidebar_right(elementlist = NULL, append = TRUE) expect_null(result, "add_ui_sidebar_right") - + result <- add_ui_sidebar_right(elementlist = NULL, append = FALSE) expect_null(result, "add_ui_sidebar_right") }) diff --git a/tests/testthat/test_ui_misc_functions.R b/tests/testthat/test_ui_misc_functions.R index 6153165..2eb8ab0 100755 --- a/tests/testthat/test_ui_misc_functions.R +++ b/tests/testthat/test_ui_misc_functions.R @@ -63,5 +63,10 @@ test_that("fw_server_setup", { logger = periscope:::fw_get_user_log())) }) +test_that("is_valid_color", { + expect_true(is_valid_color("green")) + expect_false(is_valid_color("not color")) +}) + # clean up unlink("log", TRUE) diff --git a/vignettes/downloadFile-module.Rmd b/vignettes/downloadFile-module.Rmd index 8e04442..df3d341 100755 --- a/vignettes/downloadFile-module.Rmd +++ b/vignettes/downloadFile-module.Rmd @@ -14,7 +14,7 @@ vignette: > # Overview -## Purpose +## Purpose This *Shiny Module* was created in order to provide a consistent-looking and easy-to-use button that facilitates one or multiple types of file downloads. @@ -36,21 +36,16 @@ easy-to-use button that facilitates one or multiple types of file downloads. Shiny modules consist of a pair of functions that modularize, or package, a small piece of reusable functionality. The UI function is called directly by the user to place the UI in the correct location (as with other shiny UI -objects). The server function is not called directly by the user of the module. -Instead the module server function is called only once to set it up using the -shiny::callModule function inside the server function (i.e. user-local session -scope. The callModule function supplies the first three arguments of the -Shiny Module's function inputs - the input, output, and session. Additional -arguments supplied by the user in the callModule function are passed to the -specific shiny module that is called. There can be additional helper functions -that are a part of a shiny module. +objects). The module server function that is called only once to set it up using the +module name as a function inside the server function (i.e. user-local session +scope. The function first arguments is string represents the module id (the same id used in module UI function). Additional arguments can be supplied by the user based on the specific shiny module that is called. There can be additional helper functions that are a part of a shiny module. The **downloadFile** Shiny Module is a part of the *periscope* package and consists of the following functions: * **downloadFileButton** - the UI function to place the button in the -application -* **downloadFile** - the Server function supplied to callModule. +application. +* **downloadFile** - the server function to be called inside server_local.R. * **downloadFile_ValidateTypes** - a helper function that will check a given list of file types and warn the caller if the list contains an invalid or unsupported type. @@ -101,13 +96,8 @@ downloadFileButton("object_id2", ## downloadFile -The **downloadFile** function is not called directly - instead a call to -shiny::callModule is made inside the server.R (or equivalent) file to initialize -the module. +The **downloadFile** function is called directly. The call consists of the following: -The call consists of the following: - -* the name of the module - unquoted * the unique object ID that was provided to downloadFileButton when creating the UI object * the logging logger to be used @@ -142,20 +132,18 @@ to the user from the application. # Inside server_local.R #single download type -callModule(downloadFile, - "object_id1", - logger = ss_userAction.Log, - filenameroot = "mydownload1", - datafxns = list(csv = mydatafxn1), - aspectratio = 1) +downloadFile("object_id1", + logger = ss_userAction.Log, + filenameroot = "mydownload1", + datafxns = list(csv = mydatafxn1), + aspectratio = 1) #multiple download types -callModule(downloadFile, - "object_id2", - logger = ss_userAction.Log, - filenameroot = "mytype2", - datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), - aspectratio = 1) +downloadFile("object_id2", + logger = ss_userAction.Log, + filenameroot = "mytype2", + datafxns = list(csv = mydatafxn1, xlsx = mydatafxn2), + aspectratio = 1) ``` @@ -169,7 +157,7 @@ library(periscope) app_dir = tempdir() create_new_application('mysampleapp', location = app_dir, sampleapp = TRUE) -runApp('mysampleapp', appDir = app_dir) +runApp(paste(app_dir, 'mysampleapp', sep = .Platform$file.sep)) ```
diff --git a/vignettes/downloadablePlot-module.Rmd b/vignettes/downloadablePlot-module.Rmd index 56a58c1..9a017c0 100755 --- a/vignettes/downloadablePlot-module.Rmd +++ b/vignettes/downloadablePlot-module.Rmd @@ -15,7 +15,7 @@ vignette: > # Overview -## Purpose +## Purpose This *Shiny Module* was created in order to provide an easy-to-use downloadFileButton for a plot that is automatically created, linked @@ -47,14 +47,9 @@ button Shiny modules consist of a pair of functions that modularize, or package, a small piece of reusable functionality. The UI function is called directly by the user to place the UI in the correct location (as with other shiny UI -objects). The server function is not called directly by the user of the module. -Instead the module server function is called only once to set it up using the -shiny::callModule function inside the server function (i.e. user-local session -scope. The callModule function supplies the first three arguments of the -Shiny Module's function inputs - the input, output, and session. Additional -arguments supplied by the user in the callModule function are passed to the -specific shiny module that is called. There can be additional helper functions -that are a part of a shiny module. +objects). The module server function that is called only once to set it up using the +module name as a function inside the server function (i.e. user-local session +scope. The function first arguments is string represents the module id (the same id used in module UI function). Additional arguments can be supplied by the user based on the specific shiny module that is called. There can be additional helper functions that are a part of a shiny module. ## downloadablePlotUI @@ -93,13 +88,8 @@ downloadablePlotUI("object_id1", ## downloadablePlot -The **downloadablePlot** function is not called directly - instead a call to -shiny::callModule is made inside the server.R (or equivalent) file to initialize -the module. +The **downloadablePlot** function is also called directly. The call consists of the following: -The call consists of the following: - -* the name of the module - unquoted * the unique object ID that was provided to downloadablePlotUI when creating the UI object * the logging logger to be used @@ -139,13 +129,13 @@ to the user from the application. All the above requirements apply. ```{r, eval = F} # Inside server_local.R -callModule(downloadablePlot, - "object_id1", - logger = ss_userAction.Log, - filenameroot = "mydownload1", - aspectratio = 1.33, - downloadfxns = list(png = myplotfxn, tsv = mydatafxn), - visibleplot = myplotfxn) +downloadablePlot("object_id1", + logger = ss_userAction.Log, + filenameroot = "mydownload1", + aspectratio = 1.33, + downloadfxns = list(png = myplotfxn, tsv = mydatafxn), + visibleplot = myplotfxn) + ```
diff --git a/vignettes/downloadableTable-module.Rmd b/vignettes/downloadableTable-module.Rmd index e74be09..dbab953 100755 --- a/vignettes/downloadableTable-module.Rmd +++ b/vignettes/downloadableTable-module.Rmd @@ -15,7 +15,7 @@ vignette: > # Overview -## Purpose +## Purpose This *Shiny Module* was created in order to provide a consistent-looking and easy-to-use table including a downloadFileButton that is automatically created, @@ -48,21 +48,16 @@ scrolling (no paging) Shiny modules consist of a pair of functions that modularize, or package, a small piece of reusable functionality. The UI function is called directly by the user to place the UI in the correct location (as with other shiny UI -objects). The server function is not called directly by the user of the module. -Instead the module server function is called only once to set it up using the -shiny::callModule function inside the server function (i.e. user-local session -scope. The callModule function supplies the first three arguments of the -Shiny Module's function inputs - the input, output, and session. Additional -arguments supplied by the user in the callModule function are passed to the -specific shiny module that is called. There can be additional helper functions -that are a part of a shiny module. +objects). The module server function that is called only once to set it up using the +module name as a function inside the server function (i.e. user-local session +scope. The function first arguments is string represents the module id (the same id used in module UI function). Additional arguments can be supplied by the user based on the specific shiny module that is called. There can be additional helper functions that are a part of a shiny module. The **downloadableTable** Shiny Module is a part of the *periscope* package and consists of the following functions: * **downloadableTableUI** - the UI function to place the table in the application -* **downloadableTable** - the Server function supplied to callModule. +* **downloadableTable** - the server function to be called inside server_local.R. ## downloadableTableUI @@ -99,13 +94,8 @@ downloadableTableUI("object_id1", ## downloadableTable -The **downloadableTable** function is not called directly - instead a call to -shiny::callModule is made inside the server.R (or equivalent) file to initialize -the module. +The **downloadableTable** function is called directly. The call consists of the following: -The call consists of the following: - -* the name of the module - unquoted * the unique object ID that was provided to downloadableTableUI when creating the UI object * the logging logger to be used @@ -119,8 +109,8 @@ initiates a download *(see requirements below)*. * a data function providing the data for the visible table. It can be the same, or different, data as that provided by the download data functions. This allows finer control over what the user can view vs. download if desired. -* whether or not to show rownames on the table -* a table caption, if desired. +* ... free parameters **named list** to pass table customization options. +It supports most of DT table options customization. See example below. **Data Function Requirements** @@ -138,26 +128,60 @@ to the user from the application. All the above requirements apply. **Reactive Return Value** -The callModule function returns a reactive expression containing the selected +The server function returns a reactive expression containing the selected rows (data, not references, rownumbers, etc - the actual table row data). This allows the user to capture this to update another table, chart, etc. as desired. It is acceptable to ignore the return value as well if this functionality is not needed. +**Customization Options** -```{r, eval = F} -# Inside server_local.R +*downloadableTable* module can be customized using the same `?DT::datatable` arguments. options or format functions. These options can be sent as a named options via the server function, see example below. +*Notes*: + +* `selection` parameter in the server function has different usage than `DT::datatable` `selection` option as it should be a function or reactive expression providing the row_ids of the rows that should be selected. Its default value is `NULL` +* `editable`, `width`, `height` options in `DT::datatable` are not supported -selectedrows <- callModule(downloadableTable, - "object_id1", - logger = ss_userAction.Log, - filenameroot = "mydownload1", - downloaddatafxns = list(csv = mydatafxn1, tsv = mydatafxn2), - tabledata = mydatafxn3, - rownames = FALSE, - caption = "This is a great table! By: Me" ) +The following is an example of a customized downloadableTable: -# selectedrows is the reactive return value, captured for later use +
+ +It is generated using the following code: + +```{r, eval = F} +# Inside server_local.R +sketch <- htmltools::withTags(table( + class = "display", + thead( + tr( + th(rowspan = 2, "Location"), + th(colspan = 2, "Statistics") + ), + tr( + th("Change"), + th("Increase") + ) + + ) +)) + +selectedrows <- downloadableTable("exampleDT1", + ss_userAction.Log, + "exampletable", + list(csv = load_data3, tsv = load_data3), + load_data3, + colnames = c("Area", "Delta", "Increase"), + filter = "bottom", + callback = htmlwidgets::JS("table.order([1, 'asc']).draw();"), + container = sketch, + formatStyle = list(columns = c("Total.Population.Change"), + color = DT::styleInterval(0, c("red", "green"))), + formatStyle = list(columns = c("Natural.Increase"), + backgroundColor = DT::styleInterval( + c(7614, 15914, 34152), + c("blue", "lightblue", "#FF7F7F", "red")))) + +# NOTE: selectedrows is the reactive return value, captured for later use ``` @@ -171,7 +195,7 @@ library(periscope) app_dir = tempdir() create_new_application('mysampleapp', location = app_dir, sampleapp = TRUE) -runApp('mysampleapp', appDir = app_dir) +runApp(paste(app_dir, 'mysampleapp', sep = .Platform$file.sep)) ```
diff --git a/vignettes/figures/downloadableTable-2.jpg b/vignettes/figures/downloadableTable-2.jpg new file mode 100644 index 0000000..986a9ef Binary files /dev/null and b/vignettes/figures/downloadableTable-2.jpg differ diff --git a/vignettes/figures/periscope_style.jpg b/vignettes/figures/periscope_style.jpg new file mode 100644 index 0000000..d5ca6d1 Binary files /dev/null and b/vignettes/figures/periscope_style.jpg differ diff --git a/vignettes/figures/sample_app_styling.jpg b/vignettes/figures/sample_app_styling.jpg new file mode 100644 index 0000000..3960653 Binary files /dev/null and b/vignettes/figures/sample_app_styling.jpg differ diff --git a/vignettes/new-application.Rmd b/vignettes/new-application.Rmd index 39e2f38..cdd25e0 100755 --- a/vignettes/new-application.Rmd +++ b/vignettes/new-application.Rmd @@ -151,9 +151,20 @@ createAlert(session, "sidebarRightAlert", ``` #### Styling +##### Overview +Different parts of the generated application can be customized with a custom yaml file called *periscope_style.yaml* located under *www* folder as follow: -The application can be created with a custom style. For now, only the color of the application header bar can be changed, -but more options will be added later on. The bar color (aka the 'skin') is by default blue, but it can also be set to "black", "purple", "green", "red" or "yellow". +
+ +##### Usage + +* User can update the values for **periscope_style.yaml** then restart the application so new changes can take affect. +* User can pass an existing **periscope_style.yaml** from an existing app to new one through passing its location to `custom_theme_file` parameter in `create_new_application` method. +* The sample applications contain a section to explore updating some styles interactively: + +
+ +* The generated yaml file for blank applications will contain no values for the properties -- blank application will use default style options unless they are customized. *See the Creating a Sample Application and Creating your Application sections for an example* @@ -199,8 +210,8 @@ create_new_application(name = 'mytestapp', location = app_dir, sampleapp = TRUE, create_new_application(name = 'mytestapp', location = app_dir, sampleapp = TRUE, rightsidebar = TRUE) # application with a right sidebar using a custom icon create_new_application(name = 'mytestapp', location = app_dir, sampleapp = TRUE, rightsidebar = "table") -# application with a custom header bar color (skin) -create_new_application(name = 'mytestapp', location = app_dir, sampleapp = TRUE, style = list(skin = "green")) +# application with a custom style file +create_new_application(name = 'mytestapp', location = app_dir, sampleapp = TRUE, custom_theme_file = "periscope_style.yaml") ``` This generates a default sample application optionally with a left/right sidebar in a subdirectory named *mytestapp* @@ -213,7 +224,8 @@ user's system. ## Step 2: Run ```{r, eval=F} -runApp('mytestapp', appDir = app_dir) +runApp(paste(app_dir, 'mytestapp', sep = .Platform$file.sep)) + ``` The application should run in either the viewer or browser (depending on system @@ -239,8 +251,8 @@ create_new_application(name = 'mytestapp', location = app_dir, resetbutton = FAL create_new_application(name = 'mytestapp', location = app_dir, rightsidebar = TRUE) # application with a right sidebar using a custom icon create_new_application(name = 'mytestapp', location = app_dir, rightsidebar = "table") -# application with a custom header bar color (skin) -create_new_application(name = 'mytestapp', location = app_dir, style = list(skin = "green")) +# application with a custom style file +create_new_application(name = 'mytestapp', location = app_dir, custom_theme_file = "periscope_style.yaml") ``` This generates a default blank application optionally with a left/right sidebar in a subdirectory named *mytestapp* @@ -410,8 +422,7 @@ output$example1 <- renderUI({ p("Some great explanatory text in my application")) }) -callModule(downloadFile, "ex_d1", ss_userAction.Log, "mydownload", - list(csv=get_ref_data)) +downloadFile("ex_d1", ss_userAction.Log, "mydownload", list(csv=get_ref_data)) observeEvent(input$exButton, { loginfo("exButton Pressed!", logger = ss_userAction.Log) @@ -456,6 +467,10 @@ needs. *(i.e. you would source a file in server_local.R to scope by user session, server_global.R to scope across all sessions, and global.R to scope across all sessions and UI)* +#### www/periscope_style.yaml + +Updated this file values and restart app to customize application different parts styles. +
# Additional Resources