tests/testthat/test-multiselect.R

In glasstabs: Animated Glass-Style Tabs and Select Inputs for 'Shiny'

choices <- c(Apple = "apple", Banana = "banana", Cherry = "cherry")


test_that("glassMultiSelect() returns an htmltools object", {
  ui <- glassMultiSelect("f", choices)
  expect_true(inherits(ui, c("shiny.tag", "shiny.tag.list")))
})

test_that("glassFilterTags() returns an htmltools tag", {
  expect_true(inherits(glassFilterTags("f"), "shiny.tag"))
})


test_that("glassMultiSelect() accepts unnamed choices", {
  expect_no_error(glassMultiSelect("f", c("x", "y", "z")))
})

test_that("glassMultiSelect() renders all option values in HTML", {
  html <- as.character(glassMultiSelect("f", choices))
  expect_match(html, "apple")
  expect_match(html, "banana")
  expect_match(html, "cherry")
})

test_that("glassMultiSelect() errors when choices is NULL", {
  expect_error(glassMultiSelect("f", NULL), class = "glasstabs_error_bad_choice")
})


test_that("glassMultiSelect() defaults to all options checked", {
  html <- as.character(glassMultiSelect("f", choices))
  n <- lengths(regmatches(html, gregexpr("gt-ms-option checked", html)))
  expect_equal(n, 3L)
})

test_that("glassMultiSelect() respects partial initial selection", {
  html <- as.character(glassMultiSelect("f", choices, selected = "apple"))
  n <- lengths(regmatches(html, gregexpr("gt-ms-option checked", html)))
  expect_equal(n, 1L)
})

test_that("glassMultiSelect() respects empty initial selection", {
  html <- as.character(glassMultiSelect("f", choices, selected = character(0)))
  expect_false(grepl("gt-ms-option checked", html))
})

test_that("glassMultiSelect() drops invalid selected values", {
  html <- as.character(glassMultiSelect("f", choices, selected = c("apple", "nope")))
  n <- lengths(regmatches(html, gregexpr("gt-ms-option checked", html)))
  expect_equal(n, 1L)
  expect_match(html, "apple")
})


test_that("glassMultiSelect() renders label when supplied", {
  html <- as.character(glassMultiSelect("f", choices, label = "Pick fruits"))
  expect_match(html, "Pick fruits")
  expect_match(html, 'class="gt-input-label"')
})

test_that("glassMultiSelect() custom placeholder appears when nothing selected", {
  html <- as.character(
    glassMultiSelect(
      "f",
      choices,
      selected = character(0),
      placeholder = "Choose a fruit"
    )
  )
  expect_match(html, "Choose a fruit")
})

test_that("glassMultiSelect() shows default all label when all selected", {
  html <- as.character(glassMultiSelect("f", choices))
  expect_match(html, "All categories")
})

test_that("glassMultiSelect() respects custom all_label", {
  html <- as.character(glassMultiSelect("f", choices, all_label = "Everything"))
  expect_match(html, "Everything")
  expect_match(html, 'data-all-label="Everything"', fixed = TRUE)
})


test_that("glassMultiSelect() check_style = 'checkbox' adds correct class", {
  html <- as.character(glassMultiSelect("f", choices, check_style = "checkbox"))
  expect_match(html, "style-checkbox")
})

test_that("glassMultiSelect() check_style = 'check-only' adds correct class", {
  html <- as.character(glassMultiSelect("f", choices, check_style = "check-only"))
  expect_match(html, "style-check-only")
})

test_that("glassMultiSelect() check_style = 'filled' adds correct class", {
  html <- as.character(glassMultiSelect("f", choices, check_style = "filled"))
  expect_match(html, "style-filled")
})

test_that("glassMultiSelect() rejects invalid check_style", {
  expect_error(glassMultiSelect("f", choices, check_style = "dotted"), class = "glasstabs_error_bad_argument")
})


test_that("glassMultiSelect() show_style_switcher = TRUE renders switcher", {
  html <- as.character(glassMultiSelect("f", choices, show_style_switcher = TRUE))
  expect_match(html, "gt-style-switcher")
})

test_that("glassMultiSelect() show_style_switcher = FALSE omits switcher", {
  html <- as.character(glassMultiSelect("f", choices, show_style_switcher = FALSE))
  expect_false(grepl("gt-style-switcher", html))
})

