Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Legend position #1697

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Legend position #1697

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
240 changes: 154 additions & 86 deletions R/ggplotly.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -912,83 +912,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 @@ -1331,14 +1317,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 @@ -1353,29 +1434,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
Open in desktop
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")
})