Skip to content

Commit 5064223

Browse files
cpsievertcpsievert
committed
Use new legend titles and support theme(legend.position=...) & theme(legend.direction=...), closes #1049 
1 parent c19594b commit 5064223

File tree

2 files changed

+194
-86
lines changed

2 files changed

+194
-86
lines changed

‎R/ggplotly.R

+154-86
Original file line numberDiff line numberDiff line change
@@ -912,83 +912,69 @@ gg2list <- function(p, width = NULL, height = NULL,
912912
# will there be a legend?
913913
gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) >= 1
914914

915-
# legend styling
916-
gglayout$legend <- list(
917-
bgcolor = toRGB(theme$legend.background$fill),
918-
bordercolor = toRGB(theme$legend.background$colour),
919-
borderwidth = unitConvert(theme$legend.background$size, "pixels", "width"),
920-
font = text2font(theme$legend.text)
921-
)
922-
923915
# if theme(legend.position = "none") is used, don't show a legend _or_ guide
924916
if (npscales$n() == 0 || identical(theme$legend.position, "none")) {
925917
gglayout$showlegend <- FALSE
926918
} else {
927-
# by default, guide boxes are vertically aligned
928-
theme$legend.box <- theme$legend.box %||% "vertical"
929919

930-
# size of key (also used for bar in colorbar guide)
920+
# ------------------------------------------------------------------
921+
# Copied from body of ggplot2:::guides_build().
931922
theme$legend.key.width <- theme$legend.key.width %||% theme$legend.key.size
932923
theme$legend.key.height <- theme$legend.key.height %||% theme$legend.key.size
933-
934-
# legend direction must be vertical
935-
theme$legend.direction <- theme$legend.direction %||% "vertical"
936-
if (!identical(theme$legend.direction, "vertical")) {
937-
warning(
938-
"plotly.js does not (yet) support horizontal legend items \n",
939-
"You can track progress here: \n",
940-
"https://github.com/plotly/plotly.js/issues/53 \n",
941-
call. = FALSE
942-
)
943-
theme$legend.direction <- "vertical"
924+
# Layout of legends depends on their overall location
925+
position <- ggfun("legend_position")(theme$legend.position %||% "right")
926+
if (position == "inside") {
927+
theme$legend.box <- theme$legend.box %||% "vertical"
928+
theme$legend.direction <- theme$legend.direction %||% "vertical"
929+
theme$legend.box.just <- theme$legend.box.just %||% c("center", "center")
930+
} else if (position == "vertical") {
931+
theme$legend.box <- theme$legend.box %||% "vertical"
932+
theme$legend.direction <- theme$legend.direction %||% "vertical"
933+
theme$legend.box.just <- theme$legend.box.just %||% c("left", "top")
934+
} else if (position == "horizontal") {
935+
theme$legend.box <- theme$legend.box %||% "horizontal"
936+
theme$legend.direction <- theme$legend.direction %||% "horizontal"
937+
theme$legend.box.just <- theme$legend.box.just %||% c("center", "top")
944938
}
945939

946-
# justification of legend boxes
947-
theme$legend.box.just <- theme$legend.box.just %||% c("center", "center")
948-
# scales -> data for guides
949940
gdefs <- ggfun("guides_train")(scales, theme, plot$guides, plot$labels)
950941
if (length(gdefs) > 0) {
951942
gdefs <- ggfun("guides_merge")(gdefs)
952943
gdefs <- ggfun("guides_geom")(gdefs, layers, plot$mapping)
953944
}
945+
# ------------------------------------------------------------------
954946

955-
# colourbar -> plotly.js colorbar
956-
colorbar <- compact(lapply(gdefs, gdef2trace, theme, gglayout))
957-
nguides <- length(colorbar) + gglayout$showlegend
958-
# If we have 2 or more guides, set x/y positions accordingly
959-
if (nguides >= 2) {
960-
# place legend at the bottom
961-
gglayout$legend$y <- 1 / nguides
962-
gglayout$legend$yanchor <- "top"
963-
# adjust colorbar position(s)
964-
for (i in seq_along(colorbar)) {
965-
colorbar[[i]]$marker$colorbar$yanchor <- "top"
966-
colorbar[[i]]$marker$colorbar$len <- 1 / nguides
967-
colorbar[[i]]$marker$colorbar$y <- 1 - (i - 1) * (1 / nguides)
968-
}
969-
}
970-
traces <- c(traces, colorbar)
947+
# Until plotly.js has multiple legend support, we're stuck with smashing
948+
# all legends into one...
949+
legendTitle <- paste(
950+
compact(lapply(gdefs, function(g) if (inherits(g, "legend")) g$title else NULL)),
951+
collapse = br()
952+
)
953+
954+
# Discard everything but the first legend and colourbar(s)
955+
is_legend <- vapply(gdefs, is_guide_legend, logical(1))
956+
is_colorbar <- vapply(gdefs, is_guide_colorbar, logical(1))
957+
gdefs <- c(
958+
gdefs[is_colorbar],
959+
if (gglayout$showlegend) gdefs[which(is_legend)[1]]
960+
)
971961

972-
# legend title annotation - https://github.com/plotly/plotly.js/issues/276
973-
if (isTRUE(gglayout$showlegend)) {
974-
legendTitles <- compact(lapply(gdefs, function(g) if (inherits(g, "legend")) g$title else NULL))
975-
legendTitle <- paste(legendTitles, collapse = br())
976-
titleAnnotation <- make_label(
977-
legendTitle,
978-
x = gglayout$legend$x %||% 1.02,
979-
y = gglayout$legend$y %||% 1,
980-
theme$legend.title,
981-
xanchor = "left",
982-
yanchor = "bottom",
983-
# just so the R client knows this is a title
984-
legendTitle = TRUE
962+
# Get plotly.js positioning and orientation of all the guides at once
963+
positions <- plotly_guide_positions(gdefs, theme)
964+
965+
# Convert the legend
966+
is_legend <- vapply(gdefs, is_guide_legend, logical(1))
967+
if (sum(is_legend) == 1) {
968+
idx <- which(is_legend)
969+
gglayout$legend <- plotly_guide_legend(
970+
gdefs[[idx]], theme,
971+
positions[[idx]], legendTitle
985972
)
986-
gglayout$annotations <- c(gglayout$annotations, titleAnnotation)
987-
# adjust the height of the legend to accomodate for the title
988-
# this assumes the legend always appears below colorbars
989-
gglayout$legend$y <- (gglayout$legend$y %||% 1) -
990-
length(legendTitles) * unitConvert(theme$legend.title$size, "npc", "height")
991973
}
974+
975+
# Convert the colorbars
976+
is_colorbar <- vapply(gdefs, is_guide_colorbar, logical(1))
977+
traces <- c(traces, plotly_guide_colorbars(gdefs[is_colorbar], theme, positions[is_colorbar], gglayout))
992978
}
993979

994980
# flip x/y in traces for flipped coordinates
@@ -1331,14 +1317,109 @@ ggtype <- function(x, y = "geom") {
13311317
sub(y, "", tolower(class(x[[y]])[1]))
13321318
}
13331319

1334-
# colourbar -> plotly.js colorbar
1335-
gdef2trace <- function(gdef, theme, gglayout) {
1336-
if (inherits(gdef, "colorbar")) {
1337-
# sometimes the key has missing values, which we can ignore
1320+
1321+
plotly_guide_positions <- function(gdefs, theme) {
1322+
length <- 1 / length(gdefs)
1323+
isTop <- "top" %in% theme$legend.position
1324+
isLeft <- "left" %in% theme$legend.position
1325+
1326+
lapply(seq_along(gdefs), function(i) {
1327+
position <- (i / length(gdefs)) - (0.5 * length)
1328+
orientation <- substr(gdefs[[i]]$direction, 1, 1)
1329+
if (theme$legend.position %in% c("top", "bottom")) {
1330+
list(
1331+
xanchor = "center",
1332+
x = position,
1333+
len = length,
1334+
orientation = orientation,
1335+
yanchor = if (isTop) "bottom" else "top",
1336+
# bottom needs some additional space to dodge x-axis
1337+
# TODO: can we measure size of axis in npc?
1338+
y = if (isTop) 1 else -0.25
1339+
)
1340+
} else if (theme$legend.position %in% c("left", "right")) {
1341+
list(
1342+
yanchor = "middle",
1343+
y = position,
1344+
len = length,
1345+
orientation = orientation,
1346+
xanchor = if (isLeft) "right" else "left",
1347+
# left needs some additional space to dodge y-axis
1348+
# TODO: can we measure size of axis in npc?
1349+
x = if (isLeft) -0.25 else 1
1350+
)
1351+
} else if (is.numeric(theme$legend.position)) {
1352+
list(
1353+
x = theme$legend.position[1],
1354+
xanchor = "center",
1355+
y = theme$legend.position[2],
1356+
yanchor = "middle",
1357+
orientation = orientation
1358+
)
1359+
} else {
1360+
stop("Unrecognized legend positioning", call. = FALSE)
1361+
}
1362+
})
1363+
}
1364+
1365+
1366+
plotly_guide_legend <- function(gdef, theme, position, title) {
1367+
if (!is_guide_legend(gdef)) stop("gdef must be a legend", call. = FALSE)
1368+
legend <- list(
1369+
title = list(
1370+
# TODO: is it worth mapping to side?
1371+
text = title,
1372+
font = text2font(gdef$title.theme %||% theme$legend.text)
1373+
),
1374+
bgcolor = toRGB(theme$legend.background$fill),
1375+
bordercolor = toRGB(theme$legend.background$colour),
1376+
borderwidth = unitConvert(
1377+
theme$legend.background$size, "pixels", "width"
1378+
),
1379+
font = text2font(gdef$label.theme %||% theme$legend.text)
1380+
)
1381+
modifyList(legend, position)
1382+
}
1383+
1384+
1385+
# Colourbar(s) are implemented as an additional (hidden) trace(s)
1386+
# (Note these can't yet be displayed horizontally https://github.com/plotly/plotly.js/issues/1244)
1387+
plotly_guide_colorbars <- function(gdefs, theme, positions, gglayout) {
1388+
Map(function(gdef, position) {
1389+
if (!is_guide_colorbar(gdef)) stop("gdef must be a colourbar", call. = FALSE)
1390+
13381391
gdef$key <- gdef$key[!is.na(gdef$key$.value), ]
13391392
rng <- range(gdef$bar$value)
13401393
gdef$bar$value <- scales::rescale(gdef$bar$value, from = rng)
13411394
gdef$key$.value <- scales::rescale(gdef$key$.value, from = rng)
1395+
1396+
colorbar <- list(
1397+
bgcolor = toRGB(theme$legend.background$fill),
1398+
bordercolor = toRGB(theme$legend.background$colour),
1399+
borderwidth = unitConvert(
1400+
theme$legend.background$size, "pixels", "width"
1401+
),
1402+
thickness = unitConvert(
1403+
theme$legend.key.width, "pixels", "width"
1404+
),
1405+
title = gdef$title,
1406+
titlefont = text2font(gdef$title.theme %||% theme$legend.title),
1407+
tickmode = "array",
1408+
ticktext = gdef$key$.label,
1409+
tickvals = gdef$key$.value,
1410+
tickfont = text2font(gdef$label.theme %||% theme$legend.text),
1411+
ticklen = 2
1412+
)
1413+
1414+
colorbar <- modifyList(position, colorbar)
1415+
if (identical(colorbar$orientation, "h")) {
1416+
warning(
1417+
"plotly.js colorbars cannot (yet) be displayed horizontally ",
1418+
"https://github.com/plotly/plotly.js/issues/1244",
1419+
call. = FALSE
1420+
)
1421+
}
1422+
13421423
list(
13431424
x = with(gglayout$xaxis, if (identical(tickmode, "auto")) ticktext else tickvals)[[1]],
13441425
y = with(gglayout$yaxis, if (identical(tickmode, "auto")) ticktext else tickvals)[[1]],
@@ -1353,29 +1434,16 @@ gdef2trace <- function(gdef, theme, gglayout) {
13531434
marker = list(
13541435
color = c(0, 1),
13551436
colorscale = setNames(gdef$bar[c("value", "colour")], NULL),
1356-
colorbar = list(
1357-
bgcolor = toRGB(theme$legend.background$fill),
1358-
bordercolor = toRGB(theme$legend.background$colour),
1359-
borderwidth = unitConvert(
1360-
theme$legend.background$size, "pixels", "width"
1361-
),
1362-
thickness = unitConvert(
1363-
theme$legend.key.width, "pixels", "width"
1364-
),
1365-
title = gdef$title,
1366-
titlefont = text2font(gdef$title.theme %||% theme$legend.title),
1367-
tickmode = "array",
1368-
ticktext = gdef$key$.label,
1369-
tickvals = gdef$key$.value,
1370-
tickfont = text2font(gdef$label.theme %||% theme$legend.text),
1371-
ticklen = 2,
1372-
len = 1/2
1373-
)
1437+
colorbar = colorbar
13741438
)
13751439
)
1376-
} else {
1377-
# if plotly.js gets better support for multiple legends,
1378-
# that conversion should go here
1379-
NULL
1380-
}
1440+
}, gdefs, positions)
1441+
}
1442+
1443+
is_guide_colorbar <- function(x) {
1444+
inherits(x, "guide") && inherits(x, "colorbar")
1445+
}
1446+
1447+
is_guide_legend <- function(x) {
1448+
inherits(x, "guide") && inherits(x, "legend")
13811449
}

‎tests/testthat/test-ggplot-legend-position.R

+40
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
content("legend-positioning")
2+
3+
expect_legend <- function(p, name, position = "right") {
4+
p <- p + theme(legend.position = position)
5+
name <- paste0(name, "-", position)
6+
expect_doppelganger_built(p, name)
7+
p <- p + theme(legend.direction = "horizontal")
8+
expect_doppelganger_built(p, paste0(name, "-h"))
9+
}
10+
11+
test_that("One legend positioning", {
12+
one_legend <- ggplot(mtcars) +
13+
geom_point(aes(wt, mpg, color = factor(cyl)))
14+
expect_legend(one_legend, "one-legend", "right")
15+
expect_legend(one_legend, "one-legend", "left")
16+
expect_legend(one_legend, "one-legend", "top")
17+
expect_legend(one_legend, "one-legend", "bottom")
18+
})
19+
20+
test_that("One colorbar positioning", {
21+
one_colorbar <- ggplot(mtcars) +
22+
geom_point(aes(wt, mpg, color = mpg))
23+
expect_legend(one_colorbar, "one-colorbar", "right")
24+
expect_legend(one_colorbar, "one-colorbar", "left")
25+
expect_legend(one_colorbar, "one-colorbar", "top")
26+
expect_legend(one_colorbar, "one-colorbar", "bottom")
27+
})
28+
29+
30+
test_that("One legend & one colorbar positioning", {
31+
both <- ggplot(mtcars) +
32+
geom_point(aes(wt, mpg, color = mpg, shape = factor(cyl)))
33+
expect_legend(both, "both", "right")
34+
expect_legend(both, "both", "left")
35+
expect_legend(both, "both", "top")
36+
expect_legend(both, "both", "bottom")
37+
})
38+
39+
40+

0 commit comments

Comments
 (0)