tests/testthat/test-heatmaps.R

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

## Data ##############
geoJson <- readr::read_file(
  "https://rawgit.com/benbalter/dc-maps/master/maps/historic-landmarks-points.geojson"
)
kml <- readr::read_file(
  system.file("examples/data/kml/crimes.kml.zip", package = "leaflet.extras")
)
csv <- readr::read_file(
  system.file("examples/data/csv/world_airports.csv.zip", package = "leaflet.extras")
)
airports <- readr::read_file(
  system.file("examples/data/gpx/md-airports.gpx.zip", package = "leaflet.extras")
)

## Tests ###################
test_that("heatmaps", {
  ## WebGL Heatmap #########################
  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    addWebGLHeatmap(lng = ~long, lat = ~lat)
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$size, "30000")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$units, "m")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$opacity, 1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$alphaRange, 1)

  expect_error({
    leaflet(quakes) %>%
      addWebGLHeatmap(
        lng = ~long, lat = ~lat,
        gradientTexture = "skyline1"
      )
  })
  ts <- leaflet(quakes) %>%
    addWebGLHeatmap(
      lng = ~long, lat = ~lat, intensity = ~mag,
      gradientTexture = "skyline"
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]][, "intensity"], quakes$mag)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$size, "30000")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$units, "m")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$opacity, 1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$gradientTexture, "skyline")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$alphaRange, 1)

  ts <- leaflet(quakes) %>%
    addWebGLHeatmap(
      lng = ~long, lat = ~lat, intensity = ~mag,
      size = 20000, group = "somegroup", opacity = 0.1, alphaRange = 0.8,
      units = "px",
      gradientTexture = "deep-sea"
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]][, "intensity"], quakes$mag)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$size, 20000)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$units, "px")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$opacity, 0.1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$gradientTexture, "deep-sea")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$alphaRange, 0.8)

  ts <- leaflet(quakes) %>%
    removeWebGLHeatmap(layerId = "somelayerid")
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "removeWebGLHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], "somelayerid")

  ts <- leaflet(quakes) %>%
    clearWebGLHeatmap()
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "clearWebGLHeatmap")

  ts <- leaflet() %>%
    setView(-77.0369, 38.9072, 12) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addWebGLGeoJSONHeatmap(
      geoJson,
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLGeoJSONHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$size, "30000")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$units, "m")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$opacity, 1)

  ts <- leaflet() %>%
    setView(-77.0369, 38.9072, 12) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addWebGLGeoJSONHeatmap(
      geoJson,
      size = 30, units = "px", gradientTexture = "deep-sea",
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLGeoJSONHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$size, 30)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$units, "px")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$gradientTexture, "deep-sea")

  ts <- leaflet() %>%
    setView(-77.0369, 38.9072, 12) %>%
    addGeoJSONv2(
      geoJson,
      markerType = "circleMarker",
      stroke = FALSE, fillColor = "black", fillOpacity = 0.7,
      markerOptions = markerOptions(radius = 2)
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-omnivore")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addGeoJSONv2")

  ts <- leaflet() %>%
    setView(-77.0369, 38.9072, 12) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addWebGLKMLHeatmap(kml, size = 20, units = "px") %>%
    addKML(
      kml,
      markerType = "circleMarker",
      stroke = FALSE, fillColor = "black", fillOpacity = 1,
      markerOptions = markerOptions(radius = 1)
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-omnivore")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addKML")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], kml)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "circleMarker")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[7]], markerOptions(radius = 1))
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[12]], labelOptions())
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[14]], popupOptions())

  ts <- leaflet() %>%
    setView(0, 0, 2) %>%
    addProviderTiles(providers$CartoDB.DarkMatterNoLabels) %>%
    addWebGLCSVHeatmap(
      csv,
      csvParserOptions("latitude_deg", "longitude_deg"),
      size = 10, units = "px",
      layerId = "somelayer", group = "mygroup"
    )
  # ts
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLCSVHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], csv)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[6]], csvParserOptions("latitude_deg", "longitude_deg"))
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$size, 10)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$units, "px")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$opacity, 1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$alphaRange, 1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[3]], "somelayer")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "mygroup")


  ts <- leaflet() %>%
    addBootstrapDependency() %>%
    setView(-76.6413, 39.0458, 8) %>%
    addProviderTiles(
      providers$CartoDB.Positron,
      options = providerTileOptions(detectRetina = TRUE)
    ) %>%
    addGPX(
      airports,
      markerType = "circleMarker",
      stroke = FALSE, fillColor = "black", fillOpacity = 1,
      markerOptions = markerOptions(radius = 1.5),
      group = "airports"
    ) %>%
    addWebGLGPXHeatmap(
      airports,
      size = 20000,
      group = "airports",
      opacity = 0.9
    )
  # ts
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-webgl-heatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addWebGLGPXHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], airports)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "airports")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$size, 20000)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$units, "m")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$opacity, 0.9)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$alphaRange, 1)

  expect_identical(ts$dependencies[[length(ts$dependencies) - 1]]$name, "lfx-omnivore")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$method, "addGPX")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[1]], airports)
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[3]], "airports")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[4]], "circleMarker")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[7]], markerOptions(radius = 1.5))
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[12]], labelOptions())
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[14]], popupOptions())
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[15]]$stroke, FALSE)
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[15]]$fillColor, "black")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[15]]$fillOpacity, 1)

  ## addHeatmap #########################
  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(178, -20, 5) %>%
    addHeatmap(
      lng = ~long, lat = ~lat, intensity = ~mag,
      blur = 20, max = 0.05, radius = 15
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]][, "intensity"], quakes[, "mag"])

  ts <- leaflet() %>% removeHeatmap(layerId = "bylayerid")
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "removeHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], "bylayerid")

  ts <- leaflet() %>% clearHeatmap()
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "clearHeatmap")


  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(178, -20, 5) %>%
    addHeatmap(
      lng = ~long, lat = ~lat, intensity = ~mag,
      # gradient = RColorBrewer::brewer.pal(5, "Reds"),
      gradient = c("#FEE5D9", "#FCAE91", "#FB6A4A", "#DE2D26", "#A50F15"),
      blur = 20, max = 0.05, radius = 15
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]][, "intensity"], quakes[, "mag"])
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$max, 0.05)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$radius, 15)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$blur, 20)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]]$minOpacity, 0.05)


  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(178, -20, 5) %>%
    addHeatmap(
      lng = ~long, lat = ~lat, intensity = NULL,
      # gradient = RColorBrewer::brewer.pal(5, "BrBG"),
      gradient = c("#A6611A", "#DFC27D", "#F5F5F5", "#80CDC1", "#018571"),
      blur = 20, max = 0.05, radius = 15
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addHeatmap")
  expect_identical(ncol(ts$x$calls[[length(ts$x$calls)]]$args[[1]]), 2L)


  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(178, -20, 5) %>%
    addHeatmap(
      lng = ~long, lat = ~lat, intensity = 3,
      blur = 20, max = 0.05, radius = 15
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]][, "intensity"], rep(3, nrow(quakes)))


  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(-77.0369, 38.9072, 12) %>%
    addGeoJSONHeatmap(geojson = geoJson)
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addGeoJSONHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], geoJson)
  expect_null(ts$x$calls[[length(ts$x$calls)]]$args[[2]])
  expect_null(ts$x$calls[[length(ts$x$calls)]]$args[[3]])
  expect_null(ts$x$calls[[length(ts$x$calls)]]$args[[4]])
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$minOpacity, 0.05)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$max, 1)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$radius, 25)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$blur, 15)

  ## TODO - GRADIENT CAN BE ANYTHING-- throws error in the browser console..
  ts <- leaflet(quakes) %>%
    addProviderTiles(providers$CartoDB.DarkMatter) %>%
    setView(-77.0369, 38.9072, 12) %>%
    addGeoJSONHeatmap(
      geojson = geoJson, layerId = "id", group = "group",
      intensityProperty = "someprop", minOpacity = 0.4, max = 10,
      radius = 50, gradient = "asd", cellSize = 20
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addGeoJSONHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], geoJson)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[2]], "someprop")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "group")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[3]], "id")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$max, 10)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$radius, 50)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$cellSize, 20)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[5]]$gradient, "asd")

  ts <- leaflet() %>%
    setView(-77.0369, 38.9072, 12) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addKMLHeatmap(kml, radius = 7) %>%
    addKML(
      kml,
      markerType = "circleMarker",
      stroke = FALSE, fillColor = "black", fillOpacity = 1,
      markerOptions = markerOptions(radius = 1)
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-omnivore")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addKML")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], kml)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "circleMarker")

  # addCSVHeatmap
  ts <- leaflet() %>%
    setView(0, 0, 2) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addCSVHeatmap(
      csv, csvParserOptions("latitude_deg", "longitude_deg"),
      layerId = "somelayer", group = "mygroup"
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-heat")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addCSVHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], csv)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[3]], "somelayer")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "mygroup")

  ## for more examples see
  # browseURL(system.file("examples/KML.R", package = "leaflet.extras"))


  ts <- leaflet() %>%
    addBootstrapDependency() %>%
    setView(-76.6413, 39.0458, 8) %>%
    addProviderTiles(
      providers$CartoDB.Positron,
      options = providerTileOptions(detectRetina = TRUE)
    ) %>%
    addGPXHeatmap(airports) %>%
    addGPX(
      airports,
      markerType = "circleMarker",
      stroke = FALSE, fillColor = "black", fillOpacity = 1,
      markerOptions = markerOptions(radius = 1.5),
      group = "airports"
    )
  expect_s3_class(ts, "leaflet")
  expect_identical(ts$dependencies[[length(ts$dependencies)]]$name, "lfx-omnivore")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$method, "addGPX")
  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$method, "addGPXHeatmap")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[1]], airports)
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[3]], "airports")
  expect_identical(ts$x$calls[[length(ts$x$calls)]]$args[[4]], "circleMarker")

  expect_identical(ts$x$calls[[length(ts$x$calls) - 1]]$args[[1]], airports)
  expect_null(ts$x$calls[[length(ts$x$calls) - 1]]$args[[2]])
  expect_null(ts$x$calls[[length(ts$x$calls) - 1]]$args[[3]])
  expect_null(ts$x$calls[[length(ts$x$calls) - 1]]$args[[4]])
})