boB Rudis
6 years ago
7 changed files with 230 additions and 11 deletions
@ -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 |
||||
|
|
||||
|
) |
@ -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 |
||||
|
|
||||
|
) |
||||
|
|
@ -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) |
||||
|
} |
Loading…
Reference in new issue