Skip to content

Commit

Permalink
Use new legend titles and support theme(legend.position=...) & theme(…
Browse files Browse the repository at this point in the history 
…legend.direction=...), closes #1049
  • Loading branch information
@cpsievert
cpsievert committed Feb 6, 2020
1 parent 65493ad commit 16a567f
Show file tree
Hide file tree
Showing 2 changed files with 194 additions and 86 deletions.
240 changes: 154 additions & 86 deletions R/ggplotly.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -905,83 +905,69 @@ gg2list <- function(p, width = NULL, height = NULL,
# will there be a legend?
gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) >= 1

# legend styling
gglayout$legend <- list(
bgcolor = toRGB(theme$legend.background$fill),
bordercolor = toRGB(theme$legend.background$colour),
borderwidth = unitConvert(theme$legend.background$size, "pixels", "width"),
font = text2font(theme$legend.text)
)

# if theme(legend.position = "none") is used, don't show a legend _or_ guide
if (npscales$n() == 0 || identical(theme$legend.position, "none")) {
gglayout$showlegend <- FALSE
} else {
# by default, guide boxes are vertically aligned
theme$legend.box <- theme$legend.box %||% "vertical"

# size of key (also used for bar in colorbar guide)
# ------------------------------------------------------------------
# Copied from body of ggplot2:::guides_build().
theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size
theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size

# legend direction must be vertical
theme$legend.direction <- theme$legend.direction %||% "vertical"
if (!identical(theme$legend.direction, "vertical")) {
warning(
"plotly.js does not (yet) support horizontal legend items \n",
"You can track progress here: \n",
"https://github.com/plotly/plotly.js/issues/53 \n",
call. = FALSE
)
theme$legend.direction <- "vertical"
# Layout of legends depends on their overall location
position <- ggfun("legend_position")(theme$legend.position %||% "right")
if (position == "inside") {
theme$legend.box <- theme$legend.box %||% "vertical"
theme$legend.direction <- theme$legend.direction %||% "vertical"
theme$legend.box.just <- theme$legend.box.just %||% c("center", "center")
} else if (position == "vertical") {
theme$legend.box <- theme$legend.box %||% "vertical"
theme$legend.direction <- theme$legend.direction %||% "vertical"
theme$legend.box.just <- theme$legend.box.just %||% c("left", "top")
} else if (position == "horizontal") {
theme$legend.box <- theme$legend.box %||% "horizontal"
theme$legend.direction <- theme$legend.direction %||% "horizontal"
theme$legend.box.just <- theme$legend.box.just %||% c("center", "top")
}

# justification of legend boxes
theme$legend.box.just <- theme$legend.box.just %||% c("center", "center")
# scales -> data for guides
gdefs <- ggfun("guides_train")(scales, theme, plot$guides, plot$labels)
if (length(gdefs) > 0) {
gdefs <- ggfun("guides_merge")(gdefs)
gdefs <- ggfun("guides_geom")(gdefs, layers, plot$mapping)
}
# ------------------------------------------------------------------

# colourbar -> plotly.js colorbar
colorbar <- compact(lapply(gdefs, gdef2trace, theme, gglayout))
nguides <- length(colorbar) + gglayout$showlegend
# If we have 2 or more guides, set x/y positions accordingly
if (nguides >= 2) {
# place legend at the bottom
gglayout$legend$y <- 1 / nguides
gglayout$legend$yanchor <- "top"
# adjust colorbar position(s)
for (i in seq_along(colorbar)) {
colorbar[[i]]$marker$colorbar$yanchor <- "top"
colorbar[[i]]$marker$colorbar$len <- 1 / nguides
colorbar[[i]]$marker$colorbar$y <- 1 - (i - 1) * (1 / nguides)
}
}
traces <- c(traces, colorbar)
# Until plotly.js has multiple legend support, we're stuck with smashing
# all legends into one...
legendTitle <- paste(
compact(lapply(gdefs, function(g) if (inherits(g, "legend")) g$title else NULL)),
collapse = br()
)

# Discard everything but the first legend and colourbar(s)
is_legend <- vapply(gdefs, is_guide_legend, logical(1))
is_colorbar <- vapply(gdefs, is_guide_colorbar, logical(1))
gdefs <- c(
gdefs[is_colorbar],
if (gglayout$showlegend) gdefs[which(is_legend)[1]]
)

# legend title annotation - https://github.com/plotly/plotly.js/issues/276
if (isTRUE(gglayout$showlegend)) {
legendTitles <- compact(lapply(gdefs, function(g) if (inherits(g, "legend")) g$title else NULL))
legendTitle <- paste(legendTitles, collapse = br())
titleAnnotation <- make_label(
legendTitle,
x = gglayout$legend$x %||% 1.02,
y = gglayout$legend$y %||% 1,
theme$legend.title,
xanchor = "left",
yanchor = "bottom",
# just so the R client knows this is a title
legendTitle = TRUE
# Get plotly.js positioning and orientation of all the guides at once
positions <- plotly_guide_positions(gdefs, theme)

# Convert the legend
is_legend <- vapply(gdefs, is_guide_legend, logical(1))
if (sum(is_legend) == 1) {
idx <- which(is_legend)
gglayout$legend <- plotly_guide_legend(
gdefs[[idx]], theme,
positions[[idx]], legendTitle
)
gglayout$annotations <- c(gglayout$annotations, titleAnnotation)
# adjust the height of the legend to accomodate for the title
# this assumes the legend always appears below colorbars
gglayout$legend$y <- (gglayout$legend$y %||% 1) -
length(legendTitles) * unitConvert(theme$legend.title$size, "npc", "height")
}

# Convert the colorbars
is_colorbar <- vapply(gdefs, is_guide_colorbar, logical(1))
traces <- c(traces, plotly_guide_colorbars(gdefs[is_colorbar], theme, positions[is_colorbar], gglayout))
}

# flip x/y in traces for flipped coordinates
Expand Down Expand Up @@ -1324,14 +1310,109 @@ ggtype <- function(x, y = "geom") {
sub(y, "", tolower(class(x[[y]])[1]))
}

# colourbar -> plotly.js colorbar
gdef2trace <- function(gdef, theme, gglayout) {
if (inherits(gdef, "colorbar")) {
# sometimes the key has missing values, which we can ignore

plotly_guide_positions <- function(gdefs, theme) {
length <- 1 / length(gdefs)
isTop <- "top" %in% theme$legend.position
isLeft <- "left" %in% theme$legend.position

lapply(seq_along(gdefs), function(i) {
position <- (i / length(gdefs)) - (0.5 * length)
orientation <- substr(gdefs[[i]]$direction, 1, 1)
if (theme$legend.position %in% c("top", "bottom")) {
list(
xanchor = "center",
x = position,
len = length,
orientation = orientation,
yanchor = if (isTop) "bottom" else "top",
# bottom needs some additional space to dodge x-axis
# TODO: can we measure size of axis in npc?
y = if (isTop) 1 else -0.25
)
} else if (theme$legend.position %in% c("left", "right")) {
list(
yanchor = "middle",
y = position,
len = length,
orientation = orientation,
xanchor = if (isLeft) "right" else "left",
# left needs some additional space to dodge y-axis
# TODO: can we measure size of axis in npc?
x = if (isLeft) -0.25 else 1
)
} else if (is.numeric(theme$legend.position)) {
list(
x = theme$legend.position[1],
xanchor = "center",
y = theme$legend.position[2],
yanchor = "middle",
orientation = orientation
)
} else {
stop("Unrecognized legend positioning", call. = FALSE)
}
})
}


plotly_guide_legend <- function(gdef, theme, position, title) {
if (!is_guide_legend(gdef)) stop("gdef must be a legend", call. = FALSE)
legend <- list(
title = list(
# TODO: is it worth mapping to side?
text = title,
font = text2font(gdef$title.theme %||% theme$legend.text)
),
bgcolor = toRGB(theme$legend.background$fill),
bordercolor = toRGB(theme$legend.background$colour),
borderwidth = unitConvert(
theme$legend.background$size, "pixels", "width"
),
font = text2font(gdef$label.theme %||% theme$legend.text)
)
modifyList(legend, position)
}


# Colourbar(s) are implemented as an additional (hidden) trace(s)
# (Note these can't yet be displayed horizontally https://github.com/plotly/plotly.js/issues/1244)
plotly_guide_colorbars <- function(gdefs, theme, positions, gglayout) {
Map(function(gdef, position) {
if (!is_guide_colorbar(gdef)) stop("gdef must be a colourbar", call. = FALSE)

gdef$key <- gdef$key[!is.na(gdef$key$.value), ]
rng <- range(gdef$bar$value)
gdef$bar$value <- scales::rescale(gdef$bar$value, from = rng)
gdef$key$.value <- scales::rescale(gdef$key$.value, from = rng)

colorbar <- list(
bgcolor = toRGB(theme$legend.background$fill),
bordercolor = toRGB(theme$legend.background$colour),
borderwidth = unitConvert(
theme$legend.background$size, "pixels", "width"
),
thickness = unitConvert(
theme$legend.key.width, "pixels", "width"
),
title = gdef$title,
titlefont = text2font(gdef$title.theme %||% theme$legend.title),
tickmode = "array",
ticktext = gdef$key$.label,
tickvals = gdef$key$.value,
tickfont = text2font(gdef$label.theme %||% theme$legend.text),
ticklen = 2
)

colorbar <- modifyList(position, colorbar)
if (identical(colorbar$orientation, "h")) {
warning(
"plotly.js colorbars cannot (yet) be displayed horizontally ",
"https://github.com/plotly/plotly.js/issues/1244",
call. = FALSE
)
}

list(
x = with(gglayout$xaxis, if (identical(tickmode, "auto")) ticktext else tickvals)[[1]],
y = with(gglayout$yaxis, if (identical(tickmode, "auto")) ticktext else tickvals)[[1]],
Expand All @@ -1346,29 +1427,16 @@ gdef2trace <- function(gdef, theme, gglayout) {
marker = list(
color = c(0, 1),
colorscale = setNames(gdef$bar[c("value", "colour")], NULL),
colorbar = list(
bgcolor = toRGB(theme$legend.background$fill),
bordercolor = toRGB(theme$legend.background$colour),
borderwidth = unitConvert(
theme$legend.background$size, "pixels", "width"
),
thickness = unitConvert(
theme$legend.key.width, "pixels", "width"
),
title = gdef$title,
titlefont = text2font(gdef$title.theme %||% theme$legend.title),
tickmode = "array",
ticktext = gdef$key$.label,
tickvals = gdef$key$.value,
tickfont = text2font(gdef$label.theme %||% theme$legend.text),
ticklen = 2,
len = 1/2
)
colorbar = colorbar
)
)
} else {
# if plotly.js gets better support for multiple legends,
# that conversion should go here
NULL
}
}, gdefs, positions)
}

is_guide_colorbar <- function(x) {
inherits(x, "guide") && inherits(x, "colorbar")
}

is_guide_legend <- function(x) {
inherits(x, "guide") && inherits(x, "legend")
}
40 changes: 40 additions & 0 deletions tests/testthat/test-ggplot-legend-position.R
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,40 @@
content("legend-positioning")

expect_legend <- function(p, name, position = "right") {
p <- p + theme(legend.position = position)
name <- paste0(name, "-", position)
expect_doppelganger_built(p, name)
p <- p + theme(legend.direction = "horizontal")
expect_doppelganger_built(p, paste0(name, "-h"))
}

test_that("One legend positioning", {
one_legend <- ggplot(mtcars) +
geom_point(aes(wt, mpg, color = factor(cyl)))
expect_legend(one_legend, "one-legend", "right")
expect_legend(one_legend, "one-legend", "left")
expect_legend(one_legend, "one-legend", "top")
expect_legend(one_legend, "one-legend", "bottom")
})

test_that("One colorbar positioning", {
one_colorbar <- ggplot(mtcars) +
geom_point(aes(wt, mpg, color = mpg))
expect_legend(one_colorbar, "one-colorbar", "right")
expect_legend(one_colorbar, "one-colorbar", "left")
expect_legend(one_colorbar, "one-colorbar", "top")
expect_legend(one_colorbar, "one-colorbar", "bottom")
})


test_that("One legend & one colorbar positioning", {
both <- ggplot(mtcars) +
geom_point(aes(wt, mpg, color = mpg, shape = factor(cyl)))
expect_legend(both, "both", "right")
expect_legend(both, "both", "left")
expect_legend(both, "both", "top")
expect_legend(both, "both", "bottom")
})



0 comments on commit 16a567f

Please sign in to comment.