Merge pull request #145 from Appsilon/dev-copy

Update dropdown and uibutton
Appsilon · Dec 3, 2019 · 275a608 · 275a608
2 parents 0782ab6 + 9707bd1
commit 275a608
Show file tree

Hide file tree

Showing 31 changed files with 506 additions and 155 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: shiny.semantic
 Type: Package
 Title: Semantic UI Support for Shiny
-Version: 0.2.4.9001
+Version: 0.2.4.9002
 Authors@R: c(person("Filip", "Stachura", email = "[email protected]",
   role = "aut"),
   person("Dominik", "Krzeminski", email = "[email protected]",
@@ -30,4 +30,4 @@ Suggests:
     testthat,
     lintr,
     covr
-RoxygenNote: 6.1.1
+RoxygenNote: 7.0.0
diff --git a/NAMESPACE b/NAMESPACE
@@ -30,6 +30,7 @@ export(show_modal)
 export(simple_checkbox)
 export(slider_input)
 export(tabset)
+export(uibutton)
 export(uicard)
 export(uicards)
 export(uicheckbox)
@@ -45,6 +46,7 @@ export(uimenu)
 export(uimessage)
 export(uirender)
 export(uisegment)
+export(update_dropdown)
 import(htmlwidgets)
 import(magrittr)
 import(shiny)

diff --git a/R/button.R b/R/button.R
@@ -0,0 +1,15 @@
+#' Create Semantic UI Button
+#'
+#' @param name The \code{input} slot that will be used to access the value.
+#' @param label The contents of the button or link
+#' @param icon An optional \code{\link{uiicon}()} to appear on the button.
+#' @param type An optional attribute to be added to the button's class.
+#' @param ... Named attributes to be applied to the button
+#'
+#' @examples
+#' uibutton("simple_button", "Press Me!")
+#'
+#' @export
+uibutton <- function(name, label, icon = NULL, type = NULL, ...) {
+  tags$button(id = name, class = paste("ui", type, "button"), label, icon, ...)
+}
diff --git a/R/dropdown.R b/R/dropdown.R
@@ -0,0 +1,98 @@
+#' Create dropdown Semantic UI component
+#'
+#' This creates a default dropdown using Semantic UI styles with Shiny input.
+#' Dropdown is already initialized and available under input[[name]].
+#'
+#' @param name Input name. Reactive value is available under input[[name]].
+#' @param choices All available options one can select from.
+#' @param choices_value What reactive value should be used for corresponding
+#' choice.
+#' @param default_text Text to be visible on dropdown when nothing is selected.
+#' @param value Pass value if you want to initialize selection for dropdown.
+#' @param type Change depending what type of dropdown is wanted.
+#'
+#' @examples
+#' ## Only run examples in interactive R sessions
+#' if (interactive()) {
+#'
+#'   library(shiny)
+#'   library(shiny.semantic)
+#'   ui <- function() {
+#'       shinyUI(
+#'         semanticPage(
+#'           title = "Dropdown example",
+#'           suppressDependencies("bootstrap"),
+#'           uiOutput("dropdown"),
+#'           p("Selected letter:"),
+#'           textOutput("selected_letter")
+#'        )
+#'      )
+#'   }
+#'   server <- shinyServer(function(input, output) {
+#'      output$dropdown <- renderUI({
+#'          dropdown("simple_dropdown", LETTERS, value = "A")
+#'      })
+#'      output$selected_letter <- renderText(input[["simple_dropdown"]])
+#'   })
+#'
+#'   shinyApp(ui = ui(), server = server)
+#' }
+#'
+#' @export
+dropdown <- function(name, choices, choices_value = choices,
+                     default_text = "Select", value = NULL, type = "selection fluid") {
+    shiny::div(
+      id = name, class = paste("ui", type, "dropdown semantic-select-input"),
+      tags$input(type = "hidden", name = name, value = value),
+      uiicon("dropdown"),
+      shiny::div(class = "default text", default_text),
+      uimenu(
+        purrr::when(
+          choices,
+          is.null(names(.)) ~
+            purrr::map2(
+              choices, choices_value,
+              ~ shiny::div(class = paste0(if (.y %in% value) "active ", "item"), `data-value` = .y, .x)
+            ),
+          !is.null(names(.)) ~
+            purrr::map(
+              seq_len(length(choices)), ~ {
+                shiny::tagList(
+                  menu_header(names(choices)[.x], is_item = FALSE),
+                  menu_divider(),
+                  purrr::map2(
+                    choices[[.x]], choices_value[[.x]],
+                    ~ shiny::div(class = paste0(if (.y %in% value) "active ", "item"), `data-value` = .y, .x)
+                  )
+                )
+              }
+            )
+        )
+      )
+    )
+}
+
+#' Update dropdown Semantic UI component
+#'
+#' Change the value of a \code{\link{dropdown}} input on the client.
+#'
+#' @param session The \code{session} object passed to function given to \code{shinyServer}.
+#' @param name The id of the input object
+#' @param choices All available options one can select from. If no need to update then leave as \code{NULL}
+#' @param choices_value What reactive value should be used for corresponding choice.
+#' @param value The initially selected value.
+#'
+#' @export
+update_dropdown <- function(session, name, choices = NULL, choices_value = choices, value = NULL) {
+  if (!is.null(value)) value <- paste(as.character(value), collapse = ",") else value <- NULL
+  if (!is.null(choices)) {
+    options <- jsonlite::toJSON(data.frame(name = choices, text = choices, value = choices_value))
+  } else {
+    options <- NULL
+  }
+
+  message <- list(label = label, choices = options, value = value)
+  message <- message[!vapply(message, is.null, FUN.VALUE = logical(1))]
+
+  session$sendInputMessage(name, message)
+}
diff --git a/R/dsl.R b/R/dsl.R
@@ -26,7 +26,7 @@ uiicon <- function(type = "", ...) {
 uilabel <- function(..., type = "", is_link = TRUE) {
   label_tag <- if (is_link) tags$a else tags$div
   label_tag(class = paste("ui label", type),
-      list(...))
+            list(...))
 }
 
 #' Sets tab id if not provided
@@ -284,100 +284,18 @@ uimessage <- function(header, content, type = "", icon, closable = FALSE) {
       message_else_content)
 }
 
-
-#' Create dropdown Semantic UI component
-#'
-#' This creates a default dropdown using Semantic UI styles with Shiny input.
-#' Dropdown is already initialized and available under input[[name]].
-#'
-#' @param name Input name. Reactive value is available under input[[name]].
-#' @param choices All available options one can select from.
-#' @param choices_value What reactive value should be used for corresponding
-#' choice.
-#' @param default_text Text to be visible on dropdown when nothing is selected.
-#' @param value Pass value if you want to initialize selection for dropdown.
-#'
-#' @examples
-#' ## Only run examples in interactive R sessions
-#' if (interactive()) {
-#'
-#'   library(shiny)
-#'   library(shiny.semantic)
-#'   ui <- function() {
-#'       shinyUI(
-#'         semanticPage(
-#'           title = "Dropdown example",
-#'           suppressDependencies("bootstrap"),
-#'           uiOutput("dropdown"),
-#'           p("Selected letter:"),
-#'           textOutput("selected_letter")
-#'        )
-#'      )
-#'   }
-#'   server <- shinyServer(function(input, output) {
-#'      output$dropdown <- renderUI({
-#'          dropdown("simple_dropdown", LETTERS, value = "A")
-#'      })
-#'      output$selected_letter <- renderText(input[["simple_dropdown"]])
-#'   })
-#'
-#'   shinyApp(ui = ui(), server = server)
-#' }
-#'
-#' @export
-dropdown <- function(name,
-                     choices,
-                     choices_value = choices,
-                     default_text = "Select",
-                     value = NULL) {
-  unique_dropdown_class <- paste0("dropdown_name_", name)
-  class <- paste("ui selection fluid dropdown", unique_dropdown_class)
-
-  shiny::tagList(
-    shiny::div(class = class,
-               shiny_text_input(name,
-                                shiny::tags$input(type = "hidden", name = name),
-                                value = value
-               ),
-               uiicon("dropdown"),
-               shiny::div(class = "default text", default_text),
-               uimenu(
-                         purrr::when(
-                           choices,
-                           is.null(names(.)) ~
-                             purrr::map2(choices, choices_value, ~
-                                           menu_item(`data-value` = .y, .x)
-                             ),
-                           !is.null(names(.)) ~
-                             purrr::map(1:length(choices), ~ {
-                             shiny::tagList(
-                               menu_header(names(choices)[.x], is_item = FALSE),
-                               menu_divider(),
-                               purrr::map2(choices[[.x]], choices_value[[.x]], ~
-                                             menu_item(`data-value` = .y, .x))
-                             )
-                           })
-                         )
-               )
-    ),
-    shiny::tags$script(paste0(
-      "$('.ui.dropdown.", unique_dropdown_class,
-      "').dropdown().dropdown('set selected', '", value, "');"
-    ))
-  )
-}
-
 #' Create Semantic UI Menu
 #'
 #' This creates a menu using Semantic UI.
 #'
-#' @param ... Menu items to be created. Use menu_item function to create new menu item. Use uidropdown(is_menu_item = TRUE, ...)
-#' function to create new dropdown menu item. Use menu_header and menu_divider functions to customize menu format.
+#' @param ... Menu items to be created. Use menu_item function to create new menu item.
+#' Use uidropdown(is_menu_item = TRUE, ...) function to create new dropdown menu item.
+#' Use menu_header and menu_divider functions to customize menu format.
 #' @param type Type of the menu. Look at https://semantic-ui.com/collections/menu.html for all possiblities.
 #'
 #' @examples
 #'
-#' if (interactive()){
+#' if (interactive()) {
 #' library(shiny)
 #' library(shiny.semantic)
 #'
@@ -450,7 +368,8 @@ menu_item <- function(..., item_feature = "", style = NULL, href = NULL) {
 #' @param type Type of the dropdown. Look at https://semantic-ui.com/modules/dropdown.html for all possibilities.
 #' @param name Unique name of the created dropdown.
 #' @param is_menu_item TRUE if the dropdown is a menu item. Default is FALSE.
-#' @param dropdown_specs A list of dropdown functionalities. Look at https://semantic-ui.com/modules/dropdown.html#/settings for all possibilities.
+#' @param dropdown_specs A list of dropdown functionalities.
+#' Look at https://semantic-ui.com/modules/dropdown.html#/settings for all possibilities.
 #'
 #' @examples
 #'
@@ -540,7 +459,7 @@ list_element <- function(data, is_description, is_icon, row) {
       } else {
         div(class = "content", data$header[row])
       }
-      )
+  )
 }
 
 #' Create Semantic UI list with header, description and icons
