diff --git a/DESCRIPTION b/DESCRIPTION index 1d7e8d2ef4..109a6f27d6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -75,7 +75,8 @@ Suggests: palmerpenguins, rversions, reticulate, - rsvg + rsvg, + ggridges LazyData: true RoxygenNote: 7.2.3 Encoding: UTF-8 diff --git a/NAMESPACE b/NAMESPACE index 9fe5f8e0d5..cde1ebe817 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ S3method(geom2trace,GeomErrorbarh) S3method(geom2trace,GeomPath) S3method(geom2trace,GeomPoint) S3method(geom2trace,GeomPolygon) +S3method(geom2trace,GeomRidgelineGradient) S3method(geom2trace,GeomText) S3method(geom2trace,GeomTile) S3method(geom2trace,default) @@ -49,6 +50,9 @@ S3method(to_basic,GeomContour) S3method(to_basic,GeomCrossbar) S3method(to_basic,GeomDensity) S3method(to_basic,GeomDensity2d) +S3method(to_basic,GeomDensityLine) +S3method(to_basic,GeomDensityRidges) +S3method(to_basic,GeomDensityRidges2) S3method(to_basic,GeomDotplot) S3method(to_basic,GeomErrorbar) S3method(to_basic,GeomErrorbarh) @@ -65,6 +69,7 @@ S3method(to_basic,GeomRaster) S3method(to_basic,GeomRasterAnn) S3method(to_basic,GeomRect) S3method(to_basic,GeomRibbon) +S3method(to_basic,GeomRidgeline) S3method(to_basic,GeomRug) S3method(to_basic,GeomSegment) S3method(to_basic,GeomSf) diff --git a/NEWS.md b/NEWS.md index f56c1cf414..60173c95fd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,9 @@ # plotly (development version) +## New features + +* `ggplotly()` now supports the `{ggridges}` package. (#2314) + ## Bug fixes * Closed #2337: Creating a new `event_data()` handler no longer causes a spurious reactive update of existing `event_data()`s. (#2339) diff --git a/R/ggridges.R b/R/ggridges.R new file mode 100644 index 0000000000..ce64eb106d --- /dev/null +++ b/R/ggridges.R @@ -0,0 +1,272 @@ +#' Get data for ridge plots +#' +#' @param data dataframe, the data returned by `ggplot2::ggplot_build()`. +#' @param na.rm boolean, from params +#' +#' @return dataframe containing plotting data +#' +get_ridge_data <- function(data, na.rm) { + if (isTRUE(na.rm)) { + data <- data[stats::complete.cases(data[c("x", "ymin", "ymax")]), ] + } + + #if dataframe is empty there's nothing to draw + if (nrow(data) == 0) return(list()) + + # remove all points that fall below the minimum height + data$ymax[data$height < data$min_height] <- NA + + # order data + data <- data[order(data$ymin, data$x), ] + + # remove missing points + missing_pos <- !stats::complete.cases(data[c("x", "ymin", "ymax")]) + ids <- cumsum(missing_pos) + 1 + data$group <- paste0(data$group, "-", ids) + data[!missing_pos, ] +} + + +#' Prepare plotting data for ggridges +#' @param closed boolean, should the polygon be closed at bottom (TRUE for +#' geom_density_ridges2, FALSE for geom_density_ridges) +prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = FALSE, ...) { + d <- get_ridge_data(data, params$na.rm) + + # split data into separate groups + groups <- split(d, factor(d$group)) + + # sort list so lowest ymin values are in the front (opposite of ggridges) + o <- order( + unlist( + lapply( + groups, + function(data) data$ymin[1] + ) + ), + decreasing = FALSE + ) + groups <- groups[o] + + # for each group create a density + vline + point as applicable + res <- lapply( + rev(groups), + function(x) { + draw_stuff <- split(x, x$datatype) + + # first draw the basic density ridge part + stopifnot(!is.null(draw_stuff$ridgeline)) + + d2 <- d1 <- draw_stuff$ridgeline + if (!closed) d2$colour <- NA # no colour for density bottom line + + d1$y <- d1$ymax + d1$alpha <- 1 # don't use fill alpha for line alpha + + ridges <- list( + to_basic(prefix_class(d2, "GeomDensity")), + to_basic(prefix_class(d1, "GeomLine")) + ) + # attach the crosstalk group/set + ridges[[1]] <- structure(ridges[[1]], set = attr(d2, 'set')) # Density + ridges[[2]] <- structure(ridges[[2]], set = attr(d1, 'set')) # Line + + if ('vline' %in% names(draw_stuff)) { + draw_stuff$vline$xend <- draw_stuff$vline$x + draw_stuff$vline$yend <- draw_stuff$vline$ymax + draw_stuff$vline$y <- draw_stuff$vline$ymin + draw_stuff$vline$colour <- draw_stuff$vline$vline_colour + draw_stuff$vline$size <- draw_stuff$vline$vline_size + + vlines <- to_basic( + prefix_class(draw_stuff$vline, 'GeomSegment'), + prestats_data, layout, params, p, ... + ) + # attach the crosstalk group/set + vlines <- structure(vlines, set = attr(draw_stuff$vline, 'set')) + ridges <- c(ridges, list(vlines)) + } + + # points + if ('point' %in% names(draw_stuff)) { + draw_stuff$point$y <- draw_stuff$point$ymin + + # use point aesthetics + draw_stuff$point$shape <- draw_stuff$point$point_shape + draw_stuff$point$fill <- draw_stuff$point$point_fill + draw_stuff$point$stroke <- draw_stuff$point$point_stroke + draw_stuff$point$alpha <- draw_stuff$point$point_alpha + draw_stuff$point$colour <- draw_stuff$point$point_colour + draw_stuff$point$size <- draw_stuff$point$point_size + + points <- to_basic( + prefix_class(as.data.frame(draw_stuff$point), # remove ridge classes + 'GeomPoint'), + prestats_data, layout, params, p, ... + ) + # attach the crosstalk group/set + points <- structure(points, set = attr(draw_stuff$point, 'set')) + ridges <- c(ridges, list(points)) + } + + ridges + } + ) + res +} + + +#' @export +to_basic.GeomDensityRidgesGradient <- function(data, prestats_data, layout, params, p, ...) { + res <- prepare_ridge_chart(data, prestats_data, layout, params, p, FALSE, ...) + # set list depth to 1 + unlist(res, recursive = FALSE) +} + + +#' @export +to_basic.GeomDensityRidges <- function(data, prestats_data, layout, params, p, ...) { + to_basic( + prefix_class(data, 'GeomDensityRidgesGradient'), + prestats_data, layout, params, p, + closed = FALSE, + ... + ) +} + + +#' @export +to_basic.GeomDensityRidges2 <- function(data, prestats_data, layout, params, p, ...) { + to_basic( + prefix_class(data, 'GeomDensityRidgesGradient'), + prestats_data, layout, params, p, + closed = TRUE, + ... + ) +} + + + +#' @export +to_basic.GeomDensityLine <- function(data, prestats_data, layout, params, p, ...) { + to_basic(prefix_class(data, 'GeomDensity')) +} + + + +#' @export +to_basic.GeomRidgeline <- function(data, prestats_data, layout, params, p, ...) { + to_basic( + prefix_class(data, 'GeomDensityRidgesGradient'), + prestats_data, layout, params, p, ... + ) +} + + +#' @export +to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, p, ...) { + d <- get_ridge_data(data, params$na.rm) + + # split data into separate groups + groups <- split(d, factor(d$group)) + + # sort list so lowest ymin values are in the front (opposite of ggridges) + o <- order( + unlist( + lapply( + groups, + function(data) data$ymin[1] + ) + ), + decreasing = FALSE + ) + groups <- groups[o] + + # for each group create a density + vline + point as applicable + res <- lapply( + rev(groups), + function(x) { + + draw_stuff <- split(x, x$datatype) + + # first draw the basic density ridge part + + stopifnot(!is.null(draw_stuff$ridgeline)) + d2 <- d1 <- draw_stuff$ridgeline + d2$colour <- NA # no colour for density area + d2$fill_plotlyDomain <- NA + + d1$y <- d1$ymax + d1$alpha <- 1 # don't use fill alpha for line alpha + + # calculate all the positions where the fill type changes + fillchange <- c(FALSE, d2$fill[2:nrow(d2)] != d2$fill[1:nrow(d2)-1]) + + # and where the id changes + idchange <- c(TRUE, d2$group[2:nrow(d2)] != d2$group[1:nrow(d2)-1]) + + # make new ids from all changes in fill style or original id + d2$ids <- cumsum(fillchange | idchange) + + # get fill color for all ids + fill <- d2$fill[fillchange | idchange] + + # rows to be duplicated + dupl_rows <- which(fillchange & !idchange) + d2$y <- d2$ymax + if (length(dupl_rows) > 0) { + rows <- d2[dupl_rows, ] + rows$ids <- d2$ids[dupl_rows-1] + rows <- rows[rev(seq_len(nrow(rows))), , drop = FALSE] + # combine original and duplicated d2 + d2 <- rbind(d2, rows) + } + + # split by group to make polygons + d2 <- tibble::deframe(tidyr::nest(d2, .by = 'ids')) + + ridges <- c( + d2, + list( + to_basic(prefix_class(d1, "GeomLine")) + ) + ) + + ridges + } + ) + # set list depth to 1 + unlist(res, recursive = FALSE) +} + + + +#' @export +geom2trace.GeomRidgelineGradient <- function(data, params, p) { + # munching for polygon + positions <- data.frame( + x = c(data$x , rev(data$x)), + y = c(data$ymax, rev(data$ymin)) + ) + + L <- list( + x = positions[["x"]], + y = positions[["y"]], + text = uniq(data[["hovertext"]]), + key = data[["key"]], + customdata = data[["customdata"]], + frame = data[["frame"]], + ids = positions[["ids"]], + type = "scatter", + mode = "lines", + line = list( + width = aes2plotly(data, params, linewidth_or_size(GeomPolygon)), + color = toRGB('black'), + dash = aes2plotly(data, params, "linetype") + ), + fill = "toself", + fillcolor = toRGB(unique(data$fill[1])), + hoveron = hover_on(data) + ) + compact(L) +} diff --git a/man/get_ridge_data.Rd b/man/get_ridge_data.Rd new file mode 100644 index 0000000000..6487dd8441 --- /dev/null +++ b/man/get_ridge_data.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggridges.R +\name{get_ridge_data} +\alias{get_ridge_data} +\title{Get data for ridge plots} +\usage{ +get_ridge_data(data, na.rm) +} +\arguments{ +\item{data}{dataframe, the data returned by \code{ggplot2::ggplot_build()}.} + +\item{na.rm}{boolean, from params} +} +\value{ +dataframe containing plotting data +} +\description{ +Get data for ridge plots +} diff --git a/man/prepare_ridge_chart.Rd b/man/prepare_ridge_chart.Rd new file mode 100644 index 0000000000..64b5f84e0b --- /dev/null +++ b/man/prepare_ridge_chart.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ggridges.R +\name{prepare_ridge_chart} +\alias{prepare_ridge_chart} +\title{Prepare plotting data for ggridges} +\usage{ +prepare_ridge_chart( + data, + prestats_data, + layout, + params, + p, + closed = FALSE, + ... +) +} +\arguments{ +\item{closed}{boolean, should the polygon be closed at bottom (TRUE for +geom_density_ridges2, FALSE for geom_density_ridges)} +} +\description{ +Prepare plotting data for ggridges +} diff --git a/tests/testthat/_snaps/ggridges/basic-ridgeline.svg b/tests/testthat/_snaps/ggridges/basic-ridgeline.svg new file mode 100644 index 0000000000..6470518639 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/basic-ridgeline.svg @@ -0,0 +1 @@ +1234512345xy diff --git a/tests/testthat/_snaps/ggridges/cutting-tails.svg b/tests/testthat/_snaps/ggridges/cutting-tails.svg new file mode 100644 index 0000000000..d3cec4781b --- /dev/null +++ b/tests/testthat/_snaps/ggridges/cutting-tails.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/density-ridgeline.svg b/tests/testthat/_snaps/ggridges/density-ridgeline.svg new file mode 100644 index 0000000000..157a558b91 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/density-ridgeline.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/density-ridgeline2.svg b/tests/testthat/_snaps/ggridges/density-ridgeline2.svg new file mode 100644 index 0000000000..101d8a7af9 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/density-ridgeline2.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/histogram-ridges.svg b/tests/testthat/_snaps/ggridges/histogram-ridges.svg new file mode 100644 index 0000000000..9f23a883ca --- /dev/null +++ b/tests/testthat/_snaps/ggridges/histogram-ridges.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/jittering-points.svg b/tests/testthat/_snaps/ggridges/jittering-points.svg new file mode 100644 index 0000000000..f54c7ab31a --- /dev/null +++ b/tests/testthat/_snaps/ggridges/jittering-points.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/manual-densities-stat-identity.svg b/tests/testthat/_snaps/ggridges/manual-densities-stat-identity.svg new file mode 100644 index 0000000000..6478859f2c --- /dev/null +++ b/tests/testthat/_snaps/ggridges/manual-densities-stat-identity.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/multiple-ridgelines.svg b/tests/testthat/_snaps/ggridges/multiple-ridgelines.svg new file mode 100644 index 0000000000..8f81ceab01 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/multiple-ridgelines.svg @@ -0,0 +1 @@ +123450246xy diff --git a/tests/testthat/_snaps/ggridges/negative-height-cut.svg b/tests/testthat/_snaps/ggridges/negative-height-cut.svg new file mode 100644 index 0000000000..ada40d8242 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/negative-height-cut.svg @@ -0,0 +1 @@ +1234501234xy diff --git a/tests/testthat/_snaps/ggridges/negative-height-retained.svg b/tests/testthat/_snaps/ggridges/negative-height-retained.svg new file mode 100644 index 0000000000..6619000ff9 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/negative-height-retained.svg @@ -0,0 +1 @@ +1234501234xy diff --git a/tests/testthat/_snaps/ggridges/numeric-grouping.svg b/tests/testthat/_snaps/ggridges/numeric-grouping.svg new file mode 100644 index 0000000000..dda54b9513 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/numeric-grouping.svg @@ -0,0 +1 @@ +456781234Sepal.LengthSpecies_num diff --git a/tests/testthat/_snaps/ggridges/overlapping-facet-touching.svg b/tests/testthat/_snaps/ggridges/overlapping-facet-touching.svg new file mode 100644 index 0000000000..44404fbe21 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/overlapping-facet-touching.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginica4567845678Sepal.LengthSpeciessetosaversicolorvirginica diff --git a/tests/testthat/_snaps/ggridges/overlapping-lot.svg b/tests/testthat/_snaps/ggridges/overlapping-lot.svg new file mode 100644 index 0000000000..09d33ec376 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/overlapping-lot.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/overlapping-none.svg b/tests/testthat/_snaps/ggridges/overlapping-none.svg new file mode 100644 index 0000000000..0fa74c66dc --- /dev/null +++ b/tests/testthat/_snaps/ggridges/overlapping-none.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/overlapping-touching.svg b/tests/testthat/_snaps/ggridges/overlapping-touching.svg new file mode 100644 index 0000000000..dcd1b8272b --- /dev/null +++ b/tests/testthat/_snaps/ggridges/overlapping-touching.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/quantile-colouring-tails-only.svg b/tests/testthat/_snaps/ggridges/quantile-colouring-tails-only.svg new file mode 100644 index 0000000000..ab723e641c --- /dev/null +++ b/tests/testthat/_snaps/ggridges/quantile-colouring-tails-only.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaProbability123Sepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/quantile-colouring.svg b/tests/testthat/_snaps/ggridges/quantile-colouring.svg new file mode 100644 index 0000000000..34995647f1 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/quantile-colouring.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaQuartiles1234Sepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/quantile-cut-points.svg b/tests/testthat/_snaps/ggridges/quantile-cut-points.svg new file mode 100644 index 0000000000..f0b6ad9038 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/quantile-cut-points.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/quantile-lines-1.svg b/tests/testthat/_snaps/ggridges/quantile-lines-1.svg new file mode 100644 index 0000000000..8fc3a3de27 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/quantile-lines-1.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/quantile-lines-multi.svg b/tests/testthat/_snaps/ggridges/quantile-lines-multi.svg new file mode 100644 index 0000000000..b35ea39f16 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/quantile-lines-multi.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/raincloud-effect.svg b/tests/testthat/_snaps/ggridges/raincloud-effect.svg new file mode 100644 index 0000000000..3cad788ca5 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/raincloud-effect.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg b/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg new file mode 100644 index 0000000000..167e863b1c --- /dev/null +++ b/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/stat-density.svg b/tests/testthat/_snaps/ggridges/stat-density.svg new file mode 100644 index 0000000000..8542cf6651 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/stat-density.svg @@ -0,0 +1 @@ +5678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/stat-identity.svg b/tests/testthat/_snaps/ggridges/stat-identity.svg new file mode 100644 index 0000000000..bfd9b447e7 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/stat-identity.svg @@ -0,0 +1 @@ +123450123xy diff --git a/tests/testthat/_snaps/ggridges/styling-points.svg b/tests/testthat/_snaps/ggridges/styling-points.svg new file mode 100644 index 0000000000..3afb3a94b4 --- /dev/null +++ b/tests/testthat/_snaps/ggridges/styling-points.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaSpeciesvirginicaversicolorsetosaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/styling-points2.svg b/tests/testthat/_snaps/ggridges/styling-points2.svg new file mode 100644 index 0000000000..762718104a --- /dev/null +++ b/tests/testthat/_snaps/ggridges/styling-points2.svg @@ -0,0 +1 @@ +45678setosaversicolorvirginicaPetal.LengthSpecies(virginica,1)(versicolor,1)(setosa,1)Sepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/varying-fill-colours.svg b/tests/testthat/_snaps/ggridges/varying-fill-colours.svg new file mode 100644 index 0000000000..ce8b5ceb6f --- /dev/null +++ b/tests/testthat/_snaps/ggridges/varying-fill-colours.svg @@ -0,0 +1 @@ +1234502468NA4.65.66.67.68.62.33.34.35.36.312345xy diff --git a/tests/testthat/test-ggridges.R b/tests/testthat/test-ggridges.R new file mode 100644 index 0000000000..feca915ae6 --- /dev/null +++ b/tests/testthat/test-ggridges.R @@ -0,0 +1,313 @@ +skip_if_not_installed("ggridges") +library(ggridges) + +test_that( + desc = "ggridges basic ridgelines", + code = { + + # simple ridge plot + data <- data.frame(x = 1:5, y = rep(1, 5), height = c(0, 1, 3, 4, 2)) + p <- ggplot(data, aes(x, y, height = height)) + geom_ridgeline() + + p2 <- ggplotly(p) + + expect_doppelganger(p2, 'basic_ridgeline') + + + # Negative height + data <- data.frame(x = 1:5, y = rep(1, 5), height = c(0, 1, -1, 3, 2)) + plot_base <- ggplot(data, aes(x, y, height = height)) + + ## Negative height cut off + p <- plot_base + geom_ridgeline() + + p2 <- ggplotly(p) + expect_doppelganger(p2, 'negative_height_cut') + + + ## Negative height allowed + p <- plot_base + geom_ridgeline(min_height = -2) + + p2 <- ggplotly(p) + expect_doppelganger(p2, 'negative_height_retained') + + + # Multiple ridgelines at same time + d <- data.frame( + x = rep(1:5, 3), + y = c(rep(0, 5), rep(1, 5), rep(2, 5)), + height = c(0, 1, 3, 4, 0, 1, 2, 3, 5, 4, 0, 5, 4, 4, 1) + ) + + p <- ggplot(d, aes(x, y, height = height, group = y)) + + geom_ridgeline(fill = "lightblue") + + p2 <- ggplotly(p) + expect_doppelganger(p2, 'multiple_ridgelines') + + # stat = identity (works) + p <- ggplot(d, aes(x, y, height = height, group = y)) + + geom_density_ridges(stat = "identity", scale = 1) + + p2 <- ggplotly(p) + expect_doppelganger(p2, 'stat_identity') + } +) + +test_that( + desc = "ggridges density_ridgeline", + code = { + + # Density ridgeline plots + + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges() + p2 <- ggplotly(p) + expect_doppelganger(p2, 'density_ridgeline') + + # geom_density_ridges2 (closed polygon) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges2() + p2 <- ggplotly(p) + expect_doppelganger(p2, 'density_ridgeline2') + + # Grouping aesthetic + # modified dataset that represents species as a number + iris_num <- transform(iris, Species_num = as.numeric(Species)) + + p <- ggplot(iris_num, + aes(x = Sepal.Length, + y = Species_num, + group = Species_num)) + + geom_density_ridges() + p2 <- ggplotly(p) + expect_doppelganger(p2, 'numeric_grouping') + + # Cutting trailing tails (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(rel_min_height = 0.01) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'cutting_tails') + + # Non-overlapping ridges (Works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(scale = 0.9) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'overlapping_none') + + + # Exactly touching (Works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(scale = 1) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'overlapping_touching') + + + # scale = 5, substantial overlap (Works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(scale = 5) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'overlapping_lot') + + + # Panel scaling (Works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(scale = 1) + facet_wrap(~Species) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'overlapping_facet_touching') + + } +) + +test_that( + desc = "ggridges fill colours", + code = { + + # Varying fill colors along the x axis + + # Example 1 (Works, but extra legend that is not shown in ggridges) + d <- data.frame( + x = rep(1:5, 3) + c(rep(0, 5), rep(0.3, 5), rep(0.6, 5)), + y = c(rep(0, 5), rep(1, 5), rep(3, 5)), + height = c(0, 1, 3, 4, 0, 1, 2, 3, 5, 4, 0, 5, 4, 4, 1)) + + p <- ggplot(d, aes(x, y, height = height, group = y, fill = factor(x+y))) + + geom_ridgeline_gradient() + + scale_fill_viridis_d(direction = -1, guide = "none") + p2 <- ggplotly(p) + expect_doppelganger(p2, 'varying_fill_colours') + + # geom_density_ridges_gradient (Doesn't work) + # p <- ggplot(lincoln_weather, aes(x = `Mean Temperature [F]`, y = Month, fill = stat(x))) + + # geom_density_ridges_gradient(scale = 3, rel_min_height = 0.01) + + # scale_fill_viridis_c(name = "Temp. [F]", option = "C") + + # labs(title = 'Temperatures in Lincoln NE in 2016') + # ggplotly(p) # gets stuck + + # Stats + + ## Quantile lines and coloring by quantiles or probabilities (Works) + + # quantile multiple lines + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + stat_density_ridges(quantile_lines = TRUE) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'quantile_lines_multi') + + # quantile single line + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + stat_density_ridges(quantile_lines = TRUE, quantiles = 2) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'quantile_lines_1') + + # quantile by cut points + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + stat_density_ridges(quantile_lines = TRUE, + quantiles = c(0.025, 0.975), + alpha = 0.7) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'quantile_cut_points') + + + ## Colour by quantile + # warning since ggridges uses stat(quantile) + suppressWarnings( + p <- ggplot(iris, aes(x=Sepal.Length, y=Species, fill = factor(stat(quantile)))) + + stat_density_ridges( + geom = "density_ridges_gradient", calc_ecdf = TRUE, + quantiles = 4, quantile_lines = TRUE + ) + + scale_fill_viridis_d(name = "Quartiles") + ) + + suppressWarnings( + p2 <- ggplotly(p) + ) + expect_doppelganger(p2, 'quantile_colouring') + + + # highglight tails of distributions (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = factor(stat(quantile)))) + + stat_density_ridges( + geom = "density_ridges_gradient", + calc_ecdf = TRUE, + quantiles = c(0.025, 0.975) + ) + + scale_fill_manual( + name = "Probability", values = c("#FF0000A0", "#A0A0A0A0", "#0000FFA0"), + labels = c("(0, 0.025]", "(0.025, 0.975]", "(0.975, 1]") + ) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'quantile_colouring_tails_only') + + # mapping prob onto colour (doesn't work) + # p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = 0.5 - abs(0.5 - stat(ecdf)))) + + # stat_density_ridges(geom = "density_ridges_gradient", calc_ecdf = TRUE) + + # scale_fill_viridis_c(name = "Tail probability", direction = -1) + # ggplotly(p) + + + } +) + + +test_that( + desc = "ggridges points", + code = { + + set.seed(123) # make jittering reproducible + # jittering points (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(jittered_points = TRUE) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'jittering points') + + # raincloud effect (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges( + jittered_points = TRUE, position = "raincloud", + alpha = 0.7, scale = 0.9 + ) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'raincloud_effect') + + # rug effect (doesn't work, point shape not taken into account) + # p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + # geom_density_ridges( + # jittered_points = TRUE, + # position = position_points_jitter(width = 0.05, height = 0), + # point_shape = '|', point_size = 3, point_alpha = 1, alpha = 0.7, + # ) + + + # styling points + p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = Species)) + + geom_density_ridges( + aes(point_color = Species, point_fill = Species, point_shape = Species), + alpha = .2, point_alpha = 1, jittered_points = TRUE + ) + + scale_point_color_hue(l = 40) + + scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23)) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'styling_points') + + # styling points 2 + p <- ggplot(iris, aes(x = Sepal.Length, y = Species, fill = Species)) + + geom_density_ridges( + aes(point_shape = Species, point_fill = Species, point_size = Petal.Length), + alpha = .2, point_alpha = 1, jittered_points = TRUE + ) + + scale_point_color_hue(l = 40) + scale_point_size_continuous(range = c(0.5, 4)) + + scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23)) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'styling_points2') + + + # aesthetics for vertical line (works) (might need to check line on top of points) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges( + jittered_points = TRUE, quantile_lines = TRUE, scale = 0.9, alpha = 0.7, + vline_size = 1, vline_color = "red", + point_size = 0.4, point_alpha = 1, + position = position_raincloud(adjust_vlines = TRUE) + ) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'raincloud_vertical_line_points') + + } +) + + +test_that( + desc = "ggridges alternate stats", + code = { + + ## stat_density_ridges (works) + suppressWarnings({ + p <- ggplot(iris, aes(x = Sepal.Length, y = Species, height = stat(density))) + + geom_density_ridges(stat = "density") + + p2 <- ggplotly(p) + }) + expect_doppelganger(p2, 'stat_density') + + + skip_if_not_installed("dplyr") + iris_densities <- iris %>% + dplyr::group_by(Species) %>% + dplyr::group_modify(~ ggplot2:::compute_density(.x$Sepal.Length, NULL)) %>% + dplyr::rename(Sepal.Length = x) + + p <- ggplot(iris_densities, aes(x = Sepal.Length, y = Species, height = density)) + + geom_density_ridges(stat = "identity") + p2 <- ggplotly(p) + expect_doppelganger(p2, 'manual_densities_stat_identity') + + ## histograms (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species, height = stat(density))) + + geom_density_ridges(stat = "binline", bins = 20, scale = 0.95, draw_baseline = FALSE) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'histogram_ridges') + + } +) +