R/playback.R

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

playbackDependencies <- function() {
  list(
    htmlDependency(
      "lfx-playback", "1.0.0",
      src = system.file("htmlwidgets/lfx-playback", package = "leaflet.extras2"),
      script = c(
        "leaflet.playback.js",
        "leaflet.playback-bindings.js"
      )
    )
  )
}

#' Add Playback to Leaflet
#'
#' The \href{https://github.com/hallahan/LeafletPlayback}{LeafletPlayback plugin}
#' provides the ability to replay GPS Points in the form of
#' POINT Simple Features. Rather than simply animating a marker along a
#' polyline, the speed of the animation is synchronized to a clock. The playback
#' functionality is similar to a video player; you can start and stop playback or
#' change the playback speed.
#' @param map a map widget
#' @param data data must be a POINT Simple Feature or a list of POINT Simple
#'   Feature's with a time column.
#' @param popup A formula with the column names for the popup content
#' @param label A formula with the column names for the label content
#' @param name A formula with the column names for the feature name
#' @param time The column name of the time column. Default is \code{"time"}.
#' @param icon an icon which can be created with \code{\link[leaflet]{makeIcon}}
#' @param pathOpts style the CircleMarkers with
#'   \code{\link[leaflet]{pathOptions}}
#' @param options List of additional options. See \code{\link{playbackOptions}}
#' @note If used in Shiny, you can listen to 2 events
#' \itemize{
#'  \item `map-ID`+"_pb_mouseover"
#'  \item `map-ID`+"_pb_click"
#' }
#' @family Playback Functions
#' @references \url{https://github.com/hallahan/LeafletPlayback}
#' @export
#' @inheritParams leaflet::addMarkers
#' @inherit leaflet::addMarkers return
#' @examples
#' library(leaflet)
#' library(leaflet.extras2)
#' library(sf)
#'
#' ## Single Elements
#' data <- sf::st_as_sf(leaflet::atlStorms2005[1, ])
#' data <- st_cast(data, "POINT")
#' data$time <- as.POSIXct(
#'   seq.POSIXt(Sys.time() - 1000, Sys.time(), length.out = nrow(data))
#' )
#' data$label <- as.character(data$time)
#'
#' leaflet() %>%
#'   addTiles() %>%
#'   addPlayback(
#'     data = data, label = ~label,
#'     popup = ~ sprintf(
#'       "I am a popup for <b>%s</b> and <b>%s</b>",
#'       Name, label
#'     ),
#'     popupOptions = popupOptions(offset = c(0, -35)),
#'     options = playbackOptions(
#'       radius = 3,
#'       tickLen = 36000,
#'       speed = 50,
#'       maxInterpolationTime = 1000
#'     ),
#'     pathOpts = pathOptions(weight = 5)
#'   )
#'
#'
#' ## Multiple Elements
#' data <- sf::st_as_sf(leaflet::atlStorms2005[1:5, ])
#' data$Name <- as.character(data$Name)
#' data <- st_cast(data, "POINT")
#' data$time <- unlist(lapply(rle(data$Name)$lengths, function(x) {
#'   seq.POSIXt(as.POSIXct(Sys.Date() - 2), as.POSIXct(Sys.Date()), length.out = x)
#' }))
#' data$time <- as.POSIXct(data$time, origin = "1970-01-01")
#' data$label <- paste0("Time: ", data$time)
#' data$popup <- sprintf(
#'   "<h3>Customized Popup</h3><b>Name</b>: %s<br><b>Time</b>: %s",
#'   data$Name, data$time
#' )
#' data <- split(data, f = data$Name)
#'
#' leaflet() %>%
#'   addTiles() %>%
#'   addPlayback(
#'     data = data,
#'     popup = ~popup,
#'     label = ~label,
#'     popupOptions = popupOptions(offset = c(0, -35)),
#'     labelOptions = labelOptions(noHide = TRUE),
#'     options = playbackOptions(
#'       radius = 3,
#'       tickLen = 1000000,
#'       speed = 5000,
#'       maxInterpolationTime = 10000,
#'       transitionpopup = FALSE,
#'       transitionlabel = FALSE,
#'       playCommand = "Let's go",
#'       stopCommand = "Stop it!",
#'       color = c(
#'         "red", "green", "blue",
#'         "orange", "yellow"
#'       )
#'     ),
#'     pathOpts = pathOptions(weight = 5)
#'   )
addPlayback <- function(map, data, time = "time", icon = NULL,
                        pathOpts = pathOptions(),
                        popup = NULL,
                        label = NULL,
                        popupOptions = NULL,
                        labelOptions = NULL,
                        options = playbackOptions(),
                        name = NULL) {
  if (!requireNamespace("sf")) {
    stop(
      "The package `sf` is needed for this plugin. ",
      "Please install it with:\ninstall.packages('sf')"
    )
  }

  if (inherits(data, "list")) {
    data <- lapply(data, function(x) {
      to_jsonformat(x, time, popup, label, name)
    })
    bounds <- do.call(rbind, lapply(data, function(x) x$geometry$coordinates))
  } else {
    data <- to_jsonformat(data, time, popup, label, name)
    bounds <- data$geometry$coordinates
  }

  map$dependencies <- c(map$dependencies, playbackDependencies())
  options <- leaflet::filterNULL(c(
    icon = list(icon),
    pathOptions = list(pathOpts),
    popupOptions = list(popupOptions),
    labelOptions = list(labelOptions),
    popups = if (is.null(popup)) NULL else TRUE,
    labels = if (is.null(label)) NULL else TRUE,
    options
  ))

  invokeMethod(map, NULL, "addPlayback", data, options) %>%
    expandLimits(
      lat = as.numeric(bounds[, "Y"]),
      lng = as.numeric(bounds[, "X"])
    )
}

