diff --git a/DESCRIPTION b/DESCRIPTION
index 8975b40..968ae34 100755
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -15,24 +15,25 @@ License: GPL-3
Encoding: UTF-8
RoxygenNote: 7.3.2
Imports:
- move2,
- terra,
- sf,
- s2,
- lwgeom,
- units,
- basemaps,
- lubridate,
- ggplot2,
- rlang,
- ggnewscale,
- patchwork,
- gifski,
- av,
- pbapply,
- magrittr,
- methods,
- stats
+ move2,
+ terra,
+ sf,
+ s2,
+ lwgeom,
+ units,
+ basemaps,
+ lubridate,
+ ggplot2,
+ rlang,
+ ggnewscale,
+ patchwork,
+ gifski,
+ av,
+ pbapply,
+ magrittr,
+ methods,
+ stats,
+ scales
BugReports: https://www.github.com/16eagle/moveVis/issues
SystemRequirements: ImageMagick, FFmpeg, libav
URL: https://movevis.org
diff --git a/R/frames_graph.R b/R/frames_graph.R
index e8d5549..71783c0 100644
--- a/R/frames_graph.R
+++ b/R/frames_graph.R
@@ -74,7 +74,7 @@
#'
#' @export
-frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, return_data = FALSE, graph_type = "flow", path_size = 1, path_colours = NA, path_legend = TRUE, path_legend_title = "Names",
+frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, return_data = FALSE, graph_type = "flow", path_size = 1, path_colours = NULL, colour_paths_by = move2::mt_track_id_column(m), path_legend = TRUE, path_legend_title = colour_paths_by,
val_min = NULL, val_max = NULL, val_by = 0.1, ..., verbose = T){
## check input arguments
@@ -117,7 +117,6 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra
if(!is.logical(fade_raster)) out("Argument 'fade_raster' has to be either TRUE or FALSE.", type = 3)
if(!is.numeric(path_size)) out("Argument 'path_size' must be of type 'numeric'.", type = 3)
- if(is.character(path_colours)) if(length(path_colours) != mt_n_tracks(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3)
if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3)
if(!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3)
if(!is.logical(return_data)) out("Argument 'return_data' must be of type 'logical'.", type = 3)
@@ -138,8 +137,27 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra
if(r_type == "discrete" & fade_raster == T) out("Argument 'fade_raster' is TRUE, while argument 'r_type' is set to 'discrete'. Interpolating discrete values will destroy discrete classes!", type = 2)
if(r_type == "discrete" & !val_by%%1==0) out("Argument 'val_by' is fractional, while argument 'r_type' is set to 'discrete'. You may want to set 'val_by' to 1 or another integer for discrete classes.", type = 2)
+ if (.scale_type(m[[colour_paths_by]]) == "continuous") {
+ out("Cannot color by continuous variables in `frames_graph()`", type = 3)
+ }
+
+ m <- .expand_track_attr(m, var = colour_paths_by)
+
+ pal <- .build_pal(m[[colour_paths_by]], path_colours)
+ scale <- .build_scale(m[[colour_paths_by]], pal)
+
+ m$colour <- scale(m[[colour_paths_by]])
+
+ if (.scale_type(m[[colour_paths_by]]) == "qualitative") {
+ legend_labels <- unique(m[[colour_paths_by]])
+ legend_colours <- pal(length(legend_labels))
+ } else {
+ legend_labels <- NULL
+ legend_colours <- pal(256)
+ }
+
## create data.frame from m with frame time and colour
- m <- .add_m_attributes(m, path_colours = path_colours)
+ m <- .add_m_attributes(m)
.stats(max(m$frame))
## create raster list
@@ -172,18 +190,22 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra
hist_data <- NULL
if(graph_type == "hist"){
- dummy <- do.call(rbind, lapply(as.character(unique(mt_track_id(m))), function(name){
+ dummy <- do.call(rbind, lapply(as.character(unique(m[[colour_paths_by]])), function(name){
cbind.data.frame(count = 0, value = val_seq, name = name,
- colour = unique(m[m$name == name,]$colour))
+ colour = unique(legend_colours[legend_labels == name]))
}))
+ if (is.factor(legend_labels)) {
+ dummy$name <- factor(dummy$name, levels = levels(legend_labels))
+ }
+
## Calculating time-cumulative value histogram per individual and timestep
#out("Calculating histogram...")
hist_data <- lapply(1:max(m$frame), function(i, d = dummy){
x <- m[unlist(lapply(1:i, function(x) which(m$frame == x))),]
- x <- do.call(rbind, lapply(unique(x$name), function(name){
- y <- x[x$name == name,]
+ x <- do.call(rbind, lapply(unique(x[[colour_paths_by]]), function(name){
+ y <- x[x[[colour_paths_by]] == name,]
z <- table(round(y$value, digits = val_digits))
d.name <- d[d$name == name,]
@@ -212,7 +234,10 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra
path_legend = path_legend,
path_legend_title = path_legend_title,
val_seq = val_seq,
- r_type = r_type),
+ r_type = r_type,
+ legend_labels = legend_labels,
+ legend_colours = legend_colours
+ ),
additions = NULL
)
attr(frames, "class") <- c("moveVis", "frames_graph")
diff --git a/R/frames_spatial.R b/R/frames_spatial.R
index 2fc032e..128675e 100644
--- a/R/frames_spatial.R
+++ b/R/frames_spatial.R
@@ -2,7 +2,7 @@
#'
#' \code{frames_spatial} creates frames from movement and map/raster data. If no custom raster data is provided, a basemap is pulled from a map tile service using the \code{basemaps} package. Frames are returned as an object of class \code{moveVis} and can be subsetted, viewed (see \code{\link{render_frame}}), modified (see \code{\link{add_gg}} and associated functions ) and animated (see \code{\link{animate_frames}}).
#'
-#' @param m \code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}. Can contain a column named \code{colour} to control path colours (see details below).
+#' @param m \code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}.
#' @param r \code{terra} object, either a \code{SpatRaster} (mono-temporal) or a \code{SpatRasterDataset} (multi-temporal). In case of the latter, times of `r` must be defined as 'POSIXct' (see \code{\link[terra]{time}} and details below).
#' @param r_type character, either \code{"gradient"} or \code{"discrete"}. Ignored, if \code{r} contains three bands, which are treated as RGB.
#' @param fade_raster logical, if \code{TRUE}, \code{r} is interpolated over time. If \code{FALSE}, \code{r} elements are assigned to those frames closest to the equivalent times of \code{r}.
@@ -12,11 +12,12 @@
#' @param path_join character, either \code{"round"}, \code{"mitre"} or \code{"bevel"}, indicating the path join style.
#' @param path_mitre numeric, path mitre limit (number greater than 1).
#' @param path_arrow arrow, path arrow specification, as created by grid::arrow().
-#' @param path_colours character, a vector of colours. Must be of same length as number of individual tracks in \code{m} and refers to the order of tracks in \code{m}. If undefined (\code{NA}) and \code{m} contains a column named \code{colour}, colours provided within \code{m} are used (see details). Othwersie, colours are selected from a standard rainbow palette per individual track.
+#' @param path_colours character or palette function to use to colour the tracks in `m`. If a character vector, must be a vector of the same length as the number of levels in the attribute being used to colour the tracks (see argument `colour_paths_by`). If a function, must accept an integer and return a vector of colours of that length. By default, colours are selected from a standard rainbow palette per individual track.
+#' @param colour_paths_by character indicating the name of an attribute column in `m` to use to define path colours. This attribute can be either an event or track-level attribute. By default, colours by track ID.
#' @param path_alpha numeric, defines alpha (transparency) of the path. Value between 0 and 1. Default is 1.
#' @param path_fade logical, whether paths should be faded towards the last frame or not. Useful, if \code{trace_show = TRUE} and you want to hold the last frame using \code{end_pause} in \code{\link{animate_frames}}.
-#' @param path_legend logical, wether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the tracks' temporal apperances, not by their order in \code{m}.
-#' @param path_legend_title character, path legend title. Default is \code{"Names"}.
+#' @param path_legend logical, whether to add a path legend from \code{m} or not. When colouring tracks by a qualitative attribute, legend entries will be ordered by the levels of that attribute (if a factor) or alphabetically (if a character).
+#' @param path_legend_title character, path legend title. Defaults to the column name specified in `colour_paths_by`.
#' @param tail_length numeric, length of tail per movement path.
#' @param tail_size numeric, size of the last tail element. Default is 1.
#' @param tail_colour character, colour of the last tail element, to which the path colour is faded. Default is "white".
@@ -45,9 +46,7 @@
#' }
#' @param verbose logical, if \code{TRUE}, messages and progress information are displayed on the console (default).
#'
-#' @details If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}.
-#' Colours could also be arranged to change through time or by behavioural segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected using \code{path_colours} or automatically. Call \code{colours()} to see all available colours in R.
-#'
+#' @details
#' Basemap colour scales can be changed/added using \code{\link{add_colourscale}} or by using \code{ggplot2} commands (see \code{examples}). For continuous scales, use \code{r_type = "gradient"}. For discrete scales, use \code{r_type = "discrete"}.
#'
#' If argument \code{equidistant} is set, the map extent is calculated (thus enlarged into one axis direction) to represent equal distances on the x and y axis.
@@ -131,18 +130,26 @@
#' )
#' frames[[100]]
#'
-#' m$colour <- plyr::mapvalues(
-#' as.character(mt_track_id(m)),
-#' unique(mt_track_id(m)), c("orange", "purple", "darkgreen")
-#' )
+#' # colour paths based on an attribute variable
+#' m$tag_type <- ifelse(m$track == "T246a", "A", "B")
#'
#' frames <- frames_spatial(
-#' m, map_service = "osm", map_type = "topographic", alpha = 0.5
+#' m, map_service = "osm", map_type = "topographic", alpha = 0.5,
+#' colour_paths_by = "tag_type",
+#' path_colours = c("firebrick", "steelblue")
#' )
#' frames[[100]]
-# this way, you can assign colours by segment, age, speed or other variables
#'
+#' # Colour using a separately-defined palette function
+#' # This will handle any number of levels in the attribute used for colouring
+#' frames <- frames_spatial(
+#' m, map_service = "osm", map_type = "topographic", alpha = 0.5,
+#' colour_paths_by = "tag_type",
+#' path_colours = function(x) grDevices::hcl.colors(x, "Dark 3")
+#' )
+#' frames[[100]]
#' }
+#'
#' # create frames from custom (multi-temporal) basemaps
#' r <- readRDS(example_data(file = "raster_NDVI.rds"))
#'
@@ -192,8 +199,8 @@
frames_spatial <- function(
m, r = NULL, r_type = "gradient", fade_raster = FALSE, crop_raster = TRUE, map_service = "osm", map_type = "streets", map_res = 1, map_token = NULL, map_dir = NULL,
- margin_factor = 1.1, equidistant = NULL, ext = NULL, crs = if(is.null(r)) st_crs(3857) else st_crs(terra::crs(r)), crs_graticule = st_crs(4326), path_size = 3, path_end = "round", path_join = "round", path_mitre = 10, path_arrow = NULL, path_colours = NA, path_alpha = 1, path_fade = FALSE,
- path_legend = TRUE, path_legend_title = "Names", tail_length = 19, tail_size = 1, tail_colour = "white", trace_show = FALSE, trace_size = tail_size, trace_colour = "white", cross_dateline = FALSE, ..., verbose = TRUE){
+ margin_factor = 1.1, equidistant = NULL, ext = NULL, crs = if(is.null(r)) st_crs(3857) else st_crs(terra::crs(r)), crs_graticule = st_crs(4326), path_size = 3, path_end = "round", path_join = "round", path_mitre = 10, path_arrow = NULL, path_colours = NULL, colour_paths_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE,
+ path_legend = TRUE, path_legend_title = colour_paths_by, tail_length = 19, tail_size = 1, tail_colour = "white", trace_show = FALSE, trace_size = tail_size, trace_colour = "white", cross_dateline = FALSE, ..., verbose = TRUE){
if(inherits(verbose, "logical")) options(moveVis.verbose = verbose)
extras <- list(...)
@@ -270,7 +277,6 @@ frames_spatial <- function(
}
if(!is.null(path_arrow)) if(!inherits(path_arrow, "arrow")) out("Argument 'path_arrow' must be of type 'arrrow' (see grid::arrow), if defined.", type = 3)
- if(is.character(path_colours)) if(length(path_colours) != mt_n_tracks(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3)
if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3)
if(is.null(equidistant)) if(is.null(ext)) equidistant <- TRUE else equidistant <- FALSE
if(!is.logical(equidistant)) out("Argument 'equidistant' must be of type 'logical'.", type = 3)
@@ -286,7 +292,27 @@ frames_spatial <- function(
# if(is.null(m$colour)){
# m$colour <- repl_vals(as.character(mt_track_id(m)), unique(as.character(mt_track_id(m))), path_colours[1:mt_n_tracks(m)])
# }
- m <- .add_m_attributes(m, path_colours = path_colours)
+
+ # Units do not always cooperate with color scales...
+ m[[colour_paths_by]] <- .drop_units_safe(m[[colour_paths_by]])
+ m <- .expand_track_attr(m, var = colour_paths_by)
+
+ pal <- .build_pal(m[[colour_paths_by]], path_colours)
+ scale <- .build_scale(m[[colour_paths_by]], pal)
+
+ m$colour <- scale(m[[colour_paths_by]])
+
+ if (.scale_type(m[[colour_paths_by]]) == "qualitative") {
+ legend_labels <- unique(m[[colour_paths_by]])
+ legend_colours <- pal(length(legend_labels))
+ } else {
+ # we don't actually use this except to keep a record that the scale is
+ # continuous, would be nice to find another way.
+ legend_labels <- unique(m[[colour_paths_by]])
+ legend_colours <- pal(256)
+ }
+
+ m <- .add_m_attributes(m)
# print stats
.stats(n.frames = max(m$frame))
@@ -323,7 +349,7 @@ frames_spatial <- function(
xlim = c(gg.ext$xmin, gg.ext$xmax), ylim = c(gg.ext$ymin, gg.ext$ymax),
expand = F, crs = crs, datum = crs_graticule, clip = "on")
)
- m$scaley <- m$scalex <- NULL # relict from when moveVis handled cross_dateline by itself insteaf of relying
+ m[["scaley"]] <- m[["scalex"]] <- NULL # relict from when moveVis handled cross_dateline by itself insteaf of relying
# on sf::st_shift_longitude() for it.
# m$scalex <- list(ggplot2::scale_x_continuous(labels = .x_labels)) # only works with caartesian coord on the render end
# m$scaley <- list(ggplot2::scale_y_continuous(labels = .y_labels))
@@ -338,42 +364,47 @@ frames_spatial <- function(
# } else{
# time(r) <- list(rep(floor(length(sort(unique(mt_time(m))))/2), nlyr(r_list[[1]])))
# }
-
+
# create frames object
frames <- list(
m = m,
r = r,
crs = crs,
- aesthetics = c(list(
- equidistant = equidistant,
- path_size = path_size,
- path_end = path_end,
- path_join = path_join,
- path_alpha = path_alpha,
- path_mitre = path_mitre,
- path_arrow = path_arrow,
- path_legend = path_legend,
- path_legend_title = path_legend_title,
- tail_length = tail_length,
- tail_size = tail_size,
- tail_colour = tail_colour,
- trace_show = trace_show,
- trace_size = trace_size,
- trace_colour = trace_colour,
- path_fade = path_fade,
- gg.ext = gg.ext,
- map_service = map_service,
- map_type = map_type,
- r_type = r_type,
- fade_raster = fade_raster,
- n_r = n_r),
+ aesthetics = c(
+ list(
+ equidistant = equidistant,
+ path_size = path_size,
+ path_end = path_end,
+ path_join = path_join,
+ path_alpha = path_alpha,
+ path_mitre = path_mitre,
+ path_arrow = path_arrow,
+ path_legend = path_legend,
+ path_legend_title = path_legend_title,
+ tail_length = tail_length,
+ tail_size = tail_size,
+ tail_colour = tail_colour,
+ trace_show = trace_show,
+ trace_size = trace_size,
+ trace_colour = trace_colour,
+ path_fade = path_fade,
+ gg.ext = gg.ext,
+ map_service = map_service,
+ map_type = map_type,
+ r_type = r_type,
+ fade_raster = fade_raster,
+ n_r = n_r,
+ legend_colours = legend_colours,
+ legend_labels = legend_labels
+ ),
maxpixels = if(!is.null(extras$maxpixels)) extras$maxpixels else 500000,
alpha = if(!is.null(extras$alpha)) extras$alpha else 1,
maxColorValue = if(!is.null(extras$maxColorValue)) extras$maxColorValue else NA,
- interpolate = if(!is.null(extras$interpolate)) extras$interpolate else FALSE),
+ interpolate = if(!is.null(extras$interpolate)) extras$interpolate else FALSE
+ ),
additions = NULL
)
attr(frames, "class") <- c("moveVis", "frames_spatial")
return(frames)
-}
\ No newline at end of file
+}
diff --git a/R/internal.R b/R/internal.R
index f8e7bcc..40043f8 100755
--- a/R/internal.R
+++ b/R/internal.R
@@ -531,7 +531,7 @@ repl_vals <- function(data, x, y){
#' @importFrom ggnewscale new_scale_colour
#' @importFrom rlang .data
#' @noRd
-gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length){
+gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length, legend_colours, legend_labels){
# lines: sements
x_lines <- do.call(rbind, lapply(unique(m_names), function(.name){
@@ -550,39 +550,62 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre,
} else NULL
}))
- # lines: full
- x_lines_legend <- do.call(rbind, lapply(unique(m_names), function(.name){
- coords <- st_coordinates(x)
- st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x)))
- }))
- x_lines_legend$name <- unique(m_names)
-
# scale plot to ext and set na.rm to TRUE to avoid warnings
y$layers[[1]]$geom_params$na.rm <- T
# plot
p <- y + geom_sf(data = x_lines,
- aes(colour = .data$tail_colour), linewidth = x_lines$tail_size,
- lineend = path_end, linejoin = path_join, linemitre = path_mitre, arrow = path_arrow,
- alpha = path_alpha, na.rm = T
+ aes(colour = .data$tail_colour), linewidth = x_lines$tail_size,
+ lineend = path_end, linejoin = path_join, linemitre = path_mitre, arrow = path_arrow,
+ alpha = path_alpha, na.rm = T
) + scale_colour_identity()
-
+
# # points
# ggplot(x) + geom_sf(aes(colour = tail_colour, size = tail_size)) +
# scale_colour_identity() + scale_size(guide = NULL)
# add legend?
if(isTRUE(path_legend)){
- p <- quiet(p + new_scale_colour() +
- geom_sf(data = x_lines_legend, aes(colour = .data$name, linetype = NA), linewidth = path_size, na.rm = TRUE) +
- scale_linetype(guide = "none") +
- scale_colour_manual(
- values = unique(m_colour),
- name = path_legend_title) + guides(color = guide_legend(order = 1)))
- }
+ scale_type <- .scale_type(legend_labels)
+
+ if (scale_type == "qualitative") {
+ x_lines_legend <- do.call(rbind, lapply(seq_along(legend_labels), function(.name){
+ coords <- st_coordinates(x)
+ st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x)))
+ }))
+ x_lines_legend$label <- legend_labels
+
+ p <- quiet(
+ p +
+ new_scale_colour() +
+ geom_sf(data = x_lines_legend, aes(colour = .data$label, linetype = NA), linewidth = path_size, na.rm = TRUE) +
+ scale_linetype(guide = "none") +
+ scale_colour_manual(
+ values = legend_colours,
+ name = path_legend_title
+ ) +
+ guides(color = guide_legend(order = 1))
+ )
+ } else {
+ # Continuous legend doesn't need predefined factor levels in the input
+ # data. To speed up rendering, we use an empty data layer and build the
+ # gradient scale manually based on the range of values in the input labels
+ p <- quiet(
+ p +
+ new_scale_colour() +
+ ggplot2::geom_point(
+ data = data.frame(x = numeric(0), y = numeric(0), label = numeric(0)),
+ aes(x = x, y = y, colour = .data$label)
+ ) +
+ scale_linetype(guide = "none") +
+ ggplot2::scale_colour_gradientn(colours = legend_colours, limits = range(as.numeric(legend_labels)), name = path_legend_title) +
+ guides(color = ggplot2::guide_colourbar(order = 1))
+ )
+ }
+ }
# theme
- p <- p + theme_bw() + x$coord[[1]] + x$scalex[[1]] + x$scaley[[1]]
+ p <- p + theme_bw() + x$coord[[1]] + x[["scalex"]][[1]] + x[["scaley"]][[1]]
if(isTRUE(equidistant)) p <- p + theme(aspect.ratio = 1)
return(p)
}
@@ -591,22 +614,35 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre,
#' @importFrom ggplot2 ggplot geom_path aes theme scale_fill_identity scale_y_continuous scale_x_continuous scale_colour_manual theme_bw coord_cartesian geom_bar
#' @importFrom rlang .data
#' @noRd
-.gg_flow <- function(x, y, path_legend, path_legend_title, path_size, val_seq){
+.gg_flow <- function(x, y, path_legend, path_legend_title, path_size, val_seq, legend_colours, legend_labels){
## generate base plot
p <- ggplot(x, aes(x = .data$frame, y = .data$value)) + geom_path(aes(group = .data$name), linewidth = path_size, show.legend = F, colour = x$colour) +
coord_cartesian(xlim = c(0, max(y$frame, na.rm = T)), ylim = c(min(val_seq, na.rm = T), max(val_seq, na.rm = T))) +
theme_bw() + theme(aspect.ratio = 1) + scale_y_continuous(expand = c(0,0), breaks = val_seq) + scale_x_continuous(expand = c(0,0))
+ if (is.null(y$colour_labels)) {
+ y$colour_labels <- y$name
+ }
+
## add legend
if(isTRUE(path_legend)){
- l.df <- cbind.data.frame(frame = x[1,]$frame, value = x[1,]$value, name = levels(y$name),
- colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] )]), stringsAsFactors = F)
- l.df$name <- factor(l.df$name, levels = l.df$name)
+ colour_pos <- sapply(as.character(unique(y$colour_labels)), function(x) match(x, y$colour_labels)[1])
+
+ l.df <- cbind.data.frame(frame = x[1,]$frame, value = x[1,]$value, name = legend_labels,
+ colour = legend_colours, stringsAsFactors = F)
+
+ # Ensure legend mapping is in factor order if input data are factor
+ if (is.factor(legend_labels)) {
+ l.df$name <- factor(l.df$name, levels = levels(legend_labels))
+ }
+
l.df <- rbind(l.df, l.df)
- p <- p + geom_path(data = l.df, aes(x = .data$frame, y = .data$value, colour = .data$name), linewidth = path_size, na.rm = TRUE) + scale_colour_manual(values = as.character(l.df$colour), name = path_legend_title) #linetype = NA)
- }
+ p <- p + geom_path(data = l.df, aes(x = .data$frame, y = .data$value, colour = .data$name), linewidth = path_size, na.rm = TRUE) +
+ scale_colour_manual(values = legend_colours, name = path_legend_title) #linetype = NA)
+ }
return(p)
+
}
@@ -616,7 +652,7 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre,
#'
#' @noRd
## stats plot function
-.gg_hist <- function(x, y, path_legend, path_legend_title, path_size, val_seq, r_type){
+.gg_hist <- function(x, y, path_legend, path_legend_title, path_size, val_seq, r_type, legend_colours, legend_labels){
## generate base plot
if(r_type == "gradient") p <- ggplot(x, aes(x = .data$value, y = .data$count)) + geom_path(aes(group = "name"), linewidth = path_size, show.legend = F, colour = x$colour)
@@ -625,18 +661,29 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre,
p <- p + coord_cartesian(xlim = c(min(val_seq, na.rm = T), max(val_seq, na.rm = T)), ylim = c(min(y$count, na.rm = T), max(y$count, na.rm = T))) +
theme_bw() + theme(aspect.ratio = 1) + scale_y_continuous(expand = c(0,0)) + scale_x_continuous(expand = c(0,0), breaks = val_seq)
+ if (is.null(y$colour_labels)) {
+ y$colour_labels <- y$name
+ }
+
## add legend
if(isTRUE(path_legend)){
- l.df <- cbind.data.frame(value = x[1,]$value, count = x[1,]$count, name = unique(y$name),
- colour = as.character(y$colour[sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] )]), stringsAsFactors = F)
- l.df$name <- factor(l.df$name, levels = l.df$name)
+ colour_pos <- sapply(as.character(unique(y$colour_labels)), function(x) match(x, y$colour_labels)[1])
+
+ l.df <- cbind.data.frame(value = x[1,]$value, count = x[1,]$count, name = legend_labels,
+ colour = legend_colours, stringsAsFactors = F)
+
+ # Ensure legend mapping is in factor order if input data are factor
+ if (is.factor(legend_labels)) {
+ l.df$name <- factor(l.df$name, levels = levels(legend_labels))
+ }
+
l.df <- rbind(l.df, l.df)
- p <- p + geom_path(data = l.df, aes(x = .data$value, y = .data$count, colour = .data$name), linewidth = path_size, na.rm = TRUE) + scale_colour_manual(values = as.character(l.df$colour), name = path_legend_title) #linetype = NA
+ p <- p + geom_path(data = l.df, aes(x = .data$value, y = .data$count, colour = .data$name), linewidth = path_size, na.rm = TRUE) +
+ scale_colour_manual(values = legend_colours, name = path_legend_title) #linetype = NA
}
return(p)
}
-
#' package attatching
#' @noRd
.onAttach <- function(...) {
@@ -690,14 +737,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x))
#' add attributes needed by moveVis functions to m
#' @importFrom move2 mt_time mt_track_id
#' @noRd
-.add_m_attributes <- function(m, path_colours){
- if(!is.character(path_colours)){
- path_colours <- .standard_colours(mt_n_tracks(m))
- if(is.null(m$colour)) m$colour <- .mapvalues(as.character(mt_track_id(m)), unique(mt_track_id(m)), path_colours)
- } else{
- m$colour <- .mapvalues(as.character(mt_track_id(m)), unique(mt_track_id(m)), path_colours)
- }
-
+.add_m_attributes <- function(m) {
# add some info to m
m$time_chr <- as.character(mt_time(m))
m$time <- mt_time(m)
@@ -708,6 +748,123 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x))
return(m)
}
+# This is a safe version of `move2::mt_as_event_attribute()` that does not
+# fail if passed an attribute that happens to already be an event-level
+# attribute
+.expand_track_attr <- function(m, var) {
+ # If colouring by a track attribute, expand it into the event data frame
+ is_track_attr <- var %in% colnames(move2::mt_track_data(m))
+ is_event_attr <- var %in% colnames(m)
+
+ if (is_track_attr && !is_event_attr) {
+ m <- move2::mt_as_event_attribute(m, !!as.name(var))
+ } else if (!is_event_attr) {
+ # If not colouring by a track attribute, the column must be in event data
+ out(
+ paste0("Column '", var, "' not found in 'm'"),
+ type = 3
+ )
+ }
+
+ m
+}
+
+.build_pal <- function(x, path_colours = NULL) {
+ # Identify what type of color scale we're working with.
+ scale_type <- .scale_type(x)
+
+ if (scale_type == "continuous") {
+ if (is.null(path_colours)) {
+ path_colours <- function(x) grDevices::hcl.colors(x, "viridis")
+ }
+
+ if (is.character(path_colours)) {
+ pal <- grDevices::colorRampPalette(path_colours)
+ } else {
+ pal <- path_colours
+ }
+ } else {
+ if (is.null(path_colours)) {
+ path_colours <- function(x) .standard_colours(x)
+ }
+
+ if (is.character(path_colours)) {
+ pal <- function(n) {
+ if (length(path_colours) == 1) {
+ rep(path_colours, n)
+ } else if (n <= length(path_colours)) {
+ path_colours[seq_len(n)]
+ } else {
+ out("Not enough colors in scale", type = 3)
+ }
+ }
+ } else {
+ pal <- path_colours
+ }
+ }
+
+ pal
+}
+
+.build_scale <- function(x, palette) {
+ # Identify what type of color scale we're working with.
+ scale_type <- .scale_type(x)
+
+ if (scale_type == "continuous") {
+ color_scale <- scales::col_numeric(palette(256), domain = range(x))
+ } else {
+ # Build mapping from levels of attribute being colored by to color codes
+ colour_categories <- unique(x)
+ colour_categories <- colour_categories[!is.na(colour_categories)]
+
+ n_colour_cats <- length(unique(colour_categories))
+
+ if (is.factor(colour_categories)) {
+ colour_categories <- droplevels(colour_categories)
+ }
+
+ color_scale <- scales::col_factor(
+ palette(n_colour_cats),
+ domain = colour_categories
+ )
+ }
+
+ color_scale
+}
+
+.scale_type <- function(x) {
+ if ("units" %in% class(x)) {
+ x <- units::drop_units(x)
+ }
+
+ switch(
+ class(x)[1],
+ numeric = "continuous",
+ integer = "continuous",
+ integer64 = "continuous",
+ Date = "continuous",
+ POSIXct = "continuous",
+ POSIXlt = "continuous",
+ difftime = "continuous",
+ factor = "qualitative",
+ ordered = "qualitative",
+ character = "qualitative",
+ logical = "qualitative",
+ "qualitative"
+ )
+}
+
+.drop_units_safe <- function(x) {
+ x <- tryCatch(
+ units::drop_units(x),
+ error = function(cnd) {
+ x
+ }
+ )
+
+ x
+}
+
#' extract crs params
#' @importFrom utils capture.output
#' @noRd
@@ -722,4 +879,4 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x))
if(grepl("Geodetic", crs_params[1])) out(paste0("CRS (geodetic): ", crs_params[2]), verbose = verbose) else{
out(paste0("CRS (projected): ", crs_params[2]), verbose = verbose)
}
-}
\ No newline at end of file
+}
diff --git a/R/render_frame.R b/R/render_frame.R
index 331d51e..59c46c1 100644
--- a/R/render_frame.R
+++ b/R/render_frame.R
@@ -73,7 +73,9 @@ render_frame <- function(frames, i = length(frames)){
path_legend_title = frames$aesthetics$path_legend_title,
path_size = frames$aesthetics$path_size,
equidistant = frames$aesthetics$equidistant,
- tail_length = frames$aesthetics$tail_length
+ tail_length = frames$aesthetics$tail_length,
+ legend_labels = frames$aesthetics$legend_labels,
+ legend_colours = frames$aesthetics$legend_colours
)
}
if(inherits(frames, "frames_graph")){
@@ -84,7 +86,9 @@ render_frame <- function(frames, i = length(frames)){
path_legend = frames$aesthetics$path_legend,
path_legend_title = frames$aesthetics$path_legend_title,
path_size = frames$aesthetics$path_size,
- val_seq = frames$aesthetics$val_seq
+ val_seq = frames$aesthetics$val_seq,
+ legend_labels = frames$aesthetics$legend_labels,
+ legend_colours = frames$aesthetics$legend_colours
)
}
if(frames$graph_type == "hist"){
@@ -95,7 +99,9 @@ render_frame <- function(frames, i = length(frames)){
path_legend_title = frames$aesthetics$path_legend_title,
path_size = frames$aesthetics$path_size,
val_seq = frames$aesthetics$val_seq,
- r_type = frames$aesthetics$r_type
+ r_type = frames$aesthetics$r_type,
+ legend_labels = frames$aesthetics$legend_labels,
+ legend_colours = frames$aesthetics$legend_colours
)
}
}
diff --git a/R/view_spatial.R b/R/view_spatial.R
index a75ce26..1b21145 100644
--- a/R/view_spatial.R
+++ b/R/view_spatial.R
@@ -3,14 +3,11 @@
#' \code{view_spatial} is a simple wrapper that displays movement tracks on an interactive \code{mapview} or \code{leaflet} map.
#'
#' @inheritParams frames_spatial
-#' @param m \code{move2} object. Can contain a column named \code{colour} to control path colours (see \code{details}).
+#' @param m \code{move2} object.
#' @param render_as character, either \code{'mapview'} to return a \code{mapview} map or \code{'leaflet'} to return a \code{leaflet} map.
#' @param time_labels logical, whether to display timestamps for each track fix when hovering it with the mouse cursor.
#' @param stroke logical, whether to draw stroke around circles.
#'
-#' @details If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}.
-#' Colours could also be arranged to change through time or by behavioral segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected automatically. Call \code{colours()} to see all available colours in R.
-#'
#' @return An interactive \code{mapview} or \code{leaflet} map.
#'
#' @author Jakob Schwalb-Willmann
@@ -37,25 +34,30 @@
#' @importFrom sf st_coordinates
#' @export
-view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = TRUE, path_colours = NA, path_legend = TRUE,
- path_legend_title = "Names", verbose = TRUE){
+view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = TRUE, path_colours = NULL, colour_paths_by = move2::mt_track_id_column(m), path_legend = TRUE,
+ path_legend_title = colour_paths_by, verbose = TRUE){
## dependency check
if(is.character(render_as)){
if(!isTRUE(render_as %in% c("mapview", "leaflet"))) out("Argument 'render_as' must be either 'mapview' or 'leaflet'.", type = 3)
} else{out("Argument 'render_as' must be of type 'character'.", type = 3)}
-
+
## check input arguments
if(inherits(verbose, "logical")) options(moveVis.verbose = verbose)
if(all(!inherits(m, "move2"))) out("Argument 'm' must be of class 'move2'.", type = 3)
- if(is.character(path_colours)) if(length(path_colours) != mt_n_tracks(m)) out("Argument 'path_colours' must be of same length as the number of individual tracks of 'm', if defined. Alternatively, use a column 'colour' for individual colouring per coordinate within 'm' (see details of ?frames_spatial).", type = 3)
if(!is.logical(path_legend)) out("Argument 'path_legend' must be of type 'logical'.", type = 3)
if(!is.logical(time_labels)) out("Argument 'time_labels' must be of type 'logical'.", type = 3)
if(!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3)
+ # Units do not always cooperate with color scales...
+ m[[colour_paths_by]] <- .drop_units_safe(m[[colour_paths_by]])
+ m <- .expand_track_attr(m, var = colour_paths_by)
+
+ pal <- .build_pal(m[[colour_paths_by]], path_colours)
+
## preprocess movement data
- m <- .add_m_attributes(m, path_colours = path_colours)
+ m <- .add_m_attributes(m)
## render as mapview object
if(render_as == "mapview"){
@@ -63,9 +65,9 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke =
# compose
map <- mapview::mapview(
- m, map.types = "OpenStreetMap", xcol = "x", ycol = "y", zcol = mt_track_id_column(m), legend = path_legend,
+ m, map.types = "OpenStreetMap", xcol = "x", ycol = "y", zcol = colour_paths_by, legend = path_legend,
crs = st_crs(m)$proj4string, grid = F, layer.name = path_legend_title,
- col.regions = unique(m$colour),
+ col.regions = pal,
label = if(isTRUE(time_labels)) mt_time(m) else NULL, stroke = stroke
)
}
@@ -74,19 +76,52 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke =
if(render_as == "leaflet"){
if(length(grep("leaflet", rownames(utils::installed.packages()))) == 0) out("'leaflet' has to be installed to use this function. Use install.packages('leaflet').", type = 3)
- # compose
- m.split <- split(m, mt_track_id(m))
map <- leaflet::addTiles(map = leaflet::leaflet(m))
- for(i in 1:length(m.split)) map <- leaflet::addCircleMarkers(
- map = map, lng = st_coordinates(m.split[[i]])[,1],
- lat = st_coordinates(m.split[[i]])[,2],
- radius = 5.5, color = "black", stroke = stroke, fillColor = m.split[[i]]$colour, fillOpacity = 0.6, weight = 2, opacity = 1,
- label = if(isTRUE(time_labels)) as.character(mt_time(m.split[[i]])) else NULL)
- map <- leaflet::addScaleBar(map = leaflet::addLegend(
- map = map, colors = unique(m$colour),
- labels = as.character(unique(mt_track_id(m))), opacity = 1, title = path_legend_title), position = "bottomleft"
+
+ var_type <- .scale_type(m[[colour_paths_by]])
+
+ # Need to convert palette to leaflet format (colorNumeric and colorFactor)
+ # to get correct legend behavior
+ if (var_type == "continuous") {
+ # Remove units, which leaflet can't handle.
+ m[[colour_paths_by]] <- as.numeric(m[[colour_paths_by]])
+
+ leaflet_scale <- leaflet::colorNumeric(
+ palette = pal(256),
+ domain = m[[colour_paths_by]]
+ )
+ } else {
+ leaflet_scale <- leaflet::colorFactor(
+ palette = pal(length(unique(m[[colour_paths_by]]))),
+ domain = unique(m[[colour_paths_by]])
+ )
+ }
+
+ map <- leaflet::addCircleMarkers(
+ map = map,
+ lng = st_coordinates(m)[,1],
+ lat = st_coordinates(m)[,2],
+ radius = 5.5,
+ color = "black",
+ stroke = stroke,
+ fillColor = ~ leaflet_scale(m[[colour_paths_by]]),
+ fillOpacity = 0.6,
+ weight = 2,
+ opacity = 1,
+ label = if(isTRUE(time_labels)) as.character(mt_time(m)) else m[[colour_paths_by]]
)
+ map <- leaflet::addScaleBar(
+ map = leaflet::addLegend(
+ map = map,
+ pal = leaflet_scale,
+ values = m[[colour_paths_by]],
+ opacity = 1,
+ title = path_legend_title
+ ),
+ position = "bottomleft"
+ )
}
+
return(map)
}
\ No newline at end of file
diff --git a/man/frames_graph.Rd b/man/frames_graph.Rd
index cfdaba7..7e337a0 100644
--- a/man/frames_graph.Rd
+++ b/man/frames_graph.Rd
@@ -13,9 +13,10 @@ frames_graph(
return_data = FALSE,
graph_type = "flow",
path_size = 1,
- path_colours = NA,
+ path_colours = NULL,
+ colour_paths_by = move2::mt_track_id_column(m),
path_legend = TRUE,
- path_legend_title = "Names",
+ path_legend_title = colour_paths_by,
val_min = NULL,
val_max = NULL,
val_by = 0.1,
@@ -24,7 +25,7 @@ frames_graph(
)
}
\arguments{
-\item{m}{\code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}. Can contain a column named \code{colour} to control path colours (see details below).}
+\item{m}{\code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}.}
\item{r}{\code{terra} object, either a \code{SpatRaster} (mono-temporal) or a \code{SpatRasterDataset} (multi-temporal). In case of the latter, times of `r` must be defined as 'POSIXct' (see \code{\link[terra]{time}} and details below).}
@@ -44,11 +45,13 @@ frames_graph(
\item{path_size}{numeric, size of each path.}
-\item{path_colours}{character, a vector of colours. Must be of same length as number of individual tracks in \code{m} and refers to the order of tracks in \code{m}. If undefined (\code{NA}) and \code{m} contains a column named \code{colour}, colours provided within \code{m} are used (see details). Othwersie, colours are selected from a standard rainbow palette per individual track.}
+\item{path_colours}{character or palette function to use to colour the tracks in `m`. If a character vector, must be a vector of the same length as the number of levels in the attribute being used to colour the tracks (see argument `colour_paths_by`). If a function, must accept an integer and return a vector of colours of that length. By default, colours are selected from a standard rainbow palette per individual track.}
-\item{path_legend}{logical, wether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the tracks' temporal apperances, not by their order in \code{m}.}
+\item{colour_paths_by}{character indicating the name of an attribute column in `m` to use to define path colours. This attribute can be either an event or track-level attribute. By default, colours by track ID.}
-\item{path_legend_title}{character, path legend title. Default is \code{"Names"}.}
+\item{path_legend}{logical, whether to add a path legend from \code{m} or not. When colouring tracks by a qualitative attribute, legend entries will be ordered by the levels of that attribute (if a factor) or alphabetically (if a character).}
+
+\item{path_legend_title}{character, path legend title. Defaults to the column name specified in `colour_paths_by`.}
\item{val_min}{numeric, minimum value of the value axis. If undefined, the minimum is collected automatically.}
diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd
index 933cb21..99dd00d 100644
--- a/man/frames_spatial.Rd
+++ b/man/frames_spatial.Rd
@@ -25,11 +25,12 @@ frames_spatial(
path_join = "round",
path_mitre = 10,
path_arrow = NULL,
- path_colours = NA,
+ path_colours = NULL,
+ colour_paths_by = move2::mt_track_id_column(m),
path_alpha = 1,
path_fade = FALSE,
path_legend = TRUE,
- path_legend_title = "Names",
+ path_legend_title = colour_paths_by,
tail_length = 19,
tail_size = 1,
tail_colour = "white",
@@ -42,7 +43,7 @@ frames_spatial(
)
}
\arguments{
-\item{m}{\code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}. Can contain a column named \code{colour} to control path colours (see details below).}
+\item{m}{\code{move2} object of uniform time scale and time lag as returned by \code{\link{align_move}}.}
\item{r}{\code{terra} object, either a \code{SpatRaster} (mono-temporal) or a \code{SpatRasterDataset} (multi-temporal). In case of the latter, times of `r` must be defined as 'POSIXct' (see \code{\link[terra]{time}} and details below).}
@@ -84,15 +85,17 @@ so that baesmap tiles that had been already downloaded by moveVis do not have to
\item{path_arrow}{arrow, path arrow specification, as created by grid::arrow().}
-\item{path_colours}{character, a vector of colours. Must be of same length as number of individual tracks in \code{m} and refers to the order of tracks in \code{m}. If undefined (\code{NA}) and \code{m} contains a column named \code{colour}, colours provided within \code{m} are used (see details). Othwersie, colours are selected from a standard rainbow palette per individual track.}
+\item{path_colours}{character or palette function to use to colour the tracks in `m`. If a character vector, must be a vector of the same length as the number of levels in the attribute being used to colour the tracks (see argument `colour_paths_by`). If a function, must accept an integer and return a vector of colours of that length. By default, colours are selected from a standard rainbow palette per individual track.}
+
+\item{colour_paths_by}{character indicating the name of an attribute column in `m` to use to define path colours. This attribute can be either an event or track-level attribute. By default, colours by track ID.}
\item{path_alpha}{numeric, defines alpha (transparency) of the path. Value between 0 and 1. Default is 1.}
\item{path_fade}{logical, whether paths should be faded towards the last frame or not. Useful, if \code{trace_show = TRUE} and you want to hold the last frame using \code{end_pause} in \code{\link{animate_frames}}.}
-\item{path_legend}{logical, wether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the tracks' temporal apperances, not by their order in \code{m}.}
+\item{path_legend}{logical, whether to add a path legend from \code{m} or not. When colouring tracks by a qualitative attribute, legend entries will be ordered by the levels of that attribute (if a factor) or alphabetically (if a character).}
-\item{path_legend_title}{character, path legend title. Default is \code{"Names"}.}
+\item{path_legend_title}{character, path legend title. Defaults to the column name specified in `colour_paths_by`.}
\item{tail_length}{numeric, length of tail per movement path.}
@@ -125,9 +128,6 @@ A frames object of class \code{moveVis}.
\code{frames_spatial} creates frames from movement and map/raster data. If no custom raster data is provided, a basemap is pulled from a map tile service using the \code{basemaps} package. Frames are returned as an object of class \code{moveVis} and can be subsetted, viewed (see \code{\link{render_frame}}), modified (see \code{\link{add_gg}} and associated functions ) and animated (see \code{\link{animate_frames}}).
}
\details{
-If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}.
-Colours could also be arranged to change through time or by behavioural segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected using \code{path_colours} or automatically. Call \code{colours()} to see all available colours in R.
-
Basemap colour scales can be changed/added using \code{\link{add_colourscale}} or by using \code{ggplot2} commands (see \code{examples}). For continuous scales, use \code{r_type = "gradient"}. For discrete scales, use \code{r_type = "discrete"}.
If argument \code{equidistant} is set, the map extent is calculated (thus enlarged into one axis direction) to represent equal distances on the x and y axis.
@@ -205,17 +205,26 @@ frames <- frames_spatial(
)
frames[[100]]
-m$colour <- plyr::mapvalues(
- as.character(mt_track_id(m)),
- unique(mt_track_id(m)), c("orange", "purple", "darkgreen")
-)
+# colour paths based on an attribute variable
+m$tag_type <- ifelse(m$track == "T246a", "A", "B")
frames <- frames_spatial(
- m, map_service = "osm", map_type = "topographic", alpha = 0.5
+ m, map_service = "osm", map_type = "topographic", alpha = 0.5,
+ colour_paths_by = "tag_type",
+ path_colours = c("firebrick", "steelblue")
)
frames[[100]]
+# Colour using a separately-defined palette function
+# This will handle any number of levels in the attribute used for colouring
+frames <- frames_spatial(
+ m, map_service = "osm", map_type = "topographic", alpha = 0.5,
+ colour_paths_by = "tag_type",
+ path_colours = function(x) grDevices::hcl.colors(x, "Dark 3")
+)
+frames[[100]]
}
+
# create frames from custom (multi-temporal) basemaps
r <- readRDS(example_data(file = "raster_NDVI.rds"))
diff --git a/man/view_spatial.Rd b/man/view_spatial.Rd
index 13e2afa..b9736c8 100644
--- a/man/view_spatial.Rd
+++ b/man/view_spatial.Rd
@@ -9,14 +9,15 @@ view_spatial(
render_as = "mapview",
time_labels = TRUE,
stroke = TRUE,
- path_colours = NA,
+ path_colours = NULL,
+ colour_paths_by = move2::mt_track_id_column(m),
path_legend = TRUE,
- path_legend_title = "Names",
+ path_legend_title = colour_paths_by,
verbose = TRUE
)
}
\arguments{
-\item{m}{\code{move2} object. Can contain a column named \code{colour} to control path colours (see \code{details}).}
+\item{m}{\code{move2} object.}
\item{render_as}{character, either \code{'mapview'} to return a \code{mapview} map or \code{'leaflet'} to return a \code{leaflet} map.}
@@ -24,11 +25,13 @@ view_spatial(
\item{stroke}{logical, whether to draw stroke around circles.}
-\item{path_colours}{character, a vector of colours. Must be of same length as number of individual tracks in \code{m} and refers to the order of tracks in \code{m}. If undefined (\code{NA}) and \code{m} contains a column named \code{colour}, colours provided within \code{m} are used (see details). Othwersie, colours are selected from a standard rainbow palette per individual track.}
+\item{path_colours}{character or palette function to use to colour the tracks in `m`. If a character vector, must be a vector of the same length as the number of levels in the attribute being used to colour the tracks (see argument `colour_paths_by`). If a function, must accept an integer and return a vector of colours of that length. By default, colours are selected from a standard rainbow palette per individual track.}
-\item{path_legend}{logical, wether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the tracks' temporal apperances, not by their order in \code{m}.}
+\item{colour_paths_by}{character indicating the name of an attribute column in `m` to use to define path colours. This attribute can be either an event or track-level attribute. By default, colours by track ID.}
-\item{path_legend_title}{character, path legend title. Default is \code{"Names"}.}
+\item{path_legend}{logical, whether to add a path legend from \code{m} or not. When colouring tracks by a qualitative attribute, legend entries will be ordered by the levels of that attribute (if a factor) or alphabetically (if a character).}
+
+\item{path_legend_title}{character, path legend title. Defaults to the column name specified in `colour_paths_by`.}
\item{verbose}{logical, if \code{TRUE}, messages and progress information are displayed on the console (default).}
}
@@ -38,10 +41,6 @@ An interactive \code{mapview} or \code{leaflet} map.
\description{
\code{view_spatial} is a simple wrapper that displays movement tracks on an interactive \code{mapview} or \code{leaflet} map.
}
-\details{
-If argument \code{path_colours} is not defined (set to \code{NA}), path colours can be defined by adding a character column named \code{colour} to \code{m}, containing a colour code or name per row (e.g. \code{"red"}. This way, for example, column \code{colour} for all rows belonging to individual A can be set to \code{"green"}, while column \code{colour} for all rows belonging to individual B can be set to \code{"red"}.
-Colours could also be arranged to change through time or by behavioral segments, geographic locations, age, environmental or health parameters etc. If a column name \code{colour} in \code{m} is missing, colours will be selected automatically. Call \code{colours()} to see all available colours in R.
-}
\examples{
\dontrun{
library(moveVis)
diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R
new file mode 100644
index 0000000..304007f
--- /dev/null
+++ b/tests/testthat/setup.R
@@ -0,0 +1,3 @@
+# Ensure empty graphics device is opened to prevent tests that call
+# ggplot2::ggplot_gtable() from opening a new device
+grDevices::pdf(NULL)
\ No newline at end of file
diff --git a/tests/testthat/test-frames_graph.R b/tests/testthat/test-frames_graph.R
index e4c8a57..07599b2 100755
--- a/tests/testthat/test-frames_graph.R
+++ b/tests/testthat/test-frames_graph.R
@@ -70,4 +70,237 @@ test_that("frames_graph (discrete, hist)", {
frames <- expect_length(expect_is(frames_graph(m.aligned, r_disc, r_type = "discrete", graph_type = "hist", verbose = F, val_by = 1), "moveVis"), 188)
expect_is(frames[[1]], "ggplot")
})
-#}
\ No newline at end of file
+#}
+
+test_that("frames_graph maps correct colours to tracks (flow)", {
+ fr <- frames_graph(
+ m = m.aligned,
+ r_grad,
+ graph_type = "flow",
+ verbose = F,
+ path_colours = c("#F2A08F", "#65A7C9", "#461A6B")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ pal <- setNames(cols, lims)
+
+ expect_equal(pal[["T246a"]], "#F2A08F")
+ expect_equal(pal[["T342g"]], "#65A7C9")
+ expect_equal(pal[["T932u"]], "#461A6B")
+})
+
+test_that("frames_graph maps correct colours to tracks (hist)", {
+ fr <- frames_graph(
+ m = m.aligned,
+ r_grad,
+ graph_type = "hist",
+ verbose = F,
+ path_colours = c("#F2A08F", "#65A7C9", "#461A6B")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ pal <- setNames(cols, lims)
+
+ expect_equal(pal[["T246a"]], "#F2A08F")
+ expect_equal(pal[["T342g"]], "#65A7C9")
+ expect_equal(pal[["T932u"]], "#461A6B")
+})
+
+test_that("frames_graph can color by track attributes", {
+ m <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B"))
+
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, c("A", "B"))
+ expect_equal(cols, .standard_colours(2))
+})
+
+test_that("frames_graph can color by event attributes", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, unique(m[["var"]]))
+ expect_equal(cols, .standard_colours(2))
+
+ expect_error(
+ frames_graph(m.aligned, r_grad, verbose = FALSE, colour_paths_by = "foo"),
+ "Column 'foo' not found"
+ )
+})
+
+test_that("User can provide `path_colours` when colouring by attribute", {
+ m <- move2::mutate_track_data(
+ m.aligned,
+ var = factor(c("A", "A", "B"), levels = c("B", "A"))
+ )
+
+ # User specified color vector
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var",
+ graph_type = "hist",
+ path_colours = c("#F2A08F", "#65A7C9")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, c("B", "A"))
+ expect_equal(cols, c("#F2A08F", "#65A7C9"))
+})
+
+test_that("path_colours accepts palette function", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ pal <- function(x) grDevices::hcl.colors(x, palette = "viridis")
+
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ path_colours = pal
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, levels(move2::mt_track_id(m)))
+ expect_equal(cols, pal(3))
+
+ # Palette adjusts to number of levels in coloring variable
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var",
+ path_colours = pal
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, unique(m[["var"]]))
+ expect_equal(cols, pal(length(unique(m[["var"]]))))
+})
+
+test_that("Coloring by attributes orders correctly for factor vs. character", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ fr1 <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built1 <- ggplot2::ggplot_build(fr1[[50]])
+ sc1 <- built1$plot$scales$get_scales("colour")
+ lims1 <- sc1$get_limits()
+ cols1 <- sc1$map(lims1)
+
+ m[["var"]] <- factor(m[["var"]], levels = c("B", "A"))
+
+ fr2 <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built2 <- ggplot2::ggplot_build(fr2[[50]])
+ sc2 <- built2$plot$scales$get_scales("colour")
+ lims2 <- sc2$get_limits()
+ cols2 <- sc2$map(lims2)
+
+ expect_equal(lims1, rev(lims2))
+ expect_equal(cols1, cols2)
+})
+
+test_that("Error when coloring by continuous attribute", {
+ m <- m.aligned
+ m[["var"]] <- 1:nrow(m)
+
+ expect_error(
+ frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ colour_paths_by = "var"
+ ),
+ "Cannot color by continuous variables"
+ )
+})
+
+test_that("Legend title uses attribute variable", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ fr <- frames_graph(
+ m,
+ r_grad,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ gt <- ggplot2::ggplot_gtable(built)
+
+ grobs <- gt$grobs[[15]]$grobs[[1]]$grobs
+ i <- which(sapply(grobs, function(x) grepl("guide.title.titleGrob", x$name)))
+
+ # This isn't super robust, but difficult to fully automate checking
+ # the ggplot2 internals. In the future a snapshot test would likely be
+ # more effective.
+ expect_equal(grobs[[i]]$children[[1]]$label, "var")
+})
+
diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R
index 61bacc8..2e25637 100644
--- a/tests/testthat/test-frames_spatial.R
+++ b/tests/testthat/test-frames_spatial.R
@@ -22,6 +22,27 @@ test_that("frames_spatial (default maps)", {
expect_error(frames_spatial(m.aligned, equidistant = "abc", map_res = 0.1, verbose = F)) # false path_legend
})
+test_that("frames_spatial maps correct colours to tracks", {
+ fr <- frames_spatial(
+ m = m.aligned,
+ verbose = F,
+ map_res = 0.1,
+ path_colours = c("#F2A08F", "#65A7C9", "#461A6B")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ pal <- setNames(cols, lims)
+
+ expect_equal(pal[["T246a"]], "#F2A08F")
+ expect_equal(pal[["T342g"]], "#65A7C9")
+ expect_equal(pal[["T932u"]], "#461A6B")
+})
+
test_that("frames_spatial (raster, gradient)", {
# correct calls
frames <- expect_length(expect_is(frames_spatial(m.aligned, r = r_grad, r_type = "gradient", verbose = F), "moveVis"), 188)
@@ -116,4 +137,233 @@ test_that("frames_spatial (cross_dateline)", {
frames <- expect_length(expect_is(frames_spatial(m = m.shifted, map_service = "carto", map_type = "light",
verbose = F, crs = st_crs(4326), cross_dateline = T), "moveVis"), 188)
frames <- expect_error(frames_spatial(m = m.shifted, r_grad, r_type = "gradient", verbose = F, cross_dateline = T))
-})
\ No newline at end of file
+})
+
+test_that("frames_spatial can color by track attributes", {
+ m <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B"))
+
+ fr <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, c("A", "B"))
+ expect_equal(cols, .standard_colours(2))
+})
+
+test_that("frames_spatial can color by event attributes", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ # Default
+ fr <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, unique(m[["var"]]))
+ expect_equal(cols, .standard_colours(2))
+
+ expect_error(
+ capture.output(frames_spatial(m, colour_paths_by = "foo")),
+ "Column 'foo' not found"
+ )
+})
+
+test_that("User can provide `path_colours` when colouring by attribute", {
+ m <- move2::mutate_track_data(
+ m.aligned,
+ var = factor(c("A", "A", "B"), levels = c("B", "A"))
+ )
+
+ # User specified color vector
+ fr <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var",
+ path_colours = c("#F2A08F", "#65A7C9")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, c("B", "A"))
+ expect_equal(cols, c("#F2A08F", "#65A7C9"))
+})
+
+test_that("path_colours accepts palette function", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ pal <- function(x) grDevices::hcl.colors(x, palette = "viridis")
+
+ fr <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ path_colours = pal
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, levels(move2::mt_track_id(m)))
+ expect_equal(cols, pal(3))
+
+ # Palette adjusts to number of levels in coloring variable
+ fr <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var",
+ path_colours = pal
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+ lims <- sc$get_limits()
+ cols <- sc$map(lims)
+
+ expect_equal(lims, unique(m[["var"]]))
+ expect_equal(cols, pal(length(unique(m[["var"]]))))
+})
+
+test_that("Coloring by attributes orders correctly for factor vs. character", {
+ m <- m.aligned
+ m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B")
+
+ fr1 <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built1 <- ggplot2::ggplot_build(fr1[[50]])
+ sc1 <- built1$plot$scales$get_scales("colour")
+ lims1 <- sc1$get_limits()
+ cols1 <- sc1$map(lims1)
+
+ m[["var"]] <- factor(m[["var"]], levels = c("B", "A"))
+
+ fr2 <- frames_spatial(
+ m,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built2 <- ggplot2::ggplot_build(fr2[[50]])
+ sc2 <- built2$plot$scales$get_scales("colour")
+ lims2 <- sc2$get_limits()
+ cols2 <- sc2$map(lims2)
+
+ expect_equal(lims1, rev(lims2))
+ expect_equal(cols1, cols2)
+})
+
+test_that("Can color by continuous attribute", {
+ m.aligned[["row"]] <- 1:nrow(m.aligned)
+
+ # Default
+ fr <- frames_spatial(
+ m.aligned,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "row"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+
+ lims <- sc$get_limits()
+ brks <- sc$get_breaks()
+ cols <- sc$map(brks)
+
+ expect_equal(lims, range(m.aligned[["row"]]))
+ expect_equal(brks, seq(0, 500, by = 100))
+ expect_equal(
+ cols,
+ c("grey50", "#1C4E85", "#008C98", "#00BD7E", "#B4DC3B", "grey50")
+ )
+ expect_equal(sc$guide, "colourbar")
+
+ # With user-specified palette
+ fr <- frames_spatial(
+ m.aligned,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "row",
+ path_colours = function(x) grDevices::hcl.colors(x, "Blues")
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ sc <- built$plot$scales$get_scales("colour")
+
+ lims <- sc$get_limits()
+ brks <- sc$get_breaks()
+ cols <- sc$map(brks)
+
+ expect_equal(lims, range(m.aligned[["row"]]))
+ expect_equal(brks, seq(0, 500, by = 100))
+ expect_equal(
+ cols,
+ c("grey50", "#316BB1", "#6F9ECD", "#AACBE3", "#DFEEF7", "grey50")
+ )
+ expect_equal(sc$guide, "colourbar")
+
+ # Can handle units:
+ m.aligned[["row"]] <- units::set_units(m.aligned[["row"]], "m/s")
+
+ fr2 <- frames_spatial(
+ m.aligned,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "row",
+ path_colours = function(x) grDevices::hcl.colors(x, "Blues")
+ )
+
+ expect_equal(fr$aesthetics, fr2$aesthetics)
+ expect_silent(fr2[[1]])
+})
+
+test_that("Legend title uses attribute variable", {
+ m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B")
+
+ fr <- frames_spatial(
+ m.aligned,
+ verbose = FALSE,
+ map_res = 0.1,
+ colour_paths_by = "var"
+ )
+
+ built <- ggplot2::ggplot_build(fr[[50]])
+ gt <- ggplot2::ggplot_gtable(built)
+
+ grobs <- gt$grobs[[15]]$grobs[[1]]$grobs
+ i <- which(sapply(grobs, function(x) grepl("guide.title.titleGrob", x$name)))
+
+ # This isn't super robust, but difficult to fully automate checking
+ # the ggplot2 internals. In the future a snapshot test would likely be
+ # more effective.
+ expect_equal(grobs[[i]]$children[[1]]$label, "var")
+})
diff --git a/tests/testthat/test-view_spatial.R b/tests/testthat/test-view_spatial.R
index 1d275ba..1fc6a53 100644
--- a/tests/testthat/test-view_spatial.R
+++ b/tests/testthat/test-view_spatial.R
@@ -15,8 +15,151 @@ test_that("view_spatial", {
expect_error(view_spatial(m, render_as = "abc"))
expect_error(view_spatial(m, render_as = NA))
expect_error(view_spatial(NA))
- expect_error(view_spatial(m, path_colours = "1"))
+ expect_error(view_spatial(m, path_colours = "foo"))
expect_error(view_spatial(m, path_legend = "1"))
expect_error(view_spatial(m, time_labels = "1"))
expect_error(view_spatial(m, path_legend_title = 1))
-})
\ No newline at end of file
+})
+
+test_that("view_spatial() colours tracks correctly by track ID (default)", {
+ skip_if_not_installed("mapview")
+
+ v <- view_spatial(m)
+
+ calls <- v@map$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#FF0000", "#00FF00", "#0000FF")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("T246a", "T342g", "T932u")
+ )
+})
+
+test_that("view_spatial() colours tracks correctly by track ID: leaflet", {
+ skip_if_not_installed("leaflet")
+
+ v <- view_spatial(m, render_as = "leaflet")
+
+ calls <- v$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#FF0000", "#00FF00", "#0000FF")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("T246a", "T342g", "T932u")
+ )
+})
+
+test_that("view_spatial() can colour tracks by variable", {
+ skip_if_not_installed("mapview")
+
+ m2 <- m
+ m2[["var"]] <- ifelse(m2[["track"]] == "T246a", "A", "B")
+
+ v <- view_spatial(
+ m2,
+ path_colours = c("#F2A08F", "#65A7C9"),
+ colour_paths_by = "var"
+ )
+
+ calls <- v@map$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#F2A08F", "#65A7C9")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("A", "B")
+ )
+})
+
+test_that("view_spatial() can colour tracks by variable: leaflet", {
+ skip_if_not_installed("leaflet")
+
+ m2 <- m
+ m2[["var"]] <- ifelse(m2[["track"]] == "T246a", "A", "B")
+
+ v <- view_spatial(
+ m2,
+ render_as = "leaflet",
+ path_colours = c("#F2A08F", "#65A7C9"),
+ colour_paths_by = "var"
+ )
+
+ calls <- v$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#F2A08F", "#65A7C9")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("A", "B")
+ )
+})
+
+test_that("view_spatial() can colour tracks by variable", {
+ skip_if_not_installed("mapview")
+
+ m2 <- move2::mutate_track_data(
+ m,
+ var = factor(c("A", "A", "B"), levels = c("B", "A"))
+ )
+
+ v <- view_spatial(
+ m2,
+ path_colours = c("#F2A08F", "#65A7C9"),
+ colour_paths_by = "var"
+ )
+
+ calls <- v@map$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#F2A08F", "#65A7C9")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("B", "A")
+ )
+})
+
+test_that("view_spatial() can colour tracks by variable: leaflet", {
+ skip_if_not_installed("leaflet")
+
+ m2 <- move2::mutate_track_data(
+ m,
+ var = factor(c("A", "A", "B"), levels = c("B", "A"))
+ )
+
+ v <- view_spatial(
+ m2,
+ render_as = "leaflet",
+ path_colours = c("#F2A08F", "#65A7C9"),
+ colour_paths_by = "var"
+ )
+
+ calls <- v$x$calls
+
+ i <- sapply(calls, function(x) x$method == "addLegend")
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$colors),
+ c("#F2A08F", "#65A7C9")
+ )
+ expect_equal(
+ unclass(calls[i][[1]]$args[[1]]$labels),
+ c("B", "A")
+ )
+})
+
\ No newline at end of file
diff --git a/vignettes/example-1.Rmd b/vignettes/example-1.Rmd
index cf778e1..c33f921 100644
--- a/vignettes/example-1.Rmd
+++ b/vignettes/example-1.Rmd
@@ -137,7 +137,10 @@ frames <- frames_spatial(move_data, path_colours = c("red", "green", "blue"),
map_service = "osm", map_type = "topographic", alpha = 0.5)
```
-Instead of using `path_colours`, you can add a `colour` column to your `move2` object. This allows you to colour your movement tracks as you want, e.g. not only by individual track, but by behavioural segment, time, age, speed or something different (see `?frames_spatial` for details).
+To customize the colours of the paths, you can use the `colour_paths_by` argument
+to specify an attribute variable in the input `move2` object to use for
+track colouring. For instance, you could colour tracks by behavioural
+segment, time, age, speed, or something else (see `?frames_spatial` for details).
Have a look at the newly created frames object. You can retrieve some information about the frames that you have just created and plot individual frames to get first impressions on how your animation will look like: