diff --git a/.Rbuildignore b/.Rbuildignore index 8e9d843..7182d4c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -16,3 +16,4 @@ ^appveyor\.yml$ ^codecov\.yml$ ^data-raw$ +^\.github$ \ No newline at end of file diff --git a/R/geom-oscar.R b/R/geom-oscar.R index aa34a0b..fbaacc5 100644 --- a/R/geom-oscar.R +++ b/R/geom-oscar.R @@ -1,99 +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 - -) +# +# 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 index d95fba6..3b19093 100644 --- a/R/geom-otile.R +++ b/R/geom-otile.R @@ -1,69 +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 - -) - +# 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/oscar-grob.R b/R/oscar-grob.R index c60a810..9131c22 100644 --- a/R/oscar-grob.R +++ b/R/oscar-grob.R @@ -1,48 +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) -} +# +# 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) +# }