tests/testthat/test-htmlwidgets.R

In htmlwidgets: HTML Widgets for R

test_that("Legacy widget html methods work", {
  # Finds htmlwidgets:::widgetA_html()
  res <- widget_html("widgetA", "htmlwidgets", id = "id", style = NULL, class = NULL)
  expect_identical(res$name, "canvas")
})

test_that("Legacy widget html methods are warned on unexpected output type", {
  expect_warning(
    res <- widget_html("widgetB", "htmlwidgets", id = "id", style = NULL, class = NULL),
    "widgetB_html returned an object of class `logical` instead of a `shiny.tag`.",
    fixed = TRUE
  )
  expect_identical(res, TRUE)
})

test_that("New-style widget html method works, and is preferred", {
  # widgetC has both widgetC_html and widget_html.widgetC, and they return
  # differing results. Make sure that widget_html.widgetC is the one that's
  # actually called.
  res <- widget_html("widgetC", "htmlwidgets", id = "id", style = NULL, class = NULL)
  expect_identical(
    res,
    widget_html.widgetC("widgetC", "htmlwidgets", id = "id", style = NULL, class = NULL))
})

test_that("New-style widget html methods do not trigger warning on non-tag output", {
  expect_warning(
    res <- widget_html("widgetD", "htmlwidgets", id = "id", style = NULL, class = NULL),
    NA
  )
  expect_identical(res, TRUE)
})

test_that("Fallback logic still works", {
  res <- widget_html("does_not_exist", "htmlwidgets", id = "id", style = NULL, class = NULL)
  expect_identical(res, tags$div(id = "id"))
})

test_that("Legacy methods work with tagList() and HTML()", {
  expect_warning({
    widget_html("widgetE", "htmlwidgets", id = "id", style = NULL, class = NULL)
    widget_html("widgetF", "htmlwidgets", id = "id", style = NULL, class = NULL)
  }, NA)
})