Fixes for projected CRS alignment

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_as_sf(st_line_interpolate(st_geometry(.m), .nd, normalized = TRUE)), SIMPLIFY = T)
   }
 
   # assemble sf object

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

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

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",