Skip to content

Commit 1fac212

Browse files
tdhocktdhock
committed
test polygons and paths
1 parent ae22322 commit 1fac212

File tree

4 files changed

+223
-59
lines changed

4 files changed

+223
-59
lines changed

‎R/ggplotly.R

Lines changed: 86 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,17 @@
66
##' @export
77
##' @return list of geom info.
88
##' @author Toby Dylan Hocking
9-
group2NA <- function(g, geom="path"){
9+
group2NA <- function(g, geom){
1010
poly.list <- split(g$data, g$data$group)
1111
is.group <- names(g$data) == "group"
1212
poly.na.df <- data.frame()
1313
for(i in seq_along(poly.list)){
1414
no.group <- poly.list[[i]][,!is.group,drop=FALSE]
15-
poly.na.df <- rbind(poly.na.df, no.group, NA)
15+
na.row <- no.group[1,]
16+
na.row[,c("x", "y")] <- NA
17+
poly.na.df <- rbind(poly.na.df, no.group, na.row)
1618
}
17-
g$data <- poly.na.df[-nrow(poly.na.df),]
19+
g$data <- poly.na.df
1820
g$geom <- geom
1921
g
2022
}
@@ -49,7 +51,7 @@ aes2marker <- c(alpha="opacity",
4951

5052
marker.defaults <- c(alpha=1,
5153
shape="o",
52-
size=5,
54+
size=1,
5355
colour="black")
5456
line.defaults <-
5557
list(linetype="solid",
@@ -111,23 +113,69 @@ toBasic <-
111113
rbind(cbind(x, y, others),
112114
cbind(x=xend, y=yend, others))
113115
})
114-
g$geom <- "path"
115-
group2NA(g)
116-
},polygon=group2NA,line=function(g){
116+
group2NA(g, "path")
117+
},polygon=function(g){
118+
if(is.null(g$params$fill)){
119+
g
120+
}else if(is.na(g$params$fill)){
121+
group2NA(g, "path")
122+
}else{
123+
g
124+
}
125+
},path=function(g){
126+
group2NA(g, "path")
127+
},line=function(g){
117128
g$data <- g$data[order(g$data$x),]
118-
group2NA(g)
129+
group2NA(g, "path")
119130
},ribbon=function(g){
120131
stop("TODO")
121132
})
122133

134+
#' Convert basic geoms to traces.
135+
geom2trace <-
136+
list(path=function(data, params){
137+
list(x=data$x,
138+
y=data$y,
139+
name=params$name,
140+
text=data$text,
141+
type="scatter",
142+
mode="lines",
143+
line=paramORdefault(params, aes2line, line.defaults))
144+
},polygon=function(data, params){
145+
list(x=c(data$x, data$x[1]),
146+
y=c(data$y, data$y[1]),
147+
name=params$name,
148+
text=data$text,
149+
type="scatter",
150+
mode="lines",
151+
line=paramORdefault(params, aes2line, line.defaults),
152+
fill="tonextx",
153+
fillcolor=toRGB(params$fill))
154+
},point=function(data, params){
155+
L <- list(x=data$x,
156+
y=data$y,
157+
name=params$name,
158+
text=data$text,
159+
type="scatter",
160+
mode="markers",
161+
marker=paramORdefault(params, aes2marker, marker.defaults))
162+
if("size" %in% names(data)){
163+
L$marker$sizeref <- min(data$size)
164+
L$marker$sizemode <- "area"
165+
L$marker$size <- data$size
166+
}
167+
L
168+
})
169+
123170
#' Convert ggplot2 aes to line parameters.
124171
aes2line <- c(linetype="dash",
125172
colour="color",
126173
size="width")
127174

128175
markLegends <-
129176
list(point=c("colour", "fill", "shape"),
130-
path=c("linetype", "size", "colour"))
177+
path=c("linetype", "size", "colour"),
178+
polygon=c("colour", "fill", "linetype", "size", "group"))
131179

132180
markUnique <- as.character(unique(unlist(markLegends)))
133181

