tests/testthat/test-plotly-sf.R

In plotly: Create Interactive Web Graphics via 'plotly.js'

has_mapbox <- function() {
  !is.null(tryNULL(mapbox_token()))
}

test_that("add_sf() is optional", {
  skip_if_not_installed("sf")
  
  nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
  storms <- sf::st_read(system.file("shape/storms_xyz.shp", package = "sf"), quiet = TRUE)
  
  p1 <- plotly_build(plot_ly(nc))
  p2 <- plotly_build(plot_ly() %>% add_sf(data = nc))
  
  expect_identical(p1$x$data, p2$x$data)
  
  # all counties drawn in one trace
  expect_length(p1$x$data, 1)
  
  # 108 polygons
  expect_equal(sum(is.na(p1$x$data[[1]]$x)), 107)
  expect_true(p1$x$data[[1]]$type == "scatter")
  expect_true(p1$x$data[[1]]$mode == "lines")
  expect_true(p1$x$data[[1]]$fill == "toself")
  
  # scaleanchor is set
  expect_true(p1$x$layout$xaxis$scaleanchor == "y")
  expect_equal(p1$x$layout$xaxis$scaleratio, 0.8167844, tolerance = 1e-6)
})


test_that("plot_geo() lat/lon range is set", {
  skip_if_not_installed("sf")
  
  nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
  expect_warning(p <- plotly_build(plot_geo(nc)), 
                 regexp = "Attempting transformation to the target coordinate system")
  expect_equal(
    p$x$layout$geo$lataxis$range, 
    c(33.85492, 36.61673), 
    tolerance = 1e-5
  )
  expect_equal(
    p$x$layout$geo$lonaxis$range, 
    c(-84.41252, -75.36831), 
    tolerance = 1e-5
  )
})

test_that("plot_mapbox() fitbounds is set", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
  p <- plotly_build(plot_mapbox(nc))
  expect_equal(
    p$x$layout$mapbox$`_fitBounds`$bounds, 
    c(-84.41252, 33.85492, -75.36831, 36.61673),
    tolerance = 1e-5
  )
})


test_that("sf defaults can be overriden", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
  # when applied to fillcolor, alpha defaults to 0.5
  p <- plotly_build(plot_mapbox(nc, color = I("red")))
  expect_true(p$x$data[[1]]$type == "scattermapbox")
  expect_true(p$x$data[[1]]$fill == "toself")
  expect_true(p$x$data[[1]]$line$color == toRGB("red"))
  expect_true(p$x$data[[1]]$fillcolor == toRGB("red", 0.5))
  
  p <- plotly_build(plot_mapbox(nc, color = I("red"), alpha = 0.8))
  expect_true(p$x$data[[1]]$line$color == toRGB("red"))
  expect_true(p$x$data[[1]]$fillcolor == toRGB("red", 0.8))
  
  p <- plotly_build(plot_mapbox(nc, color = I("red"), stroke = I("black"), alpha_stroke = 0.2))
  expect_true(p$x$data[[1]]$line$color == toRGB("black", 0.2))
  expect_true(p$x$data[[1]]$fillcolor == toRGB("red", 0.5))
})

test_that("Can plot sfc with a missing crs", {
  skip_if_not_installed("sf")
  
  storms <- sf::st_read(system.file("shape/storms_xyz.shp", package = "sf"), quiet = TRUE)
  expect_warning(p <- plotly_build(plot_geo(storms, name = "Storms")), 
                 regexp = "Missing coordinate reference system")
  expect_true(p$x$data[[1]]$type == "scattergeo")
  expect_true(p$x$data[[1]]$mode == "lines")
})


test_that("plot_ly() defaults to blank axes", {
  skip_if_not_installed("sf")
  
  m <- sf::st_as_sf(maps::map("world", plot = FALSE, fill = TRUE))
  
  p <- plot_ly() %>%
    add_sf(data = m, color = I("black"), fillcolor = "transparent", hoverinfo = "none") %>%
    layout(xaxis = list(title = "just a test")) %>%
    plotly_build()
  
  xaxis <- p$x$layout$xaxis
  yaxis <- p$x$layout$yaxis
  
  expect_false(xaxis$showgrid)
  expect_false(yaxis$showgrid)
  
  expect_false(xaxis$showticklabels)
  expect_false(yaxis$showticklabels)
  
  expect_false(xaxis$zeroline)
  expect_false(yaxis$zeroline)
  
  expect_true(xaxis$title == "just a test")
  expect_null(yaxis$title)
  
  expect_true(xaxis$ticks == "")
  expect_true(yaxis$ticks == "")
})

