|
1 | | -# take a "tidy" sf data frame and "expand it" so every row represents a point |
2 | | -# rather than geometry/geometries |
3 | | -expand <- function(data) { |
4 | | - xs <- lapply(data$geometry, get_x) |
5 | | - ys <- lapply(data$geometry, get_y) |
6 | | - ns <- lapply(data$geometry, get_l) |
7 | | - ids <- lapply(ns, function(x) rep(seq_len(length(x)), x)) |
8 | | - dats <- Map(function(x, y, z, w) { |
9 | | - data.frame(x, y, group = paste(z, w, sep = "-"), `.plotlyMergeID` = w, stringsAsFactors = FALSE) |
10 | | - }, xs, ys, ids, seq_along(data$geometry)) |
11 | | - # merge this "expanded" geometry data back with original data |
12 | | - ids <- seq_len(nrow(data)) |
13 | | - data[[".plotlyMergeID"]] <- ids |
14 | | - data[["group"]] <- NULL |
15 | | - dplyr::left_join(dplyr::bind_rows(dats), data, by = ".plotlyMergeID") |
| 1 | +fortify_sf <- function(model, ...) { |
| 2 | + # TODO: |
| 3 | + # (1) avoid converting redundant features |
| 4 | + # (2) warn/error if data already contains x/y |
| 5 | + geoms <- sf::st_geometry(sf::st_as_sf(model)) |
| 6 | + xy <- lapply(geoms, st_as_plotly) |
| 7 | + ids <- rep(seq_len(nrow(model)), sapply(xy, nrow)) |
| 8 | + # TODO: faster way to row bind matrices? |
| 9 | + xy_all <- cbind(do.call(rbind, xy), ids) |
| 10 | + xy_dat <- setNames(as.data.frame(xy_all), c("x", "y", sf_key())) |
| 11 | + |
| 12 | + d <- as.data.frame(model) |
| 13 | + d$geometry <- NULL |
| 14 | + d[[sf_key()]] <- seq_len(nrow(d)) |
| 15 | + xy_dat <- dplyr::left_join(xy_dat, d, by = sf_key()) |
| 16 | + xy_dat[[sf_key()]] <- NULL |
| 17 | + xy_dat |
16 | 18 | } |
17 | 19 |
|
18 | | -# ------------------------------------------------------------------ |
19 | | -# these helper functions are adapted from methods(st_as_grob) |
20 | | -# see, for example, getS3method("st_as_grob", "MULTIPOLYGON") |
21 | | -# ------------------------------------------------------------------ |
| 20 | +sf_key <- function() ".sf-group-id" |
22 | 21 |
|
23 | | -#' Obtain x coordinates of sf geometry/geometries |
24 | | -#' |
25 | | -#' Exported for internal reasons. Not intended for general use. |
26 | | -#' |
27 | | -#' @param g an sf geometry |
28 | | -#' @export |
29 | | -get_x <- function(g) { |
30 | | - UseMethod("get_x") |
31 | | -} |
32 | | - |
33 | | -#' Obtain y coordinates of sf geometry/geometries |
34 | | -#' |
35 | | -#' Exported for internal reasons. Not intended for general use. |
36 | | -#' |
37 | | -#' @param g an sf geometry |
38 | | -#' @export |
39 | | -get_y <- function(g) { |
40 | | - UseMethod("get_y") |
41 | | -} |
42 | | - |
43 | | -#' Obtain number of points comprising a geometry |
44 | | -#' |
45 | | -#' Exported for internal reasons. Not intended for general use. |
46 | | -#' |
47 | | -#' @param g an sf geometry |
48 | | -#' @export |
49 | | -get_l <- function(g) { |
50 | | - UseMethod("get_l") |
51 | | -} |
52 | | - |
53 | | -#' @export |
54 | | -get_x.MULTIPOLYGON <- function(g) { |
55 | | - unlist(sapply(g, function(v) sapply(v, function(z) z[, 1]))) |
56 | | -} |
57 | | - |
58 | | -#' @export |
59 | | -get_y.MULTIPOLYGON <- function(g) { |
60 | | - unlist(sapply(g, function(v) sapply(v, function(z) z[, 2]))) |
61 | | -} |
62 | | - |
63 | | -#' @export |
64 | | -get_l.MULTIPOLYGON <- function(g) { |
65 | | - unlist(sapply(g, function(v) sapply(v, nrow))) |
66 | | -} |
67 | | - |
68 | | -#' @export |
69 | | -get_x.POLYGON <- function(g) { |
70 | | - unlist(sapply(g, function(y) y[, 1])) |
71 | | -} |
72 | | - |
73 | | -#' @export |
74 | | -get_y.POLYGON <- function(g) { |
75 | | - unlist(sapply(g, function(y) y[, 2])) |
| 22 | +# kind of like sf_as_grob(), but maps to a plotly data structure, rather than a grob |
| 23 | +st_as_plotly <- function(x, ...) { |
| 24 | + UseMethod("st_as_plotly") |
76 | 25 | } |
77 | 26 |
|
78 | 27 | #' @export |
79 | | -get_l.POLYGON <- function(g) { |
80 | | - sapply(g, nrow) |
| 28 | +st_as_plotly.POINT = function(x, ...) { |
| 29 | + matrix(c(x[1], x[2]), ncol = 2) |
81 | 30 | } |
82 | 31 |
|
83 | 32 | #' @export |
84 | | -get_x.MULTILINESTRING <- function(g) { |
85 | | - unlist(sapply(g, function(y) y[, 1])) |
| 33 | +st_as_plotly.MULTIPOINT = function(x, ...) { |
| 34 | + if (nrow(x) == 0) return(empty_xy()) |
| 35 | + matrix(c(x[, 1], x[, 2]), ncol = 2) |
86 | 36 | } |
87 | 37 |
|
88 | 38 | #' @export |
89 | | -get_y.MULTILINESTRING <- function(g) { |
90 | | - unlist(sapply(g, function(y) y[, 2])) |
| 39 | +st_as_plotly.LINESTRING = function(x, ...) { |
| 40 | + if (nrow(x) == 0) return(empty_xy()) |
| 41 | + matrix(c(x[, 1], x[, 2]), ncol = 2) |
91 | 42 | } |
92 | 43 |
|
93 | 44 | #' @export |
94 | | -get_l.MULTILINESTRING <- function(g) { |
95 | | - sapply(g, nrow) |
| 45 | +st_as_plotly.CIRCULARSTRING = function(x, y, ...) { |
| 46 | + st_as_plotly(st_cast(x, "LINESTRING"), ...) |
96 | 47 | } |
97 | 48 |
|
98 | 49 | #' @export |
99 | | -get_x.LINESTRING <- function(g) { |
100 | | - g[, 1] |
| 50 | +st_as_plotly.MULTILINESTRING = function(x, ...) { |
| 51 | + if (length(x) == 0) return(empty_xy()) |
| 52 | + xvals <- unlist(rbind(sapply(x, function(y) y[,1]), NA)) |
| 53 | + yvals <- unlist(rbind(sapply(x, function(y) y[,2]), NA)) |
| 54 | + matrix(c(xvals, yvals), ncol = 2) |
101 | 55 | } |
102 | 56 |
|
103 | 57 | #' @export |
104 | | -get_y.LINESTRING <- function(g) { |
105 | | - g[, 2] |
| 58 | +st_as_plotly.POLYGON = function(x, ..., rule = "evenodd") { |
| 59 | + if (length(x) == 0) return(empty_xy()) |
| 60 | + xvals <- unlist(rbind(sapply(x, function(y) y[,1]), NA)) |
| 61 | + yvals <- unlist(rbind(sapply(x, function(y) y[,2]), NA)) |
| 62 | + matrix(c(xvals, yvals), ncol = 2) |
106 | 63 | } |
107 | 64 |
|
108 | 65 | #' @export |
109 | | -get_l.LINESTRING <- function(g) { |
110 | | - nrow(g) |
| 66 | +st_as_plotly.MULTIPOLYGON = function(x, ..., rule = "evenodd") { |
| 67 | + if (length(x) == 0) return(empty_xy()) |
| 68 | + xvals <- unlist(sapply(x, function(y) rbind(sapply(y, function(z) z[,1]), NA))) |
| 69 | + yvals <- unlist(sapply(x, function(y) rbind(sapply(y, function(z) z[,2]), NA))) |
| 70 | + matrix(c(xvals, yvals), ncol = 2) |
111 | 71 | } |
112 | 72 |
|
113 | 73 | #' @export |
114 | | -get_x.MULTIPOINT <- function(g) { |
115 | | - g[, 1] |
| 74 | +st_as_plotly.GEOMETRYCOLLECTION = function(x, ...) { |
| 75 | + if (length(x) == 0) return(empty_xy()) |
| 76 | + lapply(x, st_as_plotly) |
116 | 77 | } |
117 | 78 |
|
118 | 79 | #' @export |
119 | | -get_y.MULTIPOINT <- function(g) { |
120 | | - g[, 2] |
121 | | -} |
| 80 | +st_as_plotly.MULTISURFACE = st_as_plotly.GEOMETRYCOLLECTION |
122 | 81 |
|
123 | 82 | #' @export |
124 | | -get_l.MULTIPOINT <- function(g) { |
125 | | - nrow(g) |
126 | | -} |
| 83 | +st_as_plotly.CURVEPOLYGON = st_as_plotly.GEOMETRYCOLLECTION |
127 | 84 |
|
128 | 85 | #' @export |
129 | | -get_x.POINT <- function(g) { |
130 | | - g[1] |
131 | | -} |
| 86 | +st_as_plotly.COMPOUNDCURVE = st_as_plotly.GEOMETRYCOLLECTION |
132 | 87 |
|
133 | | -#' @export |
134 | | -get_y.POINT <- function(g) { |
135 | | - g[2] |
136 | | -} |
137 | 88 |
|
138 | | -#' @export |
139 | | -get_l.POINT <- function(g) { |
140 | | - nrow(g) |
| 89 | +empty_xy <- function() { |
| 90 | + matrix(rep(NA, 2), ncol = 2) |
141 | 91 | } |
0 commit comments