This pop-up can contain any valid html + code.
If you prefer to have the title + link to any valid url location by providing + a character string to the titleinfo + parameter in set_app_parameters(...) + in program/global.R file.
"), + loglevel = "DEBUG", + app_version = "1.0.0") +# -- PROGRAM -- diff --git a/tests/testthat/sample_app_both_sidebar/program/server_global.R b/tests/testthat/sample_app_both_sidebar/program/server_global.R new file mode 100644 index 0000000..bcc8a3d --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/program/server_global.R @@ -0,0 +1,41 @@ +# ---------------------------------------- +# -- PROGRAM server_global.R -- +# ---------------------------------------- +# USE: Server-specific variables and +# functions for the main reactive +# shiny server functionality. All +# code in this file will be put into +# the framework outside the call to +# shinyServer(function(input, output, session) +# in server.R +# +# NOTEs: +# - All variables/functions here are +# SERVER scoped and are available +# across all user sessions, but not to +# the UI. +# +# - For user session-scoped items +# put var/fxns in server_local.R +# +# FRAMEWORK VARIABLES +# none +# ---------------------------------------- + +# -- IMPORTS -- + + +# -- VARIABLES -- +sg_example_data <- read.csv("program/data/example.csv", + comment.char = c("#"), + stringsAsFactors = F) + #note - since this is an example, the dataset provided is a reference + # dataset. This file is being read in server_global.R, where you + # should only load data that will be available to ALL users/sessions. + # ** IMPORTANT ** + # Do not read user-specific data in this file or global.R, use + # server-local.R for user-specific (i.e. session-specific) data! + +# -- FUNCTIONS -- + + diff --git a/tests/testthat/sample_app_both_sidebar/program/server_local.R b/tests/testthat/sample_app_both_sidebar/program/server_local.R new file mode 100644 index 0000000..9ce6fee --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/program/server_local.R @@ -0,0 +1,277 @@ +# ---------------------------------------- +# -- PROGRAM server_local.R -- +# ---------------------------------------- +# USE: Session-specific variables and +# functions for the main reactive +# shiny server functionality. All +# code in this file will be put into +# the framework inside the call to +# shinyServer(function(input, output, session) +# in server.R +# +# NOTEs: +# - All variables/functions here are +# SESSION scoped and are ONLY +# available to a single session and +# not to the UI +# +# - For globally scoped session items +# put var/fxns in server_global.R +# +# FRAMEWORK VARIABLES +# input, output, session - Shiny +# ss_userAction.Log - Reactive Logger S4 object +# ---------------------------------------- + +# -- IMPORTS -- + + +# -- VARIABLES -- + + +# -- FUNCTIONS -- +source(paste("program", "fxn", "program_helpers.R", sep = .Platform$file.sep)) +source(paste("program", "fxn", "plots.R", sep = .Platform$file.sep)) + + +plot2_data <- reactive({ + result <- plot2ggplot_data() + if (!input$enableGGPlot) { + result <- NULL + } + result +}) + +plot2 <- reactive({ + result <- NULL + if (!is.null(plot2_data())) { + result <- plot2ggplot() + } + result +}) + +plot3_data <- reactive({ + result <- plot3lattice_data() + if (!input$enableLatticePlot) { + result <- NULL + } + result +}) + +plot3 <- reactive({ + result <- NULL + if (!is.null(plot3_data())) { + result <- plot3lattice() + } + result +}) + +# ---------------------------------------- +# -- SHINY SERVER CODE -- +# ---------------------------------------- + +# -- Initialize UI Elements +output$proginfo <- renderUI({ + list(p("All program-specific (i.e. application-specific) code should be ", + "modified/added in the ", strong("program subfolder"), + " of the framework"), + hr(), + p("Sidebar elements are setup and registered to the framework in ", + "program/ui_sidebar.R"), + p("UI body boxes (such as this one) are registered to the framework ", + "in program/ui_body.R."), + p("Rendering handles and reactivity are programmed in ", + "program/server_local.R for session-specific functionality. If ", + "application-wide functionality is useful across all users that ", + "should be added into server_global.R. Scoping information is in ", + "the top comment of all program example files.") ) + }) + +output$tooltips <- renderUI({ + list(hr(), + p(ui_tooltip(id = "ex1", + label = "Tooltips", + text = "Example tooltip text"), + "can be added with the following code in the UI:"), + p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) + }) + +output$busyind <- renderUI({ + list(hr(), + p("There is an automatic wait indicator in the navbar when the shiny ", + "server session is busy."), + div(align = "center", + bsButton("showWorking", + label = "Show application busy indicator for 5 seconds", + style = "primary")) ) + }) + +output$download <- renderUI({ + list( + hr(), + p("Data download buttons for single-option (no choice of format) or ", + "multiple choices of formats can be added by specifying the ", + "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)"), + "Single Download: ", + downloadFileButton("exampleDownload1", c("csv"), "csv"), + "Multiple-choice Download: ", + downloadFileButton("exampleDownload2", + c("csv", "xlsx", "tsv"), "Download options")) ) + }) + +output$alerts <- renderUI({ + list(hr(), + p("There are three standardized locations for alerts. To create ", + "an alert call the following on the server: ", + pre('S: createAlert(session, location, content = "Alert Text", ...)'), + 'LOCATION can be: "sidebarBasicAlert", "sidebarAdvancedAlert", "sidebarRightAlert", ', + 'and "bodyAlert". See the ', em("alertBS"), + "documentation for more information on styles and other options"), + div(align = "center", + bsButton( "exampleBasicAlert", + label = "Sidebar - Basic", + style = "success", + width = "25%"), + bsButton( "exampleAdvancedAlert", + label = "Sidebar - Advanced", + style = "warning", + width = "25%"), + bsButton( "exampleRightAlert", + label = "Sidebar - Right", + style = "danger", + width = "25%"), + bsButton( "exampleBodyAlert", + label = "Body", + style = "info", + append = FALSE, + width = "25%")) ) + }) + +output$loginfo <- renderUI({ + list(p("The collapsed ", + strong("User Action Log"), em("below"), + "is the standardized footer added by the framework.", + "To create actions to the framework call one of the logging ", + "functions like: ", + pre('logXXXX("Your Log Message with %s, %s parameters", parm1, parm2, logger = ss_userAction.Log)')), + p("The XXXX should be replaced by an actual log level like 'info', 'debug', 'warn' or 'error'. + The framework will handle updating the footer UI element every ", + "time the log is added to. It is important to note that the log ", + "rolls over for each session. The log files are kept in the ", + "/log directory and named 'actions.log'. ONE old copy of ", + "the log is kept as 'actions.log.last"), + p("See the ", em("logging"), "documentation for more information ", + "on functions and other options") ) + }) + +output$hover_info <- renderUI({ + hover <- input$examplePlot2_hover + point <- nearPoints(mtcars, hover, + xvar = "wt", yvar = "mpg", + maxpoints = 1) + if (nrow(point) == 0) { + return(NULL) + } + else { + left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) + left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) + + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) + top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) + + style <- paste0("position:absolute;", + "z-index:100;", + "background-color: rgba(245, 245, 245, 0.85); ", + "left:", left_px + 2, "px; top:", top_px + 2, "px;") + + return(wellPanel(class = "well-sm", + style = style, + HTML(" Car: ", rownames(point))) ) + } +}) + +# -- CanvasXpress Plot Example + +output$examplePlot1 <- renderCanvasXpress({ + result <- plot_htmlwidget() + if (!input$enableCXPlot) { + result <- canvasXpress(destroy = TRUE) + } + result +}) + +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) + +# -- Observe UI Changes +observeEvent(input$exampleBasicAlert, { + loginfo("Sidebar Basic Alert Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarBasicAlert", + style = "success", + content = "Example Basic Sidebar Alert") +}) + +observeEvent(input$exampleAdvancedAlert, { + loginfo("Sidebar Advanced Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarAdvancedAlert", + style = "warning", + content = "Example Advanced Sidebar Alert") + +}) + +observeEvent(input$exampleRightAlert, { + loginfo("Sidebar Right Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarRightAlert", + style = "danger", + content = "Example Right Sidebar Alert") + +}) + +observeEvent(input$exampleBodyAlert, { + loginfo("Body Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "bodyAlert", style = "info", append = FALSE, + content = paste("Example Body Alert - Append set to FALSE,", + "so only one alert will show")) +}) + +observeEvent(input$showWorking, { + loginfo("Show Busy Indicator Button Pushed", + logger = ss_userAction.Log) + Sys.sleep(5) +}) diff --git a/tests/testthat/sample_app_both_sidebar/program/ui_body.R b/tests/testthat/sample_app_both_sidebar/program/ui_body.R new file mode 100644 index 0000000..8a15e22 --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/program/ui_body.R @@ -0,0 +1,93 @@ +# ---------------------------------------- +# -- PROGRAM ui_body.R -- +# ---------------------------------------- +# USE: Create UI elements for the +# application body (right side on the +# desktop; contains output) and +# ATTACH them to the UI by calling +# add_ui_body() +# +# NOTEs: +# - All variables/functions here are +# not available to the UI or Server +# scopes - this is isolated +# ---------------------------------------- + +# -- IMPORTS -- + + +# ---------------------------------------- +# -- BODY ELEMENT CREATION -- +# ---------------------------------------- + +# -- Create Elements +body1 <- shinydashboard::box( id = "bodyElement1", + title = "Code Specifics and Examples", + width = 8, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("busyind"), + htmlOutput("tooltips"), + htmlOutput("alerts"), + htmlOutput("download")) + +body2 <- shinydashboard::box( id = "bodyElement2", + title = "Framework Information", + width = 4, + status = "success", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("proginfo") ) + +body3 <- shinydashboard::box( id = "bodyElement3", + title = "Downloadable Table", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + downloadableTableUI("exampleDT1", + list("csv", "tsv"), + "Download table data") ) + +body4 <- shinydashboard::box( id = "bodyElement4", + title = "CanvasXpress Plot", + width = 4, + status = "info", + collapsible = TRUE, + collapsed = FALSE, + canvasXpressOutput("examplePlot1")) + +plot2_hover <- hoverOpts(id = "examplePlot2_hover") + +body5 <- shinydashboard::box( id = "bodyElement5", + title = "downloadablePlots - ggplot2 & lattice", + width = 8, + status = "info", + collapsible = TRUE, + collapsed = FALSE, + fluidRow( + column(width = 6, downloadablePlotUI("examplePlot2", + list("jpeg", "csv"), + "Download plot or data", + btn_halign = "left", + btn_valign = "top", + btn_overlap = FALSE, + hoverOpts = plot2_hover)), + column(width = 6, downloadablePlotUI("examplePlot3", + list("png", "tiff", + "txt", "tsv"), + btn_overlap = FALSE, + "Download plot or data")) ), + uiOutput("hover_info") ) + +body6 <- shinydashboard::box( id = "bodyElement6", + title = "Logging Information", + width = 12, + status = "danger", + collapsible = FALSE, + htmlOutput("loginfo") ) + +# -- 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) diff --git a/tests/testthat/sample_app_no_sidebar/program/ui_sidebar.R b/tests/testthat/sample_app_both_sidebar/program/ui_sidebar.R similarity index 100% rename from tests/testthat/sample_app_no_sidebar/program/ui_sidebar.R rename to tests/testthat/sample_app_both_sidebar/program/ui_sidebar.R 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 new file mode 100644 index 0000000..6742ad0 --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/program/ui_sidebar_right.R @@ -0,0 +1,45 @@ +# ---------------------------------------- +# -- PROGRAM ui_sidebar_right.R -- +# ---------------------------------------- +# USE: Create UI elements for the +# application sidebar (right side on +# the desktop; contains options) and +# ATTACH them to the UI by calling +# add_ui_sidebar_right() +# +# NOTEs: +# - All variables/functions here are +# not available to the UI or Server +# scopes - this is isolated +# ---------------------------------------- + +# -- IMPORTS -- + + + +# ---------------------------------------- +# -- RIGHT SIDEBAR ELEMENT CREATION -- +# ---------------------------------------- + +# -- 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") + +# -- Register Basic Elements in the ORDER SHOWN in the UI +add_ui_sidebar_right(list(tab1, tab2, tab3)) diff --git a/tests/testthat/sample_app_both_sidebar/server.R b/tests/testthat/sample_app_both_sidebar/server.R new file mode 100644 index 0000000..954a840 --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/server.R @@ -0,0 +1,25 @@ +# ------------------------------------------------- +# -- FRAMEWORK server.R -- +# ------------------------------------------------- +# NOTEs: -- +# Program code goes in "program" directory files -- +# ------------------------------------------------- +# ***** DO NOT EDIT THIS FILE ***** -- +# ------------------------------------------------- + +source(paste("program", "server_global.R", sep = .Platform$file.sep), + local = TRUE) + + +shinyServer(function(input, output, session) { + ss_userAction.Log <- periscope:::fw_get_user_log() + + source(paste("program", "server_local.R", sep = .Platform$file.sep), + local = TRUE) + + periscope:::fw_server_setup(input, output, session, ss_userAction.Log) + + loginfo("%s started with log level <%s>", + periscope:::fw_get_title(), periscope:::fw_get_loglevel(), + logger = ss_userAction.Log) +}) diff --git a/tests/testthat/sample_app_both_sidebar/ui.R b/tests/testthat/sample_app_both_sidebar/ui.R new file mode 100644 index 0000000..c5227de --- /dev/null +++ b/tests/testthat/sample_app_both_sidebar/ui.R @@ -0,0 +1,26 @@ +# ------------------------------------------------- +# -- FRAMEWORK ui.R -- +# ------------------------------------------------- +# NOTEs: -- +# Program code goes in "program" directory files -- +# ------------------------------------------------- +# ***** DO NOT EDIT THIS FILE ***** -- +# ------------------------------------------------- + +library(shinydashboardPlus) + +periscope:::fw_reset_app_options() + +source(paste("program", "ui_sidebar.R", sep = .Platform$file.sep), + local = TRUE) +source(paste("program", "ui_sidebar_right.R", sep = .Platform$file.sep), + local = TRUE) +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) diff --git a/tests/testthat/sample_app_both_sidebar/www/img/loader.gif b/tests/testthat/sample_app_both_sidebar/www/img/loader.gif new file mode 100644 index 0000000..a259e22 Binary files /dev/null and b/tests/testthat/sample_app_both_sidebar/www/img/loader.gif differ diff --git a/tests/testthat/sample_app_both_sidebar/www/img/tooltip.png b/tests/testthat/sample_app_both_sidebar/www/img/tooltip.png new file mode 100644 index 0000000..eb7eeb3 Binary files /dev/null and b/tests/testthat/sample_app_both_sidebar/www/img/tooltip.png differ diff --git a/tests/testthat/sample_app_no_sidebar/program/fxn/plots.R b/tests/testthat/sample_app_no_sidebar/program/fxn/plots.R index d2b4283..20639a7 100644 --- a/tests/testthat/sample_app_no_sidebar/program/fxn/plots.R +++ b/tests/testthat/sample_app_no_sidebar/program/fxn/plots.R @@ -6,6 +6,7 @@ library(lattice) data(mtcars) mtcars$cyl <- factor(mtcars$cyl, levels = c(4,6,8), labels = c("4cyl", "6cyl", "8cyl")) +attr(mtcars, "show_rownames") <- TRUE # -- plotting functions 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 f05680f..5f3fb82 100644 --- a/tests/testthat/sample_app_no_sidebar/program/server_local.R +++ b/tests/testthat/sample_app_no_sidebar/program/server_local.R @@ -96,18 +96,9 @@ output$alerts <- renderUI({ p("There are three standardized locations for alerts. To create ", "an alert call the following on the server: ", pre('S: createAlert(session, location, content = "Alert Text", ...)'), - 'LOCATION can be: "sidebarBasicAlert", "sidebarAdvancedAlert", ', - 'and "bodyAlert". See the ', em("alertBS"), + 'LOCATION can be: "bodyAlert", See the ', em("alertBS"), "documentation for more information on styles and other options"), div(align = "center", - bsButton( "exampleBasicAlert", - label = "Sidebar - Basic", - style = "success", - width = "25%"), - bsButton( "exampleAdvancedAlert", - label = "Sidebar - Advanced", - style = "warning", - width = "25%"), bsButton( "exampleBodyAlert", label = "Body", style = "info", diff --git a/tests/testthat/sample_app_r_sidebar/global.R b/tests/testthat/sample_app_r_sidebar/global.R new file mode 100644 index 0000000..9407999 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/global.R @@ -0,0 +1,14 @@ +# ------------------------------------------------- +# -- FRAMEWORK global.R -- +# ------------------------------------------------- +# NOTEs: -- +# Program code goes in "program" directory files -- +# ------------------------------------------------- +# ***** DO NOT EDIT THIS FILE ***** -- +# ------------------------------------------------- + +library(periscope) +library(shinyBS) + + +source(paste("program", "global.R", sep = .Platform$file.sep), local = TRUE) diff --git a/tests/testthat/sample_app_r_sidebar/program/data/.gitignore b/tests/testthat/sample_app_r_sidebar/program/data/.gitignore new file mode 100644 index 0000000..94548af --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/data/.gitignore @@ -0,0 +1,3 @@ +* +*/ +!.gitignore diff --git a/tests/testthat/sample_app_r_sidebar/program/fxn/plots.R b/tests/testthat/sample_app_r_sidebar/program/fxn/plots.R new file mode 100644 index 0000000..20639a7 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/fxn/plots.R @@ -0,0 +1,58 @@ +library(ggplot2) +library(lattice) + + +# -- data for plots +data(mtcars) +mtcars$cyl <- factor(mtcars$cyl, levels = c(4,6,8), + labels = c("4cyl", "6cyl", "8cyl")) +attr(mtcars, "show_rownames") <- TRUE + + +# -- plotting functions + +plot2ggplot <- function() { + plot <- 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") + return(plot) +} + + +plot2ggplot_data <- function() { + return(mtcars) +} + + +plot3lattice <- function() { + plot <- xyplot(mpg ~ wt , data = mtcars, + pch = 1, groups = factor(cyl), + auto.key = list(corner = c(1, 1)), + main = "Lattice Example") + return(plot) +} + +plot3lattice_data <- function() { + return(mtcars) +} + + +plot_htmlwidget <- function(report_modus = FALSE) { + venn <- data.frame(A = 57, B = 12, C = 67, D = 72, AB = 4, + AC = 67, AD = 25, BC = 67, BD = 27, CD = 38, + ABC = 69, ABD = 28, ACD = 52, BCD = 46, ABCD = 3) + + htmlwidget <- canvasXpress(vennData = venn, + graphType = 'Venn', + vennGroups = 4, + vennLegend = list(A = "List1", B = "List2", C = "List3", D = "List4"), + title = "CanvasXpress Example", + disableToolbar = report_modus, + disableTouchToolbar = report_modus) + return(htmlwidget) +} 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 new file mode 100644 index 0000000..209068e --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/fxn/program_helpers.R @@ -0,0 +1,29 @@ +library(dplyr) + +df <- read.csv("program/data/example.csv", + strip.white = T, + comment.char = "#") + + +load_data1 <- function() { + ldf <- df %>% + filter(substr(Geographic.Area, 1, 1) == ".") %>% + mutate(Geographic.Area = substring(Geographic.Area, 2)) + + as.data.frame(ldf) +} + + +load_data2 <- function() { + ldf <- df %>% + filter(substr(Geographic.Area, 1, 1) != ".") + + as.data.frame(ldf) +} + +load_data3 <- function() { + ldf <- df %>% + select(1:3) + + as.data.frame(ldf) +} diff --git a/tests/testthat/sample_app_r_sidebar/program/global.R b/tests/testthat/sample_app_r_sidebar/program/global.R new file mode 100644 index 0000000..52cfc13 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/global.R @@ -0,0 +1,26 @@ +# ---------------------------------------- +# -- PROGRAM global.R -- +# ---------------------------------------- +# USE: Global variables and functions +# +# NOTEs: +# - All variables/functions here are +# globally scoped and will be available +# to server, UI and session scopes +# ---------------------------------------- + +# -- IMPORTS -- +library(canvasXpress) + +# -- Setup your Application -- +set_app_parameters(title = "Sample Title (click for an info pop-up)", + titleinfo = HTML("This pop-up can contain any valid html + code.
If you prefer to have the title + link to any valid url location by providing + a character string to the titleinfo + parameter in set_app_parameters(...) + in program/global.R file.
"), + loglevel = "DEBUG", + app_version = "1.0.0") +# -- PROGRAM -- diff --git a/tests/testthat/sample_app_r_sidebar/program/server_global.R b/tests/testthat/sample_app_r_sidebar/program/server_global.R new file mode 100644 index 0000000..bcc8a3d --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/server_global.R @@ -0,0 +1,41 @@ +# ---------------------------------------- +# -- PROGRAM server_global.R -- +# ---------------------------------------- +# USE: Server-specific variables and +# functions for the main reactive +# shiny server functionality. All +# code in this file will be put into +# the framework outside the call to +# shinyServer(function(input, output, session) +# in server.R +# +# NOTEs: +# - All variables/functions here are +# SERVER scoped and are available +# across all user sessions, but not to +# the UI. +# +# - For user session-scoped items +# put var/fxns in server_local.R +# +# FRAMEWORK VARIABLES +# none +# ---------------------------------------- + +# -- IMPORTS -- + + +# -- VARIABLES -- +sg_example_data <- read.csv("program/data/example.csv", + comment.char = c("#"), + stringsAsFactors = F) + #note - since this is an example, the dataset provided is a reference + # dataset. This file is being read in server_global.R, where you + # should only load data that will be available to ALL users/sessions. + # ** IMPORTANT ** + # Do not read user-specific data in this file or global.R, use + # server-local.R for user-specific (i.e. session-specific) data! + +# -- FUNCTIONS -- + + diff --git a/tests/testthat/sample_app_r_sidebar/program/server_local.R b/tests/testthat/sample_app_r_sidebar/program/server_local.R new file mode 100644 index 0000000..c3bd95a --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/server_local.R @@ -0,0 +1,264 @@ +# ---------------------------------------- +# -- PROGRAM server_local.R -- +# ---------------------------------------- +# USE: Session-specific variables and +# functions for the main reactive +# shiny server functionality. All +# code in this file will be put into +# the framework inside the call to +# shinyServer(function(input, output, session) +# in server.R +# +# NOTEs: +# - All variables/functions here are +# SESSION scoped and are ONLY +# available to a single session and +# not to the UI +# +# - For globally scoped session items +# put var/fxns in server_global.R +# +# FRAMEWORK VARIABLES +# input, output, session - Shiny +# ss_userAction.Log - Reactive Logger S4 object +# ---------------------------------------- + +# -- IMPORTS -- + + +# -- VARIABLES -- + + +# -- FUNCTIONS -- +source(paste("program", "fxn", "program_helpers.R", sep = .Platform$file.sep)) +source(paste("program", "fxn", "plots.R", sep = .Platform$file.sep)) + + +plot2_data <- reactive({ + result <- plot2ggplot_data() + if (!input$enableGGPlot) { + result <- NULL + } + result +}) + +plot2 <- reactive({ + result <- NULL + if (!is.null(plot2_data())) { + result <- plot2ggplot() + } + result +}) + +plot3_data <- reactive({ + result <- plot3lattice_data() + if (!input$enableLatticePlot) { + result <- NULL + } + result +}) + +plot3 <- reactive({ + result <- NULL + if (!is.null(plot3_data())) { + result <- plot3lattice() + } + result +}) + +# ---------------------------------------- +# -- SHINY SERVER CODE -- +# ---------------------------------------- + +# -- Initialize UI Elements +output$proginfo <- renderUI({ + list(p("All program-specific (i.e. application-specific) code should be ", + "modified/added in the ", strong("program subfolder"), + " of the framework"), + hr(), + p("Sidebar elements are setup and registered to the framework in ", + "program/ui_sidebar.R"), + p("UI body boxes (such as this one) are registered to the framework ", + "in program/ui_body.R."), + p("Rendering handles and reactivity are programmed in ", + "program/server_local.R for session-specific functionality. If ", + "application-wide functionality is useful across all users that ", + "should be added into server_global.R. Scoping information is in ", + "the top comment of all program example files.") ) + }) + +output$tooltips <- renderUI({ + list(hr(), + p(ui_tooltip(id = "ex1", + label = "Tooltips", + text = "Example tooltip text"), + "can be added with the following code in the UI:"), + p(pre("U: ui_tooltip('tooltipID', 'label text (optional)', 'text content')")) ) + }) + +output$busyind <- renderUI({ + list(hr(), + p("There is an automatic wait indicator in the navbar when the shiny ", + "server session is busy."), + div(align = "center", + bsButton("showWorking", + label = "Show application busy indicator for 5 seconds", + style = "primary")) ) + }) + +output$download <- renderUI({ + list( + hr(), + p("Data download buttons for single-option (no choice of format) or ", + "multiple choices of formats can be added by specifying the ", + "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)"), + "Single Download: ", + downloadFileButton("exampleDownload1", c("csv"), "csv"), + "Multiple-choice Download: ", + downloadFileButton("exampleDownload2", + c("csv", "xlsx", "tsv"), "Download options")) ) + }) + +output$alerts <- renderUI({ + list(hr(), + p("There are three standardized locations for alerts. 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"), + "documentation for more information on styles and other options"), + div(align = "center", + bsButton( "exampleBodyAlert", + label = "Body", + style = "info", + append = FALSE, + width = "25%")) ) +}) + +output$loginfo <- renderUI({ + list(p("The collapsed ", + strong("User Action Log"), em("below"), + "is the standardized footer added by the framework.", + "To create actions to the framework call one of the logging ", + "functions like: ", + pre('logXXXX("Your Log Message with %s, %s parameters", parm1, parm2, logger = ss_userAction.Log)')), + p("The XXXX should be replaced by an actual log level like 'info', 'debug', 'warn' or 'error'. + The framework will handle updating the footer UI element every ", + "time the log is added to. It is important to note that the log ", + "rolls over for each session. The log files are kept in the ", + "/log directory and named 'actions.log'. ONE old copy of ", + "the log is kept as 'actions.log.last"), + p("See the ", em("logging"), "documentation for more information ", + "on functions and other options") ) + }) + +output$hover_info <- renderUI({ + hover <- input$examplePlot2_hover + point <- nearPoints(mtcars, hover, + xvar = "wt", yvar = "mpg", + maxpoints = 1) + if (nrow(point) == 0) { + return(NULL) + } + else { + left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) + left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left) + + top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) + top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top) + + style <- paste0("position:absolute;", + "z-index:100;", + "background-color: rgba(245, 245, 245, 0.85); ", + "left:", left_px + 2, "px; top:", top_px + 2, "px;") + + return(wellPanel(class = "well-sm", + style = style, + HTML(" Car: ", rownames(point))) ) + } +}) + +# -- CanvasXpress Plot Example + +output$examplePlot1 <- renderCanvasXpress({ + result <- plot_htmlwidget() + if (!input$enableCXPlot) { + result <- canvasXpress(destroy = TRUE) + } + result +}) + +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) + +# -- Observe UI Changes +observeEvent(input$exampleBasicAlert, { + loginfo("Sidebar Basic Alert Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarBasicAlert", + style = "success", + content = "Example Basic Sidebar Alert") +}) + +observeEvent(input$exampleAdvancedAlert, { + loginfo("Sidebar Advanced Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarAdvancedAlert", + style = "warning", + content = "Example Advanced Sidebar Alert") + +}) + +observeEvent(input$exampleRightAlert, { + loginfo("Sidebar Right Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "sidebarRightAlert", + style = "danger", + content = "Example Right Sidebar Alert") + +}) + +observeEvent(input$exampleBodyAlert, { + loginfo("Body Alert Example Button Pushed", + logger = ss_userAction.Log) + createAlert(session, "bodyAlert", style = "info", append = FALSE, + content = paste("Example Body Alert - Append set to FALSE,", + "so only one alert will show")) +}) + +observeEvent(input$showWorking, { + loginfo("Show Busy Indicator Button Pushed", + logger = ss_userAction.Log) + Sys.sleep(5) +}) diff --git a/tests/testthat/sample_app_r_sidebar/program/ui_body.R b/tests/testthat/sample_app_r_sidebar/program/ui_body.R new file mode 100644 index 0000000..8a15e22 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/ui_body.R @@ -0,0 +1,93 @@ +# ---------------------------------------- +# -- PROGRAM ui_body.R -- +# ---------------------------------------- +# USE: Create UI elements for the +# application body (right side on the +# desktop; contains output) and +# ATTACH them to the UI by calling +# add_ui_body() +# +# NOTEs: +# - All variables/functions here are +# not available to the UI or Server +# scopes - this is isolated +# ---------------------------------------- + +# -- IMPORTS -- + + +# ---------------------------------------- +# -- BODY ELEMENT CREATION -- +# ---------------------------------------- + +# -- Create Elements +body1 <- shinydashboard::box( id = "bodyElement1", + title = "Code Specifics and Examples", + width = 8, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("busyind"), + htmlOutput("tooltips"), + htmlOutput("alerts"), + htmlOutput("download")) + +body2 <- shinydashboard::box( id = "bodyElement2", + title = "Framework Information", + width = 4, + status = "success", + collapsible = TRUE, + collapsed = TRUE, + htmlOutput("proginfo") ) + +body3 <- shinydashboard::box( id = "bodyElement3", + title = "Downloadable Table", + width = 12, + status = "primary", + collapsible = TRUE, + collapsed = TRUE, + downloadableTableUI("exampleDT1", + list("csv", "tsv"), + "Download table data") ) + +body4 <- shinydashboard::box( id = "bodyElement4", + title = "CanvasXpress Plot", + width = 4, + status = "info", + collapsible = TRUE, + collapsed = FALSE, + canvasXpressOutput("examplePlot1")) + +plot2_hover <- hoverOpts(id = "examplePlot2_hover") + +body5 <- shinydashboard::box( id = "bodyElement5", + title = "downloadablePlots - ggplot2 & lattice", + width = 8, + status = "info", + collapsible = TRUE, + collapsed = FALSE, + fluidRow( + column(width = 6, downloadablePlotUI("examplePlot2", + list("jpeg", "csv"), + "Download plot or data", + btn_halign = "left", + btn_valign = "top", + btn_overlap = FALSE, + hoverOpts = plot2_hover)), + column(width = 6, downloadablePlotUI("examplePlot3", + list("png", "tiff", + "txt", "tsv"), + btn_overlap = FALSE, + "Download plot or data")) ), + uiOutput("hover_info") ) + +body6 <- shinydashboard::box( id = "bodyElement6", + title = "Logging Information", + width = 12, + status = "danger", + collapsible = FALSE, + htmlOutput("loginfo") ) + +# -- 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) 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 new file mode 100644 index 0000000..6742ad0 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/program/ui_sidebar_right.R @@ -0,0 +1,45 @@ +# ---------------------------------------- +# -- PROGRAM ui_sidebar_right.R -- +# ---------------------------------------- +# USE: Create UI elements for the +# application sidebar (right side on +# the desktop; contains options) and +# ATTACH them to the UI by calling +# add_ui_sidebar_right() +# +# NOTEs: +# - All variables/functions here are +# not available to the UI or Server +# scopes - this is isolated +# ---------------------------------------- + +# -- IMPORTS -- + + + +# ---------------------------------------- +# -- RIGHT SIDEBAR ELEMENT CREATION -- +# ---------------------------------------- + +# -- 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") + +# -- Register Basic Elements in the ORDER SHOWN in the UI +add_ui_sidebar_right(list(tab1, tab2, tab3)) diff --git a/tests/testthat/sample_app_r_sidebar/server.R b/tests/testthat/sample_app_r_sidebar/server.R new file mode 100644 index 0000000..954a840 --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/server.R @@ -0,0 +1,25 @@ +# ------------------------------------------------- +# -- FRAMEWORK server.R -- +# ------------------------------------------------- +# NOTEs: -- +# Program code goes in "program" directory files -- +# ------------------------------------------------- +# ***** DO NOT EDIT THIS FILE ***** -- +# ------------------------------------------------- + +source(paste("program", "server_global.R", sep = .Platform$file.sep), + local = TRUE) + + +shinyServer(function(input, output, session) { + ss_userAction.Log <- periscope:::fw_get_user_log() + + source(paste("program", "server_local.R", sep = .Platform$file.sep), + local = TRUE) + + periscope:::fw_server_setup(input, output, session, ss_userAction.Log) + + loginfo("%s started with log level <%s>", + periscope:::fw_get_title(), periscope:::fw_get_loglevel(), + logger = ss_userAction.Log) +}) diff --git a/tests/testthat/sample_app_r_sidebar/ui.R b/tests/testthat/sample_app_r_sidebar/ui.R new file mode 100644 index 0000000..cfdc2ad --- /dev/null +++ b/tests/testthat/sample_app_r_sidebar/ui.R @@ -0,0 +1,24 @@ +# ------------------------------------------------- +# -- FRAMEWORK ui.R -- +# ------------------------------------------------- +# NOTEs: -- +# Program code goes in "program" directory files -- +# ------------------------------------------------- +# ***** DO NOT EDIT THIS FILE ***** -- +# ------------------------------------------------- + +library(shinydashboardPlus) + +periscope:::fw_reset_app_options() + +source(paste("program", "ui_sidebar_right.R", sep = .Platform$file.sep), + local = TRUE) +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) diff --git a/tests/testthat/sample_app_r_sidebar/www/img/loader.gif b/tests/testthat/sample_app_r_sidebar/www/img/loader.gif new file mode 100644 index 0000000..a259e22 Binary files /dev/null and b/tests/testthat/sample_app_r_sidebar/www/img/loader.gif differ diff --git a/tests/testthat/sample_app_r_sidebar/www/img/tooltip.png b/tests/testthat/sample_app_r_sidebar/www/img/tooltip.png new file mode 100644 index 0000000..eb7eeb3 Binary files /dev/null and b/tests/testthat/sample_app_r_sidebar/www/img/tooltip.png differ diff --git a/tests/testthat/test_convert_application.R b/tests/testthat/test_convert_application.R index 2170860..93ccb07 100644 --- a/tests/testthat/test_convert_application.R +++ b/tests/testthat/test_convert_application.R @@ -40,8 +40,17 @@ expect_converted_application <- function(location, right_sidebar = NULL, reset_b } # creates a temp directory, copies the sample_app to this directory and returns the path of the temp app -create_app_tmp_dir <- function(left_sidebar = TRUE) { - app_name <- ifelse(left_sidebar, "sample_app", "sample_app_no_sidebar") +create_app_tmp_dir <- function(left_sidebar = TRUE, right_sidebar = FALSE) { + app_name <- "sample_app" + + if (left_sidebar && right_sidebar) { + app_name <- "sample_app_both_sidebar" + } else if (!left_sidebar && right_sidebar) { + app_name <- "sample_app_r_sidebar" + } else if (!left_sidebar && !right_sidebar) { + app_name <- "sample_app_no_sidebar" + } + app_temp.dir <- tempdir() file.copy(app_name, app_temp.dir, recursive = TRUE) file.path(app_temp.dir, app_name) @@ -69,8 +78,15 @@ test_that("add_left_sidebar location does not contain an existing application", "Add left sidebar conversion could not proceed, location=<../testthat> does not contain a valid periscope application!") }) -test_that("add_left_sidebar valid location", { - app_location <- create_app_tmp_dir(left_sidebar = FALSE) +test_that("add_left_sidebar to r sidebar, valid location", { + app_location <- create_app_tmp_dir(left_sidebar = FALSE, right_sidebar = TRUE) + + expect_message(add_left_sidebar(location = app_location), "Add left sidebar conversion was successful. File\\(s\\) updated: ui.R") + expect_converted_application(location = app_location, left_sidebar = TRUE) +}) + +test_that("add_left_sidebar to no sidebars, valid location", { + app_location <- create_app_tmp_dir(left_sidebar = FALSE, right_sidebar = FALSE) expect_message(add_left_sidebar(location = app_location), "Add left sidebar conversion was successful. File\\(s\\) updated: ui.R") expect_converted_application(location = app_location, left_sidebar = TRUE) @@ -106,7 +122,7 @@ test_that("add_right_sidebar location does not contain an existing application", "Add right sidebar conversion could not proceed, location=<../testthat> does not contain a valid periscope application!") }) -test_that("add_right_sidebar valid location", { +test_that("add_right_sidebar to l sidebar", { app_location <- create_app_tmp_dir() expect_message(add_right_sidebar(location = app_location), "Add right sidebar conversion was successful. File\\(s\\) updated: ui.R") @@ -121,6 +137,20 @@ test_that("add_right_sidebar valid location, added twice", { expect_converted_application(location = app_location, right_sidebar = TRUE) }) +test_that("add_right_sidebar to no sidebars", { + app_location <- create_app_tmp_dir(left_sidebar = FALSE) + + expect_message(add_right_sidebar(location = app_location), "Add right sidebar conversion was successful. File\\(s\\) updated: ui.R") + expect_converted_application(location = app_location, right_sidebar = TRUE) +}) + +test_that("add_right_sidebar to r sidebar already present", { + app_location <- create_app_tmp_dir(left_sidebar = FALSE, right_sidebar = TRUE) + + expect_message(add_right_sidebar(location = app_location), "Right sidebar already available, no conversion needed") + expect_converted_application(location = app_location, right_sidebar = TRUE) +}) + ## remove_reset_button tests @@ -144,7 +174,7 @@ test_that("remove_reset_button location does not contain an existing application "Remove reset button conversion could not proceed, location=<../testthat> does not contain a valid periscope application!") }) -test_that("remove_reset_button valid location", { +test_that("remove_reset_button left sidebar", { app_location <- create_app_tmp_dir() expect_message(remove_reset_button(location = app_location), "Remove reset button conversion was successful. File\\(s\\) updated: ui.R") @@ -158,6 +188,19 @@ test_that("remove_reset_button valid location, remove twice", { expect_message(remove_reset_button(location = app_location), "Reset button already removed, no conversion needed") }) +test_that("remove_reset_button both sidebar", { + app_location <- create_app_tmp_dir(left_sidebar = TRUE, right_sidebar = TRUE) + + expect_message(remove_reset_button(location = app_location), "Remove reset button conversion was successful. File\\(s\\) updated: ui.R") + expect_converted_application(location = app_location, reset_button = FALSE) +}) + +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") +}) + ## add_reset_button tests test_that("add_reset_button null location", { diff --git a/tests/testthat/test_create_new_application.R b/tests/testthat/test_create_new_application.R index c39ed45..abc27d4 100755 --- a/tests/testthat/test_create_new_application.R +++ b/tests/testthat/test_create_new_application.R @@ -118,6 +118,25 @@ test_that("create_new_application custom style", { expect_cleanup_create_new_application(appTemp, skin = "green") }) +test_that("create_new_application bad 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 = list("green")), + "Framework creation could not proceed, invalid type for skin, only character allowed") +}) + +test_that("create_new_application custom style right sidebar", { + 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 = TRUE, style = list(skin = "green")), + "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) diff --git a/tests/testthat/test_ui_functions.R b/tests/testthat/test_ui_functions.R index 3ff0f4c..f623dc5 100755 --- a/tests/testthat/test_ui_functions.R +++ b/tests/testthat/test_ui_functions.R @@ -324,6 +324,11 @@ test_that("fw_create_right_sidebar", { }) test_that("add_ui_sidebar_right", { + result <- add_ui_sidebar_right(elementlist = NULL) + expect_null(result, "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") }) diff --git a/tests/testthat/test_ui_misc_functions.R b/tests/testthat/test_ui_misc_functions.R index 0d82649..39028e2 100755 --- a/tests/testthat/test_ui_misc_functions.R +++ b/tests/testthat/test_ui_misc_functions.R @@ -7,11 +7,17 @@ test_that("set_app_parameters", { expect_null(result, "set_app_parameters") }) -test_that("get_url_parameters", { +test_that("get_url_parameters - NULL", { result <- get_url_parameters(NULL) expect_equal(result, list(), "get_url_parameters") }) +test_that("get_url_parameters", { + fake_session <- list(clientData = list(url_search = "&test1=ABC&test2=123")) + result <- get_url_parameters(fake_session) + expect_equal(result, list(test1 = "ABC", test2 = "123"), "get_url_parameters") +}) + test_that("fw_get_loglevel", { result <- periscope:::fw_get_loglevel() expect_equal(result, "DEBUG")