Controls

NAMESPACE

@@ -11,11 +11,15 @@ export(add_popup)
 export(add_source)
 export(add_tooltip)
 export(construct_basemap_style)
+export(fullscreen_control)
 export(geojson_source)
+export(geolocate_control)
 export(layer)
 export(map_options)
 export(maplibre)
 export(maplibreOutput)
 export(marker_options)
+export(navigation_control)
 export(renderMaplibre)
+export(scale_control)
 import(htmlwidgets)

R/controls.R

@@ -0,0 +1,177 @@
+#' Add a control to a Map widget
+#'
+#' @param .map A [maplibre()] HTML widget
+#' @param control_name The name of the control
+#' @param control_position The position of the control.
+#' @param ... Control options depending on the type of control.
+#' @returns The updated [maplibre()] HTML widget
+#' @export
+#'
+#' @example examples/basemap.R
+add_control <- function(.map, control_name = c(
+  "NavigationControl",
+  "ScaleControl", "FullscreenControl",
+  "GeolocateControl", "AttributionControl"
+),
+control_position = c("top-left", "top-right", "bottom-left", "bottom-right"),
+...) {
+  control_name <- match.arg(control_name)
+  control_position <- match.arg(control_position)
+  .map |>
+    add_call("addControl", control_name, list(...), control_position)
+}
+
+
+#' Add navigation control to map
+#' A NavigationControl control contains zoom buttons and a compass.
+#' @inherit add_control params return
+#' @param position The position of the control.
+#' @param show_compass If TRUE the compass button is included.
+#' @param show_zoom If TRUE the zoom-in and zoom-out buttons are included.
+#' @param visualize_pitch If TRUE the pitch is visualized by rotating X-axis of compass.
+#'
+#' @export
+#'
+#' @example examples/controls.R
+navigation_control <- function(.map,
+                               position = c("top-left", "top-right", "bottom-left", "bottom-right"),
+                               show_compass = TRUE,
+                               show_zoom = TRUE,
+                               visualize_pitch = TRUE) {
+  control_options <- rdantic(
+    list(
+      showCompass = show_compass,
+      showZoom = show_zoom,
+      visualizePitch = visualize_pitch
+    ),
+    TYPES_NAVIGATION_CONTROL_OPTIONS
+  )
+
+  control_position <- match.arg(position)
+  options <- purrr::compact(
+    c(
+      control_name = "NavigationControl", control_position = control_position,
+      control_options
+    )
+  )
+
+  do.call(add_control, args = list(.map = .map) |> append(options))
+}
+
+
+#' A ScaleControl control displays the ratio of a distance on the map to the corresponding distance on the ground.
+#'
+#' @inherit add_control params return
+#' @inherit navigation_control params
+#' @param max_width The maximum length of the scale control in pixels.
+#' @param unit Unit of the distance ('imperial', 'metric' or 'nautical').
+#'
+#' @export
+#'
+#' @example examples/controls.R
+scale_control <- function(.map,
+                          position = c("top-left", "top-right", "bottom-left", "bottom-right"),
+                          max_width = 100,
+                          unit = c("imperial", "metric", "nautical")) {
+  control_options <- rdantic(
+    list(
+      maxWidth = max_width,
+      unit = match.arg(unit)
+    ),
+    TYPES_SCALE_CONTROL_OPTIONS
+  )
+
+  if(length(control_options)==0){
+    control_options <- list("")
+  }
+  control_position <- match.arg(position)
+  options <- purrr::compact(
+    c(
+      control_name = "ScaleControl", control_position = control_position,
+      control_options
+    )
+  )
+
+  do.call(add_control, args = list(.map = .map) |> append(options))
+}
+
+
+#' A GeolocateControl control provides a button that uses the browser's geolocation API to locate the user on the map.
+#'
+#' @inherit add_control params return
+#' @inherit navigation_control params
+#' @param show_accuracy_circle By default, if showUserLocation is true, a transparent circle will be drawn around the user location indicating the accuracy (95% confidence level) of the user's location. Set to FALSE to disable. Always disabled when showUserLocation is FALSE.
+#' @param show_user_location By default a dot will be shown on the map at the user's location. Set to FALSE to disable.
+#' @param track_user_location If TRUE the GeolocateControl becomes a toggle button and when active the map will receive updates to the user's location as it changes.
+#' @param fit_bounds_options A options object to use when the map is panned and zoomed to the user's location. The default is to use a maxZoom of 15 to limit how far the map will zoom in for very accurate locations.
+#' @param position_options Optional Geolocation APIs options
+#'
+#' @export
+#'
+#' @example examples/controls.R
+geolocate_control <- function(.map,
+                              position = c("top-left", "top-right", "bottom-left", "bottom-right"),
+                              show_accuracy_circle = FALSE,
+                              show_user_location = FALSE,
+                              track_user_location = FALSE,
+                              fit_bounds_options = NULL,
+                              position_options = NULL){
+
+  control_options <- c(
+    rdantic(
+      list(
+        showAccuracyCircle = show_accuracy_circle,
+        showUserLocation = show_user_location,
+        trackUserLocation = track_user_location
+      ),
+      TYPES_GEOLOCATION_CONTROL_OPTIONS
+    ),
+    FitBoundsOptions = rdantic(
+      fit_bounds_options, TYPES_FIT_BOUNDS_OPTIONS
+    )
+
+  )
+  if(length(control_options)==0){
+    control_options <- list("")
+  }
+
+  control_position <- match.arg(position)
+  options <- purrr::compact(
+    c(
+      control_name = "GeolocateControl", control_position = control_position,
+      control_options
+    )
+  )
+
+  do.call(add_control, args = list(.map = .map) |> append(options))
+}
+
+
+
+#' A FullscreenControl control contains a button for toggling the map in and out of fullscreen mode
+#'
+#' @inherit add_control params return
+#' @inherit navigation_control params
+#'
+#' @export
+#'
+#' @example examples/controls.R
+fullscreen_control <- function(.map,
+                               position = c("top-left", "top-right", "bottom-left", "bottom-right"),
+                               ...){
+
+  control_options <- list(...)
+  if(length(control_options)==0){
+    control_options <- list("")
+  }
+  control_position <- match.arg(position)
+  options <- purrr::compact(
+    c(
+      control_name = "FullscreenControl", control_position = control_position,
+      control_options
+      )
+  )
+
+  do.call(add_control, args = (list(.map = .map) |> append(options)))
+
+}

