From c02b588cda5259a78987259821f46144521d5ad6 Mon Sep 17 00:00:00 2001 From: AdroMine Date: Sun, 5 Nov 2023 18:37:54 +0530 Subject: [PATCH 1/5] add support for ggridges + associated tests --- DESCRIPTION | 3 +- NAMESPACE | 5 + R/ggridges.R | 289 +++++++++++++++ man/get_ridge_data.Rd | 19 + man/prepare_ridge_chart.Rd | 23 ++ .../_snaps/ggridges/basic-ridgeline.svg | 1 + .../_snaps/ggridges/cutting-tails.svg | 1 + .../_snaps/ggridges/density-ridgeline.svg | 1 + .../_snaps/ggridges/density-ridgeline2.svg | 1 + .../_snaps/ggridges/histogram-ridges.svg | 1 + .../_snaps/ggridges/jittering-points.svg | 1 + .../manual-densities-stat-identity.svg | 1 + .../_snaps/ggridges/multiple-ridgelines.svg | 1 + .../_snaps/ggridges/negative-height-cut.svg | 1 + .../ggridges/negative-height-retained.svg | 1 + .../_snaps/ggridges/numeric-grouping.svg | 1 + .../ggridges/overlapping-facet-touching.svg | 1 + .../_snaps/ggridges/overlapping-lot.svg | 1 + .../_snaps/ggridges/overlapping-none.svg | 1 + .../_snaps/ggridges/overlapping-touching.svg | 1 + .../quantile-colouring-tails-only.svg | 1 + .../_snaps/ggridges/quantile-colouring.svg | 1 + .../_snaps/ggridges/quantile-cut-points.svg | 1 + .../_snaps/ggridges/quantile-lines-1.svg | 1 + .../_snaps/ggridges/quantile-lines-multi.svg | 1 + .../_snaps/ggridges/raincloud-effect.svg | 1 + .../raincloud-vertical-line-points.svg | 1 + .../testthat/_snaps/ggridges/stat-density.svg | 1 + .../_snaps/ggridges/stat-identity.svg | 1 + .../_snaps/ggridges/styling-points.svg | 1 + .../_snaps/ggridges/styling-points2.svg | 1 + .../_snaps/ggridges/varying-fill-colours.svg | 1 + tests/testthat/test-ggridges.R | 342 ++++++++++++++++++ 33 files changed, 707 insertions(+), 1 deletion(-) create mode 100644 R/ggridges.R create mode 100644 man/get_ridge_data.Rd create mode 100644 man/prepare_ridge_chart.Rd create mode 100644 tests/testthat/_snaps/ggridges/basic-ridgeline.svg create mode 100644 tests/testthat/_snaps/ggridges/cutting-tails.svg create mode 100644 tests/testthat/_snaps/ggridges/density-ridgeline.svg create mode 100644 tests/testthat/_snaps/ggridges/density-ridgeline2.svg create mode 100644 tests/testthat/_snaps/ggridges/histogram-ridges.svg create mode 100644 tests/testthat/_snaps/ggridges/jittering-points.svg create mode 100644 tests/testthat/_snaps/ggridges/manual-densities-stat-identity.svg create mode 100644 tests/testthat/_snaps/ggridges/multiple-ridgelines.svg create mode 100644 tests/testthat/_snaps/ggridges/negative-height-cut.svg create mode 100644 tests/testthat/_snaps/ggridges/negative-height-retained.svg create mode 100644 tests/testthat/_snaps/ggridges/numeric-grouping.svg create mode 100644 tests/testthat/_snaps/ggridges/overlapping-facet-touching.svg create mode 100644 tests/testthat/_snaps/ggridges/overlapping-lot.svg create mode 100644 tests/testthat/_snaps/ggridges/overlapping-none.svg create mode 100644 tests/testthat/_snaps/ggridges/overlapping-touching.svg create mode 100644 tests/testthat/_snaps/ggridges/quantile-colouring-tails-only.svg create mode 100644 tests/testthat/_snaps/ggridges/quantile-colouring.svg create mode 100644 tests/testthat/_snaps/ggridges/quantile-cut-points.svg create mode 100644 tests/testthat/_snaps/ggridges/quantile-lines-1.svg create mode 100644 tests/testthat/_snaps/ggridges/quantile-lines-multi.svg create mode 100644 tests/testthat/_snaps/ggridges/raincloud-effect.svg create mode 100644 tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg create mode 100644 tests/testthat/_snaps/ggridges/stat-density.svg create mode 100644 tests/testthat/_snaps/ggridges/stat-identity.svg create mode 100644 tests/testthat/_snaps/ggridges/styling-points.svg create mode 100644 tests/testthat/_snaps/ggridges/styling-points2.svg create mode 100644 tests/testthat/_snaps/ggridges/varying-fill-colours.svg create mode 100644 tests/testthat/test-ggridges.R 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/R/ggridges.R b/R/ggridges.R new file mode 100644 index 0000000000..f8a55d8851 --- /dev/null +++ b/R/ggridges.R @@ -0,0 +1,289 @@ +#' 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")) + ) + + 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, ... + ) + 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, ... + ) + ridges <- c(ridges, list(points)) + } + + ridges + } + ) +} + + +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, ... + ) + +} + + +# TODO: Implement following +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 + # browser() + 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) { + + # data <- group2NA(data) + + # munching for polygon + positions <- with(data, data.frame( + x = c(x , rev(x)), + y = c(ymax, rev(ymin)) + # ids = c(ids , rev(ids)) + )) + # positions <- group2NA(positions, groupNames = 'ids') + + + 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..8e28ba6e2d --- /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..1e882ba185 --- /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..2ac1f03274 --- /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..7d01134b7b --- /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..b935ed0a15 --- /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..f787fd944f --- /dev/null +++ b/tests/testthat/test-ggridges.R @@ -0,0 +1,342 @@ +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() + + expect_no_error( + p2 <- plotly_build(p) + ) + 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() + expect_no_error(plotly_build(p)) + + p2 <- ggplotly(p) + expect_doppelganger(p2, 'negative_height_cut') + + + ## Negative height allowed + p <- plot_base + geom_ridgeline(min_height = -2) + expect_no_error(plotly_build(p)) + + 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") + expect_no_error(plotly_build(p)) + + 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) + expect_no_error(plotly_build(p)) + + 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() + expect_no_error(plotly_build(p)) + 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() + expect_no_error(plotly_build(p)) + 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() + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'cutting_tails') + ggplotly(p) + + + # Non-overlapping ridges (Works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(scale = 0.9) + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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") + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + 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( + expect_no_error(plotly_build(p)) + ) + 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]") + ) + expect_no_error(plotly_build(p)) + 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 = { + + # jittering points (works) + p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + + geom_density_ridges(jittered_points = TRUE) + expect_no_error(plotly_build(p)) + 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 + ) + expect_no_error(plotly_build(p)) + 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)) + expect_no_error(plotly_build(p)) + 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)) + expect_no_error(plotly_build(p)) + 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) + ) + expect_no_error(plotly_build(p)) + 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") + + expect_no_error(plotly_build(p)) + }) + 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") + expect_no_error(plotly_build(p)) + 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) + expect_no_error(plotly_build(p)) + p2 <- ggplotly(p) + expect_doppelganger(p2, 'histogram_ridges') + + } +) + From 10cf2dd3f3f07d32f1a8dfafcb109467724defeb Mon Sep 17 00:00:00 2001 From: AdroMine Date: Sat, 11 Nov 2023 00:29:45 +0530 Subject: [PATCH 2/5] ggridges: formatting + remove commented code --- R/ggridges.R | 97 +++++++++++++++++++++------------------------------- 1 file changed, 39 insertions(+), 58 deletions(-) diff --git a/R/ggridges.R b/R/ggridges.R index f8a55d8851..5de29d5d0d 100644 --- a/R/ggridges.R +++ b/R/ggridges.R @@ -6,25 +6,24 @@ #' @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, ] - + 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, ] } @@ -49,7 +48,7 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = decreasing = FALSE ) groups <- groups[o] - + # for each group create a density + vline + point as applicable res <- lapply( rev(groups), @@ -109,9 +108,11 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = ridges } ) + res } +#' @export to_basic.GeomDensityRidgesGradient <- function(data, prestats_data, layout, params, p, ...){ res <- prepare_ridge_chart(data, prestats_data, layout, params, p, FALSE, ...) @@ -122,60 +123,50 @@ to_basic.GeomDensityRidgesGradient <- function(data, prestats_data, layout, para #' @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, ... ) - } -# TODO: Implement following +#' @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( @@ -187,36 +178,36 @@ to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, 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 @@ -227,43 +218,35 @@ to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, # combine original and duplicated d2 d2 <- rbind(d2, rows) } - + # split by group to make polygons - # browser() 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) { - - # data <- group2NA(data) - + # munching for polygon positions <- with(data, data.frame( x = c(x , rev(x)), y = c(ymax, rev(ymin)) - # ids = c(ids , rev(ids)) )) - # positions <- group2NA(positions, groupNames = 'ids') - - + L <- list( x = positions[["x"]], y = positions[["y"]], @@ -283,7 +266,5 @@ geom2trace.GeomRidgelineGradient <- function(data, params, p) { fillcolor = toRGB(unique(data$fill[1])), hoveron = hover_on(data) ) - compact(L) - } From f419e3c323ba9a895ef3324652b5eb22fa7cf253 Mon Sep 17 00:00:00 2001 From: AdroMine Date: Sat, 11 Nov 2023 01:14:38 +0530 Subject: [PATCH 3/5] ggridges: remove unnecessary test, put seed for jittered points --- .../_snaps/ggridges/jittering-points.svg | 2 +- .../_snaps/ggridges/raincloud-effect.svg | 2 +- .../raincloud-vertical-line-points.svg | 2 +- .../_snaps/ggridges/styling-points.svg | 2 +- .../_snaps/ggridges/styling-points2.svg | 2 +- tests/testthat/test-ggridges.R | 37 ++----------------- 6 files changed, 9 insertions(+), 38 deletions(-) diff --git a/tests/testthat/_snaps/ggridges/jittering-points.svg b/tests/testthat/_snaps/ggridges/jittering-points.svg index 8e28ba6e2d..f54c7ab31a 100644 --- a/tests/testthat/_snaps/ggridges/jittering-points.svg +++ b/tests/testthat/_snaps/ggridges/jittering-points.svg @@ -1 +1 @@ -45678setosaversicolorvirginicaSepal.LengthSpecies +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/raincloud-effect.svg b/tests/testthat/_snaps/ggridges/raincloud-effect.svg index 1e882ba185..3cad788ca5 100644 --- a/tests/testthat/_snaps/ggridges/raincloud-effect.svg +++ b/tests/testthat/_snaps/ggridges/raincloud-effect.svg @@ -1 +1 @@ -45678setosaversicolorvirginicaSepal.LengthSpecies +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg b/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg index 2ac1f03274..167e863b1c 100644 --- a/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg +++ b/tests/testthat/_snaps/ggridges/raincloud-vertical-line-points.svg @@ -1 +1 @@ -45678setosaversicolorvirginicaSepal.LengthSpecies +45678setosaversicolorvirginicaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/styling-points.svg b/tests/testthat/_snaps/ggridges/styling-points.svg index 7d01134b7b..3afb3a94b4 100644 --- a/tests/testthat/_snaps/ggridges/styling-points.svg +++ b/tests/testthat/_snaps/ggridges/styling-points.svg @@ -1 +1 @@ -45678setosaversicolorvirginicaSpeciesvirginicaversicolorsetosaSepal.LengthSpecies +45678setosaversicolorvirginicaSpeciesvirginicaversicolorsetosaSepal.LengthSpecies diff --git a/tests/testthat/_snaps/ggridges/styling-points2.svg b/tests/testthat/_snaps/ggridges/styling-points2.svg index b935ed0a15..762718104a 100644 --- a/tests/testthat/_snaps/ggridges/styling-points2.svg +++ b/tests/testthat/_snaps/ggridges/styling-points2.svg @@ -1 +1 @@ -45678setosaversicolorvirginicaPetal.LengthSpecies(virginica,1)(versicolor,1)(setosa,1)Sepal.LengthSpecies +45678setosaversicolorvirginicaPetal.LengthSpecies(virginica,1)(versicolor,1)(setosa,1)Sepal.LengthSpecies diff --git a/tests/testthat/test-ggridges.R b/tests/testthat/test-ggridges.R index f787fd944f..feca915ae6 100644 --- a/tests/testthat/test-ggridges.R +++ b/tests/testthat/test-ggridges.R @@ -9,9 +9,6 @@ test_that( 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() - expect_no_error( - p2 <- plotly_build(p) - ) p2 <- ggplotly(p) expect_doppelganger(p2, 'basic_ridgeline') @@ -23,7 +20,6 @@ test_that( ## Negative height cut off p <- plot_base + geom_ridgeline() - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'negative_height_cut') @@ -31,7 +27,6 @@ test_that( ## Negative height allowed p <- plot_base + geom_ridgeline(min_height = -2) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'negative_height_retained') @@ -46,7 +41,6 @@ test_that( p <- ggplot(d, aes(x, y, height = height, group = y)) + geom_ridgeline(fill = "lightblue") - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'multiple_ridgelines') @@ -54,7 +48,6 @@ test_that( # stat = identity (works) p <- ggplot(d, aes(x, y, height = height, group = y)) + geom_density_ridges(stat = "identity", scale = 1) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'stat_identity') @@ -69,13 +62,11 @@ test_that( p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges() - expect_no_error(plotly_build(p)) 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() - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'density_ridgeline2') @@ -88,23 +79,18 @@ test_that( y = Species_num, group = Species_num)) + geom_density_ridges() - expect_no_error(plotly_build(p)) 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) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'cutting_tails') - ggplotly(p) - # Non-overlapping ridges (Works) p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges(scale = 0.9) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'overlapping_none') @@ -112,7 +98,6 @@ test_that( # Exactly touching (Works) p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges(scale = 1) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'overlapping_touching') @@ -120,7 +105,6 @@ test_that( # scale = 5, substantial overlap (Works) p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges(scale = 5) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'overlapping_lot') @@ -128,7 +112,6 @@ test_that( # Panel scaling (Works) p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + geom_density_ridges(scale = 1) + facet_wrap(~Species) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'overlapping_facet_touching') @@ -150,7 +133,6 @@ test_that( 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") - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'varying_fill_colours') @@ -168,14 +150,12 @@ test_that( # quantile multiple lines p <- ggplot(iris, aes(x = Sepal.Length, y = Species)) + stat_density_ridges(quantile_lines = TRUE) - expect_no_error(plotly_build(p)) 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) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'quantile_lines_1') @@ -184,7 +164,6 @@ test_that( stat_density_ridges(quantile_lines = TRUE, quantiles = c(0.025, 0.975), alpha = 0.7) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'quantile_cut_points') @@ -199,10 +178,10 @@ test_that( ) + scale_fill_viridis_d(name = "Quartiles") ) + suppressWarnings( - expect_no_error(plotly_build(p)) + p2 <- ggplotly(p) ) - p2 <- ggplotly(p) expect_doppelganger(p2, 'quantile_colouring') @@ -217,7 +196,6 @@ test_that( name = "Probability", values = c("#FF0000A0", "#A0A0A0A0", "#0000FFA0"), labels = c("(0, 0.025]", "(0.025, 0.975]", "(0.975, 1]") ) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'quantile_colouring_tails_only') @@ -236,10 +214,10 @@ 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) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'jittering points') @@ -249,7 +227,6 @@ test_that( jittered_points = TRUE, position = "raincloud", alpha = 0.7, scale = 0.9 ) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'raincloud_effect') @@ -270,7 +247,6 @@ test_that( ) + scale_point_color_hue(l = 40) + scale_discrete_manual(aesthetics = "point_shape", values = c(21, 22, 23)) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'styling_points') @@ -282,7 +258,6 @@ test_that( ) + 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)) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'styling_points2') @@ -295,7 +270,6 @@ test_that( point_size = 0.4, point_alpha = 1, position = position_raincloud(adjust_vlines = TRUE) ) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'raincloud_vertical_line_points') @@ -312,9 +286,8 @@ test_that( p <- ggplot(iris, aes(x = Sepal.Length, y = Species, height = stat(density))) + geom_density_ridges(stat = "density") - expect_no_error(plotly_build(p)) + p2 <- ggplotly(p) }) - p2 <- ggplotly(p) expect_doppelganger(p2, 'stat_density') @@ -326,14 +299,12 @@ test_that( p <- ggplot(iris_densities, aes(x = Sepal.Length, y = Species, height = density)) + geom_density_ridges(stat = "identity") - expect_no_error(plotly_build(p)) 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) - expect_no_error(plotly_build(p)) p2 <- ggplotly(p) expect_doppelganger(p2, 'histogram_ridges') From 857f7583f651513570a8247e91b00e6399190912 Mon Sep 17 00:00:00 2001 From: AdroMine Date: Sat, 11 Nov 2023 16:10:40 +0530 Subject: [PATCH 4/5] fix higlight working + formatting --- R/ggridges.R | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/R/ggridges.R b/R/ggridges.R index 5de29d5d0d..ce64eb106d 100644 --- a/R/ggridges.R +++ b/R/ggridges.R @@ -30,8 +30,7 @@ get_ridge_data <- function(data, na.rm) { #' 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, ...){ - +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 @@ -52,25 +51,27 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = # for each group create a density + vline + point as applicable res <- lapply( rev(groups), - function(x){ - + 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 + 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)){ - + 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 @@ -81,12 +82,13 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = 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)){ + if ('point' %in% names(draw_stuff)) { draw_stuff$point$y <- draw_stuff$point$ymin # use point aesthetics @@ -102,6 +104,8 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = '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)) } @@ -113,8 +117,7 @@ prepare_ridge_chart <- function(data, prestats_data, layout, params, p, closed = #' @export -to_basic.GeomDensityRidgesGradient <- function(data, prestats_data, layout, params, p, ...){ - +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) @@ -182,7 +185,7 @@ to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, # for each group create a density + vline + point as applicable res <- lapply( rev(groups), - function(x){ + function(x) { draw_stuff <- split(x, x$datatype) @@ -211,7 +214,7 @@ to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, # rows to be duplicated dupl_rows <- which(fillchange & !idchange) d2$y <- d2$ymax - if (length(dupl_rows)>0){ + 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] @@ -240,12 +243,11 @@ to_basic.GeomRidgelineGradient <- function(data, prestats_data, layout, params, #' @export geom2trace.GeomRidgelineGradient <- function(data, params, p) { - # munching for polygon - positions <- with(data, data.frame( - x = c(x , rev(x)), - y = c(ymax, rev(ymin)) - )) + positions <- data.frame( + x = c(data$x , rev(data$x)), + y = c(data$ymax, rev(data$ymin)) + ) L <- list( x = positions[["x"]], From a329f432b0b62ee6e26b4b40aa2bd963f72128b9 Mon Sep 17 00:00:00 2001 From: AdroMine Date: Wed, 8 May 2024 19:34:35 +0100 Subject: [PATCH 5/5] ggridges support: update news.md --- NEWS.md | 4 ++++ 1 file changed, 4 insertions(+) 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)