From 10b1c3a2f1e0d38e20e84b03e838ed5635b181b4 Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Wed, 5 May 2021 22:14:48 +0100 Subject: [PATCH 1/9] Adding template for simple navbar page --- NAMESPACE | 4 ++ R/navbarPage.R | 147 ++++++++++++++++++++++++++++++++++++++++++++ man/navbar_menu.Rd | 22 +++++++ man/navbar_page.Rd | 68 ++++++++++++++++++++ man/tab_panel.Rd | 36 +++++++++++ man/tabset_panel.Rd | 16 +++++ 6 files changed, 293 insertions(+) create mode 100644 R/navbarPage.R create mode 100644 man/navbar_menu.Rd create mode 100644 man/navbar_page.Rd create mode 100644 man/tab_panel.Rd create mode 100644 man/tabset_panel.Rd diff --git a/NAMESPACE b/NAMESPACE index 04287eb1..da4bfe72 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -50,6 +50,8 @@ export(modal) export(modalDialog) export(multiple_checkbox) export(multiple_radio) +export(navbar_menu) +export(navbar_page) export(numericInput) export(numeric_input) export(progress) @@ -83,7 +85,9 @@ export(slider_input) export(splitLayout) export(split_layout) export(steps) +export(tab_panel) export(tabset) +export(tabset_panel) export(textAreaInput) export(textInput) export(text_input) diff --git a/R/navbarPage.R b/R/navbarPage.R new file mode 100644 index 00000000..f7eced8c --- /dev/null +++ b/R/navbarPage.R @@ -0,0 +1,147 @@ +#' Semantic UI page +#' +#' This creates a Semantic page for use in a Shiny app. +#' +#' Inside, it uses two crucial options: +#' +#' (1) \code{shiny.minified} with a logical value, tells whether it should attach min or full +#' semnatic css or js (TRUE by default). +#' (2) \code{shiny.custom.semantic} if this option has not NULL character \code{semanticPage} +#' takes dependencies from custom css and js files specified in this path +#' (NULL by default). Depending on \code{shiny.minified} value the folder should contain +#' either "min" or standard version. The folder should contain: \code{semantic.css} and +#' \code{semantic.js} files, or \code{semantic.min.css} and \code{semantic.min.js} +#' in \code{shiny.minified = TRUE} mode. +#' +#' @param ... Other arguments to be added as attributes of the main div tag +#' wrapper (e.g. style, class etc.) +#' @param title A title to display in the browser's title bar. +#' @param theme Theme name or path. Full list of supported themes you will find in +#' \code{SUPPORTED_THEMES} or at http://semantic-ui-forest.com/themes. +#' @param suppress_bootstrap boolean flag that supresses bootstrap when turned on +#' @param margin character with body margin size +#' @examples +#' ## Only run examples in interactive R sessions +#' if (interactive()) { +#' library(shiny) +#' library(shiny.semantic) +#' +#' ui <- semanticPage( +#' title = "Hello Shiny Semantic!", +#' tags$label("Number of observations:"), +#' slider_input("obs", value = 500, min = 0, max = 1000), +#' segment( +#' plotOutput("dist_plot") +#' ) +#' ) +#' +#' server <- function(input, output) { +#' output$dist_plot <- renderPlot({ +#' hist(rnorm(input$obs)) +#' }) +#' } +#' +#' shinyApp(ui, server) +#' } +#' +#' @export +navbar_page <- function(..., title = "", id = NULL, selected = NULL, + theme = NULL, suppress_bootstrap = TRUE) { + tabs <- list(...) + + menu_items <- lapply(tabs, navbar_menu_creator, selected = selected) + if (is.null(selected)) menu_items[[1]]$attribs$class <- "active item" + menu_header <- tags$nav( + div( + class = "ui sem menu", + div(class = "item", title), + menu_items + ) + ) + + menu_content <- lapply(tabs, navbar_content_creator, selected = selected) + if (is.null(selected)) menu_content[[1]]$attribs$class <- paste(menu_content[[1]]$attribs$class, "active") + + semanticPage( + menu_header, menu_content, + title = title, theme = theme, suppress_bootstrap = suppress_bootstrap, margin = 0 + ) +} + +navbar_menu_creator <- function(tab, selected = NULL) { + title <- tab$attribs$`data-title` + tab_id <- tab$attribs$`data-tab` + active <- if (identical(title, selected)) "active " else "" + + tags$a(class = paste0(active, "item"), `data-tab` = tab_id, title) +} + +navbar_content_creator <- function(tab, selected = NULL) { + title <- tab$attribs$`data-title` + if (identical(title, selected)) { + tab$attribs$class <- paste(tab$attribs$class, "active") + } + tab +} + +#' Navebar Menu +#' +#' @description +#' +#' @param title Display title for menu +#' @param ... \code{\link{tab_panel}} elements to include in the page. Can also include strings as section headers, +#' or "----" as a horizontal separator. +#' @param menu_name The value that is linked to the \code{navbar_menu} +#' @param icon Optional icon to appear on the tab. +#' This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}. +#' +#' @export +navbar_menu <- function(title, ..., menu_name = title, icon = NULL) { + structure( + list(title = title, menu_name = menu_name, tabs = list(...), icon = icon), + class = "ssnavmenu" + ) +} + +#' Tabset Panel +#' +#' @description +#' Create a tabset that contains \code{\link{tab_panel}}s. +#' +#' @export +tabset_panel <- function(..., id = NULL, selected = NULL, type = c("tabs", "pills", "hidden")) { + +} + +#' Tab Panel +#' +#' @description +#' Create a tab panel +#' +#' @param title Display title for tab +#' @param ... UI elements to include within the tab +#' @param value The value that should be sent when \code{\link{tabset_panel}} reports that this tab is selected. +#' If omitted and \code{\link{tabset_panel}} has an id, then the title will be used. +#' @param icon Optional icon to appear on the tab. +#' This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}. +#' +#' @return +#' A tab that can be passed to \code{\link{tabset_panel}}. +#' +#' @seealso \code{\link{tabset_panel}} +#' +#' @examples +#' tabset_panel( +#' tab_panel("Plot", shiny::plotOutput("plot")), +#' tab_panel("Summary", shiny::verbatimTextOutput("summary")), +#' tab_panel("Table", shiny::tableOutput("table")) +#' ) +#' +#' @export +tab_panel <- function(title, ..., value = title, icon = NULL) { + shiny::div( + class = "ui bottom attached tab segment", + `data-title` = title, `data-tab` = value, `data-icon` = icon, + ... + ) +} diff --git a/man/navbar_menu.Rd b/man/navbar_menu.Rd new file mode 100644 index 00000000..69cd8d8f --- /dev/null +++ b/man/navbar_menu.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarPage.R +\name{navbar_menu} +\alias{navbar_menu} +\title{Navebar Menu} +\usage{ +navbar_menu(title, ..., menu_name = title, icon = NULL) +} +\arguments{ +\item{title}{Display title for menu} + +\item{...}{\code{\link{tab_panel}} elements to include in the page. Can also include strings as section headers, +or "----" as a horizontal separator.} + +\item{menu_name}{The value that is linked to the \code{navbar_menu}} + +\item{icon}{Optional icon to appear on the tab. +This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}.} +} +\description{ + +} diff --git a/man/navbar_page.Rd b/man/navbar_page.Rd new file mode 100644 index 00000000..3f5e9238 --- /dev/null +++ b/man/navbar_page.Rd @@ -0,0 +1,68 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarPage.R +\name{navbar_page} +\alias{navbar_page} +\title{Semantic UI page} +\usage{ +navbar_page( + ..., + title = "", + id = NULL, + selected = NULL, + theme = NULL, + suppress_bootstrap = TRUE +) +} +\arguments{ +\item{...}{Other arguments to be added as attributes of the main div tag +wrapper (e.g. style, class etc.)} + +\item{title}{A title to display in the browser's title bar.} + +\item{theme}{Theme name or path. Full list of supported themes you will find in +\code{SUPPORTED_THEMES} or at http://semantic-ui-forest.com/themes.} + +\item{suppress_bootstrap}{boolean flag that supresses bootstrap when turned on} + +\item{margin}{character with body margin size} +} +\description{ +This creates a Semantic page for use in a Shiny app. +} +\details{ +Inside, it uses two crucial options: + +(1) \code{shiny.minified} with a logical value, tells whether it should attach min or full +semnatic css or js (TRUE by default). +(2) \code{shiny.custom.semantic} if this option has not NULL character \code{semanticPage} +takes dependencies from custom css and js files specified in this path +(NULL by default). Depending on \code{shiny.minified} value the folder should contain +either "min" or standard version. The folder should contain: \code{semantic.css} and +\code{semantic.js} files, or \code{semantic.min.css} and \code{semantic.min.js} +in \code{shiny.minified = TRUE} mode. +} +\examples{ +## Only run examples in interactive R sessions +if (interactive()) { +library(shiny) +library(shiny.semantic) + +ui <- semanticPage( + title = "Hello Shiny Semantic!", + tags$label("Number of observations:"), + slider_input("obs", value = 500, min = 0, max = 1000), + segment( + plotOutput("dist_plot") + ) +) + +server <- function(input, output) { + output$dist_plot <- renderPlot({ + hist(rnorm(input$obs)) + }) +} + +shinyApp(ui, server) +} + +} diff --git a/man/tab_panel.Rd b/man/tab_panel.Rd new file mode 100644 index 00000000..ccf2b64d --- /dev/null +++ b/man/tab_panel.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarPage.R +\name{tab_panel} +\alias{tab_panel} +\title{Tab Panel} +\usage{ +tab_panel(title, ..., value = title, icon = NULL) +} +\arguments{ +\item{title}{Display title for tab} + +\item{...}{UI elements to include within the tab} + +\item{value}{The value that should be sent when \code{\link{tabset_panel}} reports that this tab is selected. +If omitted and \code{\link{tabset_panel}} has an id, then the title will be used.} + +\item{icon}{Optional icon to appear on the tab. +This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}.} +} +\value{ +A tab that can be passed to \code{\link{tabset_panel}}. +} +\description{ +Create a tab panel +} +\examples{ +tabset_panel( + tab_panel("Plot", shiny::plotOutput("plot")), + tab_panel("Summary", shiny::verbatimTextOutput("summary")), + tab_panel("Table", shiny::tableOutput("table")) +) + +} +\seealso{ +\code{\link{tabset_panel}} +} diff --git a/man/tabset_panel.Rd b/man/tabset_panel.Rd new file mode 100644 index 00000000..09c78aa8 --- /dev/null +++ b/man/tabset_panel.Rd @@ -0,0 +1,16 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarPage.R +\name{tabset_panel} +\alias{tabset_panel} +\title{Tabset Panel} +\usage{ +tabset_panel( + ..., + id = NULL, + selected = NULL, + type = c("tabs", "pills", "hidden") +) +} +\description{ +Create a tabset that contains \code{\link{tab_panel}}s. +} From 36524c6ce2690857d32474b3ec610d49a6e6a402 Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Thu, 6 May 2021 19:53:35 +0100 Subject: [PATCH 2/9] Navbar menu now works in navbar page --- NAMESPACE | 1 - R/navbarPage.R | 68 +++++++++++++++++++---------- examples/navbar_page/app.R | 40 +++++++++++++++++ man/navbar_menu.Rd | 2 +- man/tabset_panel.Rd | 16 ------- man/update_multiple_checkbox.Rd | 76 +++++++++++++++++++++++++++++++++ man/update_numeric_input.Rd | 2 +- 7 files changed, 164 insertions(+), 41 deletions(-) create mode 100644 examples/navbar_page/app.R delete mode 100644 man/tabset_panel.Rd create mode 100644 man/update_multiple_checkbox.Rd diff --git a/NAMESPACE b/NAMESPACE index da4bfe72..a65dc496 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -87,7 +87,6 @@ export(split_layout) export(steps) export(tab_panel) export(tabset) -export(tabset_panel) export(textAreaInput) export(textInput) export(text_input) diff --git a/R/navbarPage.R b/R/navbarPage.R index f7eced8c..b5b0f9b7 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -48,19 +48,18 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, theme = NULL, suppress_bootstrap = TRUE) { tabs <- list(...) + if (is.null(selected)) selected <- get_first_tab(tabs) menu_items <- lapply(tabs, navbar_menu_creator, selected = selected) - if (is.null(selected)) menu_items[[1]]$attribs$class <- "active item" menu_header <- tags$nav( div( - class = "ui sem menu", + class = "ui stackable menu sem", div(class = "item", title), menu_items ) ) menu_content <- lapply(tabs, navbar_content_creator, selected = selected) - if (is.null(selected)) menu_content[[1]]$attribs$class <- paste(menu_content[[1]]$attribs$class, "active") semanticPage( menu_header, menu_content, @@ -69,22 +68,57 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, } navbar_menu_creator <- function(tab, selected = NULL) { - title <- tab$attribs$`data-title` - tab_id <- tab$attribs$`data-tab` - active <- if (identical(title, selected)) "active " else "" + if (inherits(tab, "ssnavmenu")) { + dropdown_menu( + tab$title, + tags$i(class = "dropdown icon"), + div(class = "menu", lapply(tab$tabs, navbar_menu_creator, selected = selected)), + name = generate_random_id("nav-menu"), + is_menu_item = TRUE + ) + } else if (is.character(tab)) { + if (grepl("^(-|_){4,}$", tab)) menu_divider() else div(class = "header", tab) + } else { + title <- tab$attribs$`data-title` + icon <- tab$attribs$`data-icon` + tab_id <- tab$attribs$`data-tab` + class <- paste0(if (identical(title, selected)) "active " else "", "item") - tags$a(class = paste0(active, "item"), `data-tab` = tab_id, title) + tags$a( + class = class, + `data-tab` = tab_id, + if (!is.null(icon)) tags$i(class = paste(icon, "icon")), + if (!(!is.null(icon) && title == "")) title + ) + } } navbar_content_creator <- function(tab, selected = NULL) { - title <- tab$attribs$`data-title` - if (identical(title, selected)) { - tab$attribs$class <- paste(tab$attribs$class, "active") + if (inherits(tab, "ssnavmenu")) { + tagList(lapply(tab$tabs, navbar_content_creator, selected = selected)) + } else if (is.character(tab)) { + NULL + } else { + title <- tab$attribs$`data-title` + + if (identical(title, selected)) { + tab$attribs$class <- paste(tab$attribs$class, "active") + } + tab + } +} + +get_first_tab <- function(tabs, i = 1) { + if (inherits(tabs[[i]], "ssnavmenu")) { + get_first_tab(tabs[[i]]$tabs, i) + } else if (is.character(tabs[[i]])) { + get_first_tab(tabs, i + 1) + } else { + tabs[[i]]$attribs$`data-title` } - tab } -#' Navebar Menu +#' Navbar Menu #' #' @description #' @@ -103,16 +137,6 @@ navbar_menu <- function(title, ..., menu_name = title, icon = NULL) { ) } -#' Tabset Panel -#' -#' @description -#' Create a tabset that contains \code{\link{tab_panel}}s. -#' -#' @export -tabset_panel <- function(..., id = NULL, selected = NULL, type = c("tabs", "pills", "hidden")) { - -} - #' Tab Panel #' #' @description diff --git a/examples/navbar_page/app.R b/examples/navbar_page/app.R new file mode 100644 index 00000000..dd703fec --- /dev/null +++ b/examples/navbar_page/app.R @@ -0,0 +1,40 @@ +library(shiny) +library(shiny.semantic) + +ui <- navbar_page( + title = "Hello Shiny Semantic!", + tab_panel( + "Content", + tags$label("Number of observations:"), + slider_input("obs", value = 500, min = 0, max = 1000), + segment( + plotOutput("dist_plot") + ) + ), + tab_panel( + "Icon", icon = "r project", + "A tab with an icon in the menu" + ), + tab_panel( + "A Very Long Tab Name", + "Example of a tab name which is very long", + dropdown_input("letters", LETTERS) + ), + navbar_menu( + "Menu", + "Section 1", + tab_panel("Part 1", h3("Section 1 - Part 1"), value = "sec1_part1"), + "----", + "Section 2", + tab_panel("Part 1", h3("Section 2 - Part 1"), value = "sec2_part1"), + tab_panel("Part 2") + ) +) + +server <- function(input, output) { + output$dist_plot <- renderPlot({ + hist(rnorm(input$obs)) + }) +} + +shinyApp(ui, server) diff --git a/man/navbar_menu.Rd b/man/navbar_menu.Rd index 69cd8d8f..945b6a19 100644 --- a/man/navbar_menu.Rd +++ b/man/navbar_menu.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/navbarPage.R \name{navbar_menu} \alias{navbar_menu} -\title{Navebar Menu} +\title{Navbar Menu} \usage{ navbar_menu(title, ..., menu_name = title, icon = NULL) } diff --git a/man/tabset_panel.Rd b/man/tabset_panel.Rd deleted file mode 100644 index 09c78aa8..00000000 --- a/man/tabset_panel.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/navbarPage.R -\name{tabset_panel} -\alias{tabset_panel} -\title{Tabset Panel} -\usage{ -tabset_panel( - ..., - id = NULL, - selected = NULL, - type = c("tabs", "pills", "hidden") -) -} -\description{ -Create a tabset that contains \code{\link{tab_panel}}s. -} diff --git a/man/update_multiple_checkbox.Rd b/man/update_multiple_checkbox.Rd new file mode 100644 index 00000000..726c2f41 --- /dev/null +++ b/man/update_multiple_checkbox.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkbox.R +\name{update_multiple_checkbox} +\alias{update_multiple_checkbox} +\alias{update_multiple_radio} +\title{Update checkbox Semantic UI component} +\usage{ +update_multiple_checkbox( + session = getDefaultReactiveDomain(), + input_id, + choices = NULL, + choices_value = choices, + selected = NULL, + label = NULL +) + +update_multiple_radio( + session = getDefaultReactiveDomain(), + input_id, + choices = NULL, + choices_value = choices, + selected = NULL, + label = NULL +) +} +\arguments{ +\item{session}{The \code{session} object passed to function given to \code{shinyServer}.} + +\item{input_id}{The id of the input object} + +\item{choices}{All available options one can select from. If no need to update then leave as \code{NULL}} + +\item{choices_value}{What reactive value should be used for corresponding choice.} + +\item{label}{The label linked to the input} + +\item{value}{The initially selected value.} +} +\description{ +Change the value of a \code{\link{multiple_checkbox}} input on the client. +} +\examples{ +if (interactive()) { + +library(shiny) +library(shiny.semantic) + +ui <- function() { + shinyUI( + semanticPage( + title = "Checkbox example", + form( + multiple_checkbox( + "simple_checkbox", "Letters:", LETTERS[1:5], selected = c("A", "C"), type = "slider" + ) + ), + p("Selected letter:"), + textOutput("selected_letter"), + shiny.semantic::actionButton("simple_button", "Update input to D") + ) + ) +} + +server <- shinyServer(function(input, output, session) { + output$selected_letter <- renderText(paste(input[["simple_checkbox"]], collapse = ", ")) + + observeEvent(input$simple_button, { + update_multiple_checkbox(session, "simple_checkbox", selected = "D") + }) +}) + +shinyApp(ui = ui(), server = server) + +} + +} diff --git a/man/update_numeric_input.Rd b/man/update_numeric_input.Rd index 1b2f4446..4e37fb64 100644 --- a/man/update_numeric_input.Rd +++ b/man/update_numeric_input.Rd @@ -16,7 +16,7 @@ update_numeric_input( ) updateNumericInput( - session, + session = getDefaultReactiveDomain(), inputId, label = NULL, value = NULL, From 4d970b54a6def199a0248ffcbae8c55c45cef2ea Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Thu, 6 May 2021 21:20:39 +0100 Subject: [PATCH 3/9] Add collapsibility to navbar_page --- R/navbarPage.R | 34 +++++++++++++++++++++++++--------- R/semanticPage.R | 2 ++ examples/navbar_page/app.R | 5 ++--- inst/www/shiny-semantic.css | 18 ++++++++++++++++++ inst/www/shiny-semantic.js | 17 +++++++++++++++++ man/navbar_page.Rd | 6 ++++++ 6 files changed, 70 insertions(+), 12 deletions(-) create mode 100644 inst/www/shiny-semantic.css create mode 100644 inst/www/shiny-semantic.js diff --git a/R/navbarPage.R b/R/navbarPage.R index b5b0f9b7..4f36cdf9 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -46,15 +46,29 @@ #' #' @export navbar_page <- function(..., title = "", id = NULL, selected = NULL, - theme = NULL, suppress_bootstrap = TRUE) { + position = c("", "top fixed", "bottom fixed"), + header = NULL, footer = NULL, + collapsible = FALSE, window_title = title, + menu_class = NULL, theme = NULL, suppress_bootstrap = TRUE) { tabs <- list(...) + position <- match.arg(position) if (is.null(selected)) selected <- get_first_tab(tabs) + if (collapsible) { + collapse_icon <- tags$button( + class = "ui basic icon button collapsed-hamburger-icon", + tags$i(class = "hamburger icon") + ) + } else { + collapse_icon <- NULL + } + menu_items <- lapply(tabs, navbar_menu_creator, selected = selected) menu_header <- tags$nav( div( - class = "ui stackable menu sem", - div(class = "item", title), + class = paste("ui navbar-page-menu", position, menu_class, "stackable menu sem"), + id = id, + div(class = "item", title, collapse_icon), menu_items ) ) @@ -62,19 +76,21 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, menu_content <- lapply(tabs, navbar_content_creator, selected = selected) semanticPage( - menu_header, menu_content, - title = title, theme = theme, suppress_bootstrap = suppress_bootstrap, margin = 0 + menu_header, tags$header(header), tags$main(menu_content), tags$footer(footer), + # shiny::tags$script(src = "shiny.semantic/shiny-semantic.js"), + title = window_title, theme = theme, suppress_bootstrap = suppress_bootstrap, margin = 0 ) } navbar_menu_creator <- function(tab, selected = NULL) { if (inherits(tab, "ssnavmenu")) { dropdown_menu( - tab$title, + id = tab$menu_name, + name = tab$title, tags$i(class = "dropdown icon"), div(class = "menu", lapply(tab$tabs, navbar_menu_creator, selected = selected)), - name = generate_random_id("nav-menu"), - is_menu_item = TRUE + is_menu_item = TRUE, + class = "navbar-collapisble-item" ) } else if (is.character(tab)) { if (grepl("^(-|_){4,}$", tab)) menu_divider() else div(class = "header", tab) @@ -85,7 +101,7 @@ navbar_menu_creator <- function(tab, selected = NULL) { class <- paste0(if (identical(title, selected)) "active " else "", "item") tags$a( - class = class, + class = paste("navbar-collapisble-item", class), `data-tab` = tab_id, if (!is.null(icon)) tags$i(class = paste(icon, "icon")), if (!(!is.null(icon) && title == "")) title diff --git a/R/semanticPage.R b/R/semanticPage.R index 8500cdb2..d6deac5f 100644 --- a/R/semanticPage.R +++ b/R/semanticPage.R @@ -159,6 +159,8 @@ semanticPage <- function(..., title = "", theme = NULL, suppress_bootstrap = TRU get_dependencies(theme), shiny::tags$title(title), shiny::tags$meta(name = "viewport", content = "width=device-width, initial-scale=1.0"), + shiny::tags$link(rel = "stylesheet", type = "text/css", href = "shiny.semantic/shiny-semantic.css"), + shiny::tags$script(src = "shiny.semantic/shiny-semantic.js"), shiny::tags$link(rel = "stylesheet", type = "text/css", href = "shiny.semantic/shiny-semantic-DT.css"), shiny::tags$script(src = "shiny.semantic/shiny-semantic-modal.js"), diff --git a/examples/navbar_page/app.R b/examples/navbar_page/app.R index dd703fec..253320fe 100644 --- a/examples/navbar_page/app.R +++ b/examples/navbar_page/app.R @@ -2,11 +2,10 @@ library(shiny) library(shiny.semantic) ui <- navbar_page( - title = "Hello Shiny Semantic!", + title = "Hello Shiny Semantic!", collapsible = TRUE, tab_panel( "Content", - tags$label("Number of observations:"), - slider_input("obs", value = 500, min = 0, max = 1000), + numeric_input("obs", "Number of observations:", value = 500, min = 0, max = 1000), segment( plotOutput("dist_plot") ) diff --git a/inst/www/shiny-semantic.css b/inst/www/shiny-semantic.css new file mode 100644 index 00000000..01fb3003 --- /dev/null +++ b/inst/www/shiny-semantic.css @@ -0,0 +1,18 @@ +/* Navbar Page Visibility */ +@media only screen and (min-width: 768px) { + .navbar-page-menu .collapsed-hamburger-icon { + display: none!important; + } +} + +.ui.menu.navbar-page-menu .item>.collapsed-hamburger-icon { + position: absolute; + right: 0; + top: 0; + margin-right: 1px; + margin-top: 1px; +} + +.ui.menu .item.hidden.navbar-collapisble-item { + display: none; +} diff --git a/inst/www/shiny-semantic.js b/inst/www/shiny-semantic.js new file mode 100644 index 00000000..007f9b8f --- /dev/null +++ b/inst/www/shiny-semantic.js @@ -0,0 +1,17 @@ +$(document).ready(function() { + $('.collapsed-hamburger-icon').on('click', function() { + $('.navbar-collapisble-item').transition('fade down'); +}); + + if (window.innerWidth < 768) { + $('.navbar-collapisble-item').transition('hide'); + } + + window.addEventListener('resize', function(event) { + if (window.innerWidth >= 768) { + $('.navbar-collapisble-item').transition('show'); + } else { + $('.navbar-collapisble-item').transition('hide'); + } +}, true); +}); diff --git a/man/navbar_page.Rd b/man/navbar_page.Rd index 3f5e9238..8c80766e 100644 --- a/man/navbar_page.Rd +++ b/man/navbar_page.Rd @@ -9,6 +9,12 @@ navbar_page( title = "", id = NULL, selected = NULL, + position = c("", "top fixed", "bottom fixed"), + header = NULL, + footer = NULL, + collapsible = FALSE, + window_title = title, + menu_class = NULL, theme = NULL, suppress_bootstrap = TRUE ) From ab8f7f36d717be153adc8839f43865891dc619e7 Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Thu, 6 May 2021 21:22:01 +0100 Subject: [PATCH 4/9] Reindent JS lines --- inst/www/shiny-semantic.js | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/inst/www/shiny-semantic.js b/inst/www/shiny-semantic.js index 007f9b8f..4c19facb 100644 --- a/inst/www/shiny-semantic.js +++ b/inst/www/shiny-semantic.js @@ -1,17 +1,17 @@ $(document).ready(function() { $('.collapsed-hamburger-icon').on('click', function() { - $('.navbar-collapisble-item').transition('fade down'); -}); + $('.navbar-collapisble-item').transition('fade down'); + }); if (window.innerWidth < 768) { $('.navbar-collapisble-item').transition('hide'); } window.addEventListener('resize', function(event) { - if (window.innerWidth >= 768) { - $('.navbar-collapisble-item').transition('show'); - } else { - $('.navbar-collapisble-item').transition('hide'); - } -}, true); + if (window.innerWidth >= 768) { + $('.navbar-collapisble-item').transition('show'); + } else { + $('.navbar-collapisble-item').transition('hide'); + } + }, true); }); From 1a6f0196c8ad1d66b65f0d540f5bbefea8a2c96d Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Sun, 9 May 2021 16:33:23 +0100 Subject: [PATCH 5/9] Updating example app and documentation --- R/navbarPage.R | 118 +++++++++++++++++++++++-------------- examples/navbar_page/app.R | 38 ++++++++---- man/navbar_menu.Rd | 14 ++++- man/navbar_page.Rd | 73 ++++++++++++++--------- man/tab_panel.Rd | 20 +++++-- 5 files changed, 174 insertions(+), 89 deletions(-) diff --git a/R/navbarPage.R b/R/navbarPage.R index 4f36cdf9..e28b5485 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -1,7 +1,10 @@ -#' Semantic UI page +#' Semantic UI page with top level navigation bar #' -#' This creates a Semantic page for use in a Shiny app. +#' @description +#' This creates a Semantic page for use in a Shiny app. It is in the same layout as \code{\link[shiny]{navbarPage}}, +#' where a top level navigation bar exists. #' +#' @details #' Inside, it uses two crucial options: #' #' (1) \code{shiny.minified} with a logical value, tells whether it should attach min or full @@ -13,46 +16,61 @@ #' \code{semantic.js} files, or \code{semantic.min.css} and \code{semantic.min.js} #' in \code{shiny.minified = TRUE} mode. #' -#' @param ... Other arguments to be added as attributes of the main div tag -#' wrapper (e.g. style, class etc.) -#' @param title A title to display in the browser's title bar. +#' @param ... Other arguments to be added as attributes of the main div tag wrapper (e.g. style, class etc.) +#' @param title A title to display in the navbar. +#' @param id ID of the navbar menu. Given random ID if none specified. +#' @param selected Which tab should be selected first? If none selected, will automatically have the first tab open. +#' @param position Determines the location and behaviour of the navbar. Padding will be included when pinned to prevent +#' overlap. +#' \itemize{ +#' \item{""}{Default. Top of page, and goes out of view when scrolling} +#' \item{"top fixed"}{Top of page, pinned when scrolling} +#' \item{"bottom fixed"}{Bottom of page, pinned when scrolling} +#' } +#' @param header Optional list of tags to be added to the top of all \code{tab_panel}s. +#' @param footer Optional list of tags to be added to the bottom of all \code{tab_panel}s. +#' @param collapsible \code{TRUE} to automatically collapse the navigation elements into a menu when the width of the +#' browser is less than 768 pixels (useful for viewing on smaller touchscreen device) +#' @param window_title A title to display in the browser's title bar. By default it will be the same as the navbar +#' title. +#' @param type Class to be given to the navbar menu. #' @param theme Theme name or path. Full list of supported themes you will find in #' \code{SUPPORTED_THEMES} or at http://semantic-ui-forest.com/themes. #' @param suppress_bootstrap boolean flag that supresses bootstrap when turned on -#' @param margin character with body margin size +#' #' @examples -#' ## Only run examples in interactive R sessions -#' if (interactive()) { -#' library(shiny) -#' library(shiny.semantic) -#' -#' ui <- semanticPage( -#' title = "Hello Shiny Semantic!", -#' tags$label("Number of observations:"), -#' slider_input("obs", value = 500, min = 0, max = 1000), -#' segment( -#' plotOutput("dist_plot") -#' ) +#' navbar_page( +#' "App Title", +#' tab_panel("Plot"), +#' tab_panel("Summary"), +#' tab_panel("Table") #' ) #' -#' server <- function(input, output) { -#' output$dist_plot <- renderPlot({ -#' hist(rnorm(input$obs)) -#' }) -#' } -#' -#' shinyApp(ui, server) -#' } +#' navbar_page( +#' "App Title", +#' tab_panel("Plot"), +#' tab_panel("Icon", icon = "r project"), +#' navbar_menu( +#' "More", +#' tab_panel("Summary"), +#' "----", +#' "Section header", +#' tab_panel("Table") +#' ) +#' ) #' #' @export navbar_page <- function(..., title = "", id = NULL, selected = NULL, position = c("", "top fixed", "bottom fixed"), header = NULL, footer = NULL, collapsible = FALSE, window_title = title, - menu_class = NULL, theme = NULL, suppress_bootstrap = TRUE) { + type = "stackable", theme = NULL, suppress_bootstrap = TRUE) { tabs <- list(...) position <- match.arg(position) + # Padding depending on the position + body_padding <- switch(position, "top fixed" = "padding-top: 40px;", "bottom fixed" = "padding-bottom: 40px;", "") if (is.null(selected)) selected <- get_first_tab(tabs) + if (is.null(id)) id <- generate_random_id("navbar_menu") if (collapsible) { collapse_icon <- tags$button( @@ -63,12 +81,15 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, collapse_icon <- NULL } - menu_items <- lapply(tabs, navbar_menu_creator, selected = selected) + menu_items <- c( + list(div(class = "item", title, collapse_icon)), + lapply(tabs, navbar_menu_creator, selected = selected) + ) + menu_header <- tags$nav( div( - class = paste("ui navbar-page-menu", position, menu_class, "stackable menu sem"), + class = paste("ui navbar-page-menu", position, type, "menu sem"), id = id, - div(class = "item", title, collapse_icon), menu_items ) ) @@ -76,8 +97,8 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, menu_content <- lapply(tabs, navbar_content_creator, selected = selected) semanticPage( - menu_header, tags$header(header), tags$main(menu_content), tags$footer(footer), - # shiny::tags$script(src = "shiny.semantic/shiny-semantic.js"), + menu_header, + div(style = body_padding, tags$header(header), tags$main(menu_content), tags$footer(footer)), title = window_title, theme = theme, suppress_bootstrap = suppress_bootstrap, margin = 0 ) } @@ -85,7 +106,7 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, navbar_menu_creator <- function(tab, selected = NULL) { if (inherits(tab, "ssnavmenu")) { dropdown_menu( - id = tab$menu_name, + id = tab$id, name = tab$title, tags$i(class = "dropdown icon"), div(class = "menu", lapply(tab$tabs, navbar_menu_creator, selected = selected)), @@ -137,18 +158,28 @@ get_first_tab <- function(tabs, i = 1) { #' Navbar Menu #' #' @description +#' Create a dropdown menu for a \code{\link{navbar_page}}. #' #' @param title Display title for menu #' @param ... \code{\link{tab_panel}} elements to include in the page. Can also include strings as section headers, #' or "----" as a horizontal separator. -#' @param menu_name The value that is linked to the \code{navbar_menu} +#' @param id The ID of the \code{navbar_menu} #' @param icon Optional icon to appear on the tab. #' This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}. #' +#' @examples +#' navbar_menu( +#' "Menu", +#' tab_panel("Summary", shiny::plotOutput("plot")), +#' "----", +#' "Section header", +#' tab_panel("Table", shiny::tableOutput("table")) +#' ) +#' #' @export -navbar_menu <- function(title, ..., menu_name = title, icon = NULL) { +navbar_menu <- function(title, ..., id = title, icon = NULL) { structure( - list(title = title, menu_name = menu_name, tabs = list(...), icon = icon), + list(title = title, id = id, tabs = list(...), icon = icon), class = "ssnavmenu" ) } @@ -160,27 +191,28 @@ navbar_menu <- function(title, ..., menu_name = title, icon = NULL) { #' #' @param title Display title for tab #' @param ... UI elements to include within the tab -#' @param value The value that should be sent when \code{\link{tabset_panel}} reports that this tab is selected. -#' If omitted and \code{\link{tabset_panel}} has an id, then the title will be used. +#' @param value The value that should be sent when \code{\link{navbar_menu}} reports that this tab is selected. +#' If omitted and \code{\link{navbar_menu}} has an id, then the title will be used. #' @param icon Optional icon to appear on the tab. #' This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}. +#' @param type Change depending what type of tab is wanted. Default is \code{bottom attached segment}. #' #' @return -#' A tab that can be passed to \code{\link{tabset_panel}}. +#' A tab that can be passed to \code{\link{navbar_menu}}. #' -#' @seealso \code{\link{tabset_panel}} +#' @seealso \code{\link{navbar_menu}} #' #' @examples -#' tabset_panel( +#' navbar_menu( #' tab_panel("Plot", shiny::plotOutput("plot")), #' tab_panel("Summary", shiny::verbatimTextOutput("summary")), #' tab_panel("Table", shiny::tableOutput("table")) #' ) #' #' @export -tab_panel <- function(title, ..., value = title, icon = NULL) { +tab_panel <- function(title, ..., value = title, icon = NULL, type = "bottom attached segment") { shiny::div( - class = "ui bottom attached tab segment", + class = paste("ui tab", type), `data-title` = title, `data-tab` = value, `data-icon` = icon, ... ) diff --git a/examples/navbar_page/app.R b/examples/navbar_page/app.R index 253320fe..228a1671 100644 --- a/examples/navbar_page/app.R +++ b/examples/navbar_page/app.R @@ -2,31 +2,44 @@ library(shiny) library(shiny.semantic) ui <- navbar_page( - title = "Hello Shiny Semantic!", collapsible = TRUE, + title = "Hello Shiny Semantic!", + # id = "page_navbar", + collapsible = TRUE, + tab_panel( - "Content", + title = "Content", numeric_input("obs", "Number of observations:", value = 500, min = 0, max = 1000), - segment( - plotOutput("dist_plot") - ) + segment(plotOutput("dist_plot")) ), tab_panel( - "Icon", icon = "r project", + title = "Icon", + icon = "r project", "A tab with an icon in the menu" ), tab_panel( - "A Very Long Tab Name", + title = "A Very Long Tab Name", "Example of a tab name which is very long", - dropdown_input("letters", LETTERS) + form(field(tags$label("Test dropdown"), dropdown_input("letters", LETTERS))), + segment("Letter chosen:", textOutput("letter", inline = TRUE)) ), navbar_menu( "Menu", "Section 1", - tab_panel("Part 1", h3("Section 1 - Part 1"), value = "sec1_part1"), + tab_panel( + title = "Part 1", + value = "sec1_part1", + segment("Number chosen:", textOutput("number", inline = TRUE)) + ), "----", "Section 2", - tab_panel("Part 1", h3("Section 2 - Part 1"), value = "sec2_part1"), - tab_panel("Part 2") + tab_panel( + title = "Part 1", + value = "sec2_part1", + h3("Section 2 - Part 1") + ), + tab_panel( + title = "Part 2" + ) ) ) @@ -34,6 +47,9 @@ server <- function(input, output) { output$dist_plot <- renderPlot({ hist(rnorm(input$obs)) }) + + output$letter <- renderText(input$letters) + output$number <- renderText(input$obs) } shinyApp(ui, server) diff --git a/man/navbar_menu.Rd b/man/navbar_menu.Rd index 945b6a19..47e48f6c 100644 --- a/man/navbar_menu.Rd +++ b/man/navbar_menu.Rd @@ -4,7 +4,7 @@ \alias{navbar_menu} \title{Navbar Menu} \usage{ -navbar_menu(title, ..., menu_name = title, icon = NULL) +navbar_menu(title, ..., id = title, icon = NULL) } \arguments{ \item{title}{Display title for menu} @@ -12,11 +12,21 @@ navbar_menu(title, ..., menu_name = title, icon = NULL) \item{...}{\code{\link{tab_panel}} elements to include in the page. Can also include strings as section headers, or "----" as a horizontal separator.} -\item{menu_name}{The value that is linked to the \code{navbar_menu}} +\item{id}{The ID of the \code{navbar_menu}} \item{icon}{Optional icon to appear on the tab. This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}.} } \description{ +Create a dropdown menu for a \code{\link{navbar_page}}. +} +\examples{ +navbar_menu( + "Menu", + tab_panel("Summary", shiny::plotOutput("plot")), + "----", + "Section header", + tab_panel("Table", shiny::tableOutput("table")) +) } diff --git a/man/navbar_page.Rd b/man/navbar_page.Rd index 8c80766e..63bba29a 100644 --- a/man/navbar_page.Rd +++ b/man/navbar_page.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/navbarPage.R \name{navbar_page} \alias{navbar_page} -\title{Semantic UI page} +\title{Semantic UI page with top level navigation bar} \usage{ navbar_page( ..., @@ -14,26 +14,48 @@ navbar_page( footer = NULL, collapsible = FALSE, window_title = title, - menu_class = NULL, + type = "stackable", theme = NULL, suppress_bootstrap = TRUE ) } \arguments{ -\item{...}{Other arguments to be added as attributes of the main div tag -wrapper (e.g. style, class etc.)} +\item{...}{Other arguments to be added as attributes of the main div tag wrapper (e.g. style, class etc.)} -\item{title}{A title to display in the browser's title bar.} +\item{title}{A title to display in the navbar.} + +\item{id}{ID of the navbar menu. Given random ID if none specified.} + +\item{selected}{Which tab should be selected first? If none selected, will automatically have the first tab open.} + +\item{position}{Determines the location and behaviour of the navbar. Padding will be included when pinned to prevent +overlap. +\itemize{ +\item{""}{Default. Top of page, and goes out of view when scrolling} +\item{"top fixed"}{Top of page, pinned when scrolling} +\item{"bottom fixed"}{Bottom of page, pinned when scrolling} +}} + +\item{header}{Optional list of tags to be added to the top of all \code{tab_panel}s.} + +\item{footer}{Optional list of tags to be added to the bottom of all \code{tab_panel}s.} + +\item{collapsible}{\code{TRUE} to automatically collapse the navigation elements into a menu when the width of the +browser is less than 768 pixels (useful for viewing on smaller touchscreen device)} + +\item{window_title}{A title to display in the browser's title bar. By default it will be the same as the navbar +title.} + +\item{type}{Class to be given to the navbar menu.} \item{theme}{Theme name or path. Full list of supported themes you will find in \code{SUPPORTED_THEMES} or at http://semantic-ui-forest.com/themes.} \item{suppress_bootstrap}{boolean flag that supresses bootstrap when turned on} - -\item{margin}{character with body margin size} } \description{ -This creates a Semantic page for use in a Shiny app. +This creates a Semantic page for use in a Shiny app. It is in the same layout as \code{\link[shiny]{navbarPage}}, +where a top level navigation bar exists. } \details{ Inside, it uses two crucial options: @@ -48,27 +70,24 @@ either "min" or standard version. The folder should contain: \code{semantic.css} in \code{shiny.minified = TRUE} mode. } \examples{ -## Only run examples in interactive R sessions -if (interactive()) { -library(shiny) -library(shiny.semantic) +navbar_page( + "App Title", + tab_panel("Plot"), + tab_panel("Summary"), + tab_panel("Table") +) -ui <- semanticPage( - title = "Hello Shiny Semantic!", - tags$label("Number of observations:"), - slider_input("obs", value = 500, min = 0, max = 1000), - segment( - plotOutput("dist_plot") +navbar_page( + "App Title", + tab_panel("Plot"), + tab_panel("Icon", icon = "r project"), + navbar_menu( + "More", + tab_panel("Summary"), + "----", + "Section header", + tab_panel("Table") ) ) -server <- function(input, output) { - output$dist_plot <- renderPlot({ - hist(rnorm(input$obs)) - }) -} - -shinyApp(ui, server) -} - } diff --git a/man/tab_panel.Rd b/man/tab_panel.Rd index ccf2b64d..59629f6c 100644 --- a/man/tab_panel.Rd +++ b/man/tab_panel.Rd @@ -4,27 +4,35 @@ \alias{tab_panel} \title{Tab Panel} \usage{ -tab_panel(title, ..., value = title, icon = NULL) +tab_panel( + title, + ..., + value = title, + icon = NULL, + type = "bottom attached segment" +) } \arguments{ \item{title}{Display title for tab} \item{...}{UI elements to include within the tab} -\item{value}{The value that should be sent when \code{\link{tabset_panel}} reports that this tab is selected. -If omitted and \code{\link{tabset_panel}} has an id, then the title will be used.} +\item{value}{The value that should be sent when \code{\link{navbar_menu}} reports that this tab is selected. +If omitted and \code{\link{navbar_menu}} has an id, then the title will be used.} \item{icon}{Optional icon to appear on the tab. This attribute is only valid when using a \code{tab_panel} within a \code{\link{navbar_page}}.} + +\item{type}{Change depending what type of tab is wanted. Default is \code{bottom attached segment}.} } \value{ -A tab that can be passed to \code{\link{tabset_panel}}. +A tab that can be passed to \code{\link{navbar_menu}}. } \description{ Create a tab panel } \examples{ -tabset_panel( +navbar_menu( tab_panel("Plot", shiny::plotOutput("plot")), tab_panel("Summary", shiny::verbatimTextOutput("summary")), tab_panel("Table", shiny::tableOutput("table")) @@ -32,5 +40,5 @@ tabset_panel( } \seealso{ -\code{\link{tabset_panel}} +\code{\link{navbar_menu}} } From 119fdc67a7d9d548a9136c75a965e70769f3d649 Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Sun, 9 May 2021 16:44:18 +0100 Subject: [PATCH 6/9] Adding tests for navbar_page --- R/navbarPage.R | 2 ++ tests/testthat/test_navbar_page.R | 38 +++++++++++++++++++++++++++++++ 2 files changed, 40 insertions(+) create mode 100644 tests/testthat/test_navbar_page.R diff --git a/R/navbarPage.R b/R/navbarPage.R index e28b5485..c88f43a4 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -66,7 +66,9 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, collapsible = FALSE, window_title = title, type = "stackable", theme = NULL, suppress_bootstrap = TRUE) { tabs <- list(...) + if (!length(tabs)) stop("No tabs detected") position <- match.arg(position) + # Padding depending on the position body_padding <- switch(position, "top fixed" = "padding-top: 40px;", "bottom fixed" = "padding-bottom: 40px;", "") if (is.null(selected)) selected <- get_first_tab(tabs) diff --git a/tests/testthat/test_navbar_page.R b/tests/testthat/test_navbar_page.R new file mode 100644 index 00000000..15179aba --- /dev/null +++ b/tests/testthat/test_navbar_page.R @@ -0,0 +1,38 @@ +context("navbar_page") + +testthat::test_that("navbar_page creates UI page", { + ui <- navbar_page(tab_panel("Panel")) + + testthat::expect_s3_class(ui, "shiny.tag.list") +}) + +testthat::test_that("navbar_page with no panels errors", { + testthat::expect_error(navbar_page(), "No tabs detected") +}) + +testthat::test_that("navbar_page works with navbar_menu", { + menu <- navbar_menu( + "Menu", + tab_panel("Panel 1"), + tab_panel("Panel 2") + ) + + testthat::expect_s3_class(menu, "ssnavmenu") + + ui <- navbar_page(menu) + + testthat::expect_s3_class(ui, "shiny.tag.list") +}) + +testthat::test_that("selected works with tab name", { + ui <- navbar_page( + tab_panel("Panel 1"), + tab_panel("Panel 2"), + tab_panel("Panel 3"), + selected = "Panel 3" + ) + + # Will check whole of ui menu for a tab to be classed as active + body_tag <- which(sapply(ui, function(x) x$name == "body")) + testthat::expect_true(grepl("active", ui[[body_tag]])) +}) From 7fbd8e5c47d0c2619d86facf9951eeb316fc15e7 Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Sun, 9 May 2021 17:37:07 +0100 Subject: [PATCH 7/9] Adding update tab visibility functions --- NAMESPACE | 2 ++ R/navbarPage.R | 27 ++++++++++++++++++++++++++- examples/navbar_page/app.R | 26 ++++++++++++-------------- inst/www/shiny-semantic-tabset.js | 10 ++++++++++ man/tab_visibility.Rd | 17 +++++++++++++++++ 5 files changed, 67 insertions(+), 15 deletions(-) create mode 100644 man/tab_visibility.Rd diff --git a/NAMESPACE b/NAMESPACE index a65dc496..543161ec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -34,6 +34,7 @@ export(grid) export(grid_template) export(header) export(hide_modal) +export(hide_tab) export(horizontal_menu) export(icon) export(incProgress) @@ -77,6 +78,7 @@ export(shiny_input) export(shiny_text_input) export(showNotification) export(show_modal) +export(show_tab) export(sidebar_layout) export(sidebar_panel) export(single_step) diff --git a/R/navbarPage.R b/R/navbarPage.R index c88f43a4..5d914af7 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -107,7 +107,7 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, navbar_menu_creator <- function(tab, selected = NULL) { if (inherits(tab, "ssnavmenu")) { - dropdown_menu( + nav_menu <- dropdown_menu( id = tab$id, name = tab$title, tags$i(class = "dropdown icon"), @@ -115,6 +115,8 @@ navbar_menu_creator <- function(tab, selected = NULL) { is_menu_item = TRUE, class = "navbar-collapisble-item" ) + nav_menu[[1]]$attribs$`data-tab` = tab$id + nav_menu } else if (is.character(tab)) { if (grepl("^(-|_){4,}$", tab)) menu_divider() else div(class = "header", tab) } else { @@ -219,3 +221,26 @@ tab_panel <- function(title, ..., value = title, icon = NULL, type = "bottom att ... ) } + +#' Show/Hide Tab +#' +#' @description +#' Dynamically show or hide a \code{\link{tab_panel}} or \code{navbar_menu} +#' +#' @param session +#' @param id +#' @param target +#' +#' @rdname tab_visibility +#' @export +show_tab <- function(session = shiny::getDefaultReactiveDomain(), id, target) { + menu_id <- session$ns(id) + session$sendCustomMessage("toggleSemanticNavbarTab", list(id = menu_id, target = target, toggle = "show")) +} + +#' @rdname tab_visibility +#' @export +hide_tab <- function(session = shiny::getDefaultReactiveDomain(), id, target) { + menu_id <- session$ns(id) + session$sendCustomMessage("toggleSemanticNavbarTab", list(id = menu_id, target = target, toggle = "hide")) +} diff --git a/examples/navbar_page/app.R b/examples/navbar_page/app.R index 228a1671..c08e289a 100644 --- a/examples/navbar_page/app.R +++ b/examples/navbar_page/app.R @@ -3,24 +3,22 @@ library(shiny.semantic) ui <- navbar_page( title = "Hello Shiny Semantic!", - # id = "page_navbar", + id = "page_navbar", collapsible = TRUE, tab_panel( title = "Content", - numeric_input("obs", "Number of observations:", value = 500, min = 0, max = 1000), - segment(plotOutput("dist_plot")) + form(multiple_radio("toggle", "Show Menu Dropdown", c("Yes", "No"), c("show", "hide"), "show")) ), tab_panel( title = "Icon", icon = "r project", - "A tab with an icon in the menu" + "A tab with an icon in the menu", ), tab_panel( title = "A Very Long Tab Name", "Example of a tab name which is very long", - form(field(tags$label("Test dropdown"), dropdown_input("letters", LETTERS))), - segment("Letter chosen:", textOutput("letter", inline = TRUE)) + tags$br(), ), navbar_menu( "Menu", @@ -28,7 +26,6 @@ ui <- navbar_page( tab_panel( title = "Part 1", value = "sec1_part1", - segment("Number chosen:", textOutput("number", inline = TRUE)) ), "----", "Section 2", @@ -43,13 +40,14 @@ ui <- navbar_page( ) ) -server <- function(input, output) { - output$dist_plot <- renderPlot({ - hist(rnorm(input$obs)) - }) - - output$letter <- renderText(input$letters) - output$number <- renderText(input$obs) +server <- function(input, output, session) { + observeEvent(input$toggle, { + if (input$toggle == "hide") { + hide_tab(session, "page_navbar", target = "Menu") + } else { + show_tab(session, "page_navbar", target = "Menu") + } + }, ignoreInit = TRUE) } shinyApp(ui, server) diff --git a/inst/www/shiny-semantic-tabset.js b/inst/www/shiny-semantic-tabset.js index 2db2ee83..11787dde 100644 --- a/inst/www/shiny-semantic-tabset.js +++ b/inst/www/shiny-semantic-tabset.js @@ -34,3 +34,13 @@ $.extend(semanticTabset, { }); Shiny.inputBindings.register(semanticTabset, 'shiny.semanticTabset'); + +Shiny.addCustomMessageHandler('toggleSemanticNavbarTab', function(message) { + var tabs = $(`#${message.id}`).find('.item'); + var sel_tab = tabs.filter((index, element) => $(element).data('tab') === `${message.target}`) + if (message.toggle === 'show') { + sel_tab.show(); + } else { + sel_tab.hide(); + } +}); diff --git a/man/tab_visibility.Rd b/man/tab_visibility.Rd new file mode 100644 index 00000000..bd7598b0 --- /dev/null +++ b/man/tab_visibility.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/navbarPage.R +\name{show_tab} +\alias{show_tab} +\alias{hide_tab} +\title{Show/Hide Tab} +\usage{ +show_tab(session = shiny::getDefaultReactiveDomain(), id, target) + +hide_tab(session = shiny::getDefaultReactiveDomain(), id, target) +} +\arguments{ +\item{target}{} +} +\description{ +Dynamically show or hide a \code{\link{tab_panel}} or \code{navbar_menu} +} From fe3afbedb141cbd844f6c55dd2dbc70ad3321d3c Mon Sep 17 00:00:00 2001 From: Ashley Baldry Date: Wed, 13 Oct 2021 21:20:07 +0100 Subject: [PATCH 8/9] Enabling hash history in the navbar_page --- R/dsl.R | 2 +- R/navbarPage.R | 55 +++++++++++++++++++++---- R/semanticPage.R | 1 + examples/navbar_page/app.R | 6 ++- inst/www/shared/semantic/history.min.js | 1 + inst/www/shiny-semantic-tabset.js | 18 ++++++-- man/navbar_page.Rd | 20 +++++++-- man/tab_visibility.Rd | 33 ++++++++++++++- 8 files changed, 118 insertions(+), 18 deletions(-) create mode 100644 inst/www/shared/semantic/history.min.js diff --git a/R/dsl.R b/R/dsl.R index a2ba1e64..4fcef761 100644 --- a/R/dsl.R +++ b/R/dsl.R @@ -182,7 +182,7 @@ tabset <- function(tabs, active_tab <- if (!is.null(active)) active else valid_ids[1] # nolint shiny::tagList( shiny::div(id = id, - class = paste("ui menu sem", menu_class), + class = paste("ui menu ss-menu", menu_class), purrr::map(id_tabs, ~ { class <- paste("item", if (.$id == active_tab) "active" else "") # nolint shiny::a(class = class, `data-tab` = .$id, .$menu) diff --git a/R/navbarPage.R b/R/navbarPage.R index 5d914af7..beae61ee 100644 --- a/R/navbarPage.R +++ b/R/navbarPage.R @@ -33,21 +33,32 @@ #' browser is less than 768 pixels (useful for viewing on smaller touchscreen device) #' @param window_title A title to display in the browser's title bar. By default it will be the same as the navbar #' title. -#' @param type Class to be given to the navbar menu. +#' @param class Additional classes to be given to the navbar menu. Defaults to \code{"stackable"}. For optional classes +#' have a look in details #' @param theme Theme name or path. Full list of supported themes you will find in #' \code{SUPPORTED_THEMES} or at http://semantic-ui-forest.com/themes. +#' @param enable_hash_state boolean flag that enables a different hash in the URL for each tab, and creates historical +#' events #' @param suppress_bootstrap boolean flag that supresses bootstrap when turned on #' +#' @details +#' The following classes can be applied to the navbar: +#' \itemize{ +#' \item{\code{stackable}} - When the width of the webpage becomes too thin, for example on mobile, the navbar will +#' become a stack +#' \item{\code{inverted}} - Will create an inverted coloured navbar +#' } +#' #' @examples #' navbar_page( -#' "App Title", +#' title = "App Title", #' tab_panel("Plot"), #' tab_panel("Summary"), #' tab_panel("Table") #' ) #' #' navbar_page( -#' "App Title", +#' title = "App Title", #' tab_panel("Plot"), #' tab_panel("Icon", icon = "r project"), #' navbar_menu( @@ -64,7 +75,8 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, position = c("", "top fixed", "bottom fixed"), header = NULL, footer = NULL, collapsible = FALSE, window_title = title, - type = "stackable", theme = NULL, suppress_bootstrap = TRUE) { + class = "stackable", theme = NULL, + enable_hash_state = TRUE, suppress_bootstrap = TRUE) { tabs <- list(...) if (!length(tabs)) stop("No tabs detected") position <- match.arg(position) @@ -90,8 +102,9 @@ navbar_page <- function(..., title = "", id = NULL, selected = NULL, menu_header <- tags$nav( div( - class = paste("ui navbar-page-menu", position, type, "menu sem"), + class = paste("ui menu ss-menu navbar-page-menu", position, class), id = id, + `data-hash-history` = tolower(as.character(enable_hash_state)), menu_items ) ) @@ -227,9 +240,35 @@ tab_panel <- function(title, ..., value = title, icon = NULL, type = "bottom att #' @description #' Dynamically show or hide a \code{\link{tab_panel}} or \code{navbar_menu} #' -#' @param session -#' @param id -#' @param target +#' @param session The \code{session} object passed to function given to \code{shinyServer}. +#' @param id The id of the navbar object +#' @param target The tab value to toggle visibility +#' +#' @examples +#' if (interactive()) { +#' library(shiny) +#' library(shiny.semantic) +#' +#' ui <- navbar_page( +#' title = "App Title", +#' id = "navbar", +#' tab_panel( +#' "Plot", +#' action_button("hide", "Hide Table"), +#' action_button("show", "Show Table"), +#' value = "plot" +#' ), +#' tab_panel("Summary", value = "summary"), +#' tab_panel("Table", value = "table") +#' ) +#' +#' server <- function(input, output, session) { +#' observeEvent(input$hide, hide_tab(session, "navbar", "table")) +#' observeEvent(input$show, show_tab(session, "navbar", "table")) +#' } +#' +#' shinyApp(ui, server) +#' } #' #' @rdname tab_visibility #' @export diff --git a/R/semanticPage.R b/R/semanticPage.R index d6deac5f..3aac9817 100644 --- a/R/semanticPage.R +++ b/R/semanticPage.R @@ -157,6 +157,7 @@ semanticPage <- function(..., title = "", theme = NULL, suppress_bootstrap = TRU shiny::tagList( shiny::tags$head( get_dependencies(theme), + shiny::tags$script(src = "shiny.semantic/shared/semantic/history.min.js"), shiny::tags$title(title), shiny::tags$meta(name = "viewport", content = "width=device-width, initial-scale=1.0"), shiny::tags$link(rel = "stylesheet", type = "text/css", href = "shiny.semantic/shiny-semantic.css"), diff --git a/examples/navbar_page/app.R b/examples/navbar_page/app.R index c08e289a..5140da96 100644 --- a/examples/navbar_page/app.R +++ b/examples/navbar_page/app.R @@ -8,15 +8,18 @@ ui <- navbar_page( tab_panel( title = "Content", + value = "content", form(multiple_radio("toggle", "Show Menu Dropdown", c("Yes", "No"), c("show", "hide"), "show")) ), tab_panel( title = "Icon", + value = "icon", icon = "r project", "A tab with an icon in the menu", ), tab_panel( title = "A Very Long Tab Name", + value = "long_tab_name", "Example of a tab name which is very long", tags$br(), ), @@ -35,7 +38,8 @@ ui <- navbar_page( h3("Section 2 - Part 1") ), tab_panel( - title = "Part 2" + title = "Part 2", + value = "sec2_part2" ) ) ) diff --git a/inst/www/shared/semantic/history.min.js b/inst/www/shared/semantic/history.min.js new file mode 100644 index 00000000..9d71f1bf --- /dev/null +++ b/inst/www/shared/semantic/history.min.js @@ -0,0 +1 @@ +!function(a){a.address=function(){var x,W,b=function(b){var c=a.extend(a.Event(b),function(){for(var b={},c=a.address.parameterNames(),d=0,e=c.length;e>d;d++)b[c[d]]=a.address.parameter(c[d]);return{value:a.address.value(),path:a.address.path(),pathNames:a.address.pathNames(),parameterNames:c,parameters:b,queryString:a.address.queryString()}}.call(a.address));return a(a.address).trigger(c),c},c=function(a){return Array.prototype.slice.call(a)},d=function(){return a().bind.apply(a(a.address),Array.prototype.slice.call(arguments)),a.address},e=function(){return a().unbind.apply(a(a.address),Array.prototype.slice.call(arguments)),a.address},f=function(){return P.pushState&&I.state!==x},g=function(){return("/"+Q.pathname.replace(new RegExp(I.state),"")+Q.search+(h()?"#"+h():"")).replace(T,"/")},h=function(){var a=Q.href.indexOf("#");return-1!=a?Q.href.substr(a+1):""},i=function(){return f()?g():h()},j=function(){try{return top.document!==x&&top.document.title!==x?top:window}catch(a){return window}},k=function(){return"javascript"},l=function(a){return a=a.toString(),(I.strict&&"/"!=a.substr(0,1)?"/":"")+a},m=function(a,b){return parseInt(a.css(b),10)},n=function(){if(!_){var a=i(),b=decodeURI(eb)!=decodeURI(a);b&&(M&&7>K?Q.reload():(M&&!V&&I.history&&S(q,50),eb=a,o(H)))}},o=function(a){return"null"!==I.tracker&&I.tracker!==y&&S(p,10),b(D).isDefaultPrevented()||b(a?E:F).isDefaultPrevented()},p=function(){if("null"!==I.tracker&&I.tracker!==y){var b=a.isFunction(I.tracker)?I.tracker:N[I.tracker],c=(Q.pathname+Q.search+(a.address&&!f()?a.address.value():"")).replace(/\/\//,"/").replace(/^\/$/,"");a.isFunction(b)?b(c):a.isFunction(N.urchinTracker)?N.urchinTracker(c):N.pageTracker!==x&&a.isFunction(N.pageTracker._trackPageview)?N.pageTracker._trackPageview(c):N._gaq!==x&&a.isFunction(N._gaq.push)&&N._gaq.push(["_trackPageview",decodeURI(c)])}},q=function(){var a=k()+":"+H+";document.open();document.writeln('"+O.title.replace(/\'/g,"\\'")+"