Skip to content

Commit 16a567f

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

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
@@ -905,83 +905,69 @@ gg2list <- function(p, width = NULL, height = NULL,
905905
# will there be a legend?
906906
gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) >= 1
907907

908-
# legend styling
909-
gglayout$legend <- list(
910-
bgcolor = toRGB(theme$legend.background$fill),
911-
bordercolor = toRGB(theme$legend.background$colour),
912-
borderwidth = unitConvert(theme$legend.background$size, "pixels", "width"),
913-
font = text2font(theme$legend.text)
914-
)
915-
916908
# if theme(legend.position = "none") is used, don't show a legend _or_ guide
917909
if (npscales$n() == 0 || identical(theme$legend.position, "none")) {
918910
gglayout$showlegend <- FALSE
919911
} else {
920-
# by default, guide boxes are vertically aligned
921-
theme$legend.box <- theme$legend.box %||% "vertical"
922912

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

939-
# justification of legend boxes
940-
theme$legend.box.just <- theme$legend.box.just %||% c("center", "center")
941-
# scales -> data for guides
942933
gdefs <- ggfun("guides_train")(scales, theme, plot$guides, plot$labels)
943934
if (length(gdefs) > 0) {
944935
gdefs <- ggfun("guides_merge")(gdefs)
945936
gdefs <- ggfun("guides_geom")(gdefs, layers, plot$mapping)
946937
}
938+
# ------------------------------------------------------------------
947939

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

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

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

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

‎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)