Skip to content

Commit bf54b30

Browse files
author
xsaintmleux
committed
Merge pull request #44 from ropensci/facets1
Added support for ggplot2's facets.
2 parents 4668ee4 + 1814271 commit bf54b30

File tree

3 files changed

+241
-32
lines changed

3 files changed

+241
-32
lines changed

‎.travis.yml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ before_script:
55
- chmod 755 ./travis-tool.sh
66
- ./travis-tool.sh bootstrap
77
- ./travis-tool.sh install_deps
8-
- ./travis-tool.sh install_r RCurl RJSONIO
8+
- ./travis-tool.sh install_r RCurl RJSONIO lattice
99
notifications:
10-
slack: ropensci:wh30e1MP9Am3wXb2wJx1ZRFi
10+
slack: ropensci:wh30e1MP9Am3wXb2wJx1ZRFi
11+

‎R/ggplotly.R

Lines changed: 189 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,11 @@
66
##' @export
77
##' @return list of geom info.
88
##' @author Toby Dylan Hocking
9+
10+
## calc. the epoch
11+
now <- Sys.time()
12+
the.epoch <- now - as.numeric(now)
13+
914
group2NA <- function(g, geom){
1015
poly.list <- split(g$data, g$data$group)
1116
is.group <- names(g$data) == "group"
@@ -47,12 +52,19 @@ pch2symbol <- c("0"="square",
4752
aes2marker <- c(alpha="opacity",
4853
colour="color",
4954
size="size",
55+
sizeref="sizeref",
56+
sizemode="sizemode",
5057
shape="symbol")
5158

52-
marker.defaults <- c(alpha=1,
53-
shape="o",
54-
size=1,
55-
colour="black")
59+
default.marker.sizeref = 1
60+
marker.size.mult <- 10
61+
62+
marker.defaults <- list(alpha=1,
63+
shape="o",
64+
size=marker.size.mult,
65+
sizeref=default.marker.sizeref,
66+
sizemode="area",
67+
colour="black")
5668
line.defaults <-
5769
list(linetype="solid",
5870
colour="black",
@@ -96,12 +108,19 @@ lty2dash <- c(numeric.lty, named.lty, coded.lty)
96108

97109
aesConverters <-
98110
list(linetype=function(lty){
99-
lty2dash[as.character(lty)]
100-
},colour=function(col){
101-
toRGB(col)
102-
},size=identity,alpha=identity,shape=function(pch){
103-
pch2symbol[as.character(pch)]
104-
}, direction=identity)
111+
lty2dash[as.character(lty)]
112+
},
113+
colour=function(col){
114+
toRGB(col)
115+
},
116+
size=identity,
117+
sizeref=identity,
118+
sizemode=identity,
119+
alpha=identity,
120+
shape=function(pch){
121+
pch2symbol[as.character(pch)]
122+
},
123+
direction=identity)
105124

106125
toBasic <-
107126
list(segment=function(g){
@@ -144,6 +163,7 @@ toBasic <-
144163
stop("TODO")
145164
})
146165

166+
147167
#' Convert basic geoms to traces.
148168
geom2trace <-
149169
list(path=function(data, params){
@@ -173,9 +193,10 @@ geom2trace <-
173193
mode="markers",
174194
marker=paramORdefault(params, aes2marker, marker.defaults))
175195
if("size" %in% names(data)){
176-
L$marker$sizeref <- min(data$size)
177-
L$marker$sizemode <- "area"
178-
L$marker$size <- data$size
196+
L$marker$sizeref <- default.marker.sizeref
197+
## Make sure sizes are passed as a list even when there is only one element.
198+
marker.size <- data$size * marker.size.mult
199+
L$marker$size <- if (length(marker.size) > 1) marker.size else list(marker.size)
179200
}
180201
L
181202
},
@@ -221,6 +242,8 @@ aes2line <- c(linetype="dash",
221242
direction="shape")
222243

223244
markLegends <-
245+
## NOTE: Do we also want to split on size?
246+
## list(point=c("colour", "fill", "shape", "size"),
224247
list(point=c("colour", "fill", "shape"),
225248
path=c("linetype", "size", "colour"),
226249
polygon=c("colour", "fill", "linetype", "size", "group"),
@@ -297,7 +320,6 @@ gg2list <- function(p){
297320
trace.list$plot <- built$plot$data
298321
}
299322

300-
ranges <- built$panel$ranges[[1]]
301323
for(i in seq_along(built$plot$layers)){
302324
## This is the layer from the original ggplot object.
303325
L <- p$layers[[i]]
@@ -341,7 +363,18 @@ gg2list <- function(p){
341363
misc$breaks[[sc$aesthetics]] <- ranks
342364
}
343365
}
366+
367+
## get gglayout now because we need some of its info in layer2traces
368+
gglayout <- built$panel$layout
369+
## invert rows so that plotly and ggplot2 show panels in the same order
370+
gglayout$plotly.row <- max(gglayout$ROW) - gglayout$ROW + 1
344371

372+
## Add ROW and COL to df: needed to link axes to traces; keep df's
373+
## original ordering while merging.
374+
df$order <- seq_len(nrow(df))
375+
df <- merge(df, gglayout[,c("PANEL","plotly.row","COL")])
376+
df <- df[order(df$order),]
377+
df$order <- NULL
345378
## This extracts essential info for this geom/layer.
346379
traces <- layer2traces(L, df, misc, trace.list$plot)
347380

@@ -350,11 +383,12 @@ gg2list <- function(p){
350383
## built$panel$ranges[[1]])
351384
trace.list <- c(trace.list, traces)
352385
}
353-
# Export axis specification as a combination of breaks and
354-
# labels, on the relevant axis scale (i.e. so that it can
355-
# be passed into d3 on the x axis scale instead of on the
356-
# grid 0-1 scale). This allows transformations to be used
357-
# out of the box, with no additional d3 coding.
386+
387+
## Export axis specification as a combination of breaks and labels, on
388+
## the relevant axis scale (i.e. so that it can be passed into d3 on the
389+
## x axis scale instead of on the grid 0-1 scale). This allows
390+
## transformations to be used out of the box, with no additional d3
391+
## coding.
358392
theme.pars <- ggplot2:::plot_theme(p)
359393

360394
## Flip labels if coords are flipped - transform does not take care
@@ -430,6 +464,114 @@ gg2list <- function(p){
430464
!is.blank(s("axis.ticks.%s"))
431465
layout[[s("%saxis")]] <- ax.list
432466
}
467+
468+
## copy [x/y]axis to [x/y]axisN and set domain, range, etc. for each
469+
xaxis.title <- layout$xaxis$title
470+
yaxis.title <- layout$yaxis$title
471+
inner.margin <- 0.01 ## between facets
472+
outer.margin <- 0.05 ## to put titles outside of the plots
473+
orig.xaxis <- layout$xaxis
474+
orig.yaxis <- layout$yaxis
475+
if (nrow(gglayout) > 1)
476+
{
477+
row.size <- 1. / max(gglayout$ROW)
478+
col.size <- 1. / max(gglayout$COL)
479+
for (i in seq_len(nrow(gglayout)))
480+
{
481+
row <- gglayout[i, "plotly.row"]
482+
col <- gglayout[i, "COL"]
483+
x <- col * col.size
484+
xmin <- x - col.size
485+
xmax <- x - inner.margin
486+
y <- row * row.size
487+
ymin <- y - row.size
488+
ymax <- y - inner.margin
489+
yaxis.name <- if (row == 1) "yaxis" else paste0("yaxis", row)
490+
xaxis.name <- if (col == 1) "xaxis" else paste0("xaxis", col)
491+
layout[[xaxis.name]] <- orig.xaxis
492+
layout[[xaxis.name]]$domain <- c(xmin, xmax)
493+
layout[[xaxis.name]]$anchor <- "y"
494+
layout[[xaxis.name]]$title <- NULL
495+
if (orig.xaxis$type == "linear" && # range only makes sense for numeric data
496+
(is.null(p$facet$scales) || p$facet$scales == "fixed" || p$facet$scales == "free_y"))
497+
{
498+
layout[[xaxis.name]]$range <- built$panel$ranges[[i]]$x.range
499+
layout[[xaxis.name]]$autorange <- FALSE
500+
}
501+
502+
layout[[yaxis.name]] <- orig.yaxis
503+
layout[[yaxis.name]]$domain <- c(ymin, ymax)
504+
layout[[yaxis.name]]$anchor <- "x"
505+
layout[[yaxis.name]]$title <- NULL
506+
if (orig.yaxis$type == "linear" && # range only makes sense for numeric data
507+
(is.null(p$facet$scales) || p$facet$scales == "fixed" || p$facet$scales == "free_x"))
508+
{
509+
layout[[yaxis.name]]$range <- built$panel$ranges[[i]]$y.range
510+
layout[[yaxis.name]]$autorange <- FALSE
511+
}
512+
513+
}
514+
## add panel titles as annotations
515+
annotations <- list()
516+
nann <- 1
517+
make.label <- function(text, x, y)
518+
list(text=text, showarrow=FALSE, x=x, y=y, ax=0, ay=0, xref="paper", yref="paper")
519+
520+
if ("grid" %in% class(p$facet))
521+
{
522+
frows <- names(p$facet$rows)
523+
nann <- 1
524+
525+
for (i in seq_len(max(gglayout$ROW)))
526+
{
527+
text <- paste(lapply(gglayout[gglayout$ROW == i, frows, drop=FALSE][1,],
528+
as.character),
529+
collapse=", ")
530+
annotations[[nann]] <- make.label(text, 1 + outer.margin, row.size * (max(gglayout$ROW)-i+0.5))
531+
nann <- nann + 1
532+
}
533+
534+
fcols <- names(p$facet$cols)
535+
for (i in seq_len(max(gglayout$COL)))
536+
{
537+
text <- paste(lapply(gglayout[gglayout$COL == i, fcols, drop=FALSE][1,],
538+
as.character),
539+
collapse=", ")
540+
annotations[[nann]] <- make.label(text, col.size * (i-0.5) - inner.margin/2, 1 + outer.margin)
541+
nann <- nann + 1
542+
}
543+
544+
## add empty traces everywhere so that the background shows even if there
545+
## is no data for a facet
546+
for (r in seq_len(max(gglayout$ROW)))
547+
for (c in seq_len(max(gglayout$COL)))
548+
trace.list <- c(trace.list, list(list(xaxis=paste0("x", c), yaxis=paste0("y", r), showlegend=FALSE)))
549+
}
550+
else if ("wrap" %in% class(p$facet))
551+
{
552+
facets <- names(p$facet$facets)
553+
for (i in seq_len(max(as.numeric(gglayout$PANEL))))
554+
{
555+
ix <- gglayout$PANEL == i
556+
row <- gglayout$ROW[ix]
557+
col <- gglayout$COL[ix]
558+
text <- paste(lapply(gglayout[ix, facets, drop=FALSE][1,],
559+
as.character),
560+
collapse=", ")
561+
annotations[[nann]] <- make.label(text, col.size * (col-0.5) - inner.margin/2,
562+
row.size * (max(gglayout$ROW) - row + 1))
563+
nann <- nann + 1
564+
}
565+
}
566+
567+
## axes titles
568+
annotations[[nann]] <- make.label(xaxis.title, 0.5, -outer.margin)
569+
nann <- nann + 1
570+
annotations[[nann]] <- make.label(yaxis.title, -outer.margin, 0.5)
571+
nann <- nann + 1
572+
573+
layout$annotations <- annotations
574+
}
433575

434576
## Remove legend if theme has no legend position
435577
if(theme.pars$legend.position=="none") layout$showlegend <- FALSE
@@ -465,18 +607,20 @@ layer2traces <- function(l, d, misc, plot=NULL){
465607
plot=plot)
466608
## needed for when group, etc. is an expression.
467609
g$aes <- sapply(l$mapping, function(k) as.character(as.expression(k)))
468-
610+
469611
## For non-numeric data on the axes, we should take the values from
470612
## the original data.
471-
for(axis.name in c("x", "y")){
472-
if(!misc$is.continuous[[axis.name]]){
613+
for (axis.name in c("x", "y")){
614+
if (!misc$is.continuous[[axis.name]]){
473615
aes.names <- paste0(axis.name, c("", "end", "min", "max"))
474616
aes.used <- aes.names[aes.names %in% names(g$aes)]
475617
for(a in aes.used){
476618
col.name <- g$aes[aes.used]
477619
data.vec <- l$data[[col.name]]
478-
if(inherits(data.vec, "POSIXt")){
479-
data.vec <- strftime(data.vec, "%Y-%m-%d %H:%M:%S")
620+
if (inherits(data.vec, "POSIXt")) {
621+
## Re-create dates from nb seconds
622+
data.vec <- strftime(as.POSIXlt(g$data[[a]], origin=the.epoch),
623+
"%Y-%m-%d %H:%M:%S")
480624
} else if (inherits(data.vec, "factor")) {
481625
## Re-order data so that Plotly gets it right from ggplot2.
482626
g$data <- g$data[order(g$data[[a]]),]
@@ -486,6 +630,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
486630
}
487631
}
488632
}
633+
489634
## use un-named parameters so that they will not be exported
490635
## to JSON as a named object, since that causes problems with
491636
## e.g. colour.
@@ -525,7 +670,6 @@ layer2traces <- function(l, d, misc, plot=NULL){
525670
}else{
526671
convert(g)
527672
}
528-
529673
## Then split on visual characteristics that will get different
530674
## legend entries.
531675
data.list <- if(basic$geom %in% names(markLegends)){
@@ -540,29 +684,30 @@ layer2traces <- function(l, d, misc, plot=NULL){
540684
## mark.names <- mark.names[!mark.names %in% to.erase]
541685
## }
542686
name.names <- sprintf("%s.name", mark.names)
543-
is.split <- names(basic$data) %in% name.names
687+
## split on 'PANEL' to support facets
688+
is.split <- names(basic$data) %in% c(name.names, "PANEL")
544689
if(any(is.split)){
545690
data.i <- which(is.split)
546691
matched.names <- names(basic$data)[data.i]
547-
name.i <- which(name.names %in% matched.names)
692+
name.i <- name.names %in% matched.names
548693
invariable.names <- cbind(name.names, mark.names)[name.i,]
549694
other.names <- !names(basic$data) %in% invariable.names
550695
vec.list <- basic$data[is.split]
551696
df.list <- split(basic$data, vec.list, drop=TRUE)
552697
lapply(df.list, function(df){
553698
params <- basic$params
554-
params[invariable.names] <- df[1, invariable.names]
699+
params[invariable.names] <- if (ncol(x <- df[1, invariable.names]) > 0) x else NULL
555700
list(data=df[other.names],
556701
params=params)
557702
})
558703
}
559704
}
705+
560706
## case of no legend, if either of the two ifs above failed.
561707
if(is.null(data.list)){
562708
data.list <- structure(list(list(data=basic$data, params=basic$params)),
563709
names=basic$params$name)
564710
}
565-
566711
getTrace <- geom2trace[[basic$geom]]
567712
if(is.null(getTrace)){
568713
warning("Conversion not implemented for geom_",
@@ -572,6 +717,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
572717
return(list())
573718
}
574719
traces <- NULL
720+
names.in.legend <- NULL
575721
for(data.i in seq_along(data.list)){
576722
data.params <- data.list[[data.i]]
577723
tr <- do.call(getTrace, data.params)
@@ -594,8 +740,21 @@ layer2traces <- function(l, d, misc, plot=NULL){
594740
name.list <- data.params$params[name.names]
595741
tr$name <- paste(unlist(name.list), collapse=".")
596742
}
743+
744+
dpd <- data.params$data
745+
if ("PANEL" %in% names(dpd) && nrow(dpd) > 0)
746+
{
747+
tr$xaxis <- paste0("x", dpd[1, "COL"])
748+
tr$yaxis <- paste0("y", dpd[1, "plotly.row"])
749+
}
750+
751+
if (is.null(tr$name) || tr$name %in% names.in.legend)
752+
tr$showlegend <- FALSE
753+
names.in.legend <- c(names.in.legend, tr$name)
754+
597755
traces <- c(traces, list(tr))
598756
}
757+
599758
sort.val <- sapply(traces, function(tr){
600759
rank.val <- unlist(tr$sort)
601760
if(is.null(rank.val)){
@@ -606,6 +765,7 @@ layer2traces <- function(l, d, misc, plot=NULL){
606765
0
607766
}
608767
})
768+
609769
ord <- order(sort.val)
610770
no.sort <- traces[ord]
611771
for(tr.i in seq_along(no.sort)){
@@ -630,7 +790,6 @@ paramORdefault <- function(params, aesVec, defaults){
630790
ggplot.value <- defaults[[ggplot.name]]
631791
}
632792
if(is.null(ggplot.value)){
633-
print(defaults)
634793
stop("no ggplot default for ", ggplot.name)
635794
}
636795
convert <- aesConverters[[ggplot.name]]

0 commit comments

Comments
 (0)