From 93446dfce4602d028fc8eae6bf9f8213c9f91519 Mon Sep 17 00:00:00 2001 From: hrbrmstr Date: Sat, 25 Aug 2018 16:51:19 -0400 Subject: [PATCH] suppress warnings --- DESCRIPTION | 4 +++ R/geom-oscar.R | 99 +++++++++++++++++++++++++++++++++++++++++++++++++++ R/geom-otile.R | 69 +++++++++++++++++++++++++++++++++++ R/geom-statebins.r | 7 ++-- R/oscar-grob.R | 48 +++++++++++++++++++++++++ R/util.R | 6 ++-- man/geom_statebins.Rd | 8 ++--- 7 files changed, 230 insertions(+), 11 deletions(-) create mode 100644 R/geom-oscar.R create mode 100644 R/geom-otile.R create mode 100644 R/oscar-grob.R diff --git a/DESCRIPTION b/DESCRIPTION index abf7710..e489c09 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,6 +27,7 @@ Description: Cartogram heatmaps are an alternative to choropleth maps for 'USA' URL: https://github.com/hrbrmstr/statebins BugReports: https://github.com/hrbrmstr/statebins/issues License: MIT + file LICENSE +Encoding: UTF-8 Suggests: testthat, viridis, @@ -41,6 +42,9 @@ Imports: RoxygenNote: 6.0.1.9000 Collate: 'aaa.R' + 'geom-oscar.R' + 'geom-otile.R' + 'oscar-grob.R' 'geom-rrect.r' 'geom-rtile.R' 'geom-statebins.r' diff --git a/R/geom-oscar.R b/R/geom-oscar.R new file mode 100644 index 0000000..aa34a0b --- /dev/null +++ b/R/geom-oscar.R @@ -0,0 +1,99 @@ + +geom_oscar <- function(mapping = NULL, data = NULL, + ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE) { + + stat = "oscar" + position = "identity" + + layer( + data = data, + mapping = mapping, + stat = stat, + geom = GeomOscar, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list( + na.rm = na.rm, + ... + ) + ) +} + +StatOscar<- ggplot2::ggproto("StatOscar", Stat, + + required_aes = c("xmin", "xmax", "ymin", "ymax"), + + default_aes = ggplot2::aes( + l_fill = "blue", r_fill = "red", colour = NA, size = 0.1, linetype = 1, alpha = NA + ), + + required_aes = c("x", "y"), + + compute_panel = function(data, scales) { + data + } + +) + +stat_oscar <- function(mapping = NULL, data = NULL, geom = "oscar", + position = "identity", na.rm = FALSE, n = 500, revolutions = NULL, + show.legend = NA, inherit.aes = TRUE, ...) { + + layer( + stat = StatOscar, data = data, mapping = mapping, geom = geom, + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) + +} + +GeomOscar <- ggplot2::ggproto("GeomOscar", ggplot2::Geom, + + default_aes = ggplot2::aes( + l_fill = "blue", r_fill = "red", colour = NA, size = 0.1, linetype = 1, alpha = NA + ), + + draw_panel = function(self, data, panel_params, coord) { + + coords <- coord$transform(data, panel_params) + + lapply(1:length(coords$xmin), function(i) { + + oscarGrob( + name = as.character(i), + coords$xmin[i], coords$ymax[i], + width = (coords$xmax[i] - coords$xmin[i]), + height = (coords$ymax[i] - coords$ymin)[i], + default.units = "native", + gpbl = grid::gpar( + col = coords$colour[i], + fill = alpha(coords$l_fill[i], coords$alpha[i]), + lwd = coords$size[i] * .pt, + lty = coords$linetype[i], + lineend = "butt" + ), + gptr = grid::gpar( + col = coords$colour[i], + fill = alpha(coords$r_fill[i], coords$alpha[i]), + lwd = coords$size[i] * .pt, + lty = coords$linetype[i], + lineend = "butt" + ) + + ) + + }) -> gl + + grobs <- do.call(grid::gList, gl) + + ggname("geom_oscar", grid::grobTree(children = grobs)) + + }, + + draw_key = ggplot2::draw_key_polygon + +) diff --git a/R/geom-otile.R b/R/geom-otile.R new file mode 100644 index 0000000..d95fba6 --- /dev/null +++ b/R/geom-otile.R @@ -0,0 +1,69 @@ +geom_otile <- function(mapping = NULL, data = NULL, ..., + na.rm = FALSE, + show.legend = NA, + inherit.aes = TRUE) { + + stat <- "otile" + position <- "identity" + + ggplot2::layer( + data = data, + mapping = mapping, + stat = stat, + geom = GeomOtile, + position = position, + show.legend = show.legend, + inherit.aes = inherit.aes, + params = list( + na.rm = na.rm, + ... + ) + ) +} + +StatOtile <- ggplot2::ggproto("StatOtile", Stat, + + default_aes = ggplot2::aes( + colour = NA, size = 0.1, linetype = 1, alpha = NA, l_fill="blue", r_fill="red" + ), + + required_aes = c("x", "y"), + + compute_panel = function(data, scales) { + data + } + +) + +stat_otile <- function(mapping = NULL, data = NULL, geom = "otile", + position = "identity", na.rm = FALSE, + show.legend = NA, inherit.aes = TRUE, ...) { + + layer( + stat = StatOtile, data = data, mapping = mapping, geom = geom, + position = position, show.legend = show.legend, inherit.aes = inherit.aes, + params = list(na.rm = na.rm, ...) + ) + +} + +GeomOtile <- ggplot2::ggproto("GeomOtile", GeomOscar, + + default_aes = ggplot2::aes( + l_fill = "blue", r_fill = "red", colour = NA, size = 0.1, linetype = 1, alpha = NA + ), + + setup_data = function(data, params) { + data$width <- data$width %||% params$width %||% ggplot2::resolution(data$x, FALSE) + data$height <- data$height %||% params$height %||% ggplot2::resolution(data$y, FALSE) + + transform(data, + xmin = x - width / 2, xmax = x + width / 2, width = NULL, + ymin = y - height / 2, ymax = y + height / 2, height = NULL + ) + }, + + draw_key = ggplot2::draw_key_polygon + +) + diff --git a/R/geom-statebins.r b/R/geom-statebins.r index 4fe94c9..7d79a9d 100644 --- a/R/geom-statebins.r +++ b/R/geom-statebins.r @@ -30,7 +30,7 @@ #' @param border_col border color of the state squares, default "`white`" #' @param border_size thickness of the square state borders #' @param lbl_size font size (relative) of the label text -#' @param dark_lbl,light_lbl,na_lbl colors to be uses when the label should be dark, light, or NA. +#' @param dark_lbl,light_lbl colrs to be uses when the label should be dark or light. #' The function automagically computes when this should be. #' @param radius the corner radius #' @param na.rm If `FALSE`, the default, missing values are removed with @@ -72,7 +72,7 @@ geom_statebins <- function( mapping = NULL, data = NULL, border_col = "white", border_size = 2, - lbl_size = 3, dark_lbl = "black", light_lbl = "white", na_lbl = "white", + lbl_size = 3, dark_lbl = "black", light_lbl = "white", radius = grid::unit(6, "pt"), ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) { @@ -147,7 +147,6 @@ GeomStatebins <- ggplot2::ggproto("GeomStatebins", ggplot2::Geom, draw_panel = function(self, data, panel_params, coord, border_col = "white", border_size = 2, lbl_size = 3, dark_lbl = "black", light_lbl = "white", - na_lbl = "white", radius = grid::unit(6, "pt")) { tile_data <- data @@ -159,7 +158,7 @@ GeomStatebins <- ggplot2::ggproto("GeomStatebins", ggplot2::Geom, text_data$label <- data$abbrev text_data$fill <- NA text_data$size <- lbl_size - text_data$colour <- .sb_invert(data$fill, dark_lbl, light_lbl, na_lbl) + text_data$colour <- .sb_invert(data$fill, dark_lbl, light_lbl) coord <- coord_equal() diff --git a/R/oscar-grob.R b/R/oscar-grob.R new file mode 100644 index 0000000..c60a810 --- /dev/null +++ b/R/oscar-grob.R @@ -0,0 +1,48 @@ + +oscarGrob <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"), + width=unit(1, "npc"), height=unit(1, "npc"), + default.units="npc", + name=NULL, gpbl=gpar(), gptr=gpar(), vp=NULL) { + if (!is.unit(x)) + x <- unit(x, default.units) + if (!is.unit(y)) + y <- unit(y, default.units) + if (!is.unit(width)) + width <- unit(width, default.units) + if (!is.unit(height)) + height <- unit(height, default.units) + + if (length(name) == 0) name <- "oscar" + + ggname( + + name, + + grid::grobTree( + + grob(x=unit.c(x, x+width, x, x), + y=unit.c(y, y, y+height, y), + name=sprintf("%s_bl", name), gp=gpbl, vp=vp, cl="polygon"), + + grob(x=unit.c(x+width, x, x+width, x+width), + y=unit.c(y+height, y+height, y, y+height), + name=sprintf("%s_tr", name), gp=gptr, vp=vp, cl="polygon") + ) + + ) + +} + +grid.oscar <- function(x=unit(0.5, "npc"), y=unit(0.5, "npc"), + width=unit(1, "npc"), height=unit(1, "npc"), + default.units="npc", + name=NULL, gpbl=gpar(), gptr=gpar(), + draw=TRUE, vp=NULL) { + + rg <- oscarGrob(x=x, y=y, width=width, height=height, + default.units=default.units, + name=name, gpbl=gpbl, gptr=gptr, vp=vp) + if (draw) + grid.draw(rg) + invisible(rg) +} diff --git a/R/util.R b/R/util.R index 9af4620..35bc8ae 100644 --- a/R/util.R +++ b/R/util.R @@ -3,9 +3,9 @@ hex_color <- gsub("#", "", hex_color) - R <- as.integer(paste("0x", substr(hex_color,1,2), sep="")) - G <- as.integer(paste("0x", substr(hex_color,3,4), sep="")) - B <- as.integer(paste("0x", substr(hex_color,5,6), sep="")) + R <- suppressWarnings(as.integer(paste("0x", substr(hex_color,1,2), sep=""))) + G <- suppressWarnings(as.integer(paste("0x", substr(hex_color,3,4), sep=""))) + B <- suppressWarnings(as.integer(paste("0x", substr(hex_color,5,6), sep=""))) YIQ <- ((R*299) + (G*587) + (B*114)) / 1000 diff --git a/man/geom_statebins.Rd b/man/geom_statebins.Rd index 73172ce..4d77dd0 100644 --- a/man/geom_statebins.Rd +++ b/man/geom_statebins.Rd @@ -5,12 +5,12 @@ \alias{geom_statebins} \alias{GeomStatebins} \title{A statebins Geom} -\format{An object of class \code{GeomStatebins} (inherits from \code{Geom}, \code{ggproto}) of length 7.} +\format{An object of class \code{GeomStatebins} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 7.} \usage{ geom_statebins(mapping = NULL, data = NULL, border_col = "white", border_size = 2, lbl_size = 3, dark_lbl = "black", - light_lbl = "white", na_lbl = "white", radius = grid::unit(6, "pt"), - ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) + light_lbl = "white", radius = grid::unit(6, "pt"), ..., na.rm = FALSE, + show.legend = NA, inherit.aes = TRUE) GeomStatebins } @@ -40,7 +40,7 @@ will be used as the layer data.} \item{lbl_size}{font size (relative) of the label text} -\item{dark_lbl, light_lbl, na_lbl}{colors to be uses when the label should be dark, light, or NA. +\item{dark_lbl, light_lbl}{colrs to be uses when the label should be dark or light. The function automagically computes when this should be.} \item{radius}{the corner radius}