Skip to content
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.

Commit 44499f2

Browse files
authoredMay 8, 2024
Add support for ggridges (#2314)
* add support for ggridges + associated tests * ggridges: formatting + remove commented code * ggridges: remove unnecessary test, put seed for jittered points * fix higlight working + formatting * ggridges support: update news.md
1 parent dc6455f commit 44499f2

34 files changed

+665
-1
lines changed
 

‎DESCRIPTION

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -75,7 +75,8 @@ Suggests:
7575
palmerpenguins,
7676
rversions,
7777
reticulate,
78-
rsvg
78+
rsvg,
79+
ggridges
7980
LazyData: true
8081
RoxygenNote: 7.2.3
8182
Encoding: UTF-8

‎NAMESPACE

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ S3method(geom2trace,GeomErrorbarh)
1313
S3method(geom2trace,GeomPath)
1414
S3method(geom2trace,GeomPoint)
1515
S3method(geom2trace,GeomPolygon)
16+
S3method(geom2trace,GeomRidgelineGradient)
1617
S3method(geom2trace,GeomText)
1718
S3method(geom2trace,GeomTile)
1819
S3method(geom2trace,default)
@@ -49,6 +50,9 @@ S3method(to_basic,GeomContour)
4950
S3method(to_basic,GeomCrossbar)
5051
S3method(to_basic,GeomDensity)
5152
S3method(to_basic,GeomDensity2d)
53+
S3method(to_basic,GeomDensityLine)
54+
S3method(to_basic,GeomDensityRidges)
55+
S3method(to_basic,GeomDensityRidges2)
5256
S3method(to_basic,GeomDotplot)
5357
S3method(to_basic,GeomErrorbar)
5458
S3method(to_basic,GeomErrorbarh)
@@ -65,6 +69,7 @@ S3method(to_basic,GeomRaster)
6569
S3method(to_basic,GeomRasterAnn)
6670
S3method(to_basic,GeomRect)
6771
S3method(to_basic,GeomRibbon)
72+
S3method(to_basic,GeomRidgeline)
6873
S3method(to_basic,GeomRug)
6974
S3method(to_basic,GeomSegment)
7075
S3method(to_basic,GeomSf)

‎NEWS.md

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,9 @@
11
# plotly (development version)
22

3+
## New features
4+
5+
* `ggplotly()` now supports the `{ggridges}` package. (#2314)
6+
37
## Bug fixes
48

59
* Closed #2337: Creating a new `event_data()` handler no longer causes a spurious reactive update of existing `event_data()`s. (#2339)

‎R/ggridges.R

Lines changed: 272 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,272 @@
1+
#' Get data for ridge plots
2+
#'
3+
#' @param data dataframe, the data returned by `ggplot2::ggplot_build()`.
4+
#' @param na.rm boolean, from params
5+
#'
6+
#' @return dataframe containing plotting data
7+
#'
8+
get_ridge_data <- function(data, na.rm) {
9+
if (isTRUE(na.rm)) {
10+
data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ]
11+
}
12+
13+
#if dataframe is empty there's nothing to draw
14+
if (nrow(data) == 0) return(list())
15+
16+
# remove all points that fall below the minimum height
17+
data$ymax[data$height < data$min_height] <- NA
18+
19+
# order data
20+
data <- data[order(data$ymin, data$x), ]
21+
22+
# remove missing points
23+
missing_pos <- !stats::complete.cases(data[c("x", "ymin", "ymax")])
24+
ids <- cumsum(missing_pos) + 1
25+
data$group <- paste0(data$group, "-", ids)
26+
data[!missing_pos, ]
27+
}
28+
29+
30+
#' Prepare plotting data for ggridges
31+
#' @param closed boolean, should the polygon be closed at bottom (TRUE for
32+
#' geom_density_ridges2, FALSE for geom_density_ridges)
33+
prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = FALSE, ...) {
34+
d <- get_ridge_data(data, params$na.rm)
35+
36+
# split data into separate groups
37+
groups <- split(d, factor(d$group))
38+
39+
# sort list so lowest ymin values are in the front (opposite of ggridges)
40+
o <- order(
41+
unlist(
42+
lapply(
43+
groups,
44+
function(data) data$ymin[1]
45+
)
46+
),
47+
decreasing = FALSE
48+
)
49+
groups <- groups[o]
50+
51+
# for each group create a density + vline + point as applicable
52+
res <- lapply(
53+
rev(groups),
54+
function(x) {
55+
draw_stuff <- split(x, x$datatype)
56+
57+
# first draw the basic density ridge part
58+
stopifnot(!is.null(draw_stuff$ridgeline))
59+
60+
d2 <- d1 <- draw_stuff$ridgeline
61+
if (!closed) d2$colour <- NA # no colour for density bottom line
62+
63+
d1$y <- d1$ymax
64+
d1$alpha <- 1 # don't use fill alpha for line alpha
65+
66+
ridges <- list(
67+
to_basic(prefix_class(d2, "GeomDensity")),
68+
to_basic(prefix_class(d1, "GeomLine"))
69+
)
70+
# attach the crosstalk group/set
71+
ridges[[1]] <- structure(ridges[[1]], set = attr(d2, 'set')) # Density
72+
ridges[[2]] <- structure(ridges[[2]], set = attr(d1, 'set')) # Line
73+
74+
if ('vline' %in% names(draw_stuff)) {
75+
draw_stuff$vline$xend <- draw_stuff$vline$x
76+
draw_stuff$vline$yend <- draw_stuff$vline$ymax
77+
draw_stuff$vline$y <- draw_stuff$vline$ymin
78+
draw_stuff$vline$colour <- draw_stuff$vline$vline_colour
79+
draw_stuff$vline$size <- draw_stuff$vline$vline_size
80+
81+
vlines <- to_basic(
82+
prefix_class(draw_stuff$vline, 'GeomSegment'),
83+
prestats_data, layout, params, p, ...
84+
)
85+
# attach the crosstalk group/set
86+
vlines <- structure(vlines, set = attr(draw_stuff$vline, 'set'))
87+
ridges <- c(ridges, list(vlines))
88+
}
89+
90+
# points
91+
if ('point' %in% names(draw_stuff)) {
92+
draw_stuff$point$y <- draw_stuff$point$ymin
93+
94+
# use point aesthetics
95+
draw_stuff$point$shape <- draw_stuff$point$point_shape
96+
draw_stuff$point$fill <- draw_stuff$point$point_fill
97+
draw_stuff$point$stroke <- draw_stuff$point$point_stroke
98+
draw_stuff$point$alpha <- draw_stuff$point$point_alpha
99+
draw_stuff$point$colour <- draw_stuff$point$point_colour
100+
draw_stuff$point$size <- draw_stuff$point$point_size
101+
102+
points <- to_basic(
103+
prefix_class(as.data.frame(draw_stuff$point), # remove ridge classes
104+
'GeomPoint'),
105+
prestats_data, layout, params, p, ...
106+
)
107+
# attach the crosstalk group/set
108+
points <- structure(points, set = attr(draw_stuff$point, 'set'))
109+
ridges <- c(ridges, list(points))
110+
}
111+
112+
ridges
113+
}
114+
)
115+
res
116+
}
117+
118+
119+
#' @export
120+
to_basic.GeomDensityRidgesGradient <- function(data, prestats_data, layout, params, p, ...) {
121+
res <- prepare_ridge_chart(data, prestats_data, layout, params, p, FALSE, ...)
122+
# set list depth to 1
123+
unlist(res, recursive = FALSE)
124+
}
125+
126+
127+
#' @export
128+
to_basic.GeomDensityRidges <- function(data, prestats_data, layout, params, p, ...) {
129+
to_basic(
130+
prefix_class(data, 'GeomDensityRidgesGradient'),
131+
prestats_data, layout, params, p,
132+
closed = FALSE,
133+
...
134+
)
135+
}
136+
137+
138+
#' @export
139+
to_basic.GeomDensityRidges2 <- function(data, prestats_data, layout, params, p, ...) {
140+
to_basic(
141+
prefix_class(data, 'GeomDensityRidgesGradient'),
142+
prestats_data, layout, params, p,
143+
closed = TRUE,
144+
...
145+
)
146+
}
147+
148+
149+
150+
#' @export
151+
to_basic.GeomDensityLine <- function(data, prestats_data, layout, params, p, ...) {
152+
to_basic(prefix_class(data, 'GeomDensity'))
153+
}
154+
155+
156+
157+
#' @export
158+
to_basic.GeomRidgeline <- function(data, prestats_data, layout, params, p, ...) {
159+
to_basic(
160+
prefix_class(data, 'GeomDensityRidgesGradient'),
161+
prestats_data, layout, params, p, ...
162+
)
163+
}
164+
165+
166+
#' @export
167+
to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, p, ...) {
168+
d <- get_ridge_data(data, params$na.rm)
169+
170+
# split data into separate groups
171+
groups <- split(d, factor(d$group))
172+
173+
# sort list so lowest ymin values are in the front (opposite of ggridges)
174+
o <- order(
175+
unlist(
176+
lapply(
177+
groups,
178+
function(data) data$ymin[1]
179+
)
180+
),
181+
decreasing = FALSE
182+
)
183+
groups <- groups[o]
184+
185+
# for each group create a density + vline + point as applicable
186+
res <- lapply(
187+
rev(groups),
188+
function(x) {
189+
190+
draw_stuff <- split(x, x$datatype)
191+
192+
# first draw the basic density ridge part
193+
194+
stopifnot(!is.null(draw_stuff$ridgeline))
195+
d2 <- d1 <- draw_stuff$ridgeline
196+
d2$colour <- NA # no colour for density area
197+
d2$fill_plotlyDomain <- NA
198+
199+
d1$y <- d1$ymax
200+
d1$alpha <- 1 # don't use fill alpha for line alpha
201+
202+
# calculate all the positions where the fill type changes
203+
fillchange <- c(FALSE, d2$fill[2:nrow(d2)] != d2$fill[1:nrow(d2)-1])
204+
205+
# and where the id changes
206+
idchange <- c(TRUE, d2$group[2:nrow(d2)] != d2$group[1:nrow(d2)-1])
207+
208+
# make new ids from all changes in fill style or original id
209+
d2$ids <- cumsum(fillchange | idchange)
210+
211+
# get fill color for all ids
212+
fill <- d2$fill[fillchange | idchange]
213+
214+
# rows to be duplicated
215+
dupl_rows <- which(fillchange & !idchange)
216+
d2$y <- d2$ymax
217+
if (length(dupl_rows) > 0) {
218+
rows <- d2[dupl_rows, ]
219+
rows$ids <- d2$ids[dupl_rows-1]
220+
rows <- rows[rev(seq_len(nrow(rows))), , drop = FALSE]
221+
# combine original and duplicated d2
222+
d2 <- rbind(d2, rows)
223+
}
224+
225+
# split by group to make polygons
226+
d2 <- tibble::deframe(tidyr::nest(d2, .by = 'ids'))
227+
228+
ridges <- c(
229+
d2,
230+
list(
231+
to_basic(prefix_class(d1, "GeomLine"))
232+
)
233+
)
234+
235+
ridges
236+
}
237+
)
238+
# set list depth to 1
239+
unlist(res, recursive = FALSE)
240+
}
241+
242+
243+
244+
#' @export
245+
geom2trace.GeomRidgelineGradient <- function(data, params, p) {
246+
# munching for polygon
247+
positions <- data.frame(
248+
x = c(data$x , rev(data$x)),
249+
y = c(data$ymax, rev(data$ymin))
250+
)
251+
252+
L <- list(
253+
x = positions[["x"]],
254+
y = positions[["y"]],
255+
text = uniq(data[["hovertext"]]),
256+
key = data[["key"]],
257+
customdata = data[["customdata"]],
258+
frame = data[["frame"]],
259+
ids = positions[["ids"]],
260+
type = "scatter",
261+
mode = "lines",
262+
line = list(
263+
width = aes2plotly(data, params, linewidth_or_size(GeomPolygon)),
264+
color = toRGB('black'),
265+
dash = aes2plotly(data, params, "linetype")
266+
),
267+
fill = "toself",
268+
fillcolor = toRGB(unique(data$fill[1])),
269+
hoveron = hover_on(data)
270+
)
271+
compact(L)
272+
}

