Skip to content

Updates to better support dendrograms #818

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

Open
wants to merge 13 commits into
base: master
Choose a base branch
from
Open

Updates to better support dendrograms #818

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
13 commits
Select commit Hold shift + click to select a range
a6663c4
Improvements for dendrograms
jrowen Nov 30, 2016
208eed4
Improvements for dendrograms
jrowen Nov 30, 2016
9489610
Merge branch 'master' of https://github.com/jrowen/plotly
jrowen Nov 30, 2016
4dcdebb
Fix rect to handle coord flip
jrowen Nov 30, 2016
10936b4
Fix fontface
jrowen Nov 30, 2016
f7cce29
Fix fontface
jrowen Nov 30, 2016
7862f00
Fixed rect
jrowen Nov 30, 2016
3e63f3c
Cleanup hjust
jrowen Nov 30, 2016
16d097b
Clean-up GeomRect
jrowen Nov 30, 2016
dac04d2
Update fontface approach
jrowen Nov 30, 2016
180fcfd
Updated approach for guide = none
jrowen Nov 30, 2016
183b39f
Another guide = none attempt
jrowen Nov 30, 2016
88110c0
Added geom_text and geom_rect tests
jrowen Apr 12, 2017
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
41 changes: 35 additions & 6 deletions R/layers2traces.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
d <- datz[[i]]
# variables that produce multiple traces and deserve their own legend entries
split_legend <- paste0(names(discreteScales), "_plotlyDomain")
show_legend <- paste0(names(Filter(function(x) x$guide != "none", discreteScales)), "_plotlyDomain")
# add variable that produce multiple traces, but do _not_ deserve entries
split_by <- c(split_legend, "PANEL", "frame", split_on(d))
# ensure the factor level orders (which determines traces order)
Expand All @@ -120,7 +121,7 @@ layers2traces <- function(data, prestats_data, layout, p) {
trs <- Map(function(x, y) { x$set <- attr(y, "set"); x}, trs, dl)
# if we need a legend, set name/legendgroup/showlegend
# note: this allows us to control multiple traces from one legend entry
if (any(split_legend %in% names(d))) {
if (any(show_legend %in% names(d))) {
nms <- strsplit(names(trs), separator, fixed = TRUE)
nms <- vapply(nms, function(x) {
y <- unique(x[seq_along(split_legend)])
Expand Down Expand Up @@ -254,11 +255,26 @@ to_basic.GeomSegment <- function(data, prestats_data, layout, params, p, ...) {
to_basic.GeomRect <- function(data, prestats_data, layout, params, p, ...) {
data$group <- seq_len(nrow(data))
others <- data[!names(data) %in% c("xmin", "ymin", "xmax", "ymax", "y", "x")]
if (inherits(p$coordinates, "CoordFlip")) {
x_min <- layout$y_min
x_max <- layout$y_max
y_min <- layout$x_min
y_max <- layout$x_max
} else {
x_min <- layout$x_min
x_max <- layout$x_max
y_min <- layout$y_min
y_max <- layout$y_max
}
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is a lot of redundant code...

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Good point, I've simplified things a bit.

dat <- with(data, {
rbind(cbind(x = xmin, y = ymin, others),
cbind(x = xmin, y = ymax, others),
cbind(x = xmax, y = ymax, others),
cbind(x = xmax, y = ymin, others))
rbind(cbind(x = ifelse(xmin == -Inf, x_min, xmin),
y = ifelse(ymin == -Inf, y_min, ymin), others),
cbind(x = ifelse(xmin == -Inf, x_min, xmin),
y = ifelse(ymax == Inf, y_max, ymax), others),
cbind(x = ifelse(xmax == Inf, x_max, xmax),
y = ifelse(ymax == Inf, y_max, ymax), others),
cbind(x = ifelse(xmax == Inf, x_max, xmax),
y = ifelse(ymin == -Inf, y_min, ymin), others))
})
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Perhaps it's better (more efficient) to use is.finite() here?

prefix_class(dat, c("GeomPolygon", "GeomRect"))
}
Expand Down Expand Up @@ -603,10 +619,15 @@ geom2trace.GeomBoxplot <- function(data, params, p) {

#' @export
geom2trace.GeomText <- function(data, params, p) {
text <- as.character(data[["label"]])
i_ind <- grepl("italic", data[["fontface"]])
text[i_ind] <- paste0("<i>", text[i_ind], "</i>")
b_ind <- grepl("bold", data[["fontface"]])
text[b_ind] <- paste0("<b>", text[b_ind], "</b>")
compact(list(
x = data[["x"]],
y = data[["y"]],
text = data[["label"]],
text = text,
key = data[["key"]],
frame = data[["frame"]],
ids = data[["ids"]],
Expand All @@ -618,6 +639,14 @@ geom2trace.GeomText <- function(data, params, p) {
aes2plotly(data, params, "alpha")
)
),
textposition = paste0(
ifelse(data[["vjust"]] < 0.5, "top ",
ifelse(data[["vjust"]] > 0.5, "bottom ", "")
),
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Shouldn't the trailing whitespace be removed here (e.g., "top" not "top ")?

Copy link
Collaborator

@cpsievert cpsievert May 29, 2018 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ahh, nevermind. I see why it's done this why

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think this should default to "middle" (not "") though

ifelse(data[["hjust"]] < 0.5, "right",
ifelse(data[["vjust"]] > 0.5, "left", "center")
)
),
type = "scatter",
mode = "text",
hoveron = hover_on(data)
Expand Down
33 changes: 33 additions & 0 deletions tests/testthat/test-ggplot-rect.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -139,3 +139,36 @@ test_that('Specifying alpha in hex color code works', {
expect_match(info$data[[1]]$fillcolor, "rgba\\(0,0,0,0\\.0[6]+")
})

p1 = ggplot(data.frame(x = 1, y = 1)) +
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It'd be great to have another test that specifying ymin = 0.5/ymax = 1.5 gives the same result

geom_point(aes(x = x, y = y)) +
geom_rect(xmin = 0.9, xmax = 1.1, ymin = -Inf, ymax = Inf)
p2 = ggplot(data.frame(x = 1, y = 1)) +
geom_point(aes(x = x, y = y)) +
geom_rect(ymin = 0.9, ymax = 1.1, xmin = -Inf, xmax = Inf) +
coord_flip()
info1 <- save_outputs(p1, "rect-vert-inf")
info2 <- save_outputs(p2, "rect-vert-flip-inf")

test_that("rect vertical inf is translated correctly", {
expect_identical(info1$data[[2]]$x, c(0.9, 0.9, 1.1, 1.1, 0.9))
expect_identical(info1$data[[2]]$y, c(0.5, 1.5, 1.5, 0.5, 0.5))
expect_identical(info2$data[[2]]$x, c(0.9, 1.1, 1.1, 0.9, 0.9))
expect_identical(info2$data[[2]]$y, c(0.5, 0.5, 1.5, 1.5, 0.5))
})

p3 = ggplot(data.frame(x = 1, y = 1)) +
geom_point(aes(x = x, y = y)) +
geom_rect(ymin = 0.9, ymax = 1.1, xmin = -Inf, xmax = Inf)
p4 = ggplot(data.frame(x = 1, y = 1)) +
geom_point(aes(x = x, y = y)) +
geom_rect(xmin = 0.9, xmax = 1.1, ymin = -Inf, ymax = Inf) +
coord_flip()
info3 <- save_outputs(p3, "rect-hor-inf")
info4 <- save_outputs(p4, "rect-hor-flip-inf")

test_that("rect horizontal inf is translated correctly", {
expect_identical(info4$data[[2]]$y, c(0.9, 0.9, 1.1, 1.1, 0.9))
expect_identical(info4$data[[2]]$x, c(0.5, 1.5, 1.5, 0.5, 0.5))
expect_identical(info3$data[[2]]$y, c(0.9, 1.1, 1.1, 0.9, 0.9))
expect_identical(info3$data[[2]]$x, c(0.5, 0.5, 1.5, 1.5, 0.5))
})
25 changes: 25 additions & 0 deletions tests/testthat/test-ggplot-text.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -42,3 +42,28 @@ test_that("geom_text splits along colour", {
# Right colour for each trace
expect_true(L$data[[1]]$textfont$color != L$data[[2]]$textfont$color)
})

gg1 = ggplot(data.frame(x = seq(5, 25, 5), y = 60)) +
geom_point(aes(x = x, y = y)) +
geom_text(x = 5, y = 60, label = "nothing") +
geom_text(x = 10, y = 60, label = "bold", fontface = "bold", hjust = 0, vjust = 0) +
geom_text(x = 15, y = 60, label = "italic", fontface = "italic", hjust = 1, vjust = 1) +
geom_text(x = 20, y = 60, label = "bold italic", fontface = "bold.italic", hjust = 0, vjust = 1) +
geom_text(x = 25, y = 60, label = "plain", fontface = "plain", hjust = 1, vjust = 0)
info1 <- save_outputs(gg1, "text-fontjust")

test_that("fontface is translated correctly", {
expect_identical(info1$data[[2]]$text, rep("nothing", 5))
expect_identical(info1$data[[3]]$text, rep("<b>bold</b>", 5))
expect_identical(info1$data[[4]]$text, rep("<i>italic</i>", 5))
expect_identical(info1$data[[5]]$text, rep("<b><i>bold italic</i></b>", 5))
expect_identical(info1$data[[6]]$text, rep("plain", 5))
})

test_that("hjust/vjust is translated correctly", {
expect_identical(info1$data[[2]]$textposition, rep("center", 5))
expect_identical(info1$data[[3]]$textposition, rep("top right", 5))
expect_identical(info1$data[[4]]$textposition, rep("bottom left", 5))
expect_identical(info1$data[[5]]$textposition, rep("bottom right", 5))
expect_identical(info1$data[[6]]$textposition, rep("top center", 5))
})