Nothing
#' Heatgrid
#'
#' The heatgrid geom is used to create a modified heat map that uses luminance
#' to show the values from two sources on the same plot.
#'
#' @param outside The column name for the outside portion of heatgrid.
#' @param outside_name The label name (in quotes) for the legend of the outside
#' rendering. Default is \code{NULL}.
#' @param outside_colors A color vector, usually as hex codes.
#' @param inside The column name for the inside portion of heatgrid.
#' @param inside_name The label name (in quotes) for the legend of the inside
#' rendering. Default is \code{NULL}.
#' @param inside_colors A color vector, usually as hex codes.
#' @param r The value that controls how large of the inside portion with respect
#' to the outside one. When \code{r} is larger, the inside get smaller.
#' Default value is 2*sqrt(2) for achieving the equal inner and outer areas.
#' @param ... \code{...} accepts any arguments \code{scale_fill_gradientn()} has
#' .
#'
#' @import ggplot2
#' @import grid
#' @import rlang
#' @import ggnewscale
#' @export
#' @return A heatgrid comparing two data sources.
#' @examples
#'
#' # heatgrid with categorical variables only
#'
#' library(ggplot2)
#'
#' data <- data.frame(x = rep(c("a", "b", "c"), 3),
#' y = rep(c("d", "e", "f"), 3),
#' outside_values = rep(c(1,5,7),3),
#' inside_values = rep(c(2,3,4),3))
#'
#' ggplot(data, aes(x,y)) +
#' geom_heat_grid(outside = outside_values,
#' inside = inside_values)
#'
#' # Making the inside smaller by setting r to be larger.
#'
#' ggplot(data, aes(x,y)) +
#' geom_heat_grid(outside = outside_values,
#' inside = inside_values,
#' r = 5)
#'
#' # heatgrid with numeric variables only
#'
#' data <- data.frame(x = rep(c(1, 2, 3), 3),
#' y = rep(c(1, 2, 3), 3),
#' outside_values = rep(c(1,5,7),3),
#' inside_values = rep(c(2,3,4),3))
#'
#' ggplot(data, aes(x,y)) +
#' geom_heat_grid(outside = outside_values,
#' inside = inside_values)
#'
#'
#' # heatgrid with a mixture of numeric and categorical variables
#'
#' data <- data.frame(x = rep(c("a", "b", "c"), 3),
#' y = rep(c(1, 2, 3), 3),
#' outside_values = rep(c(1,5,7),3),
#' inside_values = rep(c(2,3,4),3))
#'
#' ggplot(data, aes(x,y)) +
#' geom_heat_grid(outside = outside_values,
#' inside = inside_values)
#'
#'
#'
#'
geom_heat_grid <- function(outside,
outside_name = NULL,
outside_colors = c("#FED7D8","#FE8C91", "#F5636B", "#E72D3F","#C20824"),
inside,
inside_name = NULL,
inside_colors = c('gray100', 'gray85', 'gray50', 'gray35', 'gray0'),
r = 2*sqrt(2),
...){
if(r <= 2){rlang::abort(message = "`r` has to be greater than 2.")}
if(is.null(outside_name)) {outside_name = rlang::expr({{ outside }})}
if(is.null(inside_name)) {inside_name = rlang::expr({{ inside }})}
list(geom_tile_outside(ggplot2::aes(fill = {{ outside }})),
ggplot2::scale_fill_gradientn(outside_name, colors = outside_colors, ...),
ggnewscale::new_scale_fill(),
geom_tile_inside(ggplot2::aes(fill = {{ inside }}, r = r)),
ggplot2::scale_fill_gradientn(inside_name, colors = inside_colors, ...))
}
#' @format NULL
#' @usage NULL
GeomRectCenter <- ggplot2::ggproto("GeomRectCenter", ggplot2::Geom,
default_aes = ggplot2::aes(color = "black", fill = NA, size = 0.5, linetype = 1,
alpha = NA),
required_aes = c("xmin", "xmax", "ymin", "ymax"),
draw_panel = function(data, panel_params, coord) {
coords <- coord$transform(data, panel_params)
grid::rectGrob(
x = (coords$xmin + coords$xmax)/2,
y = (coords$ymin + coords$ymax)/2,
width = coords$xmax - coords$xmin,
height = coords$ymax - coords$ymin,
just = "center",
gp = gpar(
col = coords$color,
fill = alpha(coords$fill, coords$alpha),
lwd = coords$size * .pt,
lty = coords$linetype
)
)
},
draw_key = ggplot2::draw_key_rect
)
#' @format NULL
#' @usage NULL
GeomTileOutside <- ggplot2::ggproto("GeomTileOutside", GeomRectCenter,
extra_params = c("na.rm"),
setup_data = function(data, params) {
data$width <- data$width %||% params$width %||% resolution(data$x, FALSE)
data$height <- data$height %||% params$height %||% 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
)
},
default_aes = ggplot2::aes(fill = "grey20", colour = NA, size = 0.1, linetype = 1,
alpha = NA, width = NA, height = NA),
required_aes = c("x", "y"),
non_missing_aes = c("xmin", "xmax", "ymin", "ymax"),
draw_key = ggplot2::draw_key_rect
)
geom_tile_outside <- function(mapping = NULL, data = NULL,
stat = "identity", position = "identity",
...,
linejoin = "mitre",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomTileOutside,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
...
)
)
}
#' @format NULL
#' @usage NULL
GeomTileInside <- ggplot2::ggproto("GeomTileInside", GeomTileOutside,
setup_data = function(data, params) {
data$width <- data$width %||% params$width %||% resolution(data$x, FALSE)
data$height <- data$height %||% params$height %||% resolution(data$y, FALSE)
transform(data,
xmin = x - width/r, xmax = x + width/r, width = NULL,
ymin = y - height/r, ymax = y + height/r, height = NULL
)
},
required_aes = c("x", "y", "r")
)
geom_tile_inside <- function(mapping = NULL, data = NULL,
stat = "identity", position = "identity",
...,
linejoin = "mitre",
na.rm = FALSE,
show.legend = NA,
inherit.aes = TRUE) {
ggplot2::layer(
data = data,
mapping = mapping,
stat = stat,
geom = GeomTileInside,
position = position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(
na.rm = na.rm,
...
)
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.