R/maplibre.R

@@ -14,7 +14,7 @@
 maplibre <- function(map_options = NULL,
                      deck = FALSE,
                      width = "100%", height = NULL, element_id = NULL, ...) {
-  if (is.null(map_options)){
+  if (is.null(map_options)) {
     map_options <- map_options()
     warning("map_options is NULL. Using map_options() with dark-matterhl-style as style.")
   }
@@ -81,30 +81,30 @@ maplibre <- function(map_options = NULL,
 #' Parameter descriptions are adapted from the Maplibre GL JS Project, please visit the official documentation at \url{https://maplibre.org/maplibre-gl-js/docs/API/type-aliases/MapOptions/}
 #' @example examples/basemap.R
 map_options <- function(style = maplibre::basemaps$carto$dark_matter,
-                       antialias = NULL,
-                       attribution_control = NULL,
-                       bearing = NULL,
-                       bearing_snap = NULL,
-                       bounds = NULL,
-                       box_zoom = NULL,
-                       center = NULL,
-                       click_tolerance = NULL,
-                       double_click_zoom = NULL,
-                       fade_duration = NULL,
-                       fit_bounds_options = NULL,
-                       hash = NULL,
-                       interactive = NULL,
-                       keyboard = NULL,
-                       maplibre_logo = NULL,
-                       max_bounds = NULL,
-                       max_pitch = NULL,
-                       max_zoom = NULL,
-                       min_pitch = NULL,
-                       min_zoom = NULL,
-                       pitch = NULL,
-                       scroll_zoom = NULL,
-                       zoom = NULL,
-                       ...) {
+                        antialias = NULL,
+                        attribution_control = NULL,
+                        bearing = NULL,
+                        bearing_snap = NULL,
+                        bounds = NULL,
+                        box_zoom = NULL,
+                        center = NULL,
+                        click_tolerance = NULL,
+                        double_click_zoom = NULL,
+                        fade_duration = NULL,
+                        fit_bounds_options = NULL,
+                        hash = NULL,
+                        interactive = NULL,
+                        keyboard = NULL,
+                        maplibre_logo = NULL,
+                        max_bounds = NULL,
+                        max_pitch = NULL,
+                        max_zoom = NULL,
+                        min_pitch = NULL,
+                        min_zoom = NULL,
+                        pitch = NULL,
+                        scroll_zoom = NULL,
+                        zoom = NULL,
+                        ...) {
   # BODY
   options <- rdantic(
     list(
@@ -136,8 +136,7 @@ map_options <- function(style = maplibre::basemaps$carto$dark_matter,
   )
   purrr::compact(
     c(
-      options
-      ,
+      options,
       list(...)
     )
   )

R/marker.R

@@ -33,7 +33,7 @@ Marker <- function(lng_lat, popup = NULL, ...) {
 #'
 #' @example examples/markers.R
 marker_options <- function(anchor = NULL, color = NULL, pitchAlignment = NULL, rotationAlignment = NULL,
-                          draggable = NULL, rotation = NULL, scale = NULL, ...) {
+                           draggable = NULL, rotation = NULL, scale = NULL, ...) {
   marker_options <- list(...)
   stopifnot(sapply(marker_options[c("anchor", "color", "pitchAlignment", "rotationAlignment")], function(x) {
     is.null(x) | is.character(x)

R/types.R

@@ -1,10 +1,14 @@
+# Types ####
+
+## Basemap Style ####
 TYPES_BASEMAP_STYLE <- list(
   name = is.character,
   version = is.integer,
   sources = is.list,
   layers = is.list
 )
 
+## Layer ####
 TYPES_LAYER <- list(
   type = is.character,
   id = is.character,
@@ -15,6 +19,7 @@ TYPES_LAYER <- list(
   layout = is.list
 )
 
+## Map options ####
 TYPES_MAP_OPTIONS <- list(
   style = function(x) {
     is.list(x) | is.character(x)
@@ -61,3 +66,41 @@ TYPES_MAP_OPTIONS <- list(
     is.integer(x) | is.numeric(x)
   }
 )
+
+
+## Navigation control ####
+
+TYPES_NAVIGATION_CONTROL_OPTIONS <- list(
+  showCompass = is.logical,
+  showZoom = is.logical,
+  visualizePitch = is.logical
+)
+
+## Scale control ####
+TYPES_SCALE_CONTROL_OPTIONS <- list(
+  maxWidth = function(x) {
+    is.integer(x) | is.numeric(x)
+  },
+  unit = is.character
+)
+
+
+## Geolocation control ####
+
+TYPES_GEOLOCATION_CONTROL_OPTIONS <- list(
+  showAccuracyCircle = is.logical,
+  showUserLocation = is.logical,
+  trackUserLocation = is.logical
+)
+
+TYPES_FIT_BOUNDS_OPTIONS <- list(
+  linear = is.logical,
+  maxZoom = function(x){
+    is.integer(x) | x == round(x, 0)
+  },
+  offset = function(x){
+    (is.integer(x) | is.numeric(x)) & length(x) = 2
+  }
+
+)
+

R/utils.R

@@ -9,7 +9,7 @@ rdantic <- function(.obj, types, test = 1L) {
     value <- .obj[[k]]
     if (!is.null(value)) {
       if (!type_check(value)) {
-        stop("Value of '", k , "' (\"",value, "\") failed test: ", deparse(substitute(type_check)), call. = FALSE)
+        stop("Value of '", k, "' (\"", value, "\") failed test: ", deparse(substitute(type_check)), call. = FALSE)
       }
     }
   }

examples/basemap.R

@@ -3,7 +3,7 @@ map_options <- map_options(
   hash = TRUE,
   pitch = 0,
   style = basemaps$carto$dark_matter
-  )
+)
 
 # add control uses add_call to add a control to the map widget
 maplibre(map_options, zoom = 12) |>