Skip to content

Commit bd20ce9

Browse files
cpsievertcpsievert
committed
a half-baked attempt at sf conversion logic that looks more like st_as_grob
1 parent 5e4da51 commit bd20ce9

File tree

2 files changed

+66
-114
lines changed

2 files changed

+66
-114
lines changed

‎R/layers2traces.R

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
111111
separator <- new_id()
112112
fac <- factor(
113113
apply(d[split_vars], 1, paste, collapse = separator),
114-
levels = apply(lvls, 1, paste, collapse = separator)
114+
levels = unique(apply(lvls, 1, paste, collapse = separator))
115115
)
116116
if (all(is.na(fac))) fac <- 1
117117
dl <- split(d, fac, drop = TRUE)
@@ -273,16 +273,25 @@ to_basic.GeomRect <- function(data, prestats_data, layout, params, p, ...) {
273273
#' @export
274274
to_basic.GeomSf <- function(data, prestats_data, layout, params, p, ...) {
275275

276-
data <- expand(data)
276+
browser()
277+
sf_data <- sf::st_as_sf(data)
278+
sf_d <- lapply(1:nrow(data), function(i) {
279+
sf_as_plotly(sf_data[i, , drop = FALSE])
280+
})
281+
282+
sf_as_plotly()
283+
284+
# logic based on GeomSf$draw_panel
285+
#p$coord$transform(data, layout$panel_params[[1]])
277286

278-
# logic based on GeomSf$draw_key
279287
geomBasic <- switch(
280288
params$legend %||% "",
281289
point = "GeomPoint",
282290
line = "GeomPath",
283291
"GeomPolygon"
284292
)
285293

294+
286295
# determine the type of simple feature for each row
287296
# recode the simple feature with the type of geometry used to render it
288297
prefix_class(data, c("GeomSf", geomBasic))
@@ -498,7 +507,7 @@ to_basic.GeomSpoke <- function(data, prestats_data, layout, params, p, ...) {
498507
#' @export
499508
to_basic.GeomCrossbar <- function(data, prestats_data, layout, params, p, ...) {
500509
# from GeomCrossbar$draw_panel()
501-
middle <- transform(data, x = xmin, xend = xmax, yend = y, size = size * params$fatten, alpha = NA)
510+
middle <- base::transform(data, x = xmin, xend = xmax, yend = y, size = size * params$fatten, alpha = NA)
502511
list(
503512
prefix_class(to_basic.GeomRect(data), "GeomCrossbar"),
504513
prefix_class(to_basic.GeomSegment(middle), "GeomCrossbar")

‎R/sf.R

Lines changed: 53 additions & 110 deletions
Original file line numberDiff line numberDiff line change
@@ -1,141 +1,84 @@
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")
16-
}
17-
18-
# ------------------------------------------------------------------
19-
# these helper functions are adapted from methods(st_as_grob)
20-
# see, for example, getS3method("st_as_grob", "MULTIPOLYGON")
21-
# ------------------------------------------------------------------
22-
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)))
1+
# kind of like sf_as_plotly(), but maps to a plotly data structure, rather than a grob
2+
sf_as_plotly <- function(row, ...) {
3+
UseMethod("st_as_plotly")
664
}
675

686
#' @export
69-
get_x.POLYGON <- function(g) {
70-
unlist(sapply(g, function(y) y[, 1]))
7+
sf_as_plotly.POINT = function(row, ...) {
8+
x <- row[1]
9+
y <- row[2]
10+
x
7111
}
7212

7313
#' @export
74-
get_y.POLYGON <- function(g) {
75-
unlist(sapply(g, function(y) y[, 2]))
14+
sf_as_plotly.MULTIPOINT = function(row, ...) {
15+
if (nrow(x) == 0)
16+
nullGrob()
17+
else
18+
pointsGrob(x[,1], x[,2], ..., default.units = default.units)
7619
}
7720

7821
#' @export
79-
get_l.POLYGON <- function(g) {
80-
sapply(g, nrow)
22+
sf_as_plotly.LINESTRING = function(row, ...) {
23+
if (nrow(x) == 0)
24+
nullGrob()
25+
else
26+
linesGrob(x[,1], x[,2], ..., default.units = default.units)
8127
}
8228

8329
#' @export
84-
get_x.MULTILINESTRING <- function(g) {
85-
unlist(sapply(g, function(y) y[, 1]))
30+
sf_as_plotly.CIRCULARSTRING = function(x, y, ...) {
31+
sf_as_plotly(st_cast(x, "LINESTRING"), ...)
8632
}
8733

8834
#' @export
89-
get_y.MULTILINESTRING <- function(g) {
90-
unlist(sapply(g, function(y) y[, 2]))
35+
sf_as_plotly.MULTILINESTRING = function(row, ...) {
36+
if (length(x) == 0)
37+
nullGrob()
38+
else {
39+
get_x = function(x) unlist(sapply(x, function(y) y[,1]))
40+
get_y = function(x) unlist(sapply(x, function(y) y[,2]))
41+
polylineGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ...,
42+
default.units = default.units)
43+
}
9144
}
9245

9346
#' @export
94-
get_l.MULTILINESTRING <- function(g) {
95-
sapply(g, nrow)
47+
sf_as_plotly.POLYGON = function(row, ..., rule = "evenodd") {
48+
if (length(x) == 0)
49+
nullGrob()
50+
else {
51+
get_x = function(x) unlist(sapply(x, function(y) y[,1]))
52+
get_y = function(x) unlist(sapply(x, function(y) y[,2]))
53+
pathGrob(get_x(x), get_y(x), id.lengths = vapply(x, nrow, 0L), ..., default.units = default.units, rule = rule)
54+
}
9655
}
9756

9857
#' @export
99-
get_x.LINESTRING <- function(g) {
100-
g[, 1]
58+
sf_as_plotly.MULTIPOLYGON = function(row, ..., rule = "evenodd") {
59+
if (length(x) == 0)
60+
nullGrob()
61+
else {
62+
get_x = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,1])))
63+
get_y = function(x) unlist(sapply(x, function(y) sapply(y, function(z) z[,2])))
64+
get_l = function(x) unlist(sapply(x, function(y) vapply(y, nrow, 0L)))
65+
pathGrob(get_x(x), get_y(x), id.lengths = get_l(x), ..., default.units = default.units, rule = rule)
66+
}
10167
}
10268

10369
#' @export
104-
get_y.LINESTRING <- function(g) {
105-
g[, 2]
70+
sf_as_plotly.GEOMETRYCOLLECTION = function(row, ...) {
71+
if (length(x) == 0)
72+
nullGrob()
73+
else
74+
do.call(grid::grobTree, lapply(x, sf_as_plotly, ..., default.units = default.units))
10675
}
10776

10877
#' @export
109-
get_l.LINESTRING <- function(g) {
110-
nrow(g)
111-
}
78+
sf_as_plotly.MULTISURFACE = sf_as_plotly.GEOMETRYCOLLECTION
11279

11380
#' @export
114-
get_x.MULTIPOINT <- function(g) {
115-
g[, 1]
116-
}
81+
sf_as_plotly.CURVEPOLYGON = sf_as_plotly.GEOMETRYCOLLECTION
11782

11883
#' @export
119-
get_y.MULTIPOINT <- function(g) {
120-
g[, 2]
121-
}
122-
123-
#' @export
124-
get_l.MULTIPOINT <- function(g) {
125-
nrow(g)
126-
}
127-
128-
#' @export
129-
get_x.POINT <- function(g) {
130-
g[1]
131-
}
132-
133-
#' @export
134-
get_y.POINT <- function(g) {
135-
g[2]
136-
}
137-
138-
#' @export
139-
get_l.POINT <- function(g) {
140-
nrow(g)
141-
}
84+
sf_as_plotly.COMPOUNDCURVE = sf_as_plotly.GEOMETRYCOLLECTION

0 commit comments

Comments
 (0)