#' playbackOptions
#'
#' A list of options for \code{\link{addPlayback}}. For a full list please visit
#' the \href{https://github.com/hallahan/LeafletPlayback}{plugin repository}.
#' @param color colors of the CircleMarkers.
#' @param radius a numeric value for the radius of the CircleMarkers.
#' @param tickLen Set tick length in milliseconds. Increasing this value, may
#'   improve performance, at the cost of animation smoothness. Default is 250
#' @param speed Set float multiplier for default animation speed. Default is 50
#' @param maxInterpolationTime Set max interpolation time in milliseconds.
#'   Default is 5*60*1000 (5 minutes).
#' @param tracksLayer Set \code{TRUE} if you want to show layer control on the
#'   map. Default is \code{TRUE}
#' @param playControl Set \code{TRUE} if play button is needed.
#'   Default is \code{TRUE}
#' @param dateControl Set \code{TRUE} if date label is needed.
#'   Default is \code{TRUE}
#' @param sliderControl Set \code{TRUE} if slider control is needed.
#'   Default is \code{TRUE}
#' @param orientIcons Set \code{TRUE} if you want icons to orient themselves on each
#'   tick based on the bearing towards their next location. Default: \code{FALSE}
#' @param staleTime Set time before a track is considered stale and faded out.
#'   Default is 60*60*1000 (1 hour)
#' @param transitionpopup Should the position of the popup move smoothly,
#'   like the marker icon? Default: \code{TRUE}
#' @param transitionlabel Should the position of the label move smoothly,
#'   like the marker icon? Default: \code{TRUE}
#' @param ... Further arguments passed to `L.Playback`
#' @family Playback Functions
#' @return A list of options for \code{addPlayback}
#' @references \url{https://github.com/hallahan/LeafletPlayback}
#' @export
playbackOptions <- function(
    color = "blue",
    radius = 5,
    tickLen = 250,
    speed = 50,
    maxInterpolationTime = 5 * 60 * 1000,
    tracksLayer = TRUE,
    playControl = TRUE,
    dateControl = TRUE,
    sliderControl = TRUE,
    orientIcons = FALSE,
    staleTime = 60 * 60 * 1000,
    transitionpopup = TRUE,
    transitionlabel = TRUE,
    ...) {
  leaflet::filterNULL(list(
    color = color,
    radius = radius,
    tickLen = tickLen,
    speed = speed,
    maxInterpolationTime = maxInterpolationTime,
    tracksLayer = tracksLayer,
    playControl = playControl,
    dateControl = dateControl,
    sliderControl = sliderControl,
    orientIcons = orientIcons,
    staleTime = staleTime,
    transitionpopup = transitionpopup,
    transitionlabel = transitionlabel,
    ...
  ))
}

#' removePlayback
#'
#' Remove the Playback controls and markers.
#' @param map the map widget
#' @export
#' @inherit leaflet::addMarkers return
#' @family Playback Functions
removePlayback <- function(map) {
  invokeMethod(map, NULL, "removePlayback")
}




#' to_jsonformat
#' Transform object to JSON expected format
#' @param data The data
#' @param time Name of the time column.
#' @param popup Name of the popup column.
#' @param label Name of the label column.
#' @param name Name of the name column.
#' @return A list that is transformed to the expected JSON format
to_jsonformat <- function(data, time, popup = NULL, label = NULL, name = NULL) {
  if (inherits(data, "Spatial")) data <- sf::st_as_sf(data)
  if (inherits(data, "sf")) {
    stopifnot(inherits(sf::st_geometry(data), c("sfc_POINT")))
    data <- to_ms(data, time)
    dataorig <- data
    data <- list(
      "type" = "Feature",
      "name" = evalFormula(name, dataorig)[1],
      "geometry" = list(
        "type" = "MultiPoint",
        "coordinates" = sf::st_coordinates(data)
      ),
      "properties" = list(
        "time" = data$time
      )
    )

    if (!is.null(popup)) {
      data <- c(data, list("popupContent" = evalFormula(popup, dataorig)))
    }
    if (!is.null(label)) {
      data <- c(data, list("tooltipContent" = evalFormula(label, dataorig)))
    }
  }
  data
}

#' to_ms
#' Change POSIX or Date to milliseconds
#' @inheritParams to_jsonformat
#' @return A data.frame with the time column in milliseconds
to_ms <- function(data, time) {
  coln <- colnames(data)
  if (!any(coln == time)) {
    stop("No column named `", time, "` found.")
  }
  if (time != "time") {
    colnames(data)[coln == time] <- "time"
  }
  stopifnot(inherits(data[["time"]], c("POSIXt", "Date", "numeric")))
  if (inherits(data[["time"]], "POSIXt")) {
    data[["time"]] <- as.numeric(data[["time"]]) * 1000
  } else if (inherits(data[["time"]], "Date")) {
    data[["time"]] <- as.numeric(data[["time"]]) * 86400000
  }
  data
}