test_that("glassMultiSelect() show_select_all = FALSE keeps element in DOM hidden", {
  html <- as.character(glassMultiSelect("f", choices, show_select_all = FALSE))
  expect_match(html, "gt-ms-all")
  expect_match(html, "display:none")
})

test_that("glassMultiSelect() show_clear_all = FALSE keeps clear link in DOM", {
  html <- as.character(glassMultiSelect("f", choices, show_clear_all = FALSE))
  expect_match(html, "gt-ms-clear")
  expect_match(html, "display:none")
})

test_that("glassMultiSelect() show_clear_all = TRUE renders clear link", {
  html <- as.character(glassMultiSelect("f", choices, show_clear_all = TRUE))
  expect_match(html, "gt-ms-clear")
})


test_that("glassMultiSelect() dark theme injects CSS accent variable", {
  html <- as.character(glassMultiSelect("f", choices, theme = "dark"))
  expect_match(html, "--ms-accent")
})

test_that("glassMultiSelect() light theme injects light accent color", {
  html <- as.character(glassMultiSelect("f", choices, theme = "light"))
  expect_match(html, "#2563eb")
})

test_that("glassMultiSelect() auto theme emits auto class and Bootstrap dark override", {
  html <- as.character(glassMultiSelect("f", choices, theme = "auto"))
  expect_match(html, "theme-auto", fixed = TRUE)
  expect_match(html, "theme-light", fixed = TRUE)
  expect_match(html, 'data-bs-theme="dark"', fixed = TRUE)
})

test_that("glassMultiSelect() glass_select_theme() accent appears in HTML", {
  t <- glass_select_theme(accent_color = "#abcdef")
  html <- as.character(glassMultiSelect("f", choices, theme = t))
  expect_match(html, "#abcdef")
})

test_that("glassMultiSelect() custom focus ring appears in HTML", {
  theme <- glass_select_theme(focus_ring = "#a21caf")
  html <- as.character(glassMultiSelect("f", choices, theme = theme))
  expect_match(html, "--ms-focus-ring:#a21caf", fixed = TRUE)
})

test_that("glassMultiSelect() errors on invalid theme string", {
  expect_error(glassMultiSelect("f", choices, theme = "monokai"), class = "glasstabs_error_bad_theme")
})


test_that("glassMultiSelect() auto-assigns --opt-hue to all options", {
  html <- as.character(glassMultiSelect("f", choices, check_style = "filled"))
  expect_match(html, "--opt-hue")
})

test_that("glassMultiSelect() respects manual named hues", {
  html <- as.character(
    glassMultiSelect(
      "f",
      choices,
      check_style = "filled",
      hues = c(apple = 10L, banana = 50L, cherry = 340L)
    )
  )
  expect_match(html, "--opt-hue:10")
  expect_match(html, "--opt-hue:50")
  expect_match(html, "--opt-hue:340")
})

test_that("glassMultiSelect() accepts unnamed hues of matching length", {
  expect_no_error(
    glassMultiSelect(
      "f",
      choices,
      check_style = "filled",
      hues = c(10L, 50L, 340L)
    )
  )
})

test_that("glassMultiSelect() errors on unnamed hues with wrong length", {
  expect_error(
    glassMultiSelect(
      "f",
      choices,
      check_style = "filled",
      hues = c(10L, 50L)
    ),
    class = "glasstabs_error_bad_argument"
  )
})


test_that("glassMultiSelect() scopes element ids to inputId", {
  html <- as.character(glassMultiSelect("my_filter", choices))
  expect_true(grepl('id="my_filter-wrap"', html, fixed = TRUE))
  expect_true(grepl('id="my_filter-trigger"', html, fixed = TRUE))
  expect_true(grepl('id="my_filter-dropdown"', html, fixed = TRUE))
  expect_true(grepl('id="my_filter-options"', html, fixed = TRUE))
  expect_true(grepl('id="my_filter-count"', html, fixed = TRUE))
  expect_true(grepl('id="my_filter-clear"', html, fixed = TRUE))
})

test_that("glassMultiSelect() sets data-input-id attribute", {
  html <- as.character(glassMultiSelect("my_filter", choices))
  expect_true(grepl('data-input-id="my_filter"', html, fixed = TRUE))
})


