diff --git a/NAMESPACE b/NAMESPACE index 4028256f2..175a0bbd7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,3 +1,8 @@ +S3method(pointData,SpatialPoints) +S3method(pointData,SpatialPointsDataFrame) +S3method(pointData,data.frame) +S3method(pointData,default) +S3method(pointData,matrix) export("%>%") export(addCircleMarkers) export(addCircles) @@ -12,6 +17,7 @@ export(clearBounds) export(fitBounds) export(leaflet) export(leafletOutput) +export(pointData) export(renderLeaflet) export(setView) export(uspop2000) diff --git a/R/layers.R b/R/layers.R index 261a42dd6..7903b5f1b 100644 --- a/R/layers.R +++ b/R/layers.R @@ -11,15 +11,10 @@ makeOpts <- function(matchCall, excludes = NULL, envir = parent.frame(2)) { # Evaluate list members that are formulae, using the map data as the environment # (if provided, otherwise the formula environment) -evalFormula <- function(list, map) { - data <- map$x$data +evalFormula <- function(list, data) { evalAll <- function(x) { if (is.list(x)) return(lapply(x, evalAll)) - if (inherits(x, 'formula')) { - if (length(x) != 2L) stop('The formula must be one-sided: ', deparse(x)) - x <- eval(x[[2]], data, environment(x)) - } - x + return(resolveFormula(x, data)) } evalAll(list) } @@ -76,12 +71,12 @@ addTiles = function( '© OpenStreetMap', 'contributors, CC-BY-SA' ) - appendMapData(map, 'tileLayer', urlTemplate = urlTemplate, options = options) + appendMapData(map, getMapData(map), 'tileLayer', urlTemplate = urlTemplate, options = options) } #' @export addPopups = function( - map, lat, lng, content, layerId = NULL, + map, lng = NULL, lat = NULL, content, layerId = NULL, maxWidth = 300, minWidth = 50, maxHeight = NULL, @@ -94,16 +89,18 @@ addPopups = function( # autoPanPadding = TODO, zoomAnimation = TRUE, closeOnClick = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "content", "layerId")) - appendMapData(map, 'popup', lat, lng, content, layerId, options) %>% - expandLimits(lat, lng) + options <- makeOpts(match.call(), c("map", "lng", "lat", "content", "layerId", "data")) + pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addPopups") + appendMapData(map, data, 'popup', pts$lat, pts$lng, content, layerId, options) %>% + expandLimits(pts$lat, pts$lng) } #' @export addMarkers = function( - map, lat, lng, layerId = NULL, + map, lng = NULL, lat = NULL, layerId = NULL, icon = NULL, clickable = TRUE, draggable = FALSE, @@ -113,16 +110,18 @@ addMarkers = function( zIndexOffset = 0, opacity = 1.0, riseOnHover = FALSE, - riseOffset = 250 + riseOffset = 250, + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "layerId")) - appendMapData(map, 'marker', lat, lng, layerId, options) %>% - expandLimits(lat, lng) + options <- makeOpts(match.call(), c("map", "lng", "lat", "layerId", "data")) + pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addMarkers") + appendMapData(map, data, 'marker', pts$lat, pts$lng, layerId, options) %>% + expandLimits(pts$lat, pts$lng) } #' @export addCircleMarkers = function( - map, lat, lng, radius = 10, layerId = NULL, + map, lng = NULL, lat = NULL, radius = 10, layerId = NULL, stroke = TRUE, color = "#03F", weight = 5, @@ -135,16 +134,18 @@ addCircleMarkers = function( lineJoin = NULL, clickable = TRUE, pointerEvents = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "radius", "layerId")) - appendMapData(map, 'circleMarker', lat, lng, radius, layerId, options) %>% - expandLimits(lat, lng) + options <- makeOpts(match.call(), c("map", "lng", "lat", "radius", "layerId", "data")) + pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addCircleMarkers") + appendMapData(map, data, 'circleMarker', pts$lat, pts$lng, radius, layerId, options) %>% + expandLimits(pts$lat, pts$lng) } #' @export addCircles = function( - map, lat, lng, radius = 10, layerId = NULL, + map, lng = NULL, lat = NULL, radius = 10, layerId = NULL, stroke = TRUE, color = "#03F", weight = 5, @@ -157,17 +158,19 @@ addCircles = function( lineJoin = NULL, clickable = TRUE, pointerEvents = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "radius", "layerId")) - appendMapData(map, 'circle', lat, lng, radius, layerId, options) %>% - expandLimits(lat, lng) + options <- makeOpts(match.call(), c("map", "lng", "lat", "radius", "layerId", "data")) + pts <- derivePoints(data, lng, lat, missing(lng), missing(lat), "addCircles") + appendMapData(map, data, 'circle', pts$lat, pts$lng, radius, layerId, options) %>% + expandLimits(pts$lat, pts$lng) } # WARNING: lat and lng are LISTS of latitude and longitude vectors #' @export addPolylines = function( - map, lat, lng, layerId = NULL, + map, lng = NULL, lat = NULL, layerId = NULL, smoothFactor = 1.0, noClip = FALSE, color = "#03F", @@ -178,16 +181,19 @@ addPolylines = function( lineJoin = NULL, clickable = TRUE, pointerEvents = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "layerId")) - appendMapData(map, 'polyline', lat, lng, layerId, options) %>% + options <- makeOpts(match.call(), c("map", "lng", "lat", "layerId", "data")) + lng <- resolveFormula(lng, data) + lat <- resolveFormula(lat, data) + appendMapData(map, data, 'polyline', lat, lng, layerId, options) %>% expandLimits(unlist(lat), unlist(lng)) } #' @export addRectangles = function( - map, lat1, lng1, lat2, lng2, layerId = NULL, + map, lng1, lat1, lng2, lat2, layerId = NULL, smoothFactor = 1.0, noClip = FALSE, color = "#03F", @@ -201,17 +207,22 @@ addRectangles = function( lineJoin = NULL, clickable = TRUE, pointerEvents = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat1", "lng1", "lat2", "lng2", "layerId")) - appendMapData(map, 'rectangle',lat1, lng1, lat2, lng2, layerId, options) %>% + options <- makeOpts(match.call(), c("map", "lat1", "lng1", "lat2", "lng2", "layerId", "data")) + lng1 <- resolveFormula(lng1, data) + lat1 <- resolveFormula(lat1, data) + lng2 <- resolveFormula(lng2, data) + lat2 <- resolveFormula(lat2, data) + appendMapData(map, data, 'rectangle',lat1, lng1, lat2, lng2, layerId, options) %>% expandLimits(c(lat1, lat2), c(lng1, lng2)) } # WARNING: lat and lng are LISTS of latitude and longitude vectors #' @export addPolygons = function( - map, lat, lng, layerId = NULL, + map, lng = NULL, lat = NULL, layerId = NULL, smoothFactor = 1.0, noClip = FALSE, color = "#03F", @@ -225,14 +236,17 @@ addPolygons = function( lineJoin = NULL, clickable = TRUE, pointerEvents = NULL, - className = "" + className = "", + data = getMapData(map) ) { - options <- makeOpts(match.call(), c("map", "lat", "lng", "layerId")) - appendMapData(map, 'polygon', lat, lng, layerId, options) %>% + options <- makeOpts(match.call(), c("map", "lng", "lat", "layerId", "data")) + lng <- resolveFormula(lng, data) + lat <- resolveFormula(lat, data) + appendMapData(map, data, 'polygon', lat, lng, layerId, options) %>% expandLimits(unlist(lat), unlist(lng)) } #' @export -addGeoJSON = function(map, data, layerId = NULL, options = list()) { - appendMapData(map, 'geoJSON', data, layerId, options) +addGeoJSON = function(map, geojson, layerId = NULL, options = list()) { + appendMapData(map, getMapData(map), 'geoJSON', geojson, layerId, options) } diff --git a/R/leaflet.R b/R/leaflet.R index cd25bc35c..5d8660e05 100644 --- a/R/leaflet.R +++ b/R/leaflet.R @@ -14,7 +14,10 @@ leaflet = function(data = NULL, id = NULL, width = NULL, height = NULL, padding = 0) { htmlwidgets::createWidget( 'leaflet', - list(mapId = id, data = data), + structure( + list(mapId = id), + leafletData = data + ), width = width, height = height, sizingPolicy = htmlwidgets::sizingPolicy( defaultWidth = 'auto', @@ -24,3 +27,7 @@ leaflet = function(data = NULL, id = NULL, width = NULL, height = NULL, padding ) ) } + +getMapData <- function(map) { + attr(map$x, "leafletData", exact = TRUE) +} diff --git a/R/normalize.R b/R/normalize.R index 3b571f578..71f18a7b2 100644 --- a/R/normalize.R +++ b/R/normalize.R @@ -23,23 +23,66 @@ guessLatLongCols <- function(names, stopOnFailure = TRUE, return(list(lng=NA, lat=NA)) } +resolveFormula <- function(f, data) { + if (!inherits(f, 'formula')) + return(f) + if (length(f) != 2L) + stop("Unexpected two-sided formula: ", deparse(f)) + eval(f[[2]], data, environment(f)) +} + +# Given a data object and lng/lat arguments (which may be NULL [meaning infer +# from data], formula [which should be evaluated with respect to the data], or +# vector data [which should be used as-is]) return a lng/lat data frame. +derivePoints <- function(data, lng, lat, missingLng, missingLat, funcName) { + if (missingLng || missingLat) { + if (is.null(data)) { + stop("Point data not found; please provide ", funcName, + " with data and/or lng/lat arguments") + } + pts <- pointData(data) + if (is.null(lng)) + lng <- pts$lng + if (is.null(lat)) + lat <- pts$lat + } + + lng <- resolveFormula(lng, data) + lat <- resolveFormula(lat, data) + + if (is.null(lng) && is.null(lat)) { + stop(funcName, " requires non-NULL longitude/latitude values") + } else if (is.null(lng)) { + stop(funcName, " requires non-NULL longitude values") + } else if (is.null(lat)) { + stop(funcName, " requires non-NULL latitude values") + } + + data.frame(lng=lng, lat=lat) +} + # TODO: Add tests +#' @export pointData <- function(obj) { UseMethod("pointData") } +#' @export pointData.default <- function(obj) { - stop("Don't know how to get location data from object of class ", class(obj)) + stop("Don't know how to get location data from object of class ", + class(obj)[[1]]) } +#' @export pointData.data.frame <- function(obj) { cols <- guessLatLongCols(names(obj)) - return(data.frame( - lng = obj[cols$lng], - lat = obj[cols$lat] - )) + data.frame( + lng = obj[[cols$lng]], + lat = obj[[cols$lat]] + ) } +#' @export pointData.matrix <- function(obj) { dims <- dim(obj) if (length(dims) != 2) { @@ -52,6 +95,7 @@ pointData.matrix <- function(obj) { data.frame(lng = obj[,1], lat = obj[,2]) } +#' @export pointData.SpatialPoints <- function(obj) { structure( as.data.frame(sp::coordinates(obj)), @@ -59,6 +103,7 @@ pointData.SpatialPoints <- function(obj) { ) } +#' @export pointData.SpatialPointsDataFrame <- function(obj) { structure( as.data.frame(sp::coordinates(obj)), diff --git a/R/utils.R b/R/utils.R index 94e6ec3ca..1ae444acb 100644 --- a/R/utils.R +++ b/R/utils.R @@ -4,11 +4,11 @@ filterNULL = function(x) { x[!unlist(lapply(x, is.null))] } -appendMapData = function(map, component, ...) { +appendMapData = function(map, data, component, ...) { x = map$x[[component]] if (is.null(x)) x = list() n = length(x) - x[[n + 1]] = evalFormula(list(...), map) + x[[n + 1]] = evalFormula(list(...), data) map$x[[component]] = x map } diff --git a/inst/examples/leaflet.R b/inst/examples/leaflet.R index 0170ae6ca..b16262f70 100644 --- a/inst/examples/leaflet.R +++ b/inst/examples/leaflet.R @@ -11,35 +11,35 @@ m = m %>% setView(c(42.0285, -93.65), zoom = 17) m # popup -m %>% addPopups(42.0285, -93.65, 'Here is the Department of Statistics, ISU') -rand_lat = function(n = 10) rnorm(n, 42.0285, .01) +m %>% addPopups(-93.65, 42.0285, 'Here is the Department of Statistics, ISU') rand_lng = function(n = 10) rnorm(n, -93.65, .01) +rand_lat = function(n = 10) rnorm(n, 42.0285, .01) m = m %>% clearBounds() # TODO: only one popup can be opened; need to bind all popups in a layer and show all -m %>% addPopups(rand_lat(), rand_lng(), 'Random popups') +m %>% addPopups(rand_lng(), rand_lat(), 'Random popups') # marker -m %>% addMarkers(rand_lat(), rand_lng()) +m %>% addMarkers(rand_lng(), rand_lat()) # circle (units in metres) -m %>% addCircles(rand_lat(50), rand_lng(50), radius = runif(50, 50, 150)) +m %>% addCircles(rand_lng(50), rand_lat(50), radius = runif(50, 50, 150)) # circle marker (units in pixels) -m %>% addCircleMarkers(rand_lat(50), rand_lng(50), color = '#ff0000') -m %>% addCircleMarkers(rand_lat(100), rand_lng(100), radius = runif(100, 5, 15)) +m %>% addCircleMarkers(rand_lng(50), rand_lat(50), color = '#ff0000') +m %>% addCircleMarkers(rand_lng(100), rand_lat(100), radius = runif(100, 5, 15)) # rectangle m %>% addRectangles( - rand_lat(), rand_lng(), rand_lat(), rand_lng(), + rand_lng(), rand_lat(), rand_lng(), rand_lat(), color = 'red', fill = FALSE, dashArray = '5,5', weight = 3 ) # polyline -m %>% addPolylines(rand_lat(50), rand_lng(50)) +m %>% addPolylines(rand_lng(50), rand_lat(50)) # polygon -m %>% addPolygons(rand_lat(), rand_lng(), layerId = 'foo') +m %>% addPolygons(rand_lng(), rand_lat(), layerId = 'foo') # geoJSON seattle_geojson <- list( @@ -106,19 +106,19 @@ m %>% setView(c(47.6759920119894, -122.36075812146), zoom = 13) %>% addGeoJSON(s # use the OSM BW layer -leaflet() %>% addTiles('http://{s}.www.toolserver.org/tiles/bw-mapnik/{z}/{x}/{y}.png', list( +leaflet() %>% addTiles('http://{s}.www.toolserver.org/tiles/bw-mapnik/{z}/{x}/{y}.png', attribution = paste( '© OpenStreetMap contributors,', 'CC-BY-SA' ) -)) +) # provide a data frame to leaflet() df = data.frame( lat = rand_lat(100), lng = rand_lng(100), size = runif(100, 5, 20), color = rgb(runif(100), runif(100), runif(100)), stringsAsFactors = FALSE ) -m = leaflet(df) %>% addTiles() %>% setView(c(42.0285, -93.65), zoom = 17) -m %>% addCircleMarkers(~lat, ~lng, radius = ~size) -m %>% addCircleMarkers(~lat, ~lng, radius = runif(100, 4, 10), color = 'red') -m %>% addCircleMarkers(~lat, ~lng, radius = runif(100, 4, 10), color = ~color) +m = leaflet(df) %>% addTiles() +m %>% addCircleMarkers(~lng, ~lat, radius = ~size) +m %>% addCircleMarkers(~lng, ~lat, radius = runif(100, 4, 10), color = 'red') +m %>% addCircleMarkers(~lng, ~lat, radius = runif(100, 4, 10), color = ~color) diff --git a/inst/examples/normalize.R b/inst/examples/normalize.R new file mode 100644 index 000000000..e692862f2 --- /dev/null +++ b/inst/examples/normalize.R @@ -0,0 +1,51 @@ +library(leaflet) +library(sp) + +## Create different forms of point data ========== + +# Individual lng/lat vectors +lng <- runif(20) +lat <- runif(20) +# Simple matrix +mtx <- cbind(lng, lat) +# Spatial +pts <- sp::SpatialPoints(mtx) +ptsdf <- sp::SpatialPointsDataFrame(pts, data.frame(1:20)) +# Data frame with standard col names +data <- data.frame(Longitude=lng, Latitude=lat, X=1:20) +# Data frame with weird col names +dataWeird <- data.frame(LngCol = lng, LatCol = lat, X=1:20) + +# Make some circles, without formulas +leaflet() %>% addCircles(lng, lat) +leaflet() %>% addCircles(data = pts) +leaflet() %>% addCircles(data = ptsdf) +leaflet(data) %>% addCircles() +leaflet() %>% addCircles(data = data) + +# Make some circles, with formulas +leaflet(data) %>% addCircles(~Longitude, ~Latitude) +leaflet(dataWeird) %>% addCircles(~LngCol, ~LatCol) +leaflet() %>% addCircles(~LngCol, ~LatCol, data = dataWeird) + +# Recycling of lng/lat is valid (should it be??) +leaflet() %>% addTiles() %>% addCircles(c(1,2), sort(runif(20) + 10)) +# Plotting of empty data is OK +leaflet(data.frame(Latitude=numeric(0), Longitude=numeric(0))) %>% addCircles() +leaflet() %>% addCircles(numeric(0), numeric(0)) + +# Error cases +leaflet() %>% addCircles() # No data at all +leaflet() %>% addCircles(NULL, NULL) # Explicit NULL +leaflet() %>% addCircles(NULL, 1) # Explicit NULL longitude +leaflet() %>% addCircles(1, NULL) # Explicit NULL latitude +nolat <- NULL +# Indirect NULL. It'd be OK for lat to be missing, but not for it to be present +# and NULL. +leaflet(data) %>% addCircles(1, nolat) + +# Some polygon data +plng <- list(runif(3) + 1, runif(3) + 2, runif(3) + 3) +plat <- list(runif(3), runif(3), runif(3)) +pdata <- data.frame(Latitude=I(plat), Longitude=I(plng)) +leaflet(pdata) %>% addTiles() %>% addPolygons(~Longitude, ~Latitude) diff --git a/man/leaflet.Rd b/man/leaflet.Rd index 9da904404..446748603 100644 --- a/man/leaflet.Rd +++ b/man/leaflet.Rd @@ -36,35 +36,35 @@ m = m \%>\% setView(c(42.0285, -93.65), zoom = 17) m # popup -m \%>\% addPopups(42.0285, -93.65, 'Here is the Department of Statistics, ISU') -rand_lat = function(n = 10) rnorm(n, 42.0285, .01) +m \%>\% addPopups(-93.65, 42.0285, 'Here is the Department of Statistics, ISU') rand_lng = function(n = 10) rnorm(n, -93.65, .01) +rand_lat = function(n = 10) rnorm(n, 42.0285, .01) m = m \%>\% clearBounds() # TODO: only one popup can be opened; need to bind all popups in a layer and show all -m \%>\% addPopups(rand_lat(), rand_lng(), 'Random popups') +m \%>\% addPopups(rand_lng(), rand_lat(), 'Random popups') # marker -m \%>\% addMarkers(rand_lat(), rand_lng()) +m \%>\% addMarkers(rand_lng(), rand_lat()) # circle (units in metres) -m \%>\% addCircles(rand_lat(50), rand_lng(50), radius = runif(50, 50, 150)) +m \%>\% addCircles(rand_lng(50), rand_lat(50), radius = runif(50, 50, 150)) # circle marker (units in pixels) -m \%>\% addCircleMarkers(rand_lat(50), rand_lng(50), color = '#ff0000') -m \%>\% addCircleMarkers(rand_lat(100), rand_lng(100), radius = runif(100, 5, 15)) +m \%>\% addCircleMarkers(rand_lng(50), rand_lat(50), color = '#ff0000') +m \%>\% addCircleMarkers(rand_lng(100), rand_lat(100), radius = runif(100, 5, 15)) # rectangle m \%>\% addRectangles( - rand_lat(), rand_lng(), rand_lat(), rand_lng(), + rand_lng(), rand_lat(), rand_lng(), rand_lat(), color = 'red', fill = FALSE, dashArray = '5,5', weight = 3 ) # polyline -m \%>\% addPolylines(rand_lat(50), rand_lng(50)) +m \%>\% addPolylines(rand_lng(50), rand_lat(50)) # polygon -m \%>\% addPolygons(rand_lat(), rand_lng(), layerId = 'foo') +m \%>\% addPolygons(rand_lng(), rand_lat(), layerId = 'foo') # geoJSON seattle_geojson <- list( @@ -131,20 +131,20 @@ m \%>\% setView(c(47.6759920119894, -122.36075812146), zoom = 13) \%>\% addGeoJS # use the OSM BW layer -leaflet() \%>\% addTiles('http://{s}.www.toolserver.org/tiles/bw-mapnik/{z}/{x}/{y}.png', list( +leaflet() \%>\% addTiles('http://{s}.www.toolserver.org/tiles/bw-mapnik/{z}/{x}/{y}.png', attribution = paste( '© OpenStreetMap contributors,', 'CC-BY-SA' ) -)) +) # provide a data frame to leaflet() df = data.frame( lat = rand_lat(100), lng = rand_lng(100), size = runif(100, 5, 20), color = rgb(runif(100), runif(100), runif(100)), stringsAsFactors = FALSE ) -m = leaflet(df) \%>\% addTiles() \%>\% setView(c(42.0285, -93.65), zoom = 17) -m \%>\% addCircleMarkers(~lat, ~lng, radius = ~size) -m \%>\% addCircleMarkers(~lat, ~lng, radius = runif(100, 4, 10), color = 'red') -m \%>\% addCircleMarkers(~lat, ~lng, radius = runif(100, 4, 10), color = ~color) +m = leaflet(df) \%>\% addTiles() +m \%>\% addCircleMarkers(~lng, ~lat, radius = ~size) +m \%>\% addCircleMarkers(~lng, ~lat, radius = runif(100, 4, 10), color = 'red') +m \%>\% addCircleMarkers(~lng, ~lat, radius = runif(100, 4, 10), color = ~color) }