Browse Source

cleanup to pass CRAN checks

master
boB Rudis 2 years ago
parent
commit
da22fb7a95
No known key found for this signature in database GPG Key ID: 1D7529BE14E2BBA9
  1. 1
      .Rbuildignore
  2. 198
      R/geom-oscar.R
  3. 138
      R/geom-otile.R
  4. 96
      R/oscar-grob.R

1
.Rbuildignore

@ -16,3 +16,4 @@
^appveyor\.yml$
^codecov\.yml$
^data-raw$
^\.github$

198
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
#
# )

138
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
#
# )
#

96
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)
# }

Loading…
Cancel
Save