@@ -139,7 +187,15 @@ markUnique <- as.character(unique(unlist(markLegends)))
139187
gg2list <- function(p){
140188
## Always use identity size scale so that plot.ly gets the real
141189
## units for the size variables.
142-
p <- p+scale_size_identity()
190+
p <- tryCatch({
191+
## this will be an error for discrete variables.
192+
suppressMessages({
193+
ggplot2::ggplot_build(p+scale_size_continuous())
194+
p+scale_size_identity()
195+
})
196+
},error=function(e){
197+
p
198+
})
143199
layout <- list()
144200
trace.list <- list()
145201
## Before building the ggplot, we would like to add aes(name) to
@@ -348,16 +404,23 @@ layer2traces <- function(l, d, misc){
348404
## legend entries.
349405
data.list <- if(basic$geom %in% names(markLegends)){
350406
mark.names <- markLegends[[basic$geom]]
351-
to.erase <- names(misc$is.continuous)[misc$is.continuous]
352-
mark.names <- mark.names[!mark.names %in% to.erase]
407+
## However, continuously colored points are an exception: they do
408+
## not need a legend entry, and they can be efficiently rendered
409+
## using just 1 trace.
410+
411+
## Maybe it is nice to show a legend for continuous points?
412+
## if(basic$geom == "point"){
413+
## to.erase <- names(misc$is.continuous)[misc$is.continuous]
414+
## mark.names <- mark.names[!mark.names %in% to.erase]
415+
## }
353416
name.names <- sprintf("%s.name", mark.names)
354417
is.split <- names(basic$data) %in% name.names
355-
data.i <- which(is.split)
356-
matched.names <- names(basic$data)[data.i]
357-
name.i <- which(name.names %in% matched.names)
358-
invariable.names <- cbind(name.names, mark.names)[name.i,]
359-
other.names <- !names(basic$data) %in% invariable.names
360418
if(any(is.split)){
419+
data.i <- which(is.split)
420+
matched.names <- names(basic$data)[data.i]
421+
name.i <- which(name.names %in% matched.names)
422+
invariable.names <- cbind(name.names, mark.names)[name.i,]
423+
other.names <- !names(basic$data) %in% invariable.names
361424
vec.list <- basic$data[is.split]
362425
df.list <- split(basic$data, vec.list, drop=TRUE)
363426
lapply(df.list, function(df){
@@ -368,19 +431,17 @@ layer2traces <- function(l, d, misc){
368431
})
369432
}
370433
}
371-
## Case of no legend:
434+
## case of no legend, if either of the two ifs above failed.
372435
if(is.null(data.list)){
373-
data.list <-
374-
structure(list(list(data=basic$data, params=basic$params)),
375-
names=basic$params$name)
436+
data.list <- structure(list(list(data=basic$data, params=basic$params)),
437+
names=basic$params$name)
376438
}
377439

378440
getTrace <- geom2trace[[basic$geom]]
379441
if(is.null(getTrace)){
380442
stop("conversion not implemented for geom_",
381443
g$geom, " (basic geom_", basic$geom, ")")
382444
}
383-
384445
traces <- NULL
385446
for(data.i in seq_along(data.list)){
386447
data.params <- data.list[[data.i]]
@@ -391,7 +452,9 @@ layer2traces <- function(l, d, misc){
391452
a <- sub("[.]name$", "", a.name)
392453
a.value <- as.character(data.params$params[[a.name]])
393454
ranks <- misc$breaks[[a]]
394-
tr$sort[[a.name]] <- ranks[[a.value]]
455+
if(length(ranks)){
456+
tr$sort[[a.name]] <- ranks[[a.value]]
457+
}
395458
}
396459
name.list <- data.params$params[name.names]
397460
tr$name <- paste(unlist(name.list), collapse=".")
@@ -416,31 +479,6 @@ layer2traces <- function(l, d, misc){
416479
no.sort
417480
}
418481

419-
geom2trace <-
420-
list(path=function(data, params){
421-
list(x=data$x,
422-
y=data$y,
423-
name=params$name,
424-
text=data$text,
425-
type="scatter",
426-
mode="lines",
427-
line=paramORdefault(params, aes2line, line.defaults))
428-
},point=function(data, params){
429-
L <- list(x=data$x,
430-
y=data$y,
431-
name=params$name,
432-
text=data$text,
433-
type="scatter",
434-
mode="markers",
435-
marker=paramORdefault(params, aes2marker, marker.defaults))
436-
if("size" %in% names(data)){
437-
L$marker$sizeref <- min(data$size)
438-
L$marker$sizemode <- "area"
439-
L$marker$size <- data$size
440-
}
441-
L
442-
})
443-
444482
##' convert ggplot params to plotly.
445483
##' @param params named list ggplot names -> values.
446484
##' @param aesVec vector mapping ggplot names to plotly names.

‎inst/tests/test-ggplot-path.R

Lines changed: 52 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,59 @@
11
context("path")
22

3-
df <- data.frame(x=c(1, 3, 2),
4-
y=c(0, 0, 1))
5-
63
test_that("lines are different from paths", {
4+
df <- data.frame(x=c(1, 3, 2),
5+
y=c(0, 0, 1))
76
p <- qplot(x, y, data=df, geom="path")
8-
p.tr <- gg2list(p)[[1]]
9-
expect_identical(p.tr$x, c(1, 3, 2))
10-
expect_identical(p.tr$y, c(0, 0, 1))
7+
info <- gg2list(p)
8+
p.tr <- info[[1]]
9+
expect_identical(p.tr$x[1:3], c(1, 3, 2))
10+
expect_identical(p.tr$y[1:3], c(0, 0, 1))
1111
l <- qplot(x, y, data=df, geom="line")
1212
l.tr <- gg2list(l)[[1]]
13-
expect_identical(l.tr$x, c(1, 2, 3))
14-
expect_identical(l.tr$y, c(0, 1, 0))
13+
expect_identical(l.tr$x[1:3], c(1, 2, 3))
14+
expect_identical(l.tr$y[1:3], c(0, 1, 0))
15+
})
16+
17+
two.paths <- data.frame(x=c(1, 2, 1, 2),
18+
y=c(1, 1, 2, 2))
19+
20+
test_that("paths with different colors become different traces", {
21+
## Numeric color.
22+
gg <- ggplot()+
23+
geom_path(aes(x, y, group=y, color=y), data=two.paths)
24+
info <- gg2list(gg)
25+
expect_equal(length(info), 3)
26+
trace.names <- sapply(info[1:2], "[[", "name")
27+
expect_identical(as.character(trace.names), c("1", "2"))
28+
expect_identical(info[[1]]$x[1:2], c(1,2))
29+
expect_identical(info[[2]]$x[1:2], c(1,2))
30+
expect_identical(info[[1]]$y[1:2], c(1,1))
31+
expect_identical(info[[2]]$y[1:2], c(2,2))
32+
## Categorical color.
33+
gg <- ggplot()+
34+
geom_path(aes(x, y, group=y, color=paste0("FOO", y)), data=two.paths)
35+
info <- gg2list(gg)
36+
expect_equal(length(info), 3)
37+
trace.names <- sapply(info[1:2], "[[", "name")
38+
expect_identical(as.character(trace.names), c("FOO1", "FOO2"))
39+
expect_identical(info[[1]]$x[1:2], c(1,2))
40+
expect_identical(info[[2]]$x[1:2], c(1,2))
41+
expect_identical(info[[1]]$y[1:2], c(1,1))
42+
expect_identical(info[[2]]$y[1:2], c(2,2))
43+
})
44+
45+
four.paths <- rbind(data.frame(two.paths, g="positive"),
46+
data.frame(-two.paths, g="negative"))
47+
48+
test_that("paths with the same color but different groups stay together", {
49+
gg <- ggplot()+
50+
geom_path(aes(x, y, group=y, color=g), data=four.paths)
51+
info <- gg2list(gg)
52+
expect_equal(length(info), 3)
53+
expect_identical(info[[1]]$name, "positive")
54+
expect_identical(info[[2]]$name, "negative")
55+
expect_true(any(is.na(info[[1]]$x)))
56+
expect_true(any(is.na(info[[1]]$y)))
57+
expect_true(any(is.na(info[[2]]$x)))
58+
expect_true(any(is.na(info[[2]]$y)))
1559
})

‎inst/tests/test-ggplot-polygons.R

Lines changed: 83 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,88 @@
11
context("polygon")
22

3-
test_that("polygons become one trace with NA", {
3+
test_that("filled polygons become several traces", {
4+
poly.df <- data.frame(x=c(0, 1, 1, 0, 2, 3, 3, 2)+10,
5+
y=c(0, 0, 1, 1, 0, 0, 1, 1)+10,
6+
g=c(1, 1, 1, 1, 2, 2, 2, 2))
7+
poly.df$lab <- paste0("name", poly.df$g)
8+
gg <- ggplot(poly.df)+
9+
geom_polygon(aes(x, y, group=g))
10+
info <- gg2list(gg)
11+
expect_equal(length(info), 3)
12+
expect_equal(info[[1]]$x, c(10, 11, 11, 10, 10))
13+
expect_equal(info[[1]]$y, c(10, 10, 11, 11, 10))
14+
expect_equal(info[[2]]$x, c(12, 13, 13, 12, 12))
15+
expect_equal(info[[2]]$y, c(10, 10, 11, 11, 10))
16+
17+
first.color <- rgb(0.23, 0.45, 0.67)
18+
gg <- ggplot(poly.df)+
19+
geom_polygon(aes(x, y, color=lab), fill="grey")+
20+
scale_color_manual(values=c(name1=first.color, name2="springgreen3"))
21+
info <- gg2list(gg)
22+
expect_equal(length(info), 3)
23+
expect_equal(info[[1]]$x, c(10, 11, 11, 10, 10))
24+
expect_equal(info[[1]]$y, c(10, 10, 11, 11, 10))
25+
expect_equal(info[[1]]$fillcolor, toRGB("grey"))
26+
expect_equal(info[[1]]$line$color, toRGB(first.color))
27+
expect_equal(info[[1]]$name, "name1")
28+
expect_equal(info[[2]]$x, c(12, 13, 13, 12, 12))
29+
expect_equal(info[[2]]$y, c(10, 10, 11, 11, 10))
30+
expect_equal(info[[2]]$fillcolor, toRGB("grey"))
31+
expect_equal(info[[2]]$line$color, toRGB("springgreen3"))
32+
expect_equal(info[[2]]$name, "name2")
33+
34+
35+
first.color <- rgb(0.23, 0.45, 0.67)
36+
gg <- ggplot(poly.df)+
37+
geom_polygon(aes(x, y, fill=lab))+
38+
scale_fill_manual(values=c(name1=first.color, name2="springgreen3"))
39+
info <- gg2list(gg)
40+
expect_equal(length(info), 3)
41+
expect_equal(info[[1]]$x, c(10, 11, 11, 10, 10))
42+
expect_equal(info[[1]]$y, c(10, 10, 11, 11, 10))
43+
expect_equal(info[[1]]$fillcolor, toRGB(first.color))
44+
expect_equal(info[[1]]$name, "name1")
45+
expect_equal(info[[2]]$x, c(12, 13, 13, 12, 12))
46+
expect_equal(info[[2]]$y, c(10, 10, 11, 11, 10))
47+
expect_equal(info[[2]]$fillcolor, toRGB("springgreen3"))
48+
expect_equal(info[[2]]$name, "name2")
49+
50+
gg <- ggplot(poly.df)+
51+
geom_polygon(aes(x, y, linetype=lab), fill="red", colour="blue")+
52+
scale_linetype_manual(values=c(name1="dotted", name2="dashed"))
53+
info <- gg2list(gg)
54+
expect_equal(length(info), 3)
55+
expect_equal(info[[1]]$x, c(10, 11, 11, 10, 10))
56+
expect_equal(info[[1]]$y, c(10, 10, 11, 11, 10))
57+
expect_equal(info[[1]]$fillcolor, toRGB("red"))
58+
expect_equal(info[[1]]$line$color, toRGB("blue"))
59+
expect_equal(info[[1]]$line$dash, "dotted")
60+
expect_equal(info[[1]]$name, "name1")
61+
expect_equal(info[[2]]$x, c(12, 13, 13, 12, 12))
62+
expect_equal(info[[2]]$y, c(10, 10, 11, 11, 10))
63+
expect_equal(info[[2]]$fillcolor, toRGB("red"))
64+
expect_equal(info[[2]]$line$color, toRGB("blue"))
65+
expect_equal(info[[2]]$line$dash, "dash")
66+
expect_equal(info[[2]]$name, "name2")
67+
68+
gg <- ggplot(poly.df)+
69+
geom_polygon(aes(x, y, size=lab), fill="orange", colour="black")+
70+
scale_size_manual(values=c(name1=2, name2=3))
71+
info <- gg2list(gg)
72+
expect_equal(length(info), 3)
73+
expect_equal(info[[1]]$x, c(10, 11, 11, 10, 10))
74+
expect_equal(info[[1]]$y, c(10, 10, 11, 11, 10))
75+
expect_equal(info[[1]]$fillcolor, toRGB("orange"))
76+
expect_equal(info[[1]]$line$width, 2)
77+
expect_equal(info[[1]]$name, "name1")
78+
expect_equal(info[[2]]$x, c(12, 13, 13, 12, 12))
79+
expect_equal(info[[2]]$y, c(10, 10, 11, 11, 10))
80+
expect_equal(info[[2]]$fillcolor, toRGB("orange"))
81+
expect_equal(info[[2]]$line$width, 3)
82+
expect_equal(info[[2]]$name, "name2")
83+
})
84+
85+
test_that("borders become one trace with NA", {
486
library(maps)
587
data(canada.cities)
688
gg <- ggplot(canada.cities, aes(long, lat))+

‎inst/tests/test-ggplot-segment.R

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,6 @@ test_that("segments become one path", {
99
geom_segment(aes(x, y, xend=xend, yend=yend), data=seg.df)
1010
info <- gg2list(gg)
1111
tr <- info[[1]]
12-
expect_equal(tr$x, c(0, 1, NA, 0, 1))
13-
expect_equal(tr$y, c(0, 0, NA, 1, 1))
12+
expect_true(any(is.na(tr$x)))
13+
expect_true(any(is.na(tr$y)))
1414
})

0 commit comments

Comments
 (0)