|
| 1 | +#' @name coord-trans |
| 2 | +#' @title Coordinate transformations |
| 3 | +#' |
| 4 | +#' @aliases ct_translate ct_scale ct_rotate |
| 5 | +#' |
| 6 | +#' @param x \code{SpatialData} element. |
| 7 | +#' @param t transformation data. |
| 8 | +#' @param ... ignored. |
| 9 | +#' |
| 10 | +#' @return Object of same type as input. |
| 11 | +#' |
| 12 | +#' @examples |
| 13 | +#' pa <- file.path("extdata", "blobs.zarr") |
| 14 | +#' pa <- system.file(pa, package="SpatialData") |
| 15 | +#' sd <- readSpatialData(pa) |
| 16 | +#' gg <- sd_plot() |
| 17 | +#' |
| 18 | +#' # point |
| 19 | +#' |
| 20 | +#' x <- sd@points[[1]] |
| 21 | +#' sd@points$a <- ct_translate(x, c(-10, 10)) |
| 22 | +#' sd@points$b <- ct_scale(x, c(0.5, 1.2)) |
| 23 | +#' sd@points$c <- ct_rotate(x, 5) |
| 24 | +#' |
| 25 | +#' gg + |
| 26 | +#' sd_plot_point(sd, 1, col=1) + |
| 27 | +#' sd_plot_point(sd, "a", col=2) + |
| 28 | +#' sd_plot_point(sd, "b", col=3) + |
| 29 | +#' sd_plot_point(sd, "c", col=4) |
| 30 | +#' |
| 31 | +#' # shape |
| 32 | +#' |
| 33 | +#' x <- sd@shapes[[2]] |
| 34 | +#' sd@shapes$a <- ct_translate(x, c(-10, 10)) |
| 35 | +#' sd@shapes$b <- ct_scale(x, c(0.5, 1.2)) |
| 36 | +#' sd@shapes$c <- ct_rotate(x, 5) |
| 37 | +#' |
| 38 | +#' gg + |
| 39 | +#' sd_plot_shape(sd, 2, col=1) + |
| 40 | +#' sd_plot_shape(sd, "a", col=2) + |
| 41 | +#' sd_plot_shape(sd, "b", col=3) + |
| 42 | +#' sd_plot_shape(sd, "c", col=4) |
| 43 | +NULL |
| 44 | + |
| 45 | +# translate ---- |
| 46 | + |
| 47 | +#' @rdname coord-trans |
| 48 | +#' @export |
| 49 | +ct_translate <- new_generic("ct_translate", "x") |
| 50 | + |
| 51 | +method(ct_translate, PointFrame) <- \(x, t) { |
| 52 | + y <- NULL # R CMD check |
| 53 | + x@data <- x@data |> |
| 54 | + mutate(x=x+t[1]) |> |
| 55 | + mutate(y=y+t[2]) |
| 56 | + return(x) |
| 57 | +} |
| 58 | + |
| 59 | +#' @importFrom sfarrow read_sf_dataset |
| 60 | +method(ct_translate, ShapeFrame) <- \(x, t) { |
| 61 | + x@data <- read_sf_dataset(x@data) |
| 62 | + x@data$geometry <- x@data$geometry+t |
| 63 | + return(x) |
| 64 | +} |
| 65 | + |
| 66 | +# scale ---- |
| 67 | + |
| 68 | +#' @rdname coord-trans |
| 69 | +#' @export |
| 70 | +ct_scale <- new_generic("ct_scale", "x") |
| 71 | + |
| 72 | +#' @importFrom dplyr mutate |
| 73 | +method(ct_scale, PointFrame) <- \(x, t) { |
| 74 | + y <- NULL # R CMD check |
| 75 | + x@data <- x@data |> |
| 76 | + mutate(x=x*t[1]) |> |
| 77 | + mutate(y=y*t[2]) |
| 78 | + return(x) |
| 79 | +} |
| 80 | + |
| 81 | +# NOTE: this shifts the origin if it's not (0,0); |
| 82 | +# could fix, but unclear what's expected. |
| 83 | +#' @importFrom sfarrow read_sf_dataset |
| 84 | +method(ct_scale, ShapeFrame) <- \(x, t) { |
| 85 | + x@data <- read_sf_dataset(x@data) |
| 86 | + x@data$geometry <- x@data$geometry*t(t) |
| 87 | + return(x) |
| 88 | +} |
| 89 | + |
| 90 | +# rotate ---- |
| 91 | + |
| 92 | +#' @rdname coord-trans |
| 93 | +#' @export |
| 94 | +ct_rotate <- new_generic("ct_rotate", "x") |
| 95 | + |
| 96 | +# rotation matrix to rotate points |
| 97 | +# counter-clockwise through an angle 't' |
| 98 | +.R <- \(t) matrix(c(cos(t), -sin(t), sin(t), cos(t)), 2, 2) |
| 99 | + |
| 100 | +#' @importFrom dplyr mutate select |
| 101 | +method(ct_rotate, PointFrame) <- \(x, t) { |
| 102 | + y <- .y <- .x <- NULL # R CMD check |
| 103 | + R <- .R(t*pi/180) |
| 104 | + x@data <- x@data |> |
| 105 | + mutate(.x=x*R[1,1], .y=y*R[1,2]) |> |
| 106 | + mutate(x=.x+.y) |> |
| 107 | + mutate(.x=x*R[2,1], .y=y*R[2,2]) |> |
| 108 | + mutate(y=.x+.y) |> |
| 109 | + select(-.x, -.y) |
| 110 | + return(x) |
| 111 | +} |
| 112 | + |
| 113 | +#' @importFrom sfarrow read_sf_dataset |
| 114 | +method(ct_rotate, ShapeFrame) <- \(x, t) { |
| 115 | + R <- .R(t*pi/180) |
| 116 | + x@data <- read_sf_dataset(x@data) |
| 117 | + x@data$geometry <- x@data$geometry * R |
| 118 | + return(x) |
| 119 | +} |
0 commit comments