test_that("discrete color informs fillcolor", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  res <- unique(res_mn$INDRESNAME)
  cols <- viridisLite::magma(length(res))
  
  p <- plot_mapbox(res_mn, color = ~INDRESNAME, colors = cols) %>%
    plotly_build()
  
  d <- p$x$data
  expect_length(d, length(res))
  
  fillcolors <- sapply(d, "[[", "fillcolor")
  expect_identical(fillcolors, toRGB(cols, 0.5))
  
  # 'stroke' should inherit from fillcolor
  linecolors <- sapply(d, function(tr) tr$line$color)
  expect_identical(linecolors, toRGB(cols))
})


test_that("discrete color informs fillcolor", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  res <- unique(res_mn$INDRESNAME)
  cols <- viridisLite::magma(length(res))
  
  p <- plot_mapbox(res_mn, color = ~INDRESNAME, colors = cols) %>%
    plotly_build()
  
  d <- p$x$data
  expect_length(d, length(res))
  
  # alpha defaults to 0.5 when applied to fillcolor
  fillcolors <- sapply(d, "[[", "fillcolor")
  expect_identical(fillcolors, toRGB(cols, 0.5))
  
  # 'stroke' inherits from 'color'
  linecolors <- sapply(d, function(tr) tr$line$color)
  expect_identical(linecolors, toRGB(cols))
  
  # make sure we can set alpha/stroke
  p <- plot_mapbox(res_mn, color = ~INDRESNAME, colors = cols, alpha = 1, stroke = I("black")) %>%
    plotly_build()
  
  d <- p$x$data
  expect_length(d, length(res))
  
  fillcolors <- sapply(d, "[[", "fillcolor")
  expect_identical(fillcolors, toRGB(cols))
  
  linecolors <- sapply(d, function(tr) tr$line$color)
  expect_match(linecolors, "rgba(0,0,0,1)", fixed = TRUE)
})


test_that("numeric color informs fillcolor", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  p <- plot_mapbox(res_mn, color = ~AREA)
  expect_warning(plotly_build(p), "Only one fillcolor per trace allowed")
  
  d <- plotly_build(p)$x$data
  expect_true(d[[1]]$mode == "lines")
  
  
  res <- unique(res_mn$INDRESNAME)
  cols <- viridisLite::magma(length(res))
  p <- plot_mapbox(res_mn, split = ~INDRESNAME, color = ~AREA, colors = cols) %>%
    plotly_build()
  
  d <- p$x$data
  expect_length(d, length(res) + 1)
  
  # alpha defaults to 0.5 when applied to fillcolor
  area <- unique(res_mn$AREA)
  fillcolors <- unlist(lapply(d, "[[", "fillcolor"))
  areacolors <- scales::col_numeric(cols, range(area))(area)
  expect_identical(sort(fillcolors), sort(toRGB(areacolors, 0.5)))
  
  # 'stroke' should inherit from fillcolor
  # TODO: should strokes inherit from colors?
  linecolors <- unlist(lapply(d, function(tr) tr$line$color))
  expect_identical(sort(linecolors), sort(toRGB(areacolors)))
  
  # can set alpha_stroke
  p <- plot_mapbox(res_mn, split = ~INDRESNAME, color = ~AREA, colors = cols, alpha_stroke = 0) %>%
    plotly_build()
  d <- p$x$data
  expect_length(d, length(res) + 1)
  areas <- unique(res_mn$AREA)
  pal <- scales::col_numeric(cols, domain = range(areas))(areas)
  fillcolors <- unlist(lapply(d, function(tr) tr$fillcolor))
  expect_identical(sort(fillcolors), sort(toRGB(pal, 0.5)))
  linecolors <- unlist(lapply(d, function(tr) tr$line$color))
  expect_identical(sort(linecolors), sort(toRGB(pal, 0)))
})


