tests/testthat/test-sidebar.R

In leaflet.extras2: Extra Functionality for 'leaflet' Package

test_that("sidebar", {
  ## Check HTML ####################
  m <- sidebar_pane(
    title = "messages", id = "messages_id", icon = tags$i(class = "person"),
    tagList(tags$div("Some Shiny Inputs"))
  )
  expect_is(m, "shiny.tag")

  m <- sidebar_tabs(
    id = "sidebar",
    list(tags$i(class = "car"), tags$i(class = "user"), tags$i(class = "car")),
    sidebar_pane(
      title = "home", id = "home_id", icon = tags$i(class = "home"),
      tagList(tags$div("Some Shiny Inputs"))
    ),
    sidebar_pane(
      title = "profile", id = "profile_id", icon = tags$i(class = "wrench"),
      tagList(tags$div("Some Shiny Inputs"))
    ),
    sidebar_pane(
      title = "messages", id = "messages_id", icon = tags$i(class = "person"),
      tagList(tags$div("Some Shiny Inputs"))
    )
  )
  expect_is(m, "shiny.tag")

  ## Leaflet ####################
  m <- leaflet() %>%
    addSidebar()
  expect_is(m, "leaflet")

  deps <- findDependencies(m)
  expect_equal(deps[[length(deps)]]$name, "lfx-sidebar")

  m <- m %>%
    removeSidebar()
  expect_equal(
    m$x$calls[[length(m$x$calls)]]$method,
    "removeSidebar"
  )

  m <- m %>%
    openSidebar("tab1")
  expect_equal(
    m$x$calls[[length(m$x$calls)]]$method,
    "openSidebar"
  )

  m <- m %>%
    closeSidebar()
  expect_equal(
    m$x$calls[[length(m$x$calls)]]$method,
    "closeSidebar"
  )

  ## Check For Modules ##########
  m <- leaflet() %>%
    addSidebar(ns = shiny::NS("modul"))
  expect_is(m, "leaflet")
  expect_equal(
    m$x$calls[[length(m$x$calls)]]$args[[1]],
    "modul-sidebar"
  )

  m <- leaflet() %>%
    addSidebar(ns = shiny::NS("modul")) %>%
    openSidebar(id = "sidebar", ns = shiny::NS("modul"))
  expect_is(m, "leaflet")
  expect_equal(
    m$x$calls[[length(m$x$calls)]]$args[[1]]$id,
    "modul-sidebar"
  )
})

test_that("sidebar isolates map pointer events", {
  js <- paste(
    paste(readLines(system.file(
      "htmlwidgets/lfx-sidebar/leaflet-sidebar.js",
      package = "leaflet.extras2"
    )), collapse = "\n"),
    paste(readLines(system.file(
      "htmlwidgets/lfx-sidebar/leaflet-sidebar-binding.js",
      package = "leaflet.extras2"
    )), collapse = "\n"),
    sep = "\n"
  )
  expect_match(js, "disableClickPropagation")
  expect_match(js, "disableScrollPropagation")
  expect_match(js, "__lfxSidebarFix")
  expect_match(js, "lfx-sidebar-ui-open")
  expect_match(js, "dropdownParent")
})

test_that("sidebar-error", {
  expect_error(
    sidebar_pane(
      icon = tags$i(class = "person"),
      tagList()
    )
  )

  expect_error(
    sidebar_tabs(
      list(tags$i(class = "person"), tags$i(class = "person")),
      sidebar_pane(
        id = "home_id",
        icon = tags$i(class = "person"), tagList()
      ),
      sidebar_pane(
        id = "profile_id",
        icon = tags$i(class = "person"), tagList()
      ),
      sidebar_pane(
        id = "messages_id",
        icon = tags$i(class = "person"), tagList()
      )
    )
  )
})