Skip to content

Commit fc009e3

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

File tree

1 file changed

+151
-87
lines changed

1 file changed

+151
-87
lines changed

‎R/ggplotly.R‎

Lines changed: 151 additions & 87 deletions
Original file line numberDiff line numberDiff line change
@@ -905,83 +905,65 @@ 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+
)
964946

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
978-
)
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")
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+
if (gglayout$showlegend) gdefs[which(is_legend)[1]],
952+
gdefs[is_colorbar]
953+
)
954+
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+
gglayout$legend <- plotly_guide_legend(gdefs[[1]], theme, positions[[1]], legendTitle)
984962
}
963+
964+
# Convert the colorbars
965+
is_colorbar <- vapply(gdefs, is_guide_colorbar, logical(1))
966+
traces <- c(traces, plotly_guide_colorbars(gdefs[is_colorbar], theme, positions[is_colorbar], gglayout))
985967
}
986968

987969
# flip x/y in traces for flipped coordinates
@@ -1324,14 +1306,109 @@ ggtype <- function(x, y = "geom") {
13241306
sub(y, "", tolower(class(x[[y]])[1]))
13251307
}
13261308

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

0 commit comments

Comments
 (0)