test_that("sizing constants", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  # span controls 'stroke-size'
  p <- plot_mapbox(res_mn, span = I(5)) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  expect_true(d[[1]]$line$width == 5)
  
  # size controls marker-size
  mn_pts <- sf::st_centroid(res_mn)
  p <- plot_mapbox(mn_pts, size = I(30)) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  expect_length(d[[1]]$marker$size, nrow(mn_pts))
  expect_true(all(d[[1]]$marker$size == 30))
  expect_true(d[[1]]$marker$sizemode == "area")
  
  # span controls marker.line.width
  p <- plot_ly(mn_pts, size = I(30), span = I(10), stroke = I("black")) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  expect_length(d[[1]]$marker$size, nrow(mn_pts))
  expect_true(all(d[[1]]$marker$size == 30))
  expect_true(d[[1]]$marker$sizemode == "area")
  expect_true(d[[1]]$marker$line$width == 10)
  expect_true(d[[1]]$marker$line$color == toRGB("black"))
  
  # size controls error_x.width
  p <- plot_ly(mn_pts, size = I(20), error_x = list(value = 5)) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  expect_length(d[[1]]$marker$size, nrow(mn_pts))
  expect_true(all(d[[1]]$marker$size == 20))
  expect_true(d[[1]]$marker$sizemode == "area")
  expect_true(d[[1]]$error_x$value == 5)
  expect_true(d[[1]]$error_x$width == 20)

  
  # size controls textfont.size
  p <- plot_ly(mn_pts, size = I(20), text = "MN rocks", mode = "text") %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  expect_true(d[[1]]$mode == "text")
  expect_true(d[[1]]$textfont$size == 20)
})


test_that("size mappings", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  expect_warning(
    plotly_build(plot_mapbox(res_mn, span = ~PERIMETER)), 
    "`line.width` does not currently support multiple values"
  )
  
  # TODO: should a `size` mapping yield the same result in this case?
  res <- unique(res_mn$INDRESNAME)
  p <- plot_mapbox(res_mn, span = ~PERIMETER, split = ~INDRESNAME) %>% plotly_build()
  d <- p$x$data
  expect_length(d, length(res))
  perimeters <- unique(res_mn$PERIMETER)
  widths <- sapply(d, function(tr) tr$line$width)
  expect_equal(sort(widths), sort(scales::rescale(perimeters, to = c(1, 20))))
  
  
  mn_pts <- sf::st_centroid(res_mn)
  p <- plot_ly(mn_pts, size = ~AREA, span = I(10), stroke = I("black")) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  areas <- unique(res_mn$AREA)
  sizes <- unlist(lapply(d, function(tr) tr$marker$size))
  expect_equal(sort(sizes), sort(scales::rescale(areas, to = c(10, 100))))
  
  p <- plot_ly(mn_pts, size = I(10), span = ~PERIMETER, stroke = I("black")) %>% plotly_build()
  d <- p$x$data
  expect_length(d, 1)
  perimeters <- unique(res_mn$PERIMETER)
  widths <- unlist(lapply(d, function(tr) tr$marker$line$width))
  expect_equal(sort(widths), sort(scales::rescale(perimeters, to = c(1, 20))))
})


test_that("altogether now", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  nc <- sf::st_read(system.file("shape/nc.shp", package = "sf"), quiet = TRUE)
  s <- subplot(plot_ly(nc), plot_geo(nc), plot_mapbox(nc), nrows = 3) %>% plotly_build()
  d <- s$x$data
  expect_length(d, 3)
  linecolors <- sapply(d, function(tr) tr$line$color)
  fillcolors <- sapply(d, function(tr) tr$fillcolor)
  expect_equal(linecolors, toRGB(colorway()[1:3]))
  # should be 0.5, but close enough
  expect_equal(fillcolors, toRGB(colorway()[1:3], 0.498))

  
  # specify a colorway
  cols <- c("red", "blue", "green")
  s <- subplot(
    layout(plot_ly(nc), colorway = cols), 
    plot_geo(nc), plot_mapbox(nc), nrows = 3
  ) 
  d <- s$x$data
  expect_length(d, 3)
  linecolors <- sapply(d, function(tr) tr$line$color)
  fillcolors <- sapply(d, function(tr) tr$fillcolor)
  expect_equal(linecolors, toRGB(cols))
  # should be 0.5, but close enough
  expect_equal(fillcolors, toRGB(cols, 0.498))
  
  # TODO: this should also work
  # layout(s, colorway = c("red", "blue", "green"))
  
})



test_that("color and stroke scales can be set independently", {
  skip_if_not_installed("sf")
  skip_if_not(has_mapbox())
  
  n <- length(unique(res_mn$INDRESNAME))
  p <- plot_mapbox(res_mn, split = ~INDRESNAME, color = ~AREA, stroke = ~PERIMETER, span = I(2)) %>%
    plotly_build()
  
  # two colorbars
  d <- p$x$data
  expect_true(length(d) == n + 2)
  
  colorbars <- d[vapply(d, is.colorbar, logical(1))]
  
  expect_true(colorbars[[1]]$marker$colorbar$title == "AREA")
  expect_true(colorbars[[2]]$marker$colorbar$title == "PERIMETER")
  expect_true(all(colorbars[[1]]$marker$color == range(res_mn$AREA)))
  expect_true(all(colorbars[[2]]$marker$color == range(res_mn$PERIMETER)))
  
})