+
+
+
+
+# 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