From 4ebbd33e408127cf2c6994d7404a0cad74505329 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Tue, 14 Oct 2025 16:19:06 +0200 Subject: [PATCH 1/3] Fixes #139; use normalized distance interpolation --- R/align_move.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/align_move.R b/R/align_move.R index b4ee79e..403d85c 100644 --- a/R/align_move.R +++ b/R/align_move.R @@ -147,7 +147,7 @@ align_move <- function(m, res = "minimum", start_end_time = NULL, fill_na_values if(all(st_is_longlat(m), sf_use_s2())){ m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_as_sf(s2_interpolate_normalized(st_geometry(.m), .nd)), SIMPLIFY = T) } else{ - m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_line_interpolate(st_geometry(.m), .nd), SIMPLIFY = T) + m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_line_interpolate(st_geometry(.m), .nd, normalized = TRUE), SIMPLIFY = T) } # assemble sf object From 16e14c3545afb08bc4f9763b45a72392edc24889 Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Wed, 15 Oct 2025 11:58:18 +0200 Subject: [PATCH 2/3] Fixes #141; coerce interpolated points to sf --- R/align_move.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/align_move.R b/R/align_move.R index 403d85c..0e51b57 100644 --- a/R/align_move.R +++ b/R/align_move.R @@ -147,7 +147,7 @@ align_move <- function(m, res = "minimum", start_end_time = NULL, fill_na_values if(all(st_is_longlat(m), sf_use_s2())){ m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_as_sf(s2_interpolate_normalized(st_geometry(.m), .nd)), SIMPLIFY = T) } else{ - m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_line_interpolate(st_geometry(.m), .nd, normalized = TRUE), SIMPLIFY = T) + m_aligned <- mapply(.m = m_sf_lines, .nd = nd, function(.m, .nd) st_as_sf(st_line_interpolate(st_geometry(.m), .nd, normalized = TRUE)), SIMPLIFY = T) } # assemble sf object From 2a53c0f0270cfc7d410b2f1d595cd89319eaac1e Mon Sep 17 00:00:00 2001 From: Finn Roberts Date: Thu, 16 Oct 2025 14:40:23 +0200 Subject: [PATCH 3/3] Fixes #142; crop frames to ext when in nonstandard CRS --- R/frames_spatial.R | 6 +- R/internal.R | 108 +++++++++++++-------------- man/frames_spatial.Rd | 4 +- tests/testthat/test-frames_spatial.R | 58 ++++++++++++++ 4 files changed, 116 insertions(+), 60 deletions(-) diff --git a/R/frames_spatial.R b/R/frames_spatial.R index 2fc032e..dbde6a5 100644 --- a/R/frames_spatial.R +++ b/R/frames_spatial.R @@ -25,7 +25,7 @@ #' @param trace_colour character, colour of the trace. Default is "white". It is recommended to define the same colours for both \code{trace_colour} and \code{tail_colour} to enforce an uninterrupted colour transition form the tail to the trace. #' @param cross_dateline logical, whether tracks are crossing the dateline (longitude 180/-180) or not. If \code{TRUE}, frames are expanded towards the side of the dateline that is smaller in space. Applies only if the CRS of \code{m} is not projected (geographical, lon/lat). If \code{FALSE} (default), frames are clipped at the minimum and maximum longitudes and tracks cannot cross. #' @param margin_factor numeric, factor relative to the extent of \code{m} by which the frame extent should be increased around the movement area. Ignored, if \code{ext} is set. -#' @param equidistant logical, whether to make the map extent equidistant (squared) with y and x axis measuring equal distances or not. Especially in polar regions of the globe it might be necessaray to set \code{equidistant} to \code{FALSE} to avoid strong stretches. By default (\code{equidistant = NULL}), equidistant is set automatically to \code{FALSE}, if \code{ext} is set, otherwise \code{TRUE}. Read more in the details. +#' @param equidistant logical, whether to make the map extent equidistant (squared) with y and x axis measuring equal distances or not. Especially in polar regions of the globe it might be necessaray to set \code{equidistant} to \code{FALSE} to avoid strong stretches. By default (\code{equidistant = TRUE}). If \code{ext} is set, this argument will always be \code{FALSE}. Read more in the details. #' @param ext \code{sf bbox} in same CRS as \code{m}, optional. If set, frames are cropped to this extent. If not set, the extent is computed from \code{m}, optionally with a margin set by \code{margin_factor}. #' @param crs \code{sf crs} object. This is the CRS that is used for visualizing both movement and map data. Defaults to \code{st_crs(3857)} (Web Mercator), unless \code{r} is defined. In that case, \code{st_crs(r)} is used. #' @param crs_graticule \code{sf crs} object. This is the CRS that should be used to generate graticules. By default, geographic coordinates (Lon/Lat WGS84, EPSG:4326) is used. @@ -192,7 +192,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, path_alpha = 1, path_fade = FALSE, + margin_factor = 1.1, equidistant = TRUE, 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){ if(inherits(verbose, "logical")) options(moveVis.verbose = verbose) @@ -272,7 +272,7 @@ 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.null(ext)) equidistant <- FALSE if(!is.logical(equidistant)) out("Argument 'equidistant' must be of type 'logical'.", type = 3) # check m time conformities diff --git a/R/internal.R b/R/internal.R index f8e7bcc..4af0761 100755 --- a/R/internal.R +++ b/R/internal.R @@ -152,76 +152,74 @@ repl_vals <- function(data, x, y){ return(st_bbox(.st_transform(st_as_sfc(ext.ll.sq, crs = st_crs(4326)), st_crs(ext)))) } +#' This calculates an extent for an input move2 object and provides it in +#' a desired output CRS. +#' +#' If a custom extent is provided to `ext`, all scaling arguments are ignored, +#' as we assume the custom extent itself is the desired output bbox. +#' #' generate ext, return as latlon #' @importFrom sf st_as_sf st_transform st_crs st_bbox st_as_sfc st_intersects st_coordinates #' @noRd -.ext <- function(m, crs, ext = NULL, margin_factor = 1.1, equidistant = FALSE, cross_dateline = NULL, return_latlon = FALSE){ - - m_ll <- st_as_sf(m, coords=c("x", "y"), crs = crs, remove = F) - m_ll <- st_transform(m_ll, st_crs(4326)) - - ## calculate ext - gg.ext <- st_bbox(m_ll) - - if(!is.null(ext)){ - ext <- st_bbox(st_transform(ext, st_crs(m_ll))) - #ext <- st_bbox(st_transform(st_as_sfc(st_bbox(ext, crs = crs)), st_crs(4326))) +.ext <- function(m, crs, ext = NULL, margin_factor = 1.1, equidistant = FALSE) { + # m may not be in same CRS as crs, but st_as_sf uses m's CRS if crs is inconsistent + m <- st_as_sf(m, coords = c("x", "y"), crs = crs, remove = F) + + # If no user-provided ext, calculate from m bbox, using margin_factor/equidistant + if (is.null(ext)) { + gg.ext <- st_bbox(st_transform(m, st_crs(4326))) + + xy.diff <- (gg.ext[3:4] - gg.ext[1:2])/2 + + # equidistant currently not supported for cross_dateline + if(isTRUE(equidistant)){ + gg.ext <- .equidistant(ext = gg.ext, margin_factor = margin_factor) + }else{ + gg.ext <- st_bbox( + c( + gg.ext[1:2] - (xy.diff*(-1+margin_factor)), + gg.ext[3:4] + (xy.diff*(-1+margin_factor)) + ), + crs = st_crs(gg.ext) + ) + } + } else { + # Otherwise, just need to ensure user provided ext overlaps data ext + stopifnot(inherits(ext, "bbox")) - if(!quiet(st_intersects(st_as_sfc(ext), st_as_sfc(gg.ext), sparse = F)[1,1])) out("Argument 'ext' does not overlap with the extent of 'm'.", type = 3) - margin_factor <- 1 # no margin since user extent set gg.ext <- ext + + has_intersection <- quiet( + st_intersects( + st_transform(st_as_sfc(gg.ext), st_crs(m)), + st_as_sfc(st_bbox(m)), + sparse = F + ) + ) + + if(!has_intersection[1,1]) { + out("Argument 'ext' does not overlap with the extent of 'm'.", type = 3) + } } - # xy.diff <- if(isTRUE(cross_dateline)){ - # xy <- st_coordinates(m) - # c(abs(abs(max(xy[xy[,1] < 0, 1])) - min(xy[xy[,1] > 0,1])), gg.ext[4]-gg.ext[2])/2 - # }else (gg.ext[3:4] - gg.ext[1:2])/2 - xy.diff <- (gg.ext[3:4] - gg.ext[1:2])/2 - - # squared equidistant extent or not - # if(isTRUE(cross_dateline)){ - # - # # split extents for both dateline sides - # gg.ext <- list("west" = gg.ext, "east" = gg.ext) - # - # # cut extents and add margins to x components - # gg.ext$west[[1]] <- -180 #xmin - # gg.ext$west[[3]] <- max(xy[xy[,1] < 0,1]) + xy.diff[1]*(-1+margin_factor) #xmax - # gg.ext$east[[1]] <- min(xy[xy[,1] > 0,1]) - xy.diff[1]*(-1+margin_factor) #xmin - # gg.ext$east[[3]] <- 180 #xmax - # - # # add margins to y components - # gg.ext$west[[2]] <- gg.ext$west[[2]] - xy.diff[2]*(-1+margin_factor) #ymin - # gg.ext$west[[4]] <- gg.ext$west[[4]] + xy.diff[2]*(-1+margin_factor) #ymax - # gg.ext$east[[2]] <- gg.ext$east[[2]] - xy.diff[2]*(-1+margin_factor) #ymin - # gg.ext$east[[4]] <- gg.ext$east[[4]] + xy.diff[2]*(-1+margin_factor) #ymax - # - # } else{ - - # equidistant currently not supported for cross_dateline - if(isTRUE(equidistant)){ - gg.ext <- .equidistant(ext = gg.ext, margin_factor = margin_factor) - }else{ - gg.ext <- st_bbox(c(gg.ext[1:2] - (xy.diff*(-1+margin_factor)), gg.ext[3:4] + (xy.diff*(-1+margin_factor))), crs = st_crs(gg.ext)) + # Transform gg.ext to desired output crs + transform_ext <- function(y, crs) st_bbox(st_transform(st_as_sfc(y), crs)) + + if(inherits(gg.ext, "list")){ + gg.ext <- lapply(gg.ext, function(y) transform_ext(y, crs)) + } else{ + gg.ext <- transform_ext(gg.ext, crs) } - # cut by longlat maximums - if(isTRUE(st_crs(m) == st_crs(4326))){ + # cut by longlat maximums if gg.ext is in 4326 + if(isTRUE(crs == st_crs(4326))){ if(gg.ext[1] < -180) gg.ext[1] <- -180 if(gg.ext[3] > 180) gg.ext[3] <- 180 if(gg.ext[2] < -90) gg.ext[2] <- -90 if(gg.ext[4] > 90) gg.ext[4] <- 90 } - if(isFALSE(return_latlon)){ - transform_ext <- function(y) st_bbox(st_transform(st_as_sfc(y), crs)) - if(inherits(gg.ext, "list")){ - gg.ext <- lapply(gg.ext, transform_ext) - } else{ - gg.ext <- transform_ext(gg.ext) - } - } - return(gg.ext) + gg.ext } #' calculate x labels from breaks diff --git a/man/frames_spatial.Rd b/man/frames_spatial.Rd index 933cb21..7f4b769 100644 --- a/man/frames_spatial.Rd +++ b/man/frames_spatial.Rd @@ -16,7 +16,7 @@ frames_spatial( map_token = NULL, map_dir = NULL, margin_factor = 1.1, - equidistant = NULL, + equidistant = TRUE, ext = NULL, crs = if (is.null(r)) st_crs(3857) else st_crs(terra::crs(r)), crs_graticule = st_crs(4326), @@ -66,7 +66,7 @@ so that baesmap tiles that had been already downloaded by moveVis do not have to \item{margin_factor}{numeric, factor relative to the extent of \code{m} by which the frame extent should be increased around the movement area. Ignored, if \code{ext} is set.} -\item{equidistant}{logical, whether to make the map extent equidistant (squared) with y and x axis measuring equal distances or not. Especially in polar regions of the globe it might be necessaray to set \code{equidistant} to \code{FALSE} to avoid strong stretches. By default (\code{equidistant = NULL}), equidistant is set automatically to \code{FALSE}, if \code{ext} is set, otherwise \code{TRUE}. Read more in the details.} +\item{equidistant}{logical, whether to make the map extent equidistant (squared) with y and x axis measuring equal distances or not. Especially in polar regions of the globe it might be necessaray to set \code{equidistant} to \code{FALSE} to avoid strong stretches. By default (\code{equidistant = TRUE}). If \code{ext} is set, this argument will always be \code{FALSE}. Read more in the details.} \item{ext}{\code{sf bbox} in same CRS as \code{m}, optional. If set, frames are cropped to this extent. If not set, the extent is computed from \code{m}, optionally with a margin set by \code{margin_factor}.} diff --git a/tests/testthat/test-frames_spatial.R b/tests/testthat/test-frames_spatial.R index 61bacc8..6a5e458 100644 --- a/tests/testthat/test-frames_spatial.R +++ b/tests/testthat/test-frames_spatial.R @@ -109,6 +109,64 @@ test_that("frames_spatial (different extent/proj settings)", { }) +test_that("Correctly handle custom extent selection", { + m_bbox <- st_bbox(m.aligned) + m_crs <- st_crs(m.aligned) + + # If no adjustments, .ext() should equal bbox + expect_identical( + .ext(m.aligned, m_crs, margin_factor = 1, equidistant = FALSE), + m_bbox + ) + + # If no scaling, .ext() should equal the bbox when transformed to same CRS + expect_identical( + .ext(m.aligned, crs = "epsg:4326", margin_factor = 1, equidistant = FALSE), + st_transform(m_bbox, "epsg:4326") + ) + + expect_identical( + .ext(m.aligned, crs = "epsg:32637", margin_factor = 1, equidistant = FALSE), + st_transform(m_bbox, "epsg:32637") + ) + + # with ext, .ext() should equal the ext + my_ext <- st_bbox(c(xmin = 8.4, ymin = 47, xmax = 10, ymax = 48), crs = m_crs) + + expect_identical( + .ext(m, crs = m_crs, ext = my_ext), + my_ext + ) + + expect_identical( + .ext(m.aligned, crs = st_crs("epsg:32637"), ext = my_ext), + st_transform(my_ext, st_crs("epsg:32637")) + ) + + # scale args ignored when extent is provided + expect_identical( + .ext(m.aligned, m_crs, ext = my_ext, margin_factor = 2, equidistant = TRUE), + .ext(m.aligned, m_crs, ext = my_ext, margin_factor = 0.4, equidistant = FALSE) + ) + + # Can correctly handle extent when provided in different crs of input data + ext <- sf::st_set_crs( + sf::st_bbox(c(xmin = -1740000, ymin = 5740000, xmax = -1736000, ymax = 5747000)), + sf::st_crs("epsg:32637") + ) + + fr <- frames_spatial( + m.aligned, + ext = ext, + crs = sf::st_crs("epsg:32637"), + crs_graticule = sf::st_crs("epsg:32637"), + verbose = FALSE + ) + + expect_equal(fr$aesthetics$gg.ext, ext) + expect_equal(fr$crs, sf::st_crs("epsg:32637")) +}) + test_that("frames_spatial (cross_dateline)", { frames <- expect_warning(expect_length(expect_is(frames_spatial(m = m.shifted, map_service = "carto", map_type = "light",