test_that("glassFilterTags() sets data-tags-for to inputId", {
  html <- as.character(glassFilterTags("my_filter"))
  expect_true(grepl('data-tags-for="my_filter"', html, fixed = TRUE))
})

test_that("glassFilterTags() includes gt-filter-tags class", {
  html <- as.character(glassFilterTags("f"))
  expect_match(html, "gt-filter-tags")
})

test_that("glassFilterTags() appends extra CSS class", {
  html <- as.character(glassFilterTags("f", class = "my-class"))
  expect_match(html, "my-class")
  expect_match(html, "gt-filter-tags")
})


test_that("glassMultiSelectValue() returns selected and style reactives", {
  input <- shiny::reactiveValues(
    pick = c("apple", "banana"),
    pick_style = "filled"
  )

  helper <- glassMultiSelectValue(input, "pick")

  expect_true(is.list(helper))
  expect_true(is.function(helper$selected))
  expect_true(is.function(helper$style))

  expect_equal(shiny::isolate(helper$selected()), c("apple", "banana"))
  expect_equal(shiny::isolate(helper$style()), "filled")
})

test_that("glassMultiSelectValue() falls back to empty selection and checkbox style", {
  input <- shiny::reactiveValues()

  helper <- glassMultiSelectValue(input, "pick")

  expect_equal(shiny::isolate(helper$selected()), character(0))
  expect_equal(shiny::isolate(helper$style()), "checkbox")
})

test_that("updateGlassMultiSelect() sends normalized choices", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(fake_session, "pick", choices = choices)

  mockery::expect_called(send_mock, 1)
  args <- mockery::mock_args(send_mock)[[1]]

  expect_equal(args[[1]], "pick")
  expect_true(is.list(args[[2]]$choices))
  expect_equal(args[[2]]$choices[[1]]$label, "Apple")
  expect_equal(args[[2]]$choices[[1]]$value, "apple")
})

test_that("updateGlassMultiSelect() sends selected values unchanged", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(
    fake_session,
    "pick",
    selected = c("apple", "cherry")
  )

  args <- mockery::mock_args(send_mock)[[1]]
  expect_equal(args[[1]], "pick")
  expect_equal(args[[2]]$selected, c("apple", "cherry"))
})

test_that("updateGlassMultiSelect() uses retryable custom messages for Shiny sessions", {
  sent <- list()
  fake_session <- list(
    sendCustomMessage = function(type, message) {
      sent[[length(sent) + 1L]] <<- list(type = type, message = message)
    },
    ns = shiny::NS("module")
  )

  updateGlassMultiSelect(fake_session, "pick", selected = "apple")

  expect_length(sent, 1L)
  expect_equal(sent[[1]]$type, "glasstabs_update_multiselect")
  expect_equal(sent[[1]]$message$inputId, "module-pick")
  expect_equal(sent[[1]]$message$data$selected, "apple")
})

test_that("updateGlassMultiSelect() allows clearing with character(0)", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(
    fake_session,
    "pick",
    selected = character(0)
  )

  args <- mockery::mock_args(send_mock)[[1]]
  expect_equal(args[[2]]$selected, character(0))
})

test_that("updateGlassMultiSelect() sends style when provided", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(
    fake_session,
    "pick",
    check_style = "filled"
  )

  args <- mockery::mock_args(send_mock)[[1]]
  expect_equal(args[[2]]$style, "filled")
})

test_that("updateGlassMultiSelect() sends shape when provided", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(fake_session, "pick", shape = "square")

  args <- mockery::mock_args(send_mock)[[1]]
  expect_equal(args[[2]]$shape, "square")
})

test_that("updateGlassMultiSelect() routes shape through retryable custom messages", {
  sent <- list()
  fake_session <- list(
    sendCustomMessage = function(type, message) {
      sent[[length(sent) + 1L]] <<- list(type = type, message = message)
    },
    ns = function(id) paste0("module-", id)
  )

  updateGlassMultiSelect(fake_session, "pick", shape = "square")

  expect_equal(sent[[1]]$type, "glasstabs_update_multiselect")
  expect_equal(sent[[1]]$message$inputId, "module-pick")
  expect_equal(sent[[1]]$message$data$shape, "square")
})

test_that("updateGlassMultiSelect() rejects an invalid shape", {
  fake_session <- list(sendInputMessage = function(...) NULL)
  expect_error(updateGlassMultiSelect(fake_session, "pick", shape = "oval"), class = "glasstabs_error_bad_argument")
})

test_that("updateGlassMultiSelect() rejects invalid style", {
  fake_session <- list(sendInputMessage = function(...) NULL)

  expect_error(
    updateGlassMultiSelect(
      fake_session,
      "pick",
      check_style = "bad-style"
    ),
    class = "glasstabs_error_bad_argument"
  )
})

test_that("updateGlassMultiSelect() sends empty message when no updates supplied", {
  send_mock <- mockery::mock()
  fake_session <- list(sendInputMessage = send_mock)

  updateGlassMultiSelect(fake_session, "pick")

  args <- mockery::mock_args(send_mock)[[1]]
  expect_equal(args[[1]], "pick")
  expect_equal(args[[2]], list())
})


test_that("glassMultiSelect() with empty choices does not mark select-all as checked", {
  html <- as.character(glassMultiSelect("f", character(0)))
  expect_false(grepl("gt-ms-all checked", html, fixed = TRUE))
})

test_that("glassMultiSelect() accepts empty choices", {
  expect_no_error(glassMultiSelect("f", character(0)))
})

test_that("glassMultiSelect() with empty choices shows placeholder", {
  html <- as.character(glassMultiSelect("f", character(0), placeholder = "Choose"))
  expect_true(grepl("Choose", html, fixed = TRUE))
})

test_that("glassMultiSelect() with empty choices renders no option rows", {
  html <- as.character(glassMultiSelect("f", character(0)))
  expect_false(grepl("gt-ms-option", html, fixed = TRUE))
})

test_that("glassMultiSelect(server = TRUE) renders a bounded initial option set", {
  many <- stats::setNames(sprintf("value-%03d", 1:100), sprintf("Choice %03d", 1:100))
  html <- as.character(glassMultiSelect("remote", many, server = TRUE, server_limit = 10))

  n <- lengths(regmatches(html, gregexpr("gt-ms-option", html, fixed = TRUE)))
  checked <- lengths(regmatches(html, gregexpr("gt-ms-option checked", html, fixed = TRUE)))

  expect_equal(n, 10L)
  expect_equal(checked, 10L)
  expect_true(grepl('data-server="true"', html, fixed = TRUE))
  expect_true(grepl('data-server-total="100"', html, fixed = TRUE))
  expect_true(grepl("100 / 100 selected", html, fixed = TRUE))
  expect_true(grepl("value-010", html, fixed = TRUE))
  expect_false(grepl('data-value="value-011"', html, fixed = TRUE))
})

test_that("glassMultiSelect(server = TRUE) preserves full selected state outside DOM", {
  many <- stats::setNames(sprintf("value-%03d", 1:100), sprintf("Choice %03d", 1:100))
  html <- as.character(glassMultiSelect("remote", many, server = TRUE, server_limit = 10))

  expect_true(grepl('data-selected-values="[&quot;value-001&quot;', html, fixed = TRUE))
  expect_true(grepl('&quot;value-100&quot;]"', html, fixed = TRUE))
})

test_that("glassMultiSelect(server = TRUE) does not render all explicit selected values", {
  many <- stats::setNames(sprintf("value-%03d", 1:100), sprintf("Choice %03d", 1:100))
  html <- as.character(
    glassMultiSelect(
      "remote",
      many,
      selected = sprintf("value-%03d", c(1:5, 95:100)),
      server = TRUE,
      server_limit = 10
    )
  )

  n <- lengths(regmatches(html, gregexpr("gt-ms-option", html, fixed = TRUE)))
  expect_equal(n, 10L)
  expect_false(grepl('data-value="value-095"', html, fixed = TRUE))
  expect_true(grepl('&quot;value-095&quot;', html, fixed = TRUE))
})



test_that("glassMultiSelect() defaults to rounded corners (no shape-square class)", {
  html <- as.character(glassMultiSelect("f", choices))
  expect_false(grepl("shape-square", html, fixed = TRUE))
})

test_that("glassMultiSelect(shape = 'square') adds the shape-square wrap class", {
  html <- as.character(glassMultiSelect("f", choices, shape = "square"))
  expect_match(html, "gt-ms-wrap[^\"]*shape-square")
})

test_that("glassMultiSelect() rejects an invalid shape", {
  expect_error(glassMultiSelect("f", choices, shape = "circle"), class = "glasstabs_error_bad_argument")
})