From 8a752b496409da0a3c0020af70e48d33029a096e Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 9 Sep 2025 16:41:07 +0200 Subject: [PATCH 01/22] Fixes 16Eagle/moveVis#133; Ensure correct legend color order --- R/frames_spatial.R | 2 +- R/internal.R | 14 +++++---- man/frames_graph.Rd | 2 +- man/frames_spatial.Rd | 2 +- man/view_spatial.Rd | 2 +- tests/testthat/test-frames_graph.R | 46 +++++++++++++++++++++++++++- tests/testthat/test-frames_spatial.R | 23 ++++++++++++++ 7 files changed, 80 insertions(+), 11 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 2fc032e..fa54412 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -15,7 +15,7 @@ #' @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_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 logical, whether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character). #' @param path_legend_title character, path legend title. Default is \code{"Names"}. #' @param tail_length numeric, length of tail per movement path. #' @param tail_size numeric, size of the last tail element. Default is 1. diff --git a/R/internal.R b/R/internal.R index f8e7bcc..4d3b05a 100755 --- a/R/internal.R +++ b/R/internal.R @@ -577,7 +577,7 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, 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), + values = setNames(unique(m_colour), unique(m_names)), name = path_legend_title) + guides(color = guide_legend(order = 1))) } @@ -600,13 +600,16 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, ## 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) + colour_pos <- sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] ) + + l.df <- cbind.data.frame(frame = x[1,]$frame, value = x[1,]$value, name = names(colour_pos), + colour = as.character(y$colour[colour_pos]), stringsAsFactors = F) l.df$name <- factor(l.df$name, levels = l.df$name) 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) - } + } return(p) + } @@ -631,12 +634,11 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, 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) 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 = setNames(as.character(l.df$colour), as.character(l.df$name)), name = path_legend_title) #linetype = NA } return(p) } - #' package attatching #' @noRd .onAttach <- function(...) { diff --git a/man/frames_graph.Rd b/man/frames_graph.Rd index cfdaba7..d105699 100644 --- a/man/frames_graph.Rd +++ b/man/frames_graph.Rd @@ -46,7 +46,7 @@ frames_graph( \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_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. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd index 933cb21..ac1dd2a 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -90,7 +90,7 @@ so that baesmap tiles that had been already downloaded by moveVis do not have to \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. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/view_spatial.Rd b/man/view_spatial.Rd index 13e2afa..0ca9b0d 100644 --- a/man/view_spatial.Rd +++ b/man/view_spatial.Rd @@ -26,7 +26,7 @@ view_spatial( \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_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. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/tests/testthat/test-frames_graph.R b/tests/testthat/test-frames_graph.R index e4c8a57..c2dae5b 100755 --- a/tests/testthat/test-frames_graph.R +++ b/tests/testthat/test-frames_graph.R @@ -70,4 +70,48 @@ 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") +}) diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 61bacc8..db62e8a 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -22,6 +22,29 @@ 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]]) + + 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) From b498448f9d94fb9bf5c08e0dd4e55eaa349acac9 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 11 Sep 2025 17:18:11 +0200 Subject: [PATCH 02/22] Order all legends by temporal appearance Makes `frames_spatial()` consistent with `frames_graph()` after fixing label mapping --- R/frames_spatial.R | 2 +- R/internal.R | 5 +++-- man/frames_graph.Rd | 2 +- man/frames_spatial.Rd | 2 +- man/view_spatial.Rd | 2 +- 5 files changed, 7 insertions(+), 6 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index fa54412..2a7d29e 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -15,7 +15,7 @@ #' @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_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, whether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character). +#' @param path_legend logical, whether 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 tail_length numeric, length of tail per movement path. #' @param tail_size numeric, size of the last tail element. Default is 1. diff --git a/R/internal.R b/R/internal.R index 4d3b05a..a9be3bb 100755 --- a/R/internal.R +++ b/R/internal.R @@ -555,7 +555,8 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, coords <- st_coordinates(x) st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x))) })) - x_lines_legend$name <- unique(m_names) + x_lines_legend$name <- factor(unique(m_names), levels = unique(m_names)) + x_lines_legend$colour <- unique(m_colour) # scale plot to ext and set na.rm to TRUE to avoid warnings y$layers[[1]]$geom_params$na.rm <- T @@ -577,7 +578,7 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, 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 = setNames(unique(m_colour), unique(m_names)), + values = setNames(x_lines_legend$colour, x_lines_legend$name), name = path_legend_title) + guides(color = guide_legend(order = 1))) } diff --git a/man/frames_graph.Rd b/man/frames_graph.Rd index d105699..a43a524 100644 --- a/man/frames_graph.Rd +++ b/man/frames_graph.Rd @@ -46,7 +46,7 @@ frames_graph( \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_legend}{logical, whether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} +\item{path_legend}{logical, whether 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_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd index ac1dd2a..8b5eaeb 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -90,7 +90,7 @@ so that baesmap tiles that had been already downloaded by moveVis do not have to \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, whether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} +\item{path_legend}{logical, whether 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_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/view_spatial.Rd b/man/view_spatial.Rd index 0ca9b0d..2d823cc 100644 --- a/man/view_spatial.Rd +++ b/man/view_spatial.Rd @@ -26,7 +26,7 @@ view_spatial( \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_legend}{logical, whether to add a path legend from \code{m} or not. Legend tracks and colours will be ordered by the track levels in \code{m} (if a factor) or alphabetically (if a character).} +\item{path_legend}{logical, whether 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_title}{character, path legend title. Default is \code{"Names"}.} From 0e05218ae5853fa68c1daf9d232273b4764ccc53 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Mon, 8 Sep 2025 10:41:52 +0200 Subject: [PATCH 03/22] Prevent uninitialized column warning for tibbles --- R/internal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/internal.R b/R/internal.R index a9be3bb..b70f7eb 100755 --- a/R/internal.R +++ b/R/internal.R @@ -696,7 +696,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) .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) + if(!"colour" %in% colnames(m)) 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) } From 1683637f1c1908486f775929439d77f211d024ad Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 9 Sep 2025 17:35:43 +0200 Subject: [PATCH 04/22] enable color by track attribute --- R/frames_spatial.R | 58 +++++++++++++++++++------------------ R/internal.R | 71 ++++++++++++++++++++++++++++++++++------------ R/render_frame.R | 1 + 3 files changed, 85 insertions(+), 45 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 2a7d29e..39faf38 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -192,8 +192,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 = NA, colour_tracks_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE, + path_legend = TRUE, path_legend_title = colour_tracks_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(...) @@ -286,7 +286,7 @@ 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) + m <- .add_m_attributes(m, path_colours = path_colours, colour_tracks_by = colour_tracks_by) # print stats .stats(n.frames = max(m$frame)) @@ -344,33 +344,37 @@ frames_spatial <- function( 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, + colour_tracks_by = colour_tracks_by, + 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 + ), 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") diff --git a/R/internal.R b/R/internal.R index b70f7eb..8883684 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, m_labels, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length){ # lines: sements x_lines <- do.call(rbind, lapply(unique(m_names), function(.name){ @@ -550,24 +550,31 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, } else NULL })) + if (is.null(m_labels)) { + m_labels <- m_names + } + # lines: full - x_lines_legend <- do.call(rbind, lapply(unique(m_names), function(.name){ + colour_map <- unique(data.frame(name = m_names, colour = m_colour, label = m_labels)) + + x_lines_legend <- do.call(rbind, lapply(colour_map$label, function(.name){ coords <- st_coordinates(x) st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x))) })) x_lines_legend$name <- factor(unique(m_names), levels = unique(m_names)) - x_lines_legend$colour <- unique(m_colour) + x_lines_legend$label <- colour_map$label + x_lines_legend$colour <- colour_map$colour # 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) @@ -575,11 +582,13 @@ gg.spatial <- function(x, y, m_names, m_colour, path_end, path_join, path_mitre, # 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 = setNames(x_lines_legend$colour, x_lines_legend$name), - name = path_legend_title) + guides(color = guide_legend(order = 1))) + 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 = setNames(x_lines_legend$colour, x_lines_legend$label), + name = path_legend_title + ) + + guides(color = guide_legend(order = 1))) } # theme @@ -693,11 +702,37 @@ 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(!"colour" %in% colnames(m)) m$colour <- .mapvalues(as.character(mt_track_id(m)), unique(mt_track_id(m)), path_colours) - } else{ +.add_m_attributes <- function(m, path_colours, colour_tracks_by) { + if (!is.character(path_colours)) { + track_data <- move2::mt_track_data(m) + track_id_col <- move2::mt_track_id_column(m) + + # Attach track attribute categories to colors + colour_categories <- unique(track_data[[colour_tracks_by]]) + path_colours <- .standard_colours(length(unique(colour_categories))) + + attr_colour_map <- setNames( + data.frame(colour_categories, path_colours), + c(colour_tracks_by, "colour") + ) + + # Attach colors to individual track records based on track attribute + # Use `union()` because it is possible that the attribute to color by + # is actually track ID column itself. + track_colour_map <- merge( + track_data[union(track_id_col, colour_tracks_by)], + attr_colour_map, + by = colour_tracks_by + ) + + # Add appropriate colour and category labels to m for use when rendering frames + if (!"colour" %in% colnames(m)) { + i <- match(move2::mt_track_id(m), track_colour_map[[track_id_col]]) + + m$colour <- track_colour_map$colour[i] + m$colour_labels <- track_colour_map[[colour_tracks_by]][i] + } + } else { m$colour <- .mapvalues(as.character(mt_track_id(m)), unique(mt_track_id(m)), path_colours) } @@ -725,4 +760,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..4987ef5 100644 --- a/R/render_frame.R +++ b/R/render_frame.R @@ -64,6 +64,7 @@ render_frame <- function(frames, i = length(frames)){ add_coord = FALSE), m_names = frames$m$name, m_colour = frames$m$colour, + m_labels = frames$m$colour_labels, path_end = frames$aesthetics$path_end, path_join = frames$aesthetics$path_join, path_mitre = frames$aesthetics$path_mitre, From 797dc5945424370ac9f7a53c4449f83116a2462b Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Wed, 10 Sep 2025 14:37:06 +0200 Subject: [PATCH 05/22] Enable color by event attributes --- R/frames_spatial.R | 1 - R/internal.R | 84 ++++++++++++++++++++++++++++++---------------- 2 files changed, 55 insertions(+), 30 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 39faf38..ec74813 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -270,7 +270,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) diff --git a/R/internal.R b/R/internal.R index 8883684..25e36b8 100755 --- a/R/internal.R +++ b/R/internal.R @@ -561,7 +561,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p coords <- st_coordinates(x) st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x))) })) - x_lines_legend$name <- factor(unique(m_names), levels = unique(m_names)) + x_lines_legend$name <- colour_map$name x_lines_legend$label <- colour_map$label x_lines_legend$colour <- colour_map$colour @@ -703,39 +703,65 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) #' @importFrom move2 mt_time mt_track_id #' @noRd .add_m_attributes <- function(m, path_colours, colour_tracks_by) { - if (!is.character(path_colours)) { - track_data <- move2::mt_track_data(m) - track_id_col <- move2::mt_track_id_column(m) - - # Attach track attribute categories to colors - colour_categories <- unique(track_data[[colour_tracks_by]]) - path_colours <- .standard_colours(length(unique(colour_categories))) - - attr_colour_map <- setNames( - data.frame(colour_categories, path_colours), - c(colour_tracks_by, "colour") - ) - - # Attach colors to individual track records based on track attribute - # Use `union()` because it is possible that the attribute to color by - # is actually track ID column itself. - track_colour_map <- merge( - track_data[union(track_id_col, colour_tracks_by)], - attr_colour_map, - by = colour_tracks_by + # If colouring by a track attribute, expand it into the event data frame + if (colour_tracks_by %in% colnames(move2::mt_track_data(m))) { + m <- move2::mt_as_event_attribute(m, !!as.name(colour_tracks_by)) + } else if (!colour_tracks_by %in% colnames(m)) { + # If not colouring by a track attribute, the column must be in event data + out( + paste0("Column '", colour_tracks_by, "' not found in 'm'"), + type = 3 ) + } + + # Build mapping from levels of attribute being colored by to color codes + colour_categories <- unique(m[[colour_tracks_by]]) + + n_colour_cats <- length(unique(colour_categories)) + + # Default colours. Otherwise uses the values provided to `path_colours` + if (!is.character(path_colours)) { + path_colours <- .standard_colours(n_colour_cats) + } else { + # Recycle `path_colours` if only length 1 + if (length(path_colours) == 1) { + path_colours <- rep(path_colours, n_colour_cats) + } - # Add appropriate colour and category labels to m for use when rendering frames - if (!"colour" %in% colnames(m)) { - i <- match(move2::mt_track_id(m), track_colour_map[[track_id_col]]) - - m$colour <- track_colour_map$colour[i] - m$colour_labels <- track_colour_map[[colour_tracks_by]][i] + if (length(path_colours) != n_colour_cats) { + out( + paste0( + "Number of 'path_colours' (", length(path_colours), ") does not equal", + " the number of levels in '", colour_tracks_by, "' (", + n_colour_cats, ")" + ), + type = 3 + ) } - } else { - m$colour <- .mapvalues(as.character(mt_track_id(m)), unique(mt_track_id(m)), path_colours) } + # Avoid duplicate names if `colour_tracks_by = "colour"` + colour_col_name <- make.unique(c(colour_tracks_by, "colour"))[2] + + attr_colour_map <- setNames( + data.frame(colour_categories, path_colours), + c(colour_tracks_by, colour_col_name) + ) + + colour_map <- merge( + m[union(move2::mt_track_id_column(m), colour_tracks_by)], + attr_colour_map, + by = colour_tracks_by + ) + + # Add appropriate colour and category labels to m for use when rendering frames + # if (!"colour" %in% colnames(m)) { + i <- match(m[[colour_tracks_by]], colour_map[[colour_tracks_by]]) + + m$colour <- colour_map[[colour_col_name]][i] + m$colour_labels <- colour_map[[colour_tracks_by]][i] + # } + # add some info to m m$time_chr <- as.character(mt_time(m)) m$time <- mt_time(m) From 51b0fdc63ab2b3b86f521b4b0d9a25e26c084d5e Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Wed, 10 Sep 2025 16:13:26 +0200 Subject: [PATCH 06/22] Fix uninitialized column warnings --- R/frames_spatial.R | 2 +- R/internal.R | 4 +--- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index ec74813..0b9c35e 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -322,7 +322,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)) diff --git a/R/internal.R b/R/internal.R index 25e36b8..537f840 100755 --- a/R/internal.R +++ b/R/internal.R @@ -592,7 +592,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p } # 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) } @@ -755,12 +755,10 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) ) # Add appropriate colour and category labels to m for use when rendering frames - # if (!"colour" %in% colnames(m)) { i <- match(m[[colour_tracks_by]], colour_map[[colour_tracks_by]]) m$colour <- colour_map[[colour_col_name]][i] m$colour_labels <- colour_map[[colour_tracks_by]][i] - # } # add some info to m m$time_chr <- as.character(mt_time(m)) From 8c8a200c9950b6d23a776ff0e468d07183d1451e Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Wed, 10 Sep 2025 17:09:30 +0200 Subject: [PATCH 07/22] Can pass palette function to `path_colours` This allows for color scale to dynamically adapt to levels in attribute data --- R/internal.R | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/R/internal.R b/R/internal.R index 537f840..05f6c5e 100755 --- a/R/internal.R +++ b/R/internal.R @@ -719,11 +719,15 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) n_colour_cats <- length(unique(colour_categories)) - # Default colours. Otherwise uses the values provided to `path_colours` - if (!is.character(path_colours)) { - path_colours <- .standard_colours(n_colour_cats) + # Default colour palette. Otherwise get colours from provided `path_colours` + if (!is.character(path_colours) && !is.function(path_colours)) { + path_colours <- function(x) .standard_colours(x) + } + + if (is.function(path_colours)) { + path_colours <- path_colours(n_colour_cats) } else { - # Recycle `path_colours` if only length 1 + # Recycle `path_colours` if length 1 if (length(path_colours) == 1) { path_colours <- rep(path_colours, n_colour_cats) } From 7f7b037e0b96c5a5a67799462ed1b52efb2398df Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 11 Sep 2025 13:38:17 +0200 Subject: [PATCH 08/22] Add support for continuous color palettes in `colour_tracks_by` Uses scales package to simplify color mapping --- DESCRIPTION | 37 +++++++------- R/internal.R | 139 ++++++++++++++++++++++++++++++++------------------- 2 files changed, 107 insertions(+), 69 deletions(-) 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/internal.R b/R/internal.R index 05f6c5e..d28d687 100755 --- a/R/internal.R +++ b/R/internal.R @@ -579,17 +579,33 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p # ggplot(x) + geom_sf(aes(colour = tail_colour, size = tail_size)) + # scale_colour_identity() + scale_size(guide = NULL) + scale_type <- .scale_type(class(x_lines_legend$label)) + # add legend? if(isTRUE(path_legend)){ - 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 = setNames(x_lines_legend$colour, x_lines_legend$label), - name = path_legend_title - ) + - guides(color = guide_legend(order = 1))) - } + if (scale_type == "qualitative") { + 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 = setNames(x_lines_legend$colour, x_lines_legend$label), + name = path_legend_title + ) + + guides(color = guide_legend(order = 1))) + } else { + cont_colours <- unique(colour_map[, c("colour", "label")]) + cont_colours <- cont_colours[order(cont_colours$label), ] + + 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") + + ggplot2::scale_colour_gradientn(colours = cont_colours$colour, limits = range(cont_colours$label), 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]] @@ -714,55 +730,59 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) ) } - # Build mapping from levels of attribute being colored by to color codes - colour_categories <- unique(m[[colour_tracks_by]]) - - n_colour_cats <- length(unique(colour_categories)) - - # Default colour palette. Otherwise get colours from provided `path_colours` - if (!is.character(path_colours) && !is.function(path_colours)) { - path_colours <- function(x) .standard_colours(x) - } + # Identify what type of color scale we're working with. + scale_type <- .scale_type(class(m[[colour_tracks_by]])) - if (is.function(path_colours)) { - path_colours <- path_colours(n_colour_cats) + if (scale_type == "continuous") { + # Default colour palette. Otherwise get colours from provided `path_colours` + if (!is.character(path_colours) && !is.function(path_colours)) { + path_colours <- function(x) grDevices::hcl.colors(x) + } + + if (is.function(path_colours)) { + path_colours <- path_colours(256) + } + + color_scale <- scales::col_numeric(path_colours, domain = range(m[[colour_paths_by]])) } else { - # Recycle `path_colours` if length 1 - if (length(path_colours) == 1) { - path_colours <- rep(path_colours, n_colour_cats) + # Build mapping from levels of attribute being colored by to color codes + colour_categories <- unique(m[[colour_tracks_by]]) + + n_colour_cats <- length(unique(colour_categories)) + + if (!is.character(path_colours) && !is.function(path_colours)) { + path_colours <- function(x) .standard_colours(x) } - if (length(path_colours) != n_colour_cats) { - out( - paste0( - "Number of 'path_colours' (", length(path_colours), ") does not equal", - " the number of levels in '", colour_tracks_by, "' (", - n_colour_cats, ")" - ), - type = 3 - ) + if (is.function(path_colours)) { + path_colours <- path_colours(n_colour_cats) + } else { + # Recycle `path_colours` if length 1 + if (length(path_colours) == 1) { + path_colours <- rep(path_colours, n_colour_cats) + } + + if (length(path_colours) != n_colour_cats) { + out( + paste0( + "Number of 'path_colours' (", length(path_colours), ") does not equal", + " the number of levels in '", colour_tracks_by, "' (", + n_colour_cats, ")" + ), + type = 3 + ) + } + } + + if (is.factor(colour_categories)) { + colour_categories <- droplevels(colour_categories) } + + color_scale <- scales::col_factor(path_colours, domain = colour_categories) } - # Avoid duplicate names if `colour_tracks_by = "colour"` - colour_col_name <- make.unique(c(colour_tracks_by, "colour"))[2] - - attr_colour_map <- setNames( - data.frame(colour_categories, path_colours), - c(colour_tracks_by, colour_col_name) - ) - - colour_map <- merge( - m[union(move2::mt_track_id_column(m), colour_tracks_by)], - attr_colour_map, - by = colour_tracks_by - ) - - # Add appropriate colour and category labels to m for use when rendering frames - i <- match(m[[colour_tracks_by]], colour_map[[colour_tracks_by]]) - - m$colour <- colour_map[[colour_col_name]][i] - m$colour_labels <- colour_map[[colour_tracks_by]][i] + m$colour <- color_scale(m[[colour_paths_by]]) + m$colour_labels <- m[[colour_paths_by]] # add some info to m m$time_chr <- as.character(mt_time(m)) @@ -774,6 +794,23 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) return(m) } +.scale_type <- function(x) { + switch( + x[1], + numeric = "continuous", + integer = "continuous", + Date = "continuous", + POSIXct = "continuous", + POSIXlt = "continuous", + difftime = "continuous", + factor = "qualitative", + ordered = "qualitative", + character = "qualitative", + logical = "qualitative", + "qualitative" + ) +} + #' extract crs params #' @importFrom utils capture.output #' @noRd From d5608ea9d4e6aa3a594db17593deddb8e2c1d94b Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 11 Sep 2025 14:02:45 +0200 Subject: [PATCH 09/22] Use arg name `colour_paths_by` For consistency with `path_colours` --- R/frames_spatial.R | 10 +++++----- R/internal.R | 18 +++++++++--------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 0b9c35e..e0bf2f8 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -192,8 +192,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, colour_tracks_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE, - path_legend = TRUE, path_legend_title = colour_tracks_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){ + 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, 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(...) @@ -285,7 +285,7 @@ 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, colour_tracks_by = colour_tracks_by) + m <- .add_m_attributes(m, path_colours = path_colours, colour_paths_by = colour_paths_by) # print stats .stats(n.frames = max(m$frame)) @@ -346,7 +346,7 @@ frames_spatial <- function( aesthetics = c( list( equidistant = equidistant, - colour_tracks_by = colour_tracks_by, + colour_paths_by = colour_paths_by, path_size = path_size, path_end = path_end, path_join = path_join, @@ -379,4 +379,4 @@ frames_spatial <- function( 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 d28d687..cc0c922 100755 --- a/R/internal.R +++ b/R/internal.R @@ -718,20 +718,20 @@ 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, colour_tracks_by) { +.add_m_attributes <- function(m, path_colours, colour_paths_by) { # If colouring by a track attribute, expand it into the event data frame - if (colour_tracks_by %in% colnames(move2::mt_track_data(m))) { - m <- move2::mt_as_event_attribute(m, !!as.name(colour_tracks_by)) - } else if (!colour_tracks_by %in% colnames(m)) { + if (colour_paths_by %in% colnames(move2::mt_track_data(m))) { + m <- move2::mt_as_event_attribute(m, !!as.name(colour_paths_by)) + } else if (!colour_paths_by %in% colnames(m)) { # If not colouring by a track attribute, the column must be in event data out( - paste0("Column '", colour_tracks_by, "' not found in 'm'"), + paste0("Column '", colour_paths_by, "' not found in 'm'"), type = 3 ) } # Identify what type of color scale we're working with. - scale_type <- .scale_type(class(m[[colour_tracks_by]])) + scale_type <- .scale_type(class(m[[colour_paths_by]])) if (scale_type == "continuous") { # Default colour palette. Otherwise get colours from provided `path_colours` @@ -746,7 +746,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) color_scale <- scales::col_numeric(path_colours, domain = range(m[[colour_paths_by]])) } else { # Build mapping from levels of attribute being colored by to color codes - colour_categories <- unique(m[[colour_tracks_by]]) + colour_categories <- unique(m[[colour_paths_by]]) n_colour_cats <- length(unique(colour_categories)) @@ -766,7 +766,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) out( paste0( "Number of 'path_colours' (", length(path_colours), ") does not equal", - " the number of levels in '", colour_tracks_by, "' (", + " the number of levels in '", colour_paths_by, "' (", n_colour_cats, ")" ), type = 3 @@ -780,7 +780,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) color_scale <- scales::col_factor(path_colours, domain = colour_categories) } - + m$colour <- color_scale(m[[colour_paths_by]]) m$colour_labels <- m[[colour_paths_by]] From 1383bc6b6ebe36f3a2fe0c3a27c0caf1544bf4e6 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Fri, 12 Sep 2025 15:51:50 +0200 Subject: [PATCH 10/22] Allow `color_paths_by` in `frames_graph()` --- R/frames_graph.R | 25 +++- R/frames_spatial.R | 3 +- R/internal.R | 32 ++++- man/frames_graph.Rd | 2 +- man/frames_spatial.Rd | 5 +- man/view_spatial.Rd | 2 +- tests/testthat/test-frames_graph.R | 199 +++++++++++++++++++++++++++++ 7 files changed, 249 insertions(+), 19 deletions(-) diff --git a/R/frames_graph.R b/R/frames_graph.R index e8d5549..d4c020b 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 = NA, 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,12 @@ 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(class(m[[colour_paths_by]])) == "continuous") { + out("Cannot color by continuous variables in `frames_graph()`", type = 3) + } + ## create data.frame from m with frame time and colour - m <- .add_m_attributes(m, path_colours = path_colours) + m <- .add_m_attributes(m, path_colours = path_colours, colour_paths_by = colour_paths_by) .stats(max(m$frame)) ## create raster list @@ -172,18 +175,26 @@ 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){ + if (is.null(m[["colour_labels"]])) { + m$colour_labels <- m$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(m[m[["colour_labels"]] == name,]$colour)) })) + if (is.factor(m$colour_labels)) { + dummy$name <- factor(dummy$name, levels = levels(m$colour_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_labels), function(name){ + y <- x[x$colour_labels == name,] z <- table(round(y$value, digits = val_digits)) d.name <- d[d$name == name,] diff --git a/R/frames_spatial.R b/R/frames_spatial.R index e0bf2f8..0bcd076 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -15,7 +15,7 @@ #' @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_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, whether 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 logical, whether to add a path legend from \code{m} or not. When coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character). #' @param path_legend_title character, path legend title. Default is \code{"Names"}. #' @param tail_length numeric, length of tail per movement path. #' @param tail_size numeric, size of the last tail element. Default is 1. @@ -346,7 +346,6 @@ frames_spatial <- function( aesthetics = c( list( equidistant = equidistant, - colour_paths_by = colour_paths_by, path_size = path_size, path_end = path_end, path_join = path_join, diff --git a/R/internal.R b/R/internal.R index cc0c922..b593cd6 100755 --- a/R/internal.R +++ b/R/internal.R @@ -624,15 +624,24 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p 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)){ - colour_pos <- sapply(as.character(unique(y$name)), function(x) match(x, y$name)[1] ) + 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 = names(colour_pos), colour = as.character(y$colour[colour_pos]), stringsAsFactors = F) - l.df$name <- factor(l.df$name, levels = l.df$name) + + # Ensure legend mapping is in factor order if input data are factor + if (is.factor(y$colour_labels)) { + l.df$name <- factor(l.df$name, levels = levels(y$colour_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 = setNames(as.character(l.df$colour), as.character(l.df$name)), name = path_legend_title) #linetype = NA) } return(p) @@ -654,11 +663,22 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p 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 = names(colour_pos), + colour = as.character(y$colour[colour_pos]), stringsAsFactors = F) + + # Ensure legend mapping is in factor order if input data are factor + if (is.factor(y$colour_labels)) { + l.df$name <- factor(l.df$name, levels = levels(y$colour_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 = setNames(as.character(l.df$colour), as.character(l.df$name)), name = path_legend_title) #linetype = NA } diff --git a/man/frames_graph.Rd b/man/frames_graph.Rd index a43a524..d862e6d 100644 --- a/man/frames_graph.Rd +++ b/man/frames_graph.Rd @@ -46,7 +46,7 @@ frames_graph( \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_legend}{logical, whether 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 coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd index 8b5eaeb..26fa60e 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -26,10 +26,11 @@ frames_spatial( path_mitre = 10, path_arrow = NULL, path_colours = NA, + colour_tracks_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE, path_legend = TRUE, - path_legend_title = "Names", + path_legend_title = colour_tracks_by, tail_length = 19, tail_size = 1, tail_colour = "white", @@ -90,7 +91,7 @@ so that baesmap tiles that had been already downloaded by moveVis do not have to \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, whether 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 coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/man/view_spatial.Rd b/man/view_spatial.Rd index 2d823cc..d9b8ca5 100644 --- a/man/view_spatial.Rd +++ b/man/view_spatial.Rd @@ -26,7 +26,7 @@ view_spatial( \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_legend}{logical, whether 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 coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} \item{path_legend_title}{character, path legend title. Default is \code{"Names"}.} diff --git a/tests/testthat/test-frames_graph.R b/tests/testthat/test-frames_graph.R index c2dae5b..0fa8ece 100755 --- a/tests/testthat/test-frames_graph.R +++ b/tests/testthat/test-frames_graph.R @@ -115,3 +115,202 @@ test_that("frames_graph maps correct colours to tracks (hist)", { expect_equal(pal[["T342g"]], "#65A7C9") expect_equal(pal[["T932u"]], "#461A6B") }) + +test_that("frames_graph can color by track attributes", { + m.aligned <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) + + fr <- frames_graph( + m.aligned, + 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.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + fr <- frames_graph( + m.aligned, + 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.aligned[["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.aligned <- move2::mutate_track_data( + m.aligned, + var = factor(c("A", "A", "B"), levels = c("B", "A")) + ) + + # User specified color vector + fr <- frames_graph( + m.aligned, + 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")) + + # Bad arguments + expect_error( + frames_graph( + m.aligned, + r_grad, + colour_paths_by = "var", + verbose = FALSE, + path_colours = c("#F2A08F", "#65A7C9", "#461A6B") + ), + paste0( + "Number of 'path_colours' \\(3\\) does not equal the number of levels", + " in 'var' \\(2\\)" + ) + ) +}) + +test_that("path_colours accepts palette function", { + m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + pal <- function(x) grDevices::hcl.colors(x, palette = "viridis") + + fr <- frames_graph( + m.aligned, + 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.aligned))) + expect_equal(cols, pal(3)) + + # Palette adjusts to number of levels in coloring variable + fr <- frames_graph( + m.aligned, + 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.aligned[["var"]])) + expect_equal(cols, pal(length(unique(m.aligned[["var"]])))) +}) + +test_that("Coloring by attributes orders correctly for factor vs. character", { + m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + fr1 <- frames_graph( + m.aligned, + 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.aligned[["var"]] <- factor(m.aligned[["var"]], levels = c("B", "A")) + + fr2 <- frames_graph( + m.aligned, + 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.aligned[["var"]] <- 1:nrow(m.aligned) + + expect_error( + frames_graph( + m.aligned, + r_grad, + verbose = FALSE, + colour_paths_by = "var" + ), + "Cannot color by continuous variables" + ) +}) + +test_that("Legend title uses attribute variable", { + m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + fr <- frames_graph( + m.aligned, + r_grad, + verbose = FALSE, + map_res = 0.1, + colour_paths_by = "var" + ) + + built <- ggplot2::ggplot_build(fr[[50]]) + gt <- ggplot2::ggplot_gtable(built) + + # 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( + gt$grobs[[15]]$grobs[[1]]$grobs[[7]]$children[[1]]$label, + "var" + ) +}) + From 1546f0bfeaf0fc7516cbfde3287846213a0c741f Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 16 Sep 2025 12:03:56 +0200 Subject: [PATCH 11/22] Prevent overwrite of event attributes --- R/internal.R | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/R/internal.R b/R/internal.R index b593cd6..d7a4e08 100755 --- a/R/internal.R +++ b/R/internal.R @@ -740,9 +740,12 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) #' @noRd .add_m_attributes <- function(m, path_colours, colour_paths_by) { # If colouring by a track attribute, expand it into the event data frame - if (colour_paths_by %in% colnames(move2::mt_track_data(m))) { + is_track_attr <- colour_paths_by %in% colnames(move2::mt_track_data(m)) + is_event_attr <- colour_paths_by %in% colnames(m) + + if (is_track_attr && !is_event_attr) { m <- move2::mt_as_event_attribute(m, !!as.name(colour_paths_by)) - } else if (!colour_paths_by %in% colnames(m)) { + } else if (!is_event_attr) { # If not colouring by a track attribute, the column must be in event data out( paste0("Column '", colour_paths_by, "' not found in 'm'"), From a07f3eeea42544dbc54f248fa20be560e0f867d9 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 16 Sep 2025 12:06:05 +0200 Subject: [PATCH 12/22] frames_spatial() unit tests --- tests/testthat/test-frames_spatial.R | 231 ++++++++++++++++++++++++++- 1 file changed, 226 insertions(+), 5 deletions(-) diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index db62e8a..4783b17 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -29,15 +29,13 @@ test_that("frames_spatial maps correct colours to tracks", { map_res = 0.1, path_colours = c("#F2A08F", "#65A7C9", "#461A6B") ) - - built <- ggplot2::ggplot_build(fr[[50]]) - + 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") @@ -139,4 +137,227 @@ 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.aligned <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) + + fr <- frames_spatial( + m.aligned, + 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.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + # Default + fr <- frames_spatial( + m.aligned, + 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.aligned[["var"]])) + expect_equal(cols, .standard_colours(2)) + + expect_error( + frames_spatial(m.aligned, colour_paths_by = "foo"), + "Column 'foo' not found" + ) +}) + +test_that("User can provide `path_colours` when colouring by attribute", { + m.aligned <- move2::mutate_track_data(m.aligned, var = factor(c("A", "A", "B"), levels = c("B", "A"))) + + # User specified color vector + fr <- frames_spatial( + m.aligned, + 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")) + + # Bad arguments + expect_error( + frames_spatial( + m.aligned, + colour_paths_by = "var", + path_colours = c("#F2A08F", "#65A7C9", "#461A6B") + ), + paste0( + "Number of 'path_colours' \\(3\\) does not equal the number of levels", + " in 'var' \\(2\\)" + ) + ) +}) + +test_that("path_colours accepts palette function", { + m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + pal <- function(x) grDevices::hcl.colors(x, palette = "viridis") + + fr <- frames_spatial( + m.aligned, + 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.aligned))) + expect_equal(cols, pal(3)) + + # Palette adjusts to number of levels in coloring variable + fr <- frames_spatial( + m.aligned, + 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.aligned[["var"]])) + expect_equal(cols, pal(length(unique(m.aligned[["var"]])))) +}) + +test_that("Coloring by attributes orders correctly for factor vs. character", { + m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + + fr1 <- frames_spatial( + m.aligned, + 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.aligned[["var"]] <- factor(m.aligned[["var"]], levels = c("B", "A")) + + fr2 <- frames_spatial( + m.aligned, + 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") +}) + +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) + + # 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( + gt$grobs[[15]]$grobs[[1]]$grobs[[7]]$children[[1]]$label, + "var" + ) + +}) From 4fbb57f90ef795f8010aefa4d3480fb1defbc725 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 16 Sep 2025 14:56:36 +0200 Subject: [PATCH 13/22] Add `colour_paths_by` to `view_spatial()` --- R/view_spatial.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/R/view_spatial.R b/R/view_spatial.R index a75ce26..ee92b83 100644 --- a/R/view_spatial.R +++ b/R/view_spatial.R @@ -37,8 +37,8 @@ #' @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 = NA, 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)){ @@ -55,7 +55,7 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = if(!is.character(path_legend_title)) out("Argument 'path_legend_title' must be of type 'character'.", type = 3) ## preprocess movement data - m <- .add_m_attributes(m, path_colours = path_colours) + m <- .add_m_attributes(m, path_colours = path_colours, colour_paths_by = colour_paths_by) ## render as mapview object if(render_as == "mapview"){ @@ -63,7 +63,7 @@ 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), label = if(isTRUE(time_labels)) mt_time(m) else NULL, stroke = stroke From aee0033a84c080e378fd6c8e0768796a58915923 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 16 Sep 2025 15:50:02 +0200 Subject: [PATCH 14/22] Update docs Have not updated anything currently listed as out-of-date --- R/frames_spatial.R | 33 ++++++++++++++++++++------------- man/frames_graph.Rd | 13 ++++++++----- man/frames_spatial.Rd | 36 ++++++++++++++++++++++-------------- man/view_spatial.Rd | 11 +++++++---- vignettes/example-1.Rmd | 5 ++++- 5 files changed, 61 insertions(+), 37 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 0bcd076..2c4603c 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, whether to add a path legend from \code{m} or not. When coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character). -#' @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")) #' diff --git a/man/frames_graph.Rd b/man/frames_graph.Rd index d862e6d..7be35cf 100644 --- a/man/frames_graph.Rd +++ b/man/frames_graph.Rd @@ -14,8 +14,9 @@ frames_graph( graph_type = "flow", path_size = 1, path_colours = NA, + 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, whether to add a path legend from \code{m} or not. When coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} +\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 26fa60e..ba6141d 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -26,11 +26,11 @@ frames_spatial( path_mitre = 10, path_arrow = NULL, path_colours = NA, - colour_tracks_by = move2::mt_track_id_column(m), + colour_paths_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE, path_legend = TRUE, - path_legend_title = colour_tracks_by, + path_legend_title = colour_paths_by, tail_length = 19, tail_size = 1, tail_colour = "white", @@ -43,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).} @@ -85,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, whether to add a path legend from \code{m} or not. When coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} +\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.} @@ -126,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. @@ -206,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 d9b8ca5..0298cf2 100644 --- a/man/view_spatial.Rd +++ b/man/view_spatial.Rd @@ -10,8 +10,9 @@ view_spatial( time_labels = TRUE, stroke = TRUE, path_colours = NA, + colour_paths_by = move2::mt_track_id_column(m), path_legend = TRUE, - path_legend_title = "Names", + path_legend_title = colour_paths_by, verbose = TRUE ) } @@ -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, whether to add a path legend from \code{m} or not. When coloring tracks by a qualitative variable, legend entries will be ordered by the levels of that variable (if a factor) or alphabetically (if a character).} +\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).} } 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: From bbdb7545687411b860354b5c9c18a4ddaf25d1b9 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 2 Oct 2025 13:14:02 +0200 Subject: [PATCH 15/22] Add scale support for int64 int64 common in move2 objects --- R/internal.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/internal.R b/R/internal.R index d7a4e08..923aaa1 100755 --- a/R/internal.R +++ b/R/internal.R @@ -822,6 +822,7 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) x[1], numeric = "continuous", integer = "continuous", + integer64 = "continuous", Date = "continuous", POSIXct = "continuous", POSIXlt = "continuous", From f2976161695da85c8a20011b9a9794b0e74100a4 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 2 Oct 2025 13:14:22 +0200 Subject: [PATCH 16/22] Ensure numeric limits for gradient scale --- R/internal.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/internal.R b/R/internal.R index 923aaa1..fd55dc9 100755 --- a/R/internal.R +++ b/R/internal.R @@ -601,7 +601,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, 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") + - ggplot2::scale_colour_gradientn(colours = cont_colours$colour, limits = range(cont_colours$label), name = path_legend_title) + + ggplot2::scale_colour_gradientn(colours = cont_colours$colour, limits = range(as.numeric(cont_colours$label)), name = path_legend_title) + guides(color = ggplot2::guide_colourbar(order = 1)) ) } From a46c2f935ff4258c4a3d53f15ac5b60e87d1d70c Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 2 Oct 2025 16:07:44 +0200 Subject: [PATCH 17/22] Use palette function for legend mapping Makes legend mapping more robust and reduces skew in continuous legends --- R/frames_graph.R | 17 ++- R/frames_spatial.R | 16 ++- R/internal.R | 157 +++++++++++++++------------ R/render_frame.R | 9 +- R/view_spatial.R | 75 +++++++++---- man/frames_graph.Rd | 2 +- man/frames_spatial.Rd | 2 +- man/view_spatial.Rd | 8 +- tests/testthat/test-frames_graph.R | 64 +++++------ tests/testthat/test-frames_spatial.R | 55 ++++------ tests/testthat/test-view_spatial.R | 147 ++++++++++++++++++++++++- 11 files changed, 377 insertions(+), 175 deletions(-) diff --git a/R/frames_graph.R b/R/frames_graph.R index d4c020b..b352661 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, colour_paths_by = move2::mt_track_id_column(m), path_legend = TRUE, path_legend_title = colour_paths_by, +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 @@ -137,12 +137,20 @@ 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(class(m[[colour_paths_by]])) == "continuous") { + 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]]) + m$colour_labels <- m[[colour_paths_by]] + ## create data.frame from m with frame time and colour - m <- .add_m_attributes(m, path_colours = path_colours, colour_paths_by = colour_paths_by) + m <- .add_m_attributes(m) .stats(max(m$frame)) ## create raster list @@ -224,7 +232,8 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra path_legend_title = path_legend_title, val_seq = val_seq, r_type = r_type), - additions = NULL + additions = NULL, + palette = pal ) attr(frames, "class") <- c("moveVis", "frames_graph") diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 2c4603c..7a130f3 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -199,7 +199,7 @@ 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, colour_paths_by = move2::mt_track_id_column(m), path_alpha = 1, path_fade = FALSE, + 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) @@ -292,7 +292,16 @@ 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, colour_paths_by = 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]]) # Can be removed? + m$colour_labels <- m[[colour_paths_by]] + + m <- .add_m_attributes(m) # print stats .stats(n.frames = max(m$frame)) @@ -380,7 +389,8 @@ frames_spatial <- function( maxColorValue = if(!is.null(extras$maxColorValue)) extras$maxColorValue else NA, interpolate = if(!is.null(extras$interpolate)) extras$interpolate else FALSE ), - additions = NULL + additions = NULL, + palette = pal ) attr(frames, "class") <- c("moveVis", "frames_spatial") diff --git a/R/internal.R b/R/internal.R index fd55dc9..66ca693 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, m_labels, 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, m_labels, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length, palette){ # lines: sements x_lines <- do.call(rbind, lapply(unique(m_names), function(.name){ @@ -563,7 +563,6 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p })) x_lines_legend$name <- colour_map$name x_lines_legend$label <- colour_map$label - x_lines_legend$colour <- colour_map$colour # scale plot to ext and set na.rm to TRUE to avoid warnings y$layers[[1]]$geom_params$na.rm <- T @@ -579,29 +578,29 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p # ggplot(x) + geom_sf(aes(colour = tail_colour, size = tail_size)) + # scale_colour_identity() + scale_size(guide = NULL) - scale_type <- .scale_type(class(x_lines_legend$label)) + scale_type <- .scale_type(x_lines_legend$label) # add legend? if(isTRUE(path_legend)){ if (scale_type == "qualitative") { - 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 = setNames(x_lines_legend$colour, x_lines_legend$label), - name = path_legend_title - ) + - guides(color = guide_legend(order = 1))) + 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 = palette(length(unique(x_lines_legend$label))), + name = path_legend_title + ) + + guides(color = guide_legend(order = 1)) + ) } else { - cont_colours <- unique(colour_map[, c("colour", "label")]) - cont_colours <- cont_colours[order(cont_colours$label), ] - 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") + - ggplot2::scale_colour_gradientn(colours = cont_colours$colour, limits = range(as.numeric(cont_colours$label)), name = path_legend_title) + + ggplot2::scale_colour_gradientn(colours = palette(256), limits = range(as.numeric(x_lines_legend$label)), name = path_legend_title) + guides(color = ggplot2::guide_colourbar(order = 1)) ) } @@ -617,7 +616,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p #' @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, palette){ ## 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) + @@ -641,7 +640,8 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p } 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 = setNames(as.character(l.df$colour), as.character(l.df$name)), 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 = palette(length(unique(l.df$colour))), name = path_legend_title) #linetype = NA) } return(p) @@ -654,7 +654,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p #' #' @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, palette){ ## 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) @@ -680,7 +680,8 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p } 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 = setNames(as.character(l.df$colour), as.character(l.df$name)), 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 = palette(length(unique(l.df$colour))), name = path_legend_title) #linetype = NA } return(p) } @@ -738,88 +739,108 @@ 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, colour_paths_by) { +.add_m_attributes <- function(m) { + # add some info to m + m$time_chr <- as.character(mt_time(m)) + m$time <- mt_time(m) + m$frame <- sapply(mt_time(m), function(x) which(sort(unique(mt_time(m))) == x)) + + m <- m[order(m$frame),] + m$name <- mt_track_id(m) + 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 <- colour_paths_by %in% colnames(move2::mt_track_data(m)) - is_event_attr <- colour_paths_by %in% colnames(m) + 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(colour_paths_by)) + 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 '", colour_paths_by, "' not found in 'm'"), + 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(class(m[[colour_paths_by]])) + scale_type <- .scale_type(x) if (scale_type == "continuous") { - # Default colour palette. Otherwise get colours from provided `path_colours` - if (!is.character(path_colours) && !is.function(path_colours)) { - path_colours <- function(x) grDevices::hcl.colors(x) + if (is.null(path_colours)) { + path_colours <- function(x) grDevices::hcl.colors(x, "viridis") } - if (is.function(path_colours)) { - path_colours <- path_colours(256) + if (is.character(path_colours)) { + pal <- grDevices::colorRampPalette(path_colours) + } else { + pal <- path_colours } - - color_scale <- scales::col_numeric(path_colours, domain = range(m[[colour_paths_by]])) } else { - # Build mapping from levels of attribute being colored by to color codes - colour_categories <- unique(m[[colour_paths_by]]) - - n_colour_cats <- length(unique(colour_categories)) - - if (!is.character(path_colours) && !is.function(path_colours)) { + if (is.null(path_colours)) { path_colours <- function(x) .standard_colours(x) } - if (is.function(path_colours)) { - path_colours <- path_colours(n_colour_cats) - } else { - # Recycle `path_colours` if length 1 - if (length(path_colours) == 1) { - path_colours <- rep(path_colours, n_colour_cats) - } - - if (length(path_colours) != n_colour_cats) { - out( - paste0( - "Number of 'path_colours' (", length(path_colours), ") does not equal", - " the number of levels in '", colour_paths_by, "' (", - n_colour_cats, ")" - ), - type = 3 - ) + 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(path_colours, domain = colour_categories) + color_scale <- scales::col_factor( + palette(n_colour_cats), + domain = colour_categories + ) } - - m$colour <- color_scale(m[[colour_paths_by]]) - m$colour_labels <- m[[colour_paths_by]] - - # add some info to m - m$time_chr <- as.character(mt_time(m)) - m$time <- mt_time(m) - m$frame <- sapply(mt_time(m), function(x) which(sort(unique(mt_time(m))) == x)) - m <- m[order(m$frame),] - m$name <- mt_track_id(m) - return(m) + color_scale } .scale_type <- function(x) { + if ("units" %in% class(x)) { + x <- units::drop_units(x) + } + switch( - x[1], + class(x)[1], numeric = "continuous", integer = "continuous", integer64 = "continuous", diff --git a/R/render_frame.R b/R/render_frame.R index 4987ef5..0dbc628 100644 --- a/R/render_frame.R +++ b/R/render_frame.R @@ -74,7 +74,8 @@ 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, + palette = frames$palette ) } if(inherits(frames, "frames_graph")){ @@ -85,7 +86,8 @@ 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, + palette = frames$palette ) } if(frames$graph_type == "hist"){ @@ -96,7 +98,8 @@ 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, + palette = frames$palette ) } } diff --git a/R/view_spatial.R b/R/view_spatial.R index ee92b83..e816343 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,32 @@ #' @importFrom sf st_coordinates #' @export -view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = TRUE, path_colours = NA, colour_paths_by = move2::mt_track_id_column(m), path_legend = 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) + 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]]) + m$colour_labels <- m[[colour_paths_by]] + ## preprocess movement data - m <- .add_m_attributes(m, path_colours = path_colours, colour_paths_by = colour_paths_by) + m <- .add_m_attributes(m) ## render as mapview object if(render_as == "mapview"){ @@ -65,7 +69,7 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = map <- mapview::mapview( 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 +78,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 7be35cf..7e337a0 100644 --- a/man/frames_graph.Rd +++ b/man/frames_graph.Rd @@ -13,7 +13,7 @@ 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 = colour_paths_by, diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd index ba6141d..99dd00d 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -25,7 +25,7 @@ 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, diff --git a/man/view_spatial.Rd b/man/view_spatial.Rd index 0298cf2..b9736c8 100644 --- a/man/view_spatial.Rd +++ b/man/view_spatial.Rd @@ -9,7 +9,7 @@ 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 = colour_paths_by, @@ -17,7 +17,7 @@ view_spatial( ) } \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.} @@ -41,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/test-frames_graph.R b/tests/testthat/test-frames_graph.R index 0fa8ece..3c68407 100755 --- a/tests/testthat/test-frames_graph.R +++ b/tests/testthat/test-frames_graph.R @@ -117,10 +117,10 @@ test_that("frames_graph maps correct colours to tracks (hist)", { }) test_that("frames_graph can color by track attributes", { - m.aligned <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) + m <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) fr <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -137,10 +137,11 @@ test_that("frames_graph can color by track attributes", { }) test_that("frames_graph can color by event attributes", { - m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") fr <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -152,7 +153,7 @@ test_that("frames_graph can color by event attributes", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, unique(m.aligned[["var"]])) + expect_equal(lims, unique(m[["var"]])) expect_equal(cols, .standard_colours(2)) expect_error( @@ -162,14 +163,14 @@ test_that("frames_graph can color by event attributes", { }) test_that("User can provide `path_colours` when colouring by attribute", { - m.aligned <- move2::mutate_track_data( + 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.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -185,30 +186,16 @@ test_that("User can provide `path_colours` when colouring by attribute", { expect_equal(lims, c("B", "A")) expect_equal(cols, c("#F2A08F", "#65A7C9")) - - # Bad arguments - expect_error( - frames_graph( - m.aligned, - r_grad, - colour_paths_by = "var", - verbose = FALSE, - path_colours = c("#F2A08F", "#65A7C9", "#461A6B") - ), - paste0( - "Number of 'path_colours' \\(3\\) does not equal the number of levels", - " in 'var' \\(2\\)" - ) - ) }) test_that("path_colours accepts palette function", { - m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") pal <- function(x) grDevices::hcl.colors(x, palette = "viridis") fr <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -220,12 +207,12 @@ test_that("path_colours accepts palette function", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, levels(move2::mt_track_id(m.aligned))) + 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.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -238,15 +225,16 @@ test_that("path_colours accepts palette function", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, unique(m.aligned[["var"]])) - expect_equal(cols, pal(length(unique(m.aligned[["var"]])))) + 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.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") fr1 <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -258,10 +246,10 @@ test_that("Coloring by attributes orders correctly for factor vs. character", { lims1 <- sc1$get_limits() cols1 <- sc1$map(lims1) - m.aligned[["var"]] <- factor(m.aligned[["var"]], levels = c("B", "A")) + m[["var"]] <- factor(m[["var"]], levels = c("B", "A")) fr2 <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -278,11 +266,12 @@ test_that("Coloring by attributes orders correctly for factor vs. character", { }) test_that("Error when coloring by continuous attribute", { - m.aligned[["var"]] <- 1:nrow(m.aligned) + m <- m.aligned + m[["var"]] <- 1:nrow(m) expect_error( frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, colour_paths_by = "var" @@ -292,10 +281,11 @@ test_that("Error when coloring by continuous attribute", { }) test_that("Legend title uses attribute variable", { - m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") fr <- frames_graph( - m.aligned, + m, r_grad, verbose = FALSE, map_res = 0.1, @@ -303,7 +293,7 @@ test_that("Legend title uses attribute variable", { ) built <- ggplot2::ggplot_build(fr[[50]]) - gt <- ggplot2::ggplot_gtable(built) + gt <- ggplot2::ggplot_gtable(built) # This isn't super robust, but difficult to fully automate checking # the ggplot2 internals. In the future a snapshot test would likely be diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 4783b17..9ea75ae 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -140,10 +140,10 @@ test_that("frames_spatial (cross_dateline)", { }) test_that("frames_spatial can color by track attributes", { - m.aligned <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) + m <- move2::mutate_track_data(m.aligned, var = c("A", "A", "B")) fr <- frames_spatial( - m.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "var" @@ -159,11 +159,12 @@ test_that("frames_spatial can color by track attributes", { }) test_that("frames_spatial can color by event attributes", { - m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") # Default fr <- frames_spatial( - m.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "var" @@ -174,21 +175,24 @@ test_that("frames_spatial can color by event attributes", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, unique(m.aligned[["var"]])) + expect_equal(lims, unique(m[["var"]])) expect_equal(cols, .standard_colours(2)) expect_error( - frames_spatial(m.aligned, colour_paths_by = "foo"), + 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.aligned <- move2::mutate_track_data(m.aligned, var = factor(c("A", "A", "B"), levels = c("B", "A"))) + 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.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "var", @@ -202,28 +206,16 @@ test_that("User can provide `path_colours` when colouring by attribute", { expect_equal(lims, c("B", "A")) expect_equal(cols, c("#F2A08F", "#65A7C9")) - - # Bad arguments - expect_error( - frames_spatial( - m.aligned, - colour_paths_by = "var", - path_colours = c("#F2A08F", "#65A7C9", "#461A6B") - ), - paste0( - "Number of 'path_colours' \\(3\\) does not equal the number of levels", - " in 'var' \\(2\\)" - ) - ) }) test_that("path_colours accepts palette function", { - m.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") pal <- function(x) grDevices::hcl.colors(x, palette = "viridis") fr <- frames_spatial( - m.aligned, + m, verbose = FALSE, map_res = 0.1, path_colours = pal @@ -234,12 +226,12 @@ test_that("path_colours accepts palette function", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, levels(move2::mt_track_id(m.aligned))) + 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.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "var", @@ -251,15 +243,16 @@ test_that("path_colours accepts palette function", { lims <- sc$get_limits() cols <- sc$map(lims) - expect_equal(lims, unique(m.aligned[["var"]])) - expect_equal(cols, pal(length(unique(m.aligned[["var"]])))) + 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.aligned[["var"]] <- ifelse(m.aligned[["track"]] == "T246a", "A", "B") + m <- m.aligned + m[["var"]] <- ifelse(m[["track"]] == "T246a", "A", "B") fr1 <- frames_spatial( - m.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "var" @@ -270,10 +263,10 @@ test_that("Coloring by attributes orders correctly for factor vs. character", { lims1 <- sc1$get_limits() cols1 <- sc1$map(lims1) - m.aligned[["var"]] <- factor(m.aligned[["var"]], levels = c("B", "A")) + m[["var"]] <- factor(m[["var"]], levels = c("B", "A")) fr2 <- frames_spatial( - m.aligned, + m, verbose = FALSE, map_res = 0.1, colour_paths_by = "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 From 40ae6c79511f9353c8a8a036ad8a087208336a12 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 14 Oct 2025 15:50:53 +0200 Subject: [PATCH 18/22] Update tests for ggplot2 4.0.0 --- tests/testthat/test-frames_graph.R | 8 ++++---- tests/testthat/test-frames_spatial.R | 11 +++++------ 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/tests/testthat/test-frames_graph.R b/tests/testthat/test-frames_graph.R index 3c68407..07599b2 100755 --- a/tests/testthat/test-frames_graph.R +++ b/tests/testthat/test-frames_graph.R @@ -295,12 +295,12 @@ test_that("Legend title uses attribute variable", { 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( - gt$grobs[[15]]$grobs[[1]]$grobs[[7]]$children[[1]]$label, - "var" - ) + 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 9ea75ae..74b8252 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -343,14 +343,13 @@ test_that("Legend title uses attribute variable", { ) built <- ggplot2::ggplot_build(fr[[50]]) - gt <- ggplot2::ggplot_gtable(built) + 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( - gt$grobs[[15]]$grobs[[1]]$grobs[[7]]$children[[1]]$label, - "var" - ) - + expect_equal(grobs[[i]]$children[[1]]$label, "var") }) From d561f8e0b7634b39ff4289409630d0fcd5caafd5 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Mon, 3 Nov 2025 09:57:19 +0100 Subject: [PATCH 19/22] Remove units before applying color scale --- R/frames_spatial.R | 2 ++ R/internal.R | 11 +++++++++++ R/view_spatial.R | 2 ++ tests/testthat/test-frames_spatial.R | 14 ++++++++++++++ 4 files changed, 29 insertions(+) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 7a130f3..46c3a03 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -293,6 +293,8 @@ frames_spatial <- function( # m$colour <- repl_vals(as.character(mt_track_id(m)), unique(as.character(mt_track_id(m))), path_colours[1:mt_n_tracks(m)]) # } + # 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) diff --git a/R/internal.R b/R/internal.R index 66ca693..dc21d35 100755 --- a/R/internal.R +++ b/R/internal.R @@ -856,6 +856,17 @@ which.minpos <- function(x) min(which(min(x[x > 0]) == x)) ) } +.drop_units_safe <- function(x) { + x <- tryCatch( + units::drop_units(x), + error = function(cnd) { + x + } + ) + + x +} + #' extract crs params #' @importFrom utils capture.output #' @noRd diff --git a/R/view_spatial.R b/R/view_spatial.R index e816343..561c95e 100644 --- a/R/view_spatial.R +++ b/R/view_spatial.R @@ -50,6 +50,8 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = 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) diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 74b8252..2e25637 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -330,6 +330,20 @@ test_that("Can color by continuous attribute", { 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", { From 517ff7a65d41badc27a979d54e56d73c5f06fb02 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 4 Nov 2025 13:41:26 +0100 Subject: [PATCH 20/22] Avoid building unused categorical legend for continuous vars Speeds up animations that color by continuous vars --- R/internal.R | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/R/internal.R b/R/internal.R index dc21d35..ebed05e 100755 --- a/R/internal.R +++ b/R/internal.R @@ -554,16 +554,6 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p m_labels <- m_names } - # lines: full - colour_map <- unique(data.frame(name = m_names, colour = m_colour, label = m_labels)) - - x_lines_legend <- do.call(rbind, lapply(colour_map$label, function(.name){ - coords <- st_coordinates(x) - st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x))) - })) - x_lines_legend$name <- colour_map$name - x_lines_legend$label <- colour_map$label - # scale plot to ext and set na.rm to TRUE to avoid warnings y$layers[[1]]$geom_params$na.rm <- T @@ -578,29 +568,44 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p # ggplot(x) + geom_sf(aes(colour = tail_colour, size = tail_size)) + # scale_colour_identity() + scale_size(guide = NULL) - scale_type <- .scale_type(x_lines_legend$label) - # add legend? if(isTRUE(path_legend)){ + scale_type <- .scale_type(m_labels) + if (scale_type == "qualitative") { + colour_map <- unique(data.frame(name = m_names, colour = m_colour, label = m_labels)) + + x_lines_legend <- do.call(rbind, lapply(colour_map$label, function(.name){ + coords <- st_coordinates(x) + st_sf(geometry = st_sfc(st_linestring(coords), crs = st_crs(x))) + })) + x_lines_legend$name <- colour_map$name + x_lines_legend$label <- colour_map$label + p <- quiet( p + new_scale_colour() + - geom_sf(data = x_lines_legend, aes(colour = .data$label, linetype = NA), linewidth = path_size, na.rm = TRUE) + + 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 = palette(length(unique(x_lines_legend$label))), + values = palette(length(unique(m_labels))), 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() + - geom_sf(data = x_lines_legend, aes(colour = .data$label, linetype = NA), linewidth = path_size, na.rm = TRUE) + + 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 = palette(256), limits = range(as.numeric(x_lines_legend$label)), name = path_legend_title) + + ggplot2::scale_colour_gradientn(colours = palette(256), limits = range(as.numeric(m_labels)), name = path_legend_title) + guides(color = ggplot2::guide_colourbar(order = 1)) ) } From 060d0a80689dcb78fc2511a5ed816d92c2c63f5b Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Wed, 19 Nov 2025 15:59:22 +0100 Subject: [PATCH 21/22] Generate complete legend even for subset of frames --- R/frames_graph.R | 31 ++++++++++++++++++------------- R/frames_spatial.R | 22 ++++++++++++++++------ R/internal.R | 43 ++++++++++++++++++------------------------- R/render_frame.R | 10 ++++++---- R/view_spatial.R | 6 +----- 5 files changed, 59 insertions(+), 53 deletions(-) diff --git a/R/frames_graph.R b/R/frames_graph.R index b352661..71783c0 100644 --- a/R/frames_graph.R +++ b/R/frames_graph.R @@ -147,7 +147,14 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra scale <- .build_scale(m[[colour_paths_by]], pal) m$colour <- scale(m[[colour_paths_by]]) - m$colour_labels <- 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) @@ -183,17 +190,13 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra hist_data <- NULL if(graph_type == "hist"){ - if (is.null(m[["colour_labels"]])) { - m$colour_labels <- m$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[["colour_labels"]] == name,]$colour)) + colour = unique(legend_colours[legend_labels == name])) })) - if (is.factor(m$colour_labels)) { - dummy$name <- factor(dummy$name, levels = levels(m$colour_labels)) + if (is.factor(legend_labels)) { + dummy$name <- factor(dummy$name, levels = levels(legend_labels)) } ## Calculating time-cumulative value histogram per individual and timestep @@ -201,8 +204,8 @@ frames_graph <- function(m, r, r_type = "gradient", fade_raster = FALSE, crop_ra 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$colour_labels), function(name){ - y <- x[x$colour_labels == 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,] @@ -231,9 +234,11 @@ 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), - additions = NULL, - palette = pal + 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 46c3a03..128675e 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -300,8 +300,17 @@ frames_spatial <- function( pal <- .build_pal(m[[colour_paths_by]], path_colours) scale <- .build_scale(m[[colour_paths_by]], pal) - m$colour <- scale(m[[colour_paths_by]]) # Can be removed? - m$colour_labels <- m[[colour_paths_by]] + 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) @@ -355,7 +364,7 @@ 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, @@ -384,15 +393,16 @@ frames_spatial <- function( map_type = map_type, r_type = r_type, fade_raster = fade_raster, - n_r = n_r + 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 ), - additions = NULL, - palette = pal + additions = NULL ) attr(frames, "class") <- c("moveVis", "frames_spatial") diff --git a/R/internal.R b/R/internal.R index ebed05e..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, m_labels, path_end, path_join, path_mitre, path_arrow, path_alpha, path_legend, path_legend_title, path_size, equidistant, tail_length, palette){ +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,10 +550,6 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p } else NULL })) - if (is.null(m_labels)) { - m_labels <- m_names - } - # scale plot to ext and set na.rm to TRUE to avoid warnings y$layers[[1]]$geom_params$na.rm <- T @@ -570,17 +566,14 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p # add legend? if(isTRUE(path_legend)){ - scale_type <- .scale_type(m_labels) + scale_type <- .scale_type(legend_labels) if (scale_type == "qualitative") { - colour_map <- unique(data.frame(name = m_names, colour = m_colour, label = m_labels)) - - x_lines_legend <- do.call(rbind, lapply(colour_map$label, function(.name){ + 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$name <- colour_map$name - x_lines_legend$label <- colour_map$label + x_lines_legend$label <- legend_labels p <- quiet( p + @@ -588,7 +581,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p 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 = palette(length(unique(m_labels))), + values = legend_colours, name = path_legend_title ) + guides(color = guide_legend(order = 1)) @@ -605,7 +598,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p aes(x = x, y = y, colour = .data$label) ) + scale_linetype(guide = "none") + - ggplot2::scale_colour_gradientn(colours = palette(256), limits = range(as.numeric(m_labels)), name = path_legend_title) + + ggplot2::scale_colour_gradientn(colours = legend_colours, limits = range(as.numeric(legend_labels)), name = path_legend_title) + guides(color = ggplot2::guide_colourbar(order = 1)) ) } @@ -621,7 +614,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p #' @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, palette){ +.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) + @@ -636,17 +629,17 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p if(isTRUE(path_legend)){ 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 = names(colour_pos), - colour = as.character(y$colour[colour_pos]), stringsAsFactors = F) + 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(y$colour_labels)) { - l.df$name <- factor(l.df$name, levels = levels(y$colour_labels)) + 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 = palette(length(unique(l.df$colour))), name = path_legend_title) #linetype = NA) + scale_colour_manual(values = legend_colours, name = path_legend_title) #linetype = NA) } return(p) @@ -659,7 +652,7 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p #' #' @noRd ## stats plot function -.gg_hist <- function(x, y, path_legend, path_legend_title, path_size, val_seq, r_type, palette){ +.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) @@ -676,17 +669,17 @@ gg.spatial <- function(x, y, m_names, m_colour, m_labels, path_end, path_join, p if(isTRUE(path_legend)){ 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 = names(colour_pos), - colour = as.character(y$colour[colour_pos]), stringsAsFactors = F) + 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(y$colour_labels)) { - l.df$name <- factor(l.df$name, levels = levels(y$colour_labels)) + 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 = palette(length(unique(l.df$colour))), name = path_legend_title) #linetype = NA + scale_colour_manual(values = legend_colours, name = path_legend_title) #linetype = NA } return(p) } diff --git a/R/render_frame.R b/R/render_frame.R index 0dbc628..59c46c1 100644 --- a/R/render_frame.R +++ b/R/render_frame.R @@ -64,7 +64,6 @@ render_frame <- function(frames, i = length(frames)){ add_coord = FALSE), m_names = frames$m$name, m_colour = frames$m$colour, - m_labels = frames$m$colour_labels, path_end = frames$aesthetics$path_end, path_join = frames$aesthetics$path_join, path_mitre = frames$aesthetics$path_mitre, @@ -75,7 +74,8 @@ render_frame <- function(frames, i = length(frames)){ path_size = frames$aesthetics$path_size, equidistant = frames$aesthetics$equidistant, tail_length = frames$aesthetics$tail_length, - palette = frames$palette + legend_labels = frames$aesthetics$legend_labels, + legend_colours = frames$aesthetics$legend_colours ) } if(inherits(frames, "frames_graph")){ @@ -87,7 +87,8 @@ 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, - palette = frames$palette + legend_labels = frames$aesthetics$legend_labels, + legend_colours = frames$aesthetics$legend_colours ) } if(frames$graph_type == "hist"){ @@ -99,7 +100,8 @@ render_frame <- function(frames, i = length(frames)){ path_size = frames$aesthetics$path_size, val_seq = frames$aesthetics$val_seq, r_type = frames$aesthetics$r_type, - palette = frames$palette + 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 561c95e..1b21145 100644 --- a/R/view_spatial.R +++ b/R/view_spatial.R @@ -55,11 +55,7 @@ view_spatial <- function(m, render_as = "mapview", time_labels = TRUE, stroke = 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]]) - m$colour_labels <- m[[colour_paths_by]] - + ## preprocess movement data m <- .add_m_attributes(m) From 51dd8ac8c825ead45119766034aa8daf7e1a00c0 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 20 Nov 2025 12:19:07 +0100 Subject: [PATCH 22/22] avoid graphics device initiation in tests --- tests/testthat/setup.R | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 tests/testthat/setup.R 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