Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

added reachability / velocity plugins #181

Closed
wants to merge 2 commits into from
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions .Rbuildignore
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
^\_pkgdown\.yaml$
^docs$
^inst/examples/virginia.rds$
^inst/examples/velocity/wind-global.json$
^CONDUCT\.md$
^node_modules
^package.*\.json
Expand Down
6 changes: 4 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,9 @@ Authors@R: c(
person("Vladimir", "Agafonkin", role = c("ctb", "cph"), comment = "leaflet.heat library"),
person("Iván Sánchez", "Ortega", role = c("ctb", "cph"), comment = "leaflet.tilelayer.pouchdbcached library"),
person("Dale", "Harvey", role = c("ctb", "cph"), comment = "pouchdb-browser library"),
person("Mike", "Bostock", role = c("ctb", "cph"), comment = "topojson library")
person("Mike", "Bostock", role = c("ctb", "cph"), comment = "topojson library"),
person("Sebastian", "Gatscha", email= "[email protected]",
role = c("ctb", "cph"), comment = "leaflet.reachability, leaflet-velocity libraries")
)
Description: The 'leaflet' JavaScript library provides many plugins some of which
are available in the core 'leaflet' package, but there are many more. It is not
Expand All @@ -49,9 +51,9 @@ Imports:
htmlwidgets,
htmltools,
stringr,
jsonlite,
magrittr
Suggests:
jsonlite,
readr
URL: https://github.com/bhaskarvk/leaflet.extras, https://bhaskarvk.github.io/leaflet.extras/
BugReports: https://github.com/bhaskarvk/leaflet.extras/issues
Expand Down
9 changes: 9 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,7 @@ export(addKMLChoropleth)
export(addKMLHeatmap)
export(addMeasurePathToolbar)
export(addPulseMarkers)
export(addReachability)
export(addResetMapButton)
export(addReverseSearchGoogle)
export(addReverseSearchOSM)
Expand All @@ -34,6 +35,7 @@ export(addSearchGoogle)
export(addSearchOSM)
export(addSearchUSCensusBureau)
export(addStyleEditor)
export(addVelocity)
export(addWMSLegend)
export(addWeatherMarkers)
export(addWebGLCSVHeatmap)
Expand Down Expand Up @@ -66,21 +68,28 @@ export(propsToHTML)
export(propstoHTMLTable)
export(pulseIconList)
export(pulseIcons)
export(reachabilityOptions)
export(removeControlGPS)
export(removeDrawToolbar)
export(removeHeatmap)
export(removeReachability)
export(removeSearchFeatures)
export(removeSearchGoogle)
export(removeSearchOSM)
export(removeSearchUSCensusBureau)
export(removeStyleEditor)
export(removeVelocity)
export(removeWebGLHeatmap)
export(searchFeaturesOptions)
export(searchOptions)
export(selectedPathOptions)
export(setMapWidgetStyle)
export(suspendScroll)
export(velocityOptions)
export(weatherIconList)
export(weatherIcons)
import(leaflet)
importFrom(htmltools,htmlDependency)
importFrom(jsonlite,fromJSON)
importFrom(jsonlite,toJSON)
importFrom(magrittr,"%>%")
10 changes: 10 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,13 @@
# leaflet.extras 1.1.0

## New Features

* Added support for [Leaflet-Reachability](https://github.com/traffordDataLab/leaflet.reachability).
* Added support for [Leaflet-Velocity](https://github.com/danwild/leaflet-velocity).

## Bug Fixes
- Fixed #148, #156, #165

# leaflet.extras 1.0.0

## leaflet.js
Expand Down
2 changes: 2 additions & 0 deletions R/leaflet.extras-package.r
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,8 @@
#' plugins.
#'
#' @importFrom magrittr %>%
#' @importFrom htmltools htmlDependency
#' @importFrom jsonlite fromJSON toJSON
#' @import leaflet
#'
#' @name leaflet.extras
Expand Down
64 changes: 64 additions & 0 deletions R/reachability.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,64 @@
reachabilityDependencies <- function() {
list(
htmlDependency(
"leaflet.reachability", "1.0.0",
src = system.file("htmlwidgets/build/lfx-reachability", package = "leaflet.extras"),
script = c("leaflet.reachability.js",
"leaflet.reachability.bindings.js"),
stylesheet = "leaflet.reachability.css"
)
)
}

#' Add Isochrones to Leaflet
#'
#' @param map a map widget
#' @param apiKey a valid Openrouteservice API-key. Can be obtained from
#' \href{https://openrouteservice.org/dev/#/signup}{Openrouteservice}
#' @param options see \code{\link{reachabilityOptions}}
#' @description Add Leaflet Reachability Plugin Control. Based on the
#' \href{https://github.com/traffordDataLab/leaflet.reachability}{leaflet.reachability plugin}
#' @export
#' @family Reachability Plugin
addReachability <- function(map, apiKey = NULL,
options = reachabilityOptions()){

map$dependencies <- c(map$dependencies, reachabilityDependencies())
if (is.null(apiKey)) stop("You must provide an API Key")
options = leaflet::filterNULL(c(apiKey = apiKey, options))

invokeMethod(map, NULL, "addReachability", options)
}

#' reachabilityOptions
#'
#' @param collapsed Should the control widget start in a collapsed mode.
#' Default is \code{TRUE}
#' @param pane Leaflet pane to add the isolines GeoJSON to.
#' Default is \code{overlayPane}
#' @param position Leaflet control pane position. Default is \code{topleft}
#' @param ... Further arguments passed to `L.Control.Reachability`
#' @description Add extra options. For a full list please visit the
#' \href{https://github.com/traffordDataLab/leaflet.reachability}{plugin repository}
#' @export
#' @family Reachability Plugin
reachabilityOptions = function(collapsed = TRUE,
pane = "overlayPane",
position = "topleft",
...) {
filterNULL(list(
collapsed = collapsed,
pane = pane,
position = position,
...
))
}

#' removeReachability
#' @param map the map widget.
#' @description Remove the reachability controls
#' @export
#' @family Reachability Plugin
removeReachability <- function(map){
invokeMethod(map, NULL, "removeReachability")
}
104 changes: 104 additions & 0 deletions R/velocity.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,104 @@
velocityDependencies <- function() {
list(
htmlDependency(
"leaflet.velocity", "1.0.0",
src = system.file("htmlwidgets/build/lfx-velocity", package = "leaflet.extras"),
script = c("leaflet-velocity.js",
"leaflet-velocity-bindings.js"),
stylesheet = "leaflet-velocity.css"
)
)
}

#' Add Velocity Animation
#'
#' @param map a map widget
#' @param layerId the layer id
#' @param group the name of the group the newly created layers should belong to
#' (for \code{clearGroup} and \code{addLayersControl} purposes). Human-friendly
#' group names are permitted–they need not be short, identifier-style names.
#' Any number of layers and even different types of layers (e.g. markers and
#' polygons) can share the same group name.
#' @param content a JSON File respresenting the velocity data or a URL pointing
#' to such a JSON file.
#' @param options see \code{\link{velocityOptions}}
#' @description Add velocity animated data to leaflet. Based on the
#' \href{https://github.com/danwild/leaflet-velocity}{leaflet-velocity plugin}
#' @export
#' @family Velocity Plugin
#' @examples \dontrun{
#' library(leaflet)
#' library(leaflet.extras)
#' content <- system.file("examples/velocity/wind-global.json", package = "leaflet.extras")
#' leaflet() %>%
#' addTiles(group = "base") %>%
#' addLayersControl(baseGroups = "base", overlayGroups = "velo") %>%
#' addVelocity(content = content, group = "velo", layerId = "veloid")
#' }
addVelocity <- function(map, layerId = NULL, group = NULL,
content = NULL, options = velocityOptions()) {

## Check Content
if (is.null(content)) stop("The content is empty. Please include a JSON or a URL for a specific JSON")
if (inherits(content, "character")) {
# grepl("https:", content) || grepl("http:", content)
content <- jsonlite::fromJSON(content)
content <- jsonlite::toJSON(content)
} else if (inherits(content, "data.frame")) {
content <- jsonlite::toJSON(content)
} else if (inherits(content, "json")) {
} else {
stop("Content is does not point to a JSON file nor is it a data.frame")
}

map$dependencies <- c(map$dependencies, velocityDependencies())

invokeMethod(
map, NULL, "addVelocity",
layerId, group, content, options
)
}


#' velocityOptions
#' @description Define further options for the velocity layer.
#' @param speedUnit Could be 'm/s' for meter per second, 'k/h' for kilometer
#' per hour or 'kt' for knots
#' @param minVelocity velocity at which particle intensity is minimum
#' @param maxVelocity velocity at which particle intensity is maximum
#' @param velocityScale scale for wind velocity
#' @param colorScale A vector of hex colors or an RGB matrix
#' @param ... Further arguments passed to the Velocity layer and Windy.js.
#' For more information, please visit \href{https://github.com/danwild/leaflet-velocity}{leaflet-velocity plugin}
#' @export
#' @family Velocity Plugin
velocityOptions <- function(speedUnit = c("m/s", "k/h", "kt"),
minVelocity = 0,
maxVelocity = 10,
velocityScale = 0.005,
colorScale = NULL,
...){
if (!is.null(colorScale) && is.matrix(colorScale)) {
colorScale <- as.matrix(
paste0("rgb(", apply(colorScale, 1, function(x)
paste(x, collapse = ",")), ")"))
}
speedUnit <- match.arg(speedUnit)
list(
speedUnit = speedUnit,
minVelocity = minVelocity,
maxVelocity = maxVelocity,
velocityScale = velocityScale,
colorScale = colorScale,
...
)
}

#' removeVelocity
#' @param map the map widget
#' @param group the group to remove
#' @export
#' @family Velocity Plugin
removeVelocity <- function(map, group){
invokeMethod(map, NULL, "removeVelocity", group)
}
2 changes: 2 additions & 0 deletions README.Rmd
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,8 @@ Plugins integrated so far ...
- [Leaflet.Sleep](https://github.com/CliffCloud/Leaflet.Sleep): Demo at [Rpubs: Suspended Scrolling](http://rpubs.com/bhaskarvk/suspended-scroll)
- [Bing Tiles](https://github.com/shramov/leaflet-plugins/tree/v2)
- [Bounce Marker](https://github.com/maximeh/leaflet.bouncemarker)
- [Leaflet Reachability](https://github.com/traffordDataLab/leaflet.reachability)
- [Leaflet Velocity](https://github.com/danwild/leaflet-velocity)

If you need a plugin that is not already implemented create an [issue](https://github.com/bhaskarvk/leaflet.extras/issues/new).
See the [FAQ](#FAQ) section below for details.
Expand Down
2 changes: 2 additions & 0 deletions README.md
Original file line number Diff line number Diff line change
Expand Up @@ -50,6 +50,8 @@ Plugins integrated so far ...
- [Leaflet.Sleep](https://github.com/CliffCloud/Leaflet.Sleep): Demo at [Rpubs: Suspended Scrolling](http://rpubs.com/bhaskarvk/suspended-scroll)
- [Bing Tiles](https://github.com/shramov/leaflet-plugins/tree/v2)
- [Bounce Marker](https://github.com/maximeh/leaflet.bouncemarker)
- [Leaflet Reachability](https://github.com/traffordDataLab/leaflet.reachability)
- [Leaflet Velocity](https://github.com/danwild/leaflet-velocity)

If you need a plugin that is not already implemented create an [issue](https://github.com/bhaskarvk/leaflet.extras/issues/new). See the [FAQ](#FAQ) section below for details.

Expand Down
47 changes: 47 additions & 0 deletions inst/examples/reachability_app.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,47 @@
library(leaflet)
library(leaflet.extras)
library(shiny)

apiKey <- "Your_API_KEY"

ui <- fluidPage(
icon("cars"), ## needed to load FontAwesome Lib
leafletOutput("map")
,actionButton("removeReachability", "removeReachability")
)

server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles(group = "base") %>%
setView(8, 50, 11) %>%
addLayersControl(baseGroups = "base") %>%
addReachability(apiKey = apiKey,
options = reachabilityOptions(
collapsed = FALSE,
drawButtonContent = as.character(icon("plus")),
deleteButtonContent = as.character(icon("minus")),
distanceButtonContent = as.character(icon("map-marked")),
timeButtonContent = as.character(icon("clock")),
travelModeButton1Content = as.character(icon("car")),
travelModeButton2Content = as.character(icon("bicycle")),
travelModeButton3Content = as.character(icon("walking")),
travelModeButton4Content = as.character(icon("wheelchair"))
))
})
observeEvent(input$removeReachability, {
leafletProxy("map") %>%
removeReachability()
})
observeEvent(input$map_reachability_displayed, {
print("input$map_reachability_displayed")
})
observeEvent(input$map_reachability_delete, {
print("input$map_reachability_delete")
})
observeEvent(input$map_reachability_error, {
print("input$map_reachability_error")
})
}

shinyApp(ui, server)
49 changes: 49 additions & 0 deletions inst/examples/velocity/velocity_app.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
library(shiny)
library(leaflet)
library(leaflet.extras)

content <- system.file("examples/velocity/wind-global.json", package = "leaflet.extras")
# content <- system.file("examples/velocity/water-gbr.json", package = "leaflet.extras")
# content <- system.file("examples/velocity/wind-gbr.json", package = "leaflet.extras")

ui <- fluidPage(
leafletOutput("map")
, actionButton("showGroup", "showGroup")
, actionButton("hideGroup", "hideGroup")
, actionButton("removeVelocity", "removeVelocity")
, actionButton("clearGroup", "clearGroup")
)

server <- function(input, output, session) {
output$map <- renderLeaflet({
leaflet() %>%
addTiles(group = "base") %>%
addLayersControl(baseGroups = "base", overlayGroups = "Wind") %>%
addVelocity(content = content, group = "Wind", layerId = "veloid",
options = velocityOptions(
position = "bottomright",
emptyString = "Nothing to see",
speedUnit = "k/h",
lineWidth = 2,
colorScale = rainbow(12)
))
})
observeEvent(input$showGroup, {
leafletProxy("map") %>%
showGroup("Wind")
})
observeEvent(input$hideGroup, {
leafletProxy("map") %>%
hideGroup("Wind")
})
observeEvent(input$removeVelocity, {
leafletProxy("map") %>%
removeVelocity("veloid")
})
observeEvent(input$clearGroup, {
leafletProxy("map") %>%
clearGroup("Wind")
})
}

shinyApp(ui, server)
Loading