Improve picks ui when single choice

R/0-badge_dropdown.R

@@ -8,8 +8,13 @@
 #' @param id (`character(1)`) shiny module's id
 #' @param label (`shiny.tag`) Label displayed on a badge.
 #' @param content (`shiny.tag`) Content of a drop-down.
+#' @param badge_context (`character(1)`) Variation content of the badge i.e: "primary", "secondary" ...
+#' @param fixed (`logical(1)`) Whether to return a badge with dropdown (default) or simple fixed badge if set to TRUE
 #' @keywords internal
-badge_dropdown <- function(id, label, content) {
+badge_dropdown <- function(id, label, content, badge_context = "primary", fixed = FALSE) {
+  checkmate::assert_character(badge_context)
+  checkmate::assert_logical(fixed)
+
   ns <- shiny::NS(id)
   htmltools::tagList(
     htmltools::singleton(htmltools::tags$head(
@@ -20,11 +25,15 @@ badge_dropdown <- function(id, label, content) {
       class = "badge-dropdown-wrapper",
       htmltools::tags$span(
         id = ns("summary_badge"),
-        class = "badge bg-primary rounded-pill badge-dropdown",
-        style = "cursor: pointer;",
+        class = sprintf("badge bg-%s rounded-pill badge-dropdown", badge_context),
+        style = ifelse(fixed, "", "cursor: pointer"),
         tags$span(class = "badge-dropdown-label", label),
-        tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
-        onclick = sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
+        if (isFALSE(fixed)) tags$span(class = "badge-dropdown-icon", bsicons::bs_icon("caret-down-fill")),
+        onclick = ifelse(
+          fixed,
+          "",
+          sprintf("toggleBadgeDropdown('%s', '%s')", ns("summary_badge"), ns("inputs_container"))
+        )
       ),
       htmltools::tags$div(
         content,

R/0-module_picks.R

@@ -58,11 +58,20 @@ picks_ui.list <- function(id, picks, container) {
 picks_ui.picks <- function(id, picks, container) {
   ns <- shiny::NS(id)
   badge_label <- shiny::uiOutput(ns("summary"), container = htmltools::tags$span)
-
   content <- lapply(picks, function(x) .pick_ui(id = ns(methods::is(x))))
   htmltools::tags$div(
     if (missing(container)) {
-      badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content))
+      if (isTRUE(attr(picks$variables, "fixed")) && isTRUE(attr(picks$datasets, "fixed"))) {
+        badge_dropdown(
+          id = ns("inputs"),
+          label = badge_label,
+          htmltools::tagList(content),
+          badge_context = "secondary",
+          fixed = TRUE
+        )
+      } else {
+        badge_dropdown(id = ns("inputs"), label = badge_label, htmltools::tagList(content))
+      }
     } else {
       if (!any(sapply(htmltools::tags, identical, container))) {
         stop("Container should be one of `htmltools::tags`")
@@ -244,8 +253,18 @@ picks_srv.picks <- function(id, picks, data) {
       logger::log_debug(".pick_srv@1 rerender {pick_type} input")
       .validate_is_eager(choices())
       .validate_is_eager(selected())
-      if (isTRUE(args$fixed) || length(choices()) <= 1) {
+      if (!length(choices()) || isTRUE(args$fixed)) {
         NULL
+      } else if (length(choices()) == 1 && isFALSE(args$fixed)) {
+        .pick_ui_categorical(
+          session$ns("selected"),
+          label = sprintf("Select %s:", pick_type),
+          choices = choices(),
+          selected = selected(),
+          multiple = args$multiple,
+          choicesOpt = list(content = isolate(choices_opt_content())),
+          args = args[!names(args) %in% c("multiple")]
+        )
       } else if (.is_ranged(choices()) && inherits(choices(), "Date")) {
         .pick_ui_date(
           session$ns("range"),

inst/WORDLIST

@@ -1,3 +1,4 @@
 Analyse
 UI
+dropdown
 schemas

tests/testthat/test-0-module_picks.R

@@ -1072,3 +1072,39 @@ describe("picks_srv resolves picks interactively", {
   it("changing date range in slider input updates picks_resolved")
   it("setting picks_resolved$selected outside of range adjust to the available range")
 })
+
+describe("picks_ui creates correct badge_dropdown", {
+  it("with fixed = FALSE when picks has two datasets and one single choice var", {
+    test_picks <- picks(
+      datasets(choices = c("iris", "mtcars"), selected = "iris"),
+      variables(choices = "Species", selected = "Species")
+    )
+    ui_output <- picks_ui("test", picks = test_picks)
+
+    expect_true(grepl("cursor: pointer", as.character(ui_output)))
+    expect_true(grepl("badge-dropdown-icon", as.character(ui_output)))
+  })
+
+  it("with fixed = TRUE when picks has one dataset and single choice var", {
+    test_picks <- picks(
+      datasets(choices = "iris", selected = "iris"),
+      variables(choices = "Species", selected = "Species")
+    )
+    ui_output <- picks_ui("test", picks = test_picks)
+
+    expect_false(grepl("cursor: pointer", as.character(ui_output)))
+    expect_false(grepl("badge-dropdown-icon", as.character(ui_output)))
+    expect_true(grepl("bg-secondary", as.character(ui_output)))
+  })
+
+  it("with fixed = FALSE when picks has one dataset and single choice var with explicit fixed = FALSE", {
+    test_picks <- picks(
+      datasets(choices = "iris", selected = "iris"),
+      variables(choices = "Species", selected = "Species", fixed = FALSE)
+    )
+    ui_output <- picks_ui("test", picks = test_picks)
+
+    expect_true(grepl("cursor: pointer", as.character(ui_output)))
+    expect_true(grepl("badge-dropdown-icon", as.character(ui_output)))
+  })
+})