Skip to content

Commit

Permalink
Update stat-quadrant-counts.R
Browse files Browse the repository at this point in the history 
Ensure compute group function is seen by 'covr'
  • Loading branch information
@aphalo
aphalo committed Feb 14, 2023
1 parent 033e02d commit 6fb33a0
Show file tree
Hide file tree
Showing 6 changed files with 111 additions and 114 deletions.
1 change: 1 addition & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -103,6 +103,7 @@ export(ttheme_set)
import(ggplot2)
import(grid)
import(scales)
importFrom(dplyr,mutate)
importFrom(ggplot2,ggplot)
importFrom(magrittr,"%>%")
importFrom(polynom,polynomial)
Expand Down
4 changes: 4 additions & 0 deletions R/ggpp.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,4 +38,8 @@
#' @importFrom magrittr %>%
#' @importFrom rlang .data
#'
#' @importFrom dplyr mutate
#' @importFrom polynom polynomial
#'
#'
"_PACKAGE"
2 changes: 0 additions & 2 deletions R/position-nudge-line.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,8 +58,6 @@
#'
#' @return A \code{"Position"} object.
#'
#' @importFrom polynom polynomial
#'
#' @export
#'
#' @examples
Expand Down
217 changes: 106 additions & 111 deletions R/stat-quadrant-counts.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -164,129 +164,124 @@ stat_quadrant_counts <- function(mapping = NULL,
}

