diff --git a/.Rbuildignore b/.Rbuildignore index 136cbe9..1dc677b 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -7,3 +7,4 @@ ^\.github$ ^man/figures/logo\.png$ ^LICENSE\.md$ +^vignettes/articles$ diff --git a/.github/workflows/check-standard.yaml b/.github/workflows/check-standard.yaml new file mode 100644 index 0000000..52c2b27 --- /dev/null +++ b/.github/workflows/check-standard.yaml @@ -0,0 +1,49 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: R-CMD-check + +jobs: + R-CMD-check: + runs-on: ${{ matrix.config.os }} + + name: ${{ matrix.config.os }} (${{ matrix.config.r }}) + + strategy: + fail-fast: false + matrix: + config: + - {os: macOS-latest, r: 'release'} + - {os: windows-latest, r: 'release'} + - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} + - {os: ubuntu-latest, r: 'release'} + - {os: ubuntu-latest, r: 'oldrel-1'} + + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + r-version: ${{ matrix.config.r }} + http-user-agent: ${{ matrix.config.http-user-agent }} + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck + needs: check + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..4b65418 --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,31 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + branches: [main, master] + +name: test-coverage + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr + needs: coverage + + - name: Test coverage + run: covr::codecov(quiet = FALSE) + shell: Rscript {0} diff --git a/DESCRIPTION b/DESCRIPTION index 0502309..be7f7b4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,37 +1,30 @@ -Package: ggbraid Type: Package +Package: ggbraid Title: Braid Ribbons in 'ggplot2' Version: 0.2.2 Authors@R: - person( - given = "Neal", - family = "Grantham", - role = c("aut", "cre"), - email = "neal@nsgrantham.com" - ) + person("Neal", "Grantham", , "neal@nsgrantham.com", role = c("aut", "cre")) Description: A new stat, stat_braid(), that extends the functionality of geom_ribbon() to correctly fill the area between two alternating lines (or steps) with two different colors, and a geom, geom_braid(), that wraps geom_ribbon() and uses stat_braid() by default. -URL: https://nsgrantham.github.io/ggbraid/, https://github.com/nsgrantham/ggbraid/ -BugReports: https://github.com/nsgrantham/ggbraid/issues/ License: MIT + file LICENSE +URL: https://nsgrantham.github.io/ggbraid/, + https://github.com/nsgrantham/ggbraid/ +BugReports: https://github.com/nsgrantham/ggbraid/issues/ Depends: R (>= 3.4.0) Imports: - ggplot2 (>= 3.0.0) + ggplot2 (>= 3.0.0), + rlang Suggests: - rmarkdown, knitr, - scales, - readr, - dplyr, - tidyr, - ggtext, - glue, - hms + rmarkdown, + testthat (>= 3.0.0) +VignetteBuilder: + knitr Encoding: UTF-8 LazyData: true -RoxygenNote: 7.1.2 Roxygen: list(markdown = TRUE) -VignetteBuilder: knitr +RoxygenNote: 7.2.1 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 0b7d9d9..6240b6b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,4 +5,6 @@ export(StatBraid) export(geom_braid) export(stat_braid) import(ggplot2) +importFrom(rlang,arg_match0) +importFrom(stats,complete.cases) importFrom(stats,na.omit) diff --git a/R/braid-lines.R b/R/braid-lines.R new file mode 100644 index 0000000..44da39e --- /dev/null +++ b/R/braid-lines.R @@ -0,0 +1,115 @@ +compute_braided_lines <- function(data) { + splits <- cut(data$group, seq(0.5, max(data$group) + 1.5, by = 2)) + do.call(rbind, lapply(split(data, splits), braid_lines)) +} + +braid_lines <- function(data) { + row_pairs <- lapply(1:nrow(data), function(i) data[i:(i+1), ]) + do.call(rbind, lapply(row_pairs, braid_lines_row_pair)) +} + +braid_lines_row_pair <- function(row_pair) { + y1 <- y2 <- NULL # only included to silence notes in devtools::check() + row1 <- row_pair[1, ] + row2 <- row_pair[2, ] + + if (is.na(row2$braid)) { + return(row1) + } + + if (row1$braid == row2$braid) { + return(row1) + } + + if (row2$ymin == row2$ymax) { # explicit intersection + return( + rbind( + row1, + transform(row2, braid = row1$braid, group = row1$group) + ) + ) + } + + if (row1$x < row2$x) { + # Consider the intersection of two lines: + # one defined by points (a, b) and (c, d), and another defined by points + # (e, f) and (g, h). + # + # • (g, h) + # / + # (a, b) / + # •--o--• + # / (c, d) + # / + # • (e, f) + # + # If b > f and d < h, or if b < f and d > h, then the two lines intersect + # at a single point (x0, y0) defined by + # x0 = (u * (e - g) - v * (a - c)) / w + # y0 = (u * (f - h) - v * (b - d)) / w + # where + # u = a * d - b * c + # v = e * h - f * g + # w = (a - c) * (f - h) - (b - d) * (e - g) + # + # For more information on this formula, visit + # https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line + + a <- row1$x + e <- row1$x + c <- row2$x + g <- row2$x + b <- row1$y1 + f <- row1$y2 + d <- row2$y1 + h <- row2$y2 + + w <- (a - c) * (f - h) - (b - d) * (e - g) + u <- a * d - b * c + v <- e * h - f * g + + x0 <- (u * (e - g) - v * (a - c)) / w + y0 <- (u * (f - h) - v * (b - d)) / w + + return( + rbind( + row1, + transform(row1, x = x0, ymin = y0, ymax = y0), + transform(row2, x = x0, ymin = y0, ymax = y0) + ) + ) + } + + if (row1$x == row2$x) { + if (row1$y1 == row2$y1) { + return( + rbind( + row1, + transform(row1, ymin = y1, ymax = y1), + transform(row2, ymin = y1, ymax = y1) + ) + ) + } else if (row1$y2 == row2$y2) { + return( + rbind( + row1, + transform(row1, ymin = y2, ymax = y2), + transform(row2, ymin = y2, ymax = y2) + ) + ) + } else { + # Two overlapping vertical lines so there are infinite intersections. + # Define a single point to serve as a reasonable intersection. + y2_mid <- (row1$y2 + row2$y2) / 2 + y1_mid <- (row1$y1 + row2$y1) / 2 + y0 <- (y1_mid + y2_mid) / 2 + return( + rbind( + row1, + transform(row1, ymin = y0, ymax = y0), + transform(row2, ymin = y0, ymax = y0) + ) + ) + } + } +} diff --git a/R/braid-steps.R b/R/braid-steps.R new file mode 100644 index 0000000..9590ae6 --- /dev/null +++ b/R/braid-steps.R @@ -0,0 +1,83 @@ + +compute_braided_steps <- function(data) { + splits <- cut(data$group, seq(0.5, max(data$group) + 1.5, by = 2)) + do.call(rbind, lapply(split(data, splits), braid_steps)) +} + +braid_steps <- function (data) { + row_pairs <- lapply(1:nrow(data), function(i) data[i:(i+1), ]) + do.call(rbind, lapply(row_pairs, braid_steps_row_pair)) +} + +braid_steps_row_pair <- function(row_pair) { + y1 <- y2 <- NULL # only included to silence notes in devtools::check() + row1 <- row_pair[1, ] + row2 <- row_pair[2, ] + + if (is.na(row2$braid)) { + return(row1) + } + + if (row1$braid == row2$braid) { + return( + rbind( + row1, + transform(row1, x = row2$x, group = row2$group) + ) + ) + } + + if (row1$ymin == row1$ymax) { + return( + rbind( + row1, + transform(row1, x = row2$x), + transform(row1, x = row2$x, braid = row2$braid, group = row2$group) + ) + ) + } + + if (row2$ymin == row2$ymax) { + return( + rbind( + row1, + transform(row1, x = row2$x), + transform(row2, braid = row1$braid, group = row1$group) + ) + ) + } + + if (row1$y1 == row2$y1) { + return( + rbind( + row1, + transform(row1, x = row2$x), + transform(row1, x = row2$x, ymin = y1, ymax = y1), + transform(row2, ymin = y1, ymax = y1) + ) + ) + } else if (row1$y2 == row2$y2) { + return( + rbind( + row1, + transform(row1, x = row2$x), + transform(row1, x = row2$x, ymin = y2, ymax = y2), + transform(row2, ymin = y2, ymax = y2) + ) + ) + } else { + # Two overlapping vertical lines so there are infinite intersections. + # Define a single point to serve as a reasonable intersection. + y2_mid <- (row1$y2 + row1$y2) / 2 + y1_mid <- (row1$y1 + row2$y1) / 2 + y0 <- (y1_mid + y2_mid) / 2 + return( + rbind( + row1, + transform(row1, x = row2$x), + transform(row1, x = row2$x, ymin = y0, ymax = y0), + transform(row2, ymin = y0, ymax = y0) + ) + ) + } +} diff --git a/R/geom-braid.R b/R/geom-braid.R index d0e73b8..11e8dff 100644 --- a/R/geom-braid.R +++ b/R/geom-braid.R @@ -1,4 +1,4 @@ -#' Braided ribbons +#' Fill the area between two alternating series #' #' `geom_braid()` is an extension of `geom_ribbon()` that uses `stat_braid()` #' to correctly fill the area between two alternating series (lines or steps) @@ -6,15 +6,17 @@ #' #' @inheritParams ggplot2::layer #' @inheritParams ggplot2::geom_ribbon -#' @param method Intersection and imputation method to use to braid the ribbon, -#' accepts `NULL`, `"line"`, or `"step"`. For `method = NULL`, the default, -#' print a message to the console and use `method = "line"`. For -#' `method = "line"`, silently braid the ribbon with two series drawn by -#' `geom_line()` or `geom_path()`. For `method = "step"`, silently braid the -#' ribbon with two series drawn by `geom_step()`. -#' @param na.rm If `NA`, the default, missing values are imputed by -#' `method`. If `FALSE`, missing values are kept and appear as gaps in the -#' ribbon. If `TRUE`, missing values are removed. +#' @param method The intersection and imputation method to use to braid the ribbon, +#' accepts `NULL`, `"line"`, or `"step"`. +#' * For `method = NULL`, the default, print ``geom_braid` using method = 'line'` to the console and use +#' `method = "line"`. +#' * For `method = "line"`, silently braid the ribbon with two series drawn by +#' `geom_line()` or `geom_path()`. +#' * For `method = "step"`, silently braid the ribbon with two series drawn by `geom_step()`. +#' @param na.rm A boolean or `NA`. +#' * If `NA`, the default, missing values are imputed by `method`. +#' * If `FALSE`, missing values are kept and appear as gaps in the braided ribbon. +#' * If `TRUE`, missing values are removed from `.data` prior to plotting. #' @param geom Override the default connection with `geom_braid()`. #' @return A ggplot2 layer that can be added to a plot created with `ggplot()`. #' @examples diff --git a/R/ggbraid.R b/R/ggbraid-package.R similarity index 100% rename from R/ggbraid.R rename to R/ggbraid-package.R diff --git a/R/handle-na.R b/R/handle-na.R new file mode 100644 index 0000000..28fbb02 --- /dev/null +++ b/R/handle-na.R @@ -0,0 +1,99 @@ + +#' @importFrom stats complete.cases +remove_na <- function(data) { + data[complete.cases(data[, c("ymin", "ymax")]), ] +} + + +keep_na <- function(data, method) { + n <- nrow(data) + is_prev_na <- TRUE + + for (i in 1:n) { + ymin <- data$ymin[i] + ymax <- data$ymax[i] + + if (identical(method, "step")) { + if (is.na(ymin)) { + data[i, "ymin"] <- if (i == 1) NA else data$ymin[i-1] + } + if (is.na(ymax)) { + data[i, "ymax"] <- if (i == 1) NA else data$ymax[i-1] + } + } + + if (any(is.na(c(ymin, ymax))) && !is_prev_na) { + data[(i+1):n, "group"] <- data[(i+1):n, "group"] + 2 + } + + braid <- data$braid[i] + if (is.na(braid)) { + data[i, "braid"] <- if (i == 1) NA else data$braid[i-1] + if (is_prev_na || identical(method, "line")) { + data[i, "group"] <- -1 + } else { + data[i, "group"] <- data$group[i-1] + } + } + is_prev_na <- is.na(braid) + } + + remove_na(data) +} + + +impute_na <- function(data, method) { + braid_map <- get_braid_map(data) + braid_op <- get_braid_op(data) + + n <- nrow(data) + for (i in 2:n) { + x_curr <- data$x[i] + x_prev <- data$x[i-1] + + ymin_curr <- data$ymin[i] + if (is.na(ymin_curr)) { + ymin_prev <- data$ymin[i-1] + i_next <- which(!is.na(data$ymin[i:n]))[1] + i - 1 + if (!is.na(i_next)) { + if (identical(method, "line")) { + x_next <- data$x[i_next] + ymin_next <- data$ymin[i_next] + r <- if (x_next > x_prev) (x_curr - x_prev) / (x_next - x_prev) else 0 + data[i, "ymin"] <- ymin_prev + r * (ymin_next - ymin_prev) + } + if (identical(method, "step")) { + data[i, "ymin"] <- ymin_prev + } + } + } + + ymax_curr <- data$ymax[i] + if (is.na(ymax_curr)) { + ymax_prev <- data$ymax[i-1] + i_next <- which(!is.na(data$ymax[i:n]))[1] + i - 1 + if (!is.na(i_next)) { + if (identical(method, "line")) { + x_next <- data$x[i_next] + ymax_next <- data$ymax[i_next] + r <- if (x_next > x_prev) (x_curr - x_prev) / (x_next - x_prev) else 0 + data[i, "ymax"] <- ymax_prev + r * (ymax_next - ymax_prev) + } + if (identical(method, "step")) { + data[i, "ymax"] <- ymax_prev + } + } + } + } + + row_id <- ymin <- ymax <- NULL # only included to silence notes in devtools::check() + rows <- rownames(data) + data <- transform(data, row_id = 1:n, braid = braid_op(ymin, ymax)) + data <- data[, !(colnames(data) %in% c("fill", "group"))] + data <- merge(data, braid_map, by = "braid", sort = FALSE) + data <- with(data, data[order(row_id), ]) + data <- subset(data, select = -row_id) + rownames(data) <- rows + + remove_na(data) +} diff --git a/R/stat-braid.R b/R/stat-braid.R index 85d96a8..a6c5579 100644 --- a/R/stat-braid.R +++ b/R/stat-braid.R @@ -34,6 +34,7 @@ stat_braid <- function( #' @format NULL #' @usage NULL #' @keywords internal +#' @importFrom rlang arg_match0 #' @export StatBraid <- ggproto("StatBraid", Stat, @@ -41,16 +42,11 @@ StatBraid <- ggproto("StatBraid", Stat, setup_params = function(data, params) { params$flipped_aes <- has_flipped_aes(data, params, range_is_orthogonal = TRUE) - - msg <- character() - if (is.null(params$method)) { - params$method <- "line" - msg <- c(msg, paste0("method = '", params$method, "'")) - } - if (length(msg) > 0) { - message("`geom_braid()` using ", msg) - } - + params$method <- arg_match0( + params$method %||% "line", + c("line", "step"), + arg_nm = "method" + ) params }, @@ -137,61 +133,6 @@ get_braid_op <- function(data) { `<` } -impute_na <- function(data, method) { - braid_map <- get_braid_map(data) - braid_op <- get_braid_op(data) - - n <- nrow(data) - for (i in 2:n) { - x_curr <- data$x[i] - x_prev <- data$x[i-1] - - ymin_curr <- data$ymin[i] - if (is.na(ymin_curr)) { - ymin_prev <- data$ymin[i-1] - i_next <- which(!is.na(data$ymin[i:n]))[1] + i - 1 - if (!is.na(i_next)) { - if (identical(method, "line")) { - x_next <- data$x[i_next] - ymin_next <- data$ymin[i_next] - r <- if (x_next > x_prev) (x_curr - x_prev) / (x_next - x_prev) else 0 - data[i, "ymin"] <- ymin_prev + r * (ymin_next - ymin_prev) - } - if (identical(method, "step")) { - data[i, "ymin"] <- ymin_prev - } - } - } - - ymax_curr <- data$ymax[i] - if (is.na(ymax_curr)) { - ymax_prev <- data$ymax[i-1] - i_next <- which(!is.na(data$ymax[i:n]))[1] + i - 1 - if (!is.na(i_next)) { - if (identical(method, "line")) { - x_next <- data$x[i_next] - ymax_next <- data$ymax[i_next] - r <- if (x_next > x_prev) (x_curr - x_prev) / (x_next - x_prev) else 0 - data[i, "ymax"] <- ymax_prev + r * (ymax_next - ymax_prev) - } - if (identical(method, "step")) { - data[i, "ymax"] <- ymax_prev - } - } - } - } - - row_id <- ymin <- ymax <- NULL # only included to silence notes in devtools::check() - rows <- rownames(data) - data <- transform(data, row_id = 1:n, braid = braid_op(ymin, ymax)) - data <- data[, !(colnames(data) %in% c("fill", "group"))] - data <- merge(data, braid_map, by = "braid", sort = FALSE) - data <- with(data, data[order(row_id), ]) - data <- subset(data, select = -row_id) - rownames(data) <- rows - - remove_na(data) -} get_braid_map <- function(data) { braid_map <- merge( @@ -208,241 +149,3 @@ get_braid_map <- function(data) { braid_map } -keep_na <- function(data, method) { - n <- nrow(data) - is_prev_na <- TRUE - - for (i in 1:n) { - ymin <- data$ymin[i] - ymax <- data$ymax[i] - - if (identical(method, "step")) { - if (is.na(ymin)) { - data[i, "ymin"] <- if (i == 1) NA else data$ymin[i-1] - } - if (is.na(ymax)) { - data[i, "ymax"] <- if (i == 1) NA else data$ymax[i-1] - } - } - - if (any(is.na(c(ymin, ymax))) && !is_prev_na) { - data[(i+1):n, "group"] <- data[(i+1):n, "group"] + 2 - } - - braid <- data$braid[i] - if (is.na(braid)) { - data[i, "braid"] <- if (i == 1) NA else data$braid[i-1] - if (is_prev_na || identical(method, "line")) { - data[i, "group"] <- -1 - } else { - data[i, "group"] <- data$group[i-1] - } - } - is_prev_na <- is.na(braid) - } - - remove_na(data) -} - -remove_na <- function(data) { - data[stats::complete.cases(data[, c("ymin", "ymax")]), ] -} - -compute_braided_lines <- function(data) { - splits <- cut(data$group, seq(0.5, max(data$group) + 1.5, by = 2)) - do.call(rbind, lapply(split(data, splits), braid_lines)) -} - -braid_lines <- function(data) { - row_pairs <- lapply(1:nrow(data), function(i) data[i:(i+1), ]) - do.call(rbind, lapply(row_pairs, braid_lines_row_pair)) -} - -braid_lines_row_pair <- function(row_pair) { - y1 <- y2 <- NULL # only included to silence notes in devtools::check() - row1 <- row_pair[1, ] - row2 <- row_pair[2, ] - - if (is.na(row2$braid)) { - return(row1) - } - - if (row1$braid == row2$braid) { - return(row1) - } - - if (row2$ymin == row2$ymax) { # explicit intersection - return( - rbind( - row1, - transform(row2, braid = row1$braid, group = row1$group) - ) - ) - } - - if (row1$x < row2$x) { - # Consider the intersection of two lines: - # one defined by points (a, b) and (c, d), and another defined by points - # (e, f) and (g, h). - # - # • (g, h) - # / - # (a, b) / - # •--o--• - # / (c, d) - # / - # • (e, f) - # - # If b > f and d < h, or if b < f and d > h, then the two lines intersect - # at a single point (x0, y0) defined by - # x0 = (u * (e - g) - v * (a - c)) / w - # y0 = (u * (f - h) - v * (b - d)) / w - # where - # u = a * d - b * c - # v = e * h - f * g - # w = (a - c) * (f - h) - (b - d) * (e - g) - # - # For more information on this formula, visit - # https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line - - a <- row1$x - e <- row1$x - c <- row2$x - g <- row2$x - b <- row1$y1 - f <- row1$y2 - d <- row2$y1 - h <- row2$y2 - - w <- (a - c) * (f - h) - (b - d) * (e - g) - u <- a * d - b * c - v <- e * h - f * g - - x0 <- (u * (e - g) - v * (a - c)) / w - y0 <- (u * (f - h) - v * (b - d)) / w - - return( - rbind( - row1, - transform(row1, x = x0, ymin = y0, ymax = y0), - transform(row2, x = x0, ymin = y0, ymax = y0) - ) - ) - } - - if (row1$x == row2$x) { - if (row1$y1 == row2$y1) { - return( - rbind( - row1, - transform(row1, ymin = y1, ymax = y1), - transform(row2, ymin = y1, ymax = y1) - ) - ) - } else if (row1$y2 == row2$y2) { - return( - rbind( - row1, - transform(row1, ymin = y2, ymax = y2), - transform(row2, ymin = y2, ymax = y2) - ) - ) - } else { - # Two overlapping vertical lines so there are infinite intersections. - # Define a single point to serve as a reasonable intersection. - y2_mid <- (row1$y2 + row2$y2) / 2 - y1_mid <- (row1$y1 + row2$y1) / 2 - y0 <- (y1_mid + y2_mid) / 2 - return( - rbind( - row1, - transform(row1, ymin = y0, ymax = y0), - transform(row2, ymin = y0, ymax = y0) - ) - ) - } - } -} - -compute_braided_steps <- function(data) { - splits <- cut(data$group, seq(0.5, max(data$group) + 1.5, by = 2)) - do.call(rbind, lapply(split(data, splits), braid_steps)) -} - -braid_steps <- function (data) { - row_pairs <- lapply(1:nrow(data), function(i) data[i:(i+1), ]) - do.call(rbind, lapply(row_pairs, braid_steps_row_pair)) -} - -braid_steps_row_pair <- function(row_pair) { - y1 <- y2 <- NULL # only included to silence notes in devtools::check() - row1 <- row_pair[1, ] - row2 <- row_pair[2, ] - - if (is.na(row2$braid)) { - return(row1) - } - - if (row1$braid == row2$braid) { - return( - rbind( - row1, - transform(row1, x = row2$x, group = row2$group) - ) - ) - } - - if (row1$ymin == row1$ymax) { - return( - rbind( - row1, - transform(row1, x = row2$x), - transform(row1, x = row2$x, braid = row2$braid, group = row2$group) - ) - ) - } - - if (row2$ymin == row2$ymax) { - return( - rbind( - row1, - transform(row1, x = row2$x), - transform(row2, braid = row1$braid, group = row1$group) - ) - ) - } - - if (row1$y1 == row2$y1) { - return( - rbind( - row1, - transform(row1, x = row2$x), - transform(row1, x = row2$x, ymin = y1, ymax = y1), - transform(row2, ymin = y1, ymax = y1) - ) - ) - } else if (row1$y2 == row2$y2) { - return( - rbind( - row1, - transform(row1, x = row2$x), - transform(row1, x = row2$x, ymin = y2, ymax = y2), - transform(row2, ymin = y2, ymax = y2) - ) - ) - } else { - # Two overlapping vertical lines so there are infinite intersections. - # Define a single point to serve as a reasonable intersection. - y2_mid <- (row1$y2 + row1$y2) / 2 - y1_mid <- (row1$y1 + row2$y1) / 2 - y0 <- (y1_mid + y2_mid) / 2 - return( - rbind( - row1, - transform(row1, x = row2$x), - transform(row1, x = row2$x, ymin = y0, ymax = y0), - transform(row2, ymin = y0, ymax = y0) - ) - ) - } -} diff --git a/R/test-braid-steps.R b/R/test-braid-steps.R new file mode 100644 index 0000000..e69de29 diff --git a/R/utils.R b/R/utils.R new file mode 100644 index 0000000..6796714 --- /dev/null +++ b/R/utils.R @@ -0,0 +1 @@ +`%||%` <- function(x, y) if (is.null(x)) y else x diff --git a/README.Rmd b/README.Rmd index e8af294..a3b97a0 100644 --- a/README.Rmd +++ b/README.Rmd @@ -23,7 +23,13 @@ ggbraid provides a new stat, `stat_braid()`, that extends the functionality of ` ## Installation -You can install the development version of ggbraid from GitHub with: +Install the production version of ggbraid from CRAN with: + +```r +install.packages("ggbraid") +``` + +Or install the development version of ggbraid from GitHub with: ``` r # install.packages("remotes") diff --git a/README.md b/README.md index e0da882..3bc1537 100644 --- a/README.md +++ b/README.md @@ -14,7 +14,13 @@ provides a geom, `geom_braid()`, that wraps `geom_ribbon()` and uses ## Installation -You can install the development version of ggbraid from GitHub with: +Install the production version of ggbraid from CRAN with: + +``` r +install.packages("ggbraid") +``` + +Or install the development version of ggbraid from GitHub with: ``` r # install.packages("remotes") @@ -121,7 +127,6 @@ ggplot() + geom_line(aes(x, y, linetype = z), data = df_long) + geom_braid(aes(x, ymin = a, ymax = b, fill = a < b), data = df_wide, alpha = 0.6) + guides(linetype = "none", fill = "none") -#> `geom_braid()` using method = 'line' ``` diff --git a/man/geom_braid.Rd b/man/geom_braid.Rd index d314e73..ebf5592 100644 --- a/man/geom_braid.Rd +++ b/man/geom_braid.Rd @@ -3,7 +3,7 @@ \name{geom_braid} \alias{geom_braid} \alias{stat_braid} -\title{Braided ribbons} +\title{Fill the area between two alternating series} \usage{ geom_braid( mapping = NULL, @@ -57,16 +57,22 @@ often aesthetics, used to set an aesthetic to a fixed value, like \code{colour = "red"} or \code{size = 3}. They may also be parameters to the paired geom/stat.} -\item{method}{Intersection and imputation method to use to braid the ribbon, -accepts \code{NULL}, \code{"line"}, or \code{"step"}. For \code{method = NULL}, the default, -print a message to the console and use \code{method = "line"}. For -\code{method = "line"}, silently braid the ribbon with two series drawn by -\code{geom_line()} or \code{geom_path()}. For \code{method = "step"}, silently braid the -ribbon with two series drawn by \code{geom_step()}.} - -\item{na.rm}{If \code{NA}, the default, missing values are imputed by -\code{method}. If \code{FALSE}, missing values are kept and appear as gaps in the -ribbon. If \code{TRUE}, missing values are removed.} +\item{method}{The intersection and imputation method to use to braid the ribbon, +accepts \code{NULL}, \code{"line"}, or \code{"step"}. +\itemize{ +\item For \code{method = NULL}, the default, print ``geom_braid\verb{ using method = 'line'} to the console and use +`method = "line"`. +\item For \code{method = "line"}, silently braid the ribbon with two series drawn by +\code{geom_line()} or \code{geom_path()}. +\item For \code{method = "step"}, silently braid the ribbon with two series drawn by \code{geom_step()}. +}} + +\item{na.rm}{A boolean or \code{NA}. +\itemize{ +\item If \code{NA}, the default, missing values are imputed by \code{method}. +\item If \code{FALSE}, missing values are kept and appear as gaps in the braided ribbon. +\item If \code{TRUE}, missing values are removed from \code{.data} prior to plotting. +}} \item{show.legend}{logical. Should this layer be included in the legends? \code{NA}, the default, includes if any aesthetics are mapped. diff --git a/man/ggbraid-package.Rd b/man/ggbraid-package.Rd index b34eb2d..089a990 100644 --- a/man/ggbraid-package.Rd +++ b/man/ggbraid-package.Rd @@ -1,12 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ggbraid.R +% Please edit documentation in R/ggbraid-package.R \docType{package} \name{ggbraid-package} \alias{ggbraid} \alias{ggbraid-package} \title{ggbraid: Braid Ribbons in 'ggplot2'} \description{ -\if{html}{\figure{logo.png}{options: align='right' alt='logo' width='120'}} +\if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} A new stat, stat_braid(), that extends the functionality of geom_ribbon() to correctly fill the area between two alternating lines (or steps) with two different colors, and a geom, geom_braid(), that wraps geom_ribbon() and uses stat_braid() by default. } diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index ff22ae6..5af880e 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -21,7 +21,10 @@ articles: - title: Articles navbar: ~ contents: - - temps - - hoops - - court + - articles/temps + - articles/hoops + - articles/court + +figures: + dpi: 300 diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..2e20d40 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/tests.html +# * https://testthat.r-lib.org/reference/test_package.html#special-files + +library(testthat) +library(ggbraid) + +test_check("ggbraid") diff --git a/tests/testthat/test-braid-lines.R b/tests/testthat/test-braid-lines.R new file mode 100644 index 0000000..e69de29 diff --git a/tests/testthat/test-geom-braid.R b/tests/testthat/test-geom-braid.R new file mode 100644 index 0000000..11587ca --- /dev/null +++ b/tests/testthat/test-geom-braid.R @@ -0,0 +1,19 @@ +test_that("geom_braid works in both directions", { + df <- data.frame( + x = seq_len(5), + a = c(1, 2, 1.5, 1.8, 1), + b = c(4, 6, 5, 4.5, 5.2) + ) + + p <- ggplot(df, aes(x, ymin = a, ymax = b)) + geom_braid(method = "line") + x <- layer_data(p) + expect_false(x$flipped_aes[1]) + + p <- ggplot(df, aes(y = x, xmin = a, xmax = b)) + geom_braid(method = "line") + y <- layer_data(p) + expect_true(y$flipped_aes[1]) + + x$flipped_aes <- NULL + y$flipped_aes <- NULL + expect_identical(x, flip_data(y, flip = TRUE)[, names(x)]) +}) diff --git a/tests/testthat/test-handle-na.R b/tests/testthat/test-handle-na.R new file mode 100644 index 0000000..e69de29 diff --git a/tests/testthat/test-stat-braid.R b/tests/testthat/test-stat-braid.R new file mode 100644 index 0000000..e69de29 diff --git a/vignettes/court.Rmd b/vignettes/articles/court.Rmd similarity index 98% rename from vignettes/court.Rmd rename to vignettes/articles/court.Rmd index 429301b..5c26279 100644 --- a/vignettes/court.Rmd +++ b/vignettes/articles/court.Rmd @@ -1,18 +1,11 @@ --- title: "US Supreme Court" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{US Supreme Court} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, - comment = "#>", - out.width = "100%", - dpi = 300 + comment = "#>" ) knitr::knit_hooks$set( diff --git a/vignettes/hoops.Rmd b/vignettes/articles/hoops.Rmd similarity index 97% rename from vignettes/hoops.Rmd rename to vignettes/articles/hoops.Rmd index 2a5d965..f1081c2 100644 --- a/vignettes/hoops.Rmd +++ b/vignettes/articles/hoops.Rmd @@ -1,10 +1,5 @@ --- title: "NBA Finals Game" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{NBA Finals Game} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} --- ```{r set-chunk-opts, include = FALSE} diff --git a/vignettes/temps.Rmd b/vignettes/articles/temps.Rmd similarity index 98% rename from vignettes/temps.Rmd rename to vignettes/articles/temps.Rmd index b98da02..8c9becb 100644 --- a/vignettes/temps.Rmd +++ b/vignettes/articles/temps.Rmd @@ -1,12 +1,8 @@ --- title: "Average Daily Temperatures" -output: rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Average Daily Temperatures} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} --- + ```{r set-chunk-opts, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, @@ -231,4 +227,3 @@ p + annotate("text", x = as.Date("2021-09-10"), y = 84, size = 4, label = "NY hotter than SF", hjust = 0, color = hues[1]) + annotate("text", x = as.Date("2021-02-20"), y = 23, size = 4, label = "NY colder than SF", hjust = 0, color = hues[2]) ``` -