@@ -570,13 +489,13 @@ list_element <- function(data, is_description, is_icon, row) {
 #'
 #' # Create a 5 element divided list with alert icons and description
 #' uilist(list_content, is_icon = TRUE, is_divided = TRUE, is_description = TRUE)
-uilist <- function(data, is_icon = FALSE, is_divided = FALSE, is_description = FALSE){
+uilist <- function(data, is_icon = FALSE, is_divided = FALSE, is_description = FALSE) {
   divided_list <- ifelse(is_divided, "divided", "")
   list_class <- paste("ui", divided_list, "list")
 
   div(class = list_class,
-      1:nrow(data) %>% purrr::map(function(row){
+      seq_len(nrow(data)) %>% purrr::map(function(row) {
         list_element(data, is_description, is_icon, row)
-        })
+      })
   )
 }
diff --git a/R/modal.R b/R/modal.R
@@ -2,12 +2,16 @@
 #'
 #' This creates a modal using Semantic UI styles.
 #'
-#' @param ... Content elements to be added to the modal body. To change attributes of the container please check the `content` argument.
+#' @param ... Content elements to be added to the modal body.
+#' To change attributes of the container please check the `content` argument.
 #' @param id ID to be added to the modal div. Default "".
 #' @param class Classes except "ui modal" to be added to the modal. Semantic UI classes can be used. Default "".
-#' @param header Content to be displayed in the modal header. If given in form of a list, HTML attributes for the container can also be changed. Default "".
-#' @param content Content to be displayed in the modal body. If given in form of a list, HTML attributes for the container can also be changed. Default NULL.
-#' @param footer Content to be displayed in the modal footer. Usually for buttons. If given in form of a list, HTML attributes for the container can also be changed. Default NULL.
+#' @param header Content to be displayed in the modal header.
+#' If given in form of a list, HTML attributes for the container can also be changed. Default "".
+#' @param content Content to be displayed in the modal body.
+#' If given in form of a list, HTML attributes for the container can also be changed. Default NULL.
+#' @param footer Content to be displayed in the modal footer. Usually for buttons.
+#' If given in form of a list, HTML attributes for the container can also be changed. Default NULL.
 #' @param target Javascript selector for the element that will open the modal. Default NULL.
 #' @param settings List of vectors of Semantic UI settings to be added to the modal. Default NULL.
 #' @param modal_tags Other modal elements. Default NULL.
@@ -102,7 +106,8 @@
 #'       id = "simple-modal",
 #'       title = "Important message",
 #'       header = list(style = "background: lightcoral"),
-#'       content = list(style = "background: lightblue", `data-custom` = "value", "This is an important message!"),
+#'       content = list(style = "background: lightblue",
+#'                      `data-custom` = "value", "This is an important message!"),
 #'       p("This is also part of the content!")
 #'     ))
 #'   })

diff --git a/R/search_field.R b/R/search_field.R
@@ -36,7 +36,7 @@
 #'
 #' server <- shinyServer(function(input, output, session) {
 #'
-#'  search_api <- function(gapminder, q){
+#'  search_api <- function(gapminder, q) {
 #'    has_matching <- function(field) {
 #'      startsWith(field, q)
 #'    }

diff --git a/R/semanticPage.R b/R/semanticPage.R
@@ -1,6 +1,6 @@
 #' Supported semantic themes
 #' @export
-SUPPORTED_THEMES <- c("cerulean", "darkly", "paper", "simplex",
+SUPPORTED_THEMES <- c("cerulean", "darkly", "paper", "simplex",  # nolint
                       "superhero", "flatly", "slate", "cosmo",
                       "readable",  "united", "journal", "solar",
                       "cyborg", "sandstone", "yeti", "lumen", "spacelab")
@@ -47,7 +47,7 @@ get_dependencies <- function() {
   )
 }
 
-get_range_component_dependencies <- function() {
+get_range_component_dependencies <- function() { # nolint
   htmltools::htmlDependency("semantic-range",
                             "1.0.0",
                             c(file = system.file("semantic-range", package = "shiny.semantic")),
@@ -139,7 +139,9 @@ semanticPage <- function(..., title = "", theme = NULL){ # nolint
       },
       shiny::tags$title(title),
       shiny::tags$meta(name = "viewport", content = "width=device-width, initial-scale=1.0"),
-      shiny::tags$script(src = "shiny.semantic/shiny-semantic-modal.js")
+      shiny::tags$script(src = "shiny.semantic/shiny-semantic-modal.js"),
+      shiny::tags$script(src = "shiny.semantic/shiny-semantic-dropdown.js"),
+      shiny::tags$script(src = "shiny.semantic/shiny-semantic-button.js")
     ),
     shiny::tags$body(style = "min-height: 611px;", content)
   )

diff --git a/R/semantic_search.R b/R/semantic_search.R
@@ -44,7 +44,7 @@ define_selection_type <- function(name, multiple) {
 #'
 #'   server <- shinyServer(function(input, output, session) {
 #'
-#'    search_api <- function(gapminder, q){
+#'    search_api <- function(gapminder, q) {
 #'      has_matching <- function(field) {
 #'         startsWith(field, q)
 #'       }
@@ -207,7 +207,7 @@ search_selection_choices <- function(name,
 #' @param name function name
 #'
 #' @return function
-`%:::%` <- function (pkg, name) {
+`%:::%` <- function(pkg, name) { # nolint
   pkg <- as.character(substitute(pkg))
   name <- as.character(substitute(name))
   get(name, envir = asNamespace(pkg), inherits = FALSE)

diff --git a/R/shiny.R b/R/shiny.R
@@ -2,7 +2,7 @@
 #'
 #' @param libname library name
 #' @param pkgname package name
-.onLoad <- function(libname, pkgname) {
+.onLoad <- function(libname, pkgname) { # nolint
   # Add directory for static resources
   file <- system.file("www", package = "shiny.semantic", mustWork = TRUE)
   shiny::addResourcePath("shiny.semantic", file)