‎man/get_ridge_data.Rd

Lines changed: 19 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/prepare_ridge_chart.Rd

Lines changed: 23 additions & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.
Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/cutting-tails.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/density-ridgeline.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/density-ridgeline2.svg

Lines changed: 1 addition & 0 deletions
Loading
Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/jittering-points.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/manual-densities-stat-identity.svg

Lines changed: 1 addition & 0 deletions
Loading
Lines changed: 1 addition & 0 deletions
Loading
Lines changed: 1 addition & 0 deletions
Loading
Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/numeric-grouping.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/overlapping-facet-touching.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/overlapping-lot.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/overlapping-none.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/overlapping-touching.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/quantile-colouring-tails-only.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/quantile-colouring.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/quantile-cut-points.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/quantile-lines-1.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/quantile-lines-multi.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/raincloud-effect.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/stat-density.svg

Lines changed: 1 addition & 0 deletions
Loading
Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/styling-points.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/styling-points2.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/_snaps/ggridges/varying-fill-colours.svg

Lines changed: 1 addition & 0 deletions
Loading

‎tests/testthat/test-ggridges.R

Lines changed: 313 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,313 @@
1+
skip_if_not_installed("ggridges")
2+
library(ggridges)
3+
4+
test_that(
5+
desc = "ggridges basic ridgelines",
6+
code = {
7+
8+
# simple ridge plot
9+
data <- data.frame(x = 1:5, y = rep(1, 5), height = c(0, 1, 3, 4, 2))
10+
p <- ggplot(data, aes(x, y, height = height)) + geom_ridgeline()
11+
12+
p2 <- ggplotly(p)
13+
14+
expect_doppelganger(p2, 'basic_ridgeline')
15+
16+
17+
# Negative height
18+
data <- data.frame(x = 1:5, y = rep(1, 5), height = c(0, 1, -1, 3, 2))
19+
plot_base <- ggplot(data, aes(x, y, height = height))
20+
21+
## Negative height cut off
22+
p <- plot_base + geom_ridgeline()
23+
24+
p2 <- ggplotly(p)
25+
expect_doppelganger(p2, 'negative_height_cut')
26+
27+
28+
## Negative height allowed
29+
p <- plot_base + geom_ridgeline(min_height = -2)
30+
31+
p2 <- ggplotly(p)
32+
expect_doppelganger(p2, 'negative_height_retained')
33+
34+
35+
# Multiple ridgelines at same time
36+
d <- data.frame(
37+
x = rep(1:5, 3),
38+
y = c(rep(0, 5), rep(1, 5), rep(2, 5)),
39+
height = c(0, 1, 3, 4, 0, 1, 2, 3, 5, 4, 0, 5, 4, 4, 1)
40+
)
41+
42+
p <- ggplot(d, aes(x, y, height = height, group = y)) +
43+
geom_ridgeline(fill = "lightblue")
44+
45+
p2 <- ggplotly(p)
46+
expect_doppelganger(p2, 'multiple_ridgelines')
47+
48+
# stat = identity (works)
49+
p <- ggplot(d, aes(x, y, height = height, group = y)) +
50+
geom_density_ridges(stat = "identity", scale = 1)
51+
52+
p2 <- ggplotly(p)
53+
expect_doppelganger(p2, 'stat_identity')
54+
}
55+
)
56+
57+
test_that(
58+
desc = "ggridges density_ridgeline",
59+
code = {
60+
61+
# Density ridgeline plots
62+
63+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
64+
geom_density_ridges()
65+
p2 <- ggplotly(p)
66+
expect_doppelganger(p2, 'density_ridgeline')
67+
68+
# geom_density_ridges2 (closed polygon)
69+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges2()
70+
p2 <- ggplotly(p)
71+
expect_doppelganger(p2, 'density_ridgeline2')
72+
73+
# Grouping aesthetic
74+
# modified dataset that represents species as a number
75+
iris_num <- transform(iris, Species_num = as.numeric(Species))
76+
77+
p <- ggplot(iris_num,
78+
aes(x = Sepal.Length,
79+
y = Species_num,
80+
group = Species_num)) +
81+
geom_density_ridges()
82+
p2 <- ggplotly(p)
83+
expect_doppelganger(p2, 'numeric_grouping')
84+
85+
# Cutting trailing tails (works)
86+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
87+
geom_density_ridges(rel_min_height = 0.01)
88+
p2 <- ggplotly(p)
89+
expect_doppelganger(p2, 'cutting_tails')
90+
91+
# Non-overlapping ridges (Works)
92+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
93+
geom_density_ridges(scale = 0.9)
94+
p2 <- ggplotly(p)
95+
expect_doppelganger(p2, 'overlapping_none')
96+
97+
98+
# Exactly touching (Works)
99+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
100+
geom_density_ridges(scale = 1)
101+
p2 <- ggplotly(p)
102+
expect_doppelganger(p2, 'overlapping_touching')
103+
104+
105+
# scale = 5, substantial overlap (Works)
106+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
107+
geom_density_ridges(scale = 5)
108+
p2 <- ggplotly(p)
109+
expect_doppelganger(p2, 'overlapping_lot')
110+
111+
112+
# Panel scaling (Works)
113+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
114+
geom_density_ridges(scale = 1) + facet_wrap(~Species)
115+
p2 <- ggplotly(p)
116+
expect_doppelganger(p2, 'overlapping_facet_touching')
117+
118+
}
119+
)
120+
121+
test_that(
122+
desc = "ggridges fill colours",
123+
code = {
124+
125+
# Varying fill colors along the x axis
126+
127+
# Example 1 (Works, but extra legend that is not shown in ggridges)
128+
d <- data.frame(
129+
x = rep(1:5, 3) + c(rep(0, 5), rep(0.3, 5), rep(0.6, 5)),
130+
y = c(rep(0, 5), rep(1, 5), rep(3, 5)),
131+
height = c(0, 1, 3, 4, 0, 1, 2, 3, 5, 4, 0, 5, 4, 4, 1))
132+
133+
p <- ggplot(d, aes(x, y, height = height, group = y, fill = factor(x+y))) +
134+
geom_ridgeline_gradient() +
135+
scale_fill_viridis_d(direction = -1, guide = "none")
136+
p2 <- ggplotly(p)
137+
expect_doppelganger(p2, 'varying_fill_colours')
138+
139+
# geom_density_ridges_gradient (Doesn't work)
140+
# p <- ggplot(lincoln_weather, aes(x = `Mean Temperature [F]`, y = Month, fill = stat(x))) +
141+
# geom_density_ridges_gradient(scale = 3, rel_min_height = 0.01) +
142+
# scale_fill_viridis_c(name = "Temp. [F]", option = "C") +
143+
# labs(title = 'Temperatures in Lincoln NE in 2016')
144+
# ggplotly(p) # gets stuck
145+
146+
# Stats
147+
148+
## Quantile lines and coloring by quantiles or probabilities (Works)
149+
150+
# quantile multiple lines
151+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
152+
stat_density_ridges(quantile_lines = TRUE)
153+
p2 <- ggplotly(p)
154+
expect_doppelganger(p2, 'quantile_lines_multi')
155+
156+
# quantile single line
157+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
158+
stat_density_ridges(quantile_lines = TRUE, quantiles = 2)
159+
p2 <- ggplotly(p)
160+
expect_doppelganger(p2, 'quantile_lines_1')
161+
162+
# quantile by cut points
163+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
164+
stat_density_ridges(quantile_lines = TRUE,
165+
quantiles = c(0.025, 0.975),
166+
alpha = 0.7)
167+
p2 <- ggplotly(p)
168+
expect_doppelganger(p2, 'quantile_cut_points')
169+
170+
171+
## Colour by quantile
172+
# warning since ggridges uses stat(quantile)
173+
suppressWarnings(
174+
p <- ggplot(iris, aes(x=Sepal.Length, y=Species, fill = factor(stat(quantile)))) +
175+
stat_density_ridges(
176+
geom = "density_ridges_gradient", calc_ecdf = TRUE,
177+
quantiles = 4, quantile_lines = TRUE
178+
) +
179+
scale_fill_viridis_d(name = "Quartiles")
180+
)
181+
182+
suppressWarnings(
183+
p2 <- ggplotly(p)
184+
)
185+
expect_doppelganger(p2, 'quantile_colouring')
186+
187+
188+
# highglight tails of distributions (works)
189+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = factor(stat(quantile)))) +
190+
stat_density_ridges(
191+
geom = "density_ridges_gradient",
192+
calc_ecdf = TRUE,
193+
quantiles = c(0.025, 0.975)
194+
) +
195+
scale_fill_manual(
196+
name = "Probability", values = c("#FF0000A0", "#A0A0A0A0", "#0000FFA0"),
197+
labels = c("(0, 0.025]", "(0.025, 0.975]", "(0.975, 1]")
198+
)
199+
p2 <- ggplotly(p)
200+
expect_doppelganger(p2, 'quantile_colouring_tails_only')
201+
202+
# mapping prob onto colour (doesn't work)
203+
# p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = 0.5 - abs(0.5 - stat(ecdf)))) +
204+
# stat_density_ridges(geom = "density_ridges_gradient", calc_ecdf = TRUE) +
205+
# scale_fill_viridis_c(name = "Tail probability", direction = -1)
206+
# ggplotly(p)
207+
208+
209+
}
210+
)
211+
212+
213+
test_that(
214+
desc = "ggridges points",
215+
code = {
216+
217+
set.seed(123) # make jittering reproducible
218+
# jittering points (works)
219+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
220+
geom_density_ridges(jittered_points = TRUE)
221+
p2 <- ggplotly(p)
222+
expect_doppelganger(p2, 'jittering points')
223+
224+
# raincloud effect (works)
225+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
226+
geom_density_ridges(
227+
jittered_points = TRUE, position = "raincloud",
228+
alpha = 0.7, scale = 0.9
229+
)
230+
p2 <- ggplotly(p)
231+
expect_doppelganger(p2, 'raincloud_effect')
232+
233+
# rug effect (doesn't work, point shape not taken into account)
234+
# p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
235+
# geom_density_ridges(
236+
# jittered_points = TRUE,
237+
# position = position_points_jitter(width = 0.05, height = 0),
238+
# point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7,
239+
# )
240+
241+
242+
# styling points
243+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = Species)) +
244+
geom_density_ridges(
245+
aes(point_color = Species, point_fill = Species, point_shape = Species),
246+
alpha = .2, point_alpha = 1, jittered_points = TRUE
247+
) +
248+
scale_point_color_hue(l = 40) +
249+
scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23))
250+
p2 <- ggplotly(p)
251+
expect_doppelganger(p2, 'styling_points')
252+
253+
# styling points 2
254+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = Species)) +
255+
geom_density_ridges(
256+
aes(point_shape = Species, point_fill = Species, point_size = Petal.Length),
257+
alpha = .2, point_alpha = 1, jittered_points = TRUE
258+
) +
259+
scale_point_color_hue(l = 40) + scale_point_size_continuous(range = c(0.5, 4)) +
260+
scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23))
261+
p2 <- ggplotly(p)
262+
expect_doppelganger(p2, 'styling_points2')
263+
264+
265+
# aesthetics for vertical line (works) (might need to check line on top of points)
266+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) +
267+
geom_density_ridges(
268+
jittered_points = TRUE, quantile_lines = TRUE, scale = 0.9, alpha = 0.7,
269+
vline_size = 1, vline_color = "red",
270+
point_size = 0.4, point_alpha = 1,
271+
position = position_raincloud(adjust_vlines = TRUE)
272+
)
273+
p2 <- ggplotly(p)
274+
expect_doppelganger(p2, 'raincloud_vertical_line_points')
275+
276+
}
277+
)
278+
279+
280+
test_that(
281+
desc = "ggridges alternate stats",
282+
code = {
283+
284+
## stat_density_ridges (works)
285+
suppressWarnings({
286+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species, height = stat(density))) +
287+
geom_density_ridges(stat = "density")
288+
289+
p2 <- ggplotly(p)
290+
})
291+
expect_doppelganger(p2, 'stat_density')
292+
293+
294+
skip_if_not_installed("dplyr")
295+
iris_densities <- iris %>%
296+
dplyr::group_by(Species) %>%
297+
dplyr::group_modify(~ ggplot2:::compute_density(.x$Sepal.Length, NULL)) %>%
298+
dplyr::rename(Sepal.Length = x)
299+
300+
p <- ggplot(iris_densities, aes(x = Sepal.Length, y = Species, height = density)) +
301+
geom_density_ridges(stat = "identity")
302+
p2 <- ggplotly(p)
303+
expect_doppelganger(p2, 'manual_densities_stat_identity')
304+
305+
## histograms (works)
306+
p <- ggplot(iris, aes(x = Sepal.Length, y = Species, height = stat(density))) +
307+
geom_density_ridges(stat = "binline", bins = 20, scale = 0.95, draw_baseline = FALSE)
308+
p2 <- ggplotly(p)
309+
expect_doppelganger(p2, 'histogram_ridges')
310+
311+
}
312+
)
313+

0 commit comments

Comments
 (0)
Please sign in to comment.