#' @rdname ggpp-ggproto
#'
#' @format NULL
#' @usage NULL
#'
compute_counts_fun <- function(data,
scales,
quadrants,
pool.along,
xintercept,
yintercept,
label.x,
label.y) {
#' @export
StatQuadrantCounts <-
ggplot2::ggproto("StatQuadrantCounts", ggplot2::Stat,

which_quadrant <- function(x, y) {
z <- ifelse(x >= xintercept & y >= yintercept,
1L,
ifelse(x >= xintercept & y < yintercept,
2L,
ifelse(x < xintercept & y < yintercept,
3L,
4L)))
if (pool.along == "x") {
z <- ifelse(z %in% c(1L, 4L), 1L, 2L)
} else if(pool.along == "y") {
z <- ifelse(z %in% c(1L, 2L), 1L, 4L)
}
z
}
compute_panel = function(data,
scales,
quadrants,
pool.along,
xintercept,
yintercept,
label.x,
label.y) {

force(data)
# compute range of whole data
range.x <- range(data$x)
range.y <- range(data$y)
# set position for labels in npc units
if (is.null(label.x)) {
if (pool.along == "x") {
label.x <- rep("centre", 2)
} else {
label.x <- c("left", "right")
}
}
if (is.null(label.y)) {
if (pool.along == "y") {
label.y <- rep("centre", 2)
} else {
label.y <- c("bottom", "top")
}
}
which_quadrant <- function(x, y) {
z <- ifelse(x >= xintercept & y >= yintercept,
1L,
ifelse(x >= xintercept & y < yintercept,
2L,
ifelse(x < xintercept & y < yintercept,
3L,
4L)))
if (pool.along == "x") {
z <- ifelse(z %in% c(1L, 4L), 1L, 2L)
} else if(pool.along == "y") {
z <- ifelse(z %in% c(1L, 2L), 1L, 4L)
}
z
}

label.x <- compute_npcx(label.x)
label.y <- compute_npcy(label.y)
force(data)
# compute range of whole data
range.x <- range(data$x)
range.y <- range(data$y)
# set position for labels in npc units
if (is.null(label.x)) {
if (pool.along == "x") {
label.x <- rep("centre", 2)
} else {
label.x <- c("left", "right")
}
}
if (is.null(label.y)) {
if (pool.along == "y") {
label.y <- rep("centre", 2)
} else {
label.y <- c("bottom", "top")
}
}

label.x <- range(label.x) # ensure length is always 2
label.y <- range(label.y) # ensure length is always 2
label.x <- compute_npcx(label.x)
label.y <- compute_npcy(label.y)

# dynamic default based on data range
if (is.null(quadrants)) {
if (all(range.x >= xintercept) && all(range.y >= yintercept)) {
quadrants <- 1L
} else if (all(range.x < xintercept) && all(range.y < yintercept)) {
quadrants <- 3L
} else if (all(range.x >= xintercept)) {
quadrants <- c(1L, 2L)
} else if (all(range.y >= yintercept)) {
quadrants <- c(1L, 4L)
} else {
quadrants <- c(1L, 2L, 3L, 4L)
}
}
if (pool.along == "x") {
quadrants <- intersect(quadrants, c(1L, 2L))
}
if (pool.along == "y") {
quadrants <- intersect(quadrants, c(1L, 4L))
}
label.x <- range(label.x) # ensure length is always 2
label.y <- range(label.y) # ensure length is always 2

if (all(is.na(quadrants)) || 0L %in% quadrants) {
# total count
tibble::tibble(quadrant = 0,
count = nrow(data),
npcx = label.x[2],
npcy = label.y[2],
x = range.x[2],
y = range.y[2])
} else {
# counts for the selected quadrants
data %>%
dplyr::mutate(quadrant = which_quadrant(.data$x, .data$y)) %>%
dplyr::filter(.data$quadrant %in% quadrants) %>%
dplyr::group_by(.data$quadrant) %>%
dplyr::summarise(count = length(.data$x)) %>% # dplyr::n() triggers error
dplyr::ungroup() -> data
# dynamic default based on data range
if (is.null(quadrants)) {
if (all(range.x >= xintercept) && all(range.y >= yintercept)) {
quadrants <- 1L
} else if (all(range.x < xintercept) && all(range.y < yintercept)) {
quadrants <- 3L
} else if (all(range.x >= xintercept)) {
quadrants <- c(1L, 2L)
} else if (all(range.y >= yintercept)) {
quadrants <- c(1L, 4L)
} else {
quadrants <- c(1L, 2L, 3L, 4L)
}
}
if (pool.along == "x") {
quadrants <- intersect(quadrants, c(1L, 2L))
}
if (pool.along == "y") {
quadrants <- intersect(quadrants, c(1L, 4L))
}

zero.count.quadrants <- setdiff(quadrants, data$quadrant)
if (all(is.na(quadrants)) || 0L %in% quadrants) {
# total count
tibble::tibble(quadrant = 0,
count = nrow(data),
npcx = label.x[2],
npcy = label.y[2],
x = range.x[2],
y = range.y[2])
} else {
# counts for the selected quadrants
data %>%
dplyr::mutate(quadrant = which_quadrant(.data$x, .data$y)) %>%
dplyr::filter(.data$quadrant %in% quadrants) %>%
dplyr::group_by(.data$quadrant) %>%
dplyr::summarise(count = length(.data$x)) %>% # dplyr::n() triggers error
dplyr::ungroup() -> data

if (length(zero.count.quadrants) > 0) {
data <-
rbind(data, tibble::tibble(quadrant = zero.count.quadrants, count = 0L))
}
zero.count.quadrants <- setdiff(quadrants, data$quadrant)

data %>%
dplyr::mutate(npcx = ifelse(.data$quadrant %in% c(1L, 2L),
label.x[2],
label.x[1]),
npcy = ifelse(.data$quadrant %in% c(1L, 4L),
label.y[2],
label.y[1]),
x = ifelse(.data$quadrant %in% c(1L, 2L),
range.x[2],
range.x[1]),
y = ifelse(.data$quadrant %in% c(1L, 4L),
range.y[2],
range.y[1]))
}
}
if (length(zero.count.quadrants) > 0) {
data <-
rbind(data, tibble::tibble(quadrant = zero.count.quadrants, count = 0L))
}

data %>%
dplyr::mutate(npcx = ifelse(.data$quadrant %in% c(1L, 2L),
label.x[2],
label.x[1]),
npcy = ifelse(.data$quadrant %in% c(1L, 4L),
label.y[2],
label.y[1]),
x = ifelse(.data$quadrant %in% c(1L, 2L),
range.x[2],
range.x[1]),
y = ifelse(.data$quadrant %in% c(1L, 4L),
range.y[2],
range.y[1]))
}
},

#' @rdname ggpp-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatQuadrantCounts <-
ggplot2::ggproto("StatQuadrantCounts", ggplot2::Stat,
compute_panel = compute_counts_fun,
default_aes =
ggplot2::aes(npcx = ggplot2::after_stat(npcx),
npcy = ggplot2::after_stat(npcy),
Expand Down
1 change: 0 additions & 1 deletion man/ggpp-ggproto.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

Binary file modified tests/testthat/Rplots.pdf
View file
Binary file not shown.

0 comments on commit 6fb33a0

Please sign in to comment.