Skip to content

Commit

Permalink
move dependency check out of compute/draw step to properly throw an e…
Browse files Browse the repository at this point in the history
…rror + refactor inspired by ggplot2
thomasp85 committed Mar 7, 2019
1 parent bb37ea1 commit 4fa7b1a
Showing 4 changed files with 77 additions and 31 deletions.
6 changes: 2 additions & 4 deletions R/mark_hull.R
Original file line number Diff line number Diff line change
@@ -93,6 +93,8 @@ NULL
#' @export
GeomMarkHull <- ggproto('GeomMarkHull', GeomShape,
setup_data = function(self, data, params) {
try_require('concaveman', snake_class(self))

if (!is.null(data$filter)) {
self$removed <- data[!data$filter, c('x', 'y', 'PANEL')]
data <- data[data$filter, ]
@@ -111,10 +113,6 @@ GeomMarkHull <- ggproto('GeomMarkHull', GeomShape,
con.colour = 'black', con.size = 0.5, con.type = 'elbow',
con.linetype = 1, con.border = 'one',
con.cap = unit(3, 'mm'), con.arrow = NULL) {
if (!requireNamespace('concaveman', quietly = TRUE)) {
stop('The concaveman package is required to use geom_mark_hull',
call. = FALSE)
}
if (nrow(data) == 0) return(zeroGrob())

coords <- coord$transform(data, panel_params)
16 changes: 2 additions & 14 deletions R/scale-unit.R
Original file line number Diff line number Diff line change
@@ -43,9 +43,7 @@ scale_x_unit <- function(name = waiver(), breaks = waiver(), unit = NULL,
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = 'identity',
position = 'bottom', sec.axis = waiver()) {
if (!requireNamespace('units', quietly = TRUE)) {
stop('The units package is required for this functionality', call. = FALSE)
}
try_require('units', 'scale_x_unit')
sc <- continuous_scale(
c('x', 'xmin', 'xmax', 'xend', 'xintercept', 'xmin_final', 'xmax_final',
'xlower', 'xmiddle', 'xupper'),
@@ -82,9 +80,7 @@ scale_y_unit <- function(name = waiver(), breaks = waiver(), unit = NULL,
limits = NULL, expand = waiver(), oob = censor,
na.value = NA_real_, trans = 'identity',
position = 'left', sec.axis = waiver()) {
if (!requireNamespace('units', quietly = TRUE)) {
stop('The units package is required for this functionality', call. = FALSE)
}
try_require('units', 'scale_y_unit')
sc <- continuous_scale(
c('y', 'ymin', 'ymax', 'yend', 'yintercept', 'ymin_final', 'ymax_final',
'lower', 'middle', 'upper'),
@@ -121,10 +117,6 @@ ScaleContinuousPositionUnit <- ggproto('ScaleContinuousPositionUnit', ScaleConti
unit = NULL,

train = function(self, x) {
if (!requireNamespace('units', quietly = TRUE)) {
stop('The units package is required for this functionality',
call. = FALSE)
}
if (length(x) == 0) return()
if (!is.null(self$unit)) {
units(x) <- units::as_units(1, self$unit)
@@ -143,10 +135,6 @@ ScaleContinuousPositionUnit <- ggproto('ScaleContinuousPositionUnit', ScaleConti
ggproto_parent(ScaleContinuousPosition, self)$map(x, limits)
},
make_title = function(self, title) {
if (!requireNamespace('units', quietly = TRUE)) {
stop('The units package is required for this functionality',
call. = FALSE)
}
units::make_unit_label(title, units::as_units(1, self$unit))
}
)
48 changes: 48 additions & 0 deletions R/utilities.R
Original file line number Diff line number Diff line change
@@ -214,3 +214,51 @@ dapply <- function(df, by, fun, ..., drop = TRUE) {
new_data_frame(modify_list(unclass(vars), unclass(res)))
}))
}

# Test whether package `package` is available. `fun` provides
# the name of the ggplot2 function that uses this package, and is
# used only to produce a meaningful error message if the
# package is not available.
try_require <- function(package, fun) {
if (requireNamespace(package, quietly = TRUE)) {
return(invisible())
}

stop("Package `", package, "` required for `", fun , "`.\n",
"Please install and try again.", call. = FALSE)
}
# Use chartr() for safety since toupper() fails to convert i to I in Turkish locale
lower_ascii <- "abcdefghijklmnopqrstuvwxyz"
upper_ascii <- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
to_lower_ascii <- function(x) chartr(upper_ascii, lower_ascii, x)
to_upper_ascii <- function(x) chartr(lower_ascii, upper_ascii, x)

tolower <- function(x) {
stop('Please use `to_lower_ascii()`, which works fine in all locales.', call. = FALSE)
}

toupper <- function(x) {
stop('Please use `to_upper_ascii()`, which works fine in all locales.', call. = FALSE)
}

# Convert a snake_case string to camelCase
camelize <- function(x, first = FALSE) {
x <- gsub("_(.)", "\\U\\1", x, perl = TRUE)
if (first) x <- firstUpper(x)
x
}

snakeize <- function(x) {
x <- gsub("([A-Za-z])([A-Z])([a-z])", "\\1_\\2\\3", x)
x <- gsub(".", "_", x, fixed = TRUE)
x <- gsub("([a-z])([A-Z])", "\\1_\\2", x)
to_lower_ascii(x)
}

firstUpper <- function(s) {
paste0(to_upper_ascii(substring(s, 1, 1)), substring(s, 2))
}

snake_class <- function(x) {
snakeize(class(x)[1])
}
38 changes: 25 additions & 13 deletions R/voronoi.R
Original file line number Diff line number Diff line change
@@ -133,9 +133,12 @@ NULL
#' @importFrom scales rescale
#' @export
StatVoronoiTile <- ggproto('StatVoronoiTile', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
max.radius = NULL, normalize = FALSE, asp.ratio = 1) {
require_deldir()
data$group <- paste0(seq_len(nrow(data)), ':', data$group)
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_voronoi_tile: dropping duplicated points', call. = FALSE)
@@ -210,9 +213,12 @@ geom_voronoi_tile <- function(mapping = NULL, data = NULL, stat = 'voronoi_tile'
#' @importFrom scales rescale
#' @export
StatVoronoiSegment <- ggproto('StatVoronoiSegment', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(self, data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
require_deldir()
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_voronoi_segment: dropping duplicated points', call. = FALSE)
}
@@ -267,9 +273,12 @@ geom_voronoi_segment <- function(mapping = NULL, data = NULL,
#' @importFrom scales rescale
#' @export
StatDelaunayTile <- ggproto('StatDelaunayTile', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_panel = function(data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
require_deldir()
if (normalize) {
x_range <- range(data$x, na.rm = TRUE, finite = TRUE)
y_range <- range(data$y, na.rm = TRUE, finite = TRUE)
@@ -328,9 +337,12 @@ geom_delaunay_tile <- function(mapping = NULL, data = NULL,
#' @importFrom scales rescale
#' @export
StatDelaunaySegment <- ggproto('StatDelaunaySegment', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9,
normalize = FALSE, asp.ratio = 1) {
require_deldir()
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delaunay_segment: dropping duplicated points',
call. = FALSE)
@@ -387,9 +399,12 @@ geom_delaunay_segment <- function(mapping = NULL, data = NULL,
#' @importFrom scales rescale
#' @export
StatDelaunaySegment2 <- ggproto('StatDelaunaySegment2', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9, n = 100,
normalize = FALSE, asp.ratio = 1) {
require_deldir()
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delaunay_segment2: dropping duplicated points',
call. = FALSE)
@@ -448,10 +463,13 @@ geom_delaunay_segment2 <- function(mapping = NULL, data = NULL,
#' @importFrom scales rescale
#' @export
StatDelvorSummary <- ggproto('StatDelvorSummary', Stat,
setup_params = function(self, data, params) {
try_require('deldir', snake_class(self))
params
},
compute_group = function(data, scales, bound = NULL, eps = 1e-9,
switch.centroid = FALSE, normalize = FALSE,
asp.ratio = 1) {
require_deldir()
if (any(duplicated(data[, c('x', 'y')]))) {
warning('stat_delvor_summary: dropping duplicated points',
call. = FALSE)
@@ -509,14 +527,8 @@ stat_delvor_summary <- function(mapping = NULL, data = NULL, geom = 'point',


# HELPERS -----------------------------------------------------------------
require_deldir <- function() {
if (!requireNamespace('deldir', quietly = TRUE)) {
stop('The delauney-based geoms and stats require the deldir package',
call. = FALSE)
}
}
to_tile <- function(object) {
require_deldir()
try_require('deldir', 'to_tile')
tiles <- rbind(
structure(object$dirsgs[, c(1:2, 5)], names = c('x', 'y', 'group')),
structure(object$dirsgs[, c(1:2, 6)], names = c('x', 'y', 'group')),

0 comments on commit 4fa7b1a

Please sign in to comment.