Nothing
# Drawers -------------------------------------------------
#' grindr drawers for shape plots
#'
#' Useful drawers for building custom
#' shape plots using the grindr approach. See examples and vignettes.
#'
#' @note This approach will (soon) replace [coo_plot] and friends in further versions.
#' All comments are welcome.
#'
#' @name drawers
#' @rdname drawers
#' @seealso grindr_layers
#' @family grindr
#'
#' @param coo \code{matrix} of 2 columns for (x, y) coordinates
#' @param f an optionnal factor specification to feed. See examples and vignettes.
#' @param col color (hexadecimal) to draw components
#' @param fill color (hexadecimal) to draw components
#' @param pal a palette to use if no col/border/etc. are provided. See `[palettes]`
#' @param pch to draw components
#' @param cex to draw components ((`c(2, 1)` by default) for `draw_title`)
#' @param lwd to draw components
#' @param lty to draw components
#' @param transp `numeric` transparency (default:0, min:0, max:1)
#' @param label to indicate first point
#' @param labels \code{character} name of labels to draw (defaut to \code{1:nrow(coo)})
#' @param d `numeric` proportion of `d(centroid-each_point)` to add when centrifugating landmarks
#' @param links `matrix` of links to use to draw segments between landmarks. See `wings$ldk` for an example
#' @param main `character` title (empty by default)
#' @param sub `character` subtitle (empty by default)
#' @param font `numeric` to feed [text] (`c(2, 1)` by default)
#' @param padding `numeric` a fraction of the graphical window (`1/200` by default)
#' @param ... additional options to feed core functions for each drawer
#' @return a drawing layer
#'
#' @examples
#' bot[1] %>% paper_grid() %>% draw_polygon()
#' olea %>% paper_chess %>% draw_lines(~var)
#'
#' hearts[240] %>% paper_white() %>% draw_outline() %>%
#' coo_sample(24) %>% draw_landmarks %>% draw_labels() %>%
#' draw_links(links=replicate(2, sample(1:24, 8)))
#'
#' bot %>%
#' paper_grid() %>%
#' draw_outlines() %>%
#' draw_title("Alcohol abuse \nis dangerous for health", "Drink responsibly")
#' @export
draw_polygon <- function(coo, f, col=par("fg"), fill=NA, lwd=1, lty=1, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
if (missing(fill))
fills <- this_dispatcher(f, par("bg")) %>% pal_alpha(1)
else
fills <- this_dispatcher(f, fill) %>% pal_alpha(transp)
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
lwds <- this_dispatcher(f, lwd)
ltys <- this_dispatcher(f, lty)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# draw the outlines as a polygon
for (i in seq_along(x))
polygon(x[[i]][, 1], x[[i]][, 2],
border=cols[i], col=fills[i],
lty=ltys[i], lwd=lwds[i], ...)
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_outline <- draw_polygon
#' @export
#' @rdname drawers
draw_outlines <- draw_polygon
#' @export
#' @rdname drawers
draw_points <- function(coo, f, col=par("fg"), cex=1/2, pch=20, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
cexs <- this_dispatcher(f, cex)
pchs <- this_dispatcher(f, pch)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# single shape case (eg for PCA$x)
if (length(x)==1){
points(x[[1]][, 1], x[[1]][, 2],
col=cols,
cex=cexs, pch=pchs, ...)
} else {
# otherwise, draw the points
for (i in seq_along(x))
points(x[[i]][, 1], x[[i]][, 2],
col=cols[i],
cex=cexs[i], pch=pchs[i], ...)
}
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_landmarks <- draw_points
#' @export
#' @rdname drawers
draw_lines <- function(coo, f, col=par("fg"), lwd=1, lty=1, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
lwds <- this_dispatcher(f, lwd)
ltys <- this_dispatcher(f, lty)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# draw the outlines as a polygon
for (i in seq_along(x))
lines(x[[i]][, 1], x[[i]][, 2],
col=cols[i],
lty=ltys[i], lwd=lwds[i], ...)
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_centroid <- function(coo, f, col=par("fg"), pch=3, cex=0.5, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
cexs <- this_dispatcher(f, cex)
pchs <- this_dispatcher(f, pch)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# calculate centpos
x <- lapply(x, coo_centpos)
# draw the outlines as a polygon
for (i in seq_along(x))
points(x[[i]][1], x[[i]][2],
col=cols[i],
cex=cexs[i], pch=pchs[i], ...)
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_curve <- draw_lines
#' @export
#' @rdname drawers
draw_curves <- draw_lines
#' @export
#' @rdname drawers
draw_firstpoint <- function(coo, f, label="^", col=par("fg"), cex=3/4, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
labels <- this_dispatcher(f, label)
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
cexs <- this_dispatcher(f, cex)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# draw the outlines as a polygon
for (i in seq_along(x)){
# calculate the tangent angle (in degrees) between the first 2 points
angle <- atan2(x[[i]][2, 2] - x[[i]][1, 2],
x[[i]][2, 1] - x[[i]][1, 1]) * (180/pi) - 90
# draw it as a little circumflex
text(x[[i]][1, 1], x[[i]][1, 2],
labels = labels[i], col=cols[i], cex = cexs[i], srt = angle, ...)
}
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_axes <- function(coo, col="#999999", lwd=1/2, ...){
# add x=0 and y=0 lines for axes
abline(h=0, v=0, col=col, lwd=lwd, ...)
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
# cosmetics
draw_ticks <- function(coo, col="#333333", cex=3/4, lwd=3/4, ...){
at <- function(x) signif(c(min(x), mean(x), max(x)), 3)
# we dont need this here but it preserves
# parallelism between functions
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
x <- do.call("rbind", x)
at_x <- at(x[, 1])
at_y <- at(x[, 2])
pos_x <- min(at_y) + max(strheight(at_x, cex=cex)) - .wdw()[2]/50
pos_y <- min(at_x) + max(strheight(at_y, cex=cex)) - .wdw()[1]/50
axis(1, at=at_x, pos=pos_x,
col="#FFFFFF00", # fully transparent
col.ticks=col, cex.axis=cex,
lwd=lwd, lwd.ticks=lwd, tcl = -1/5, las=1)
axis(2, at=at_y, pos=pos_y,
col="#FFFFFF00", # fully transparent
col.ticks=col, cex.axis=cex,
lwd=lwd, lwd.ticks=lwd, tcl = -1/5, las=1)
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_labels <- function(coo, labels=1:nrow(coo), cex=1/2, d=1/20, ...){
# neater par
# here ensure that even centrifugated labels got plotted
old <- par(mar=rep(1/8, 4))
on.exit(par(old))
# this one does not support f and,
# if a Coo is provided turn it into the mean shape
# Coo case
if (is_Coo(coo))
coo <- MSHAPES(coo)
# centrifugate labels positions of d*median(distance centroid)
# away from centroid
centpos <- coo_centpos(coo)
dm <- median(coo_centdist(coo))
for (i in 1:nrow(coo)) {
dxy <- ed(centpos, coo[i, ])
labxy <- edi(centpos, coo[i, ], (dxy + dm * d)/dxy)
# draw
text(labxy[1], labxy[2], labels = i, cex = cex, ...)
}
# propagate
invisible(coo)
}
#' @export
#' @rdname drawers
draw_links <- function(coo, f, links, col="#99999955", lwd=1/2, lty=1, transp=0, pal=pal_qual, ...){
# shape case
if (is_shp(coo))
x <- list(coo)
# list and Coo case
if (is.list(coo)){
if (is_Coo(coo))
x <- coo$coo
else
x <- coo
}
# handle factor
if (!missing(f)){ # factor case for f is native: if (is.factor(f)) f <- f
if (is_Coo(coo))
f <- fac_dispatcher(coo, f)
# handle palette
if (missing(col)){
col <- pal(nlevels(f))
}
} else {
f <- factor(rep(1, length(x)))
}
# dispatch drawer argument
cols <- this_dispatcher(f, col) %>% pal_alpha(transp)
lwds <- this_dispatcher(f, lwd)
ltys <- this_dispatcher(f, lty)
# gr parameters
old <- par(xpd=NA)
on.exit(par(old))
# draw the links
for (i in seq_along(x)){
for (j in 1:nrow(links)) {
segments(x[[i]][links[j, 1], 1],
x[[i]][links[j, 1], 2],
x[[i]][links[j, 2], 1],
x[[i]][links[j, 2], 2],
col=cols[i], lwd=lwds[i], lty=ltys[i], ...)
}
}
# propagate
invisible(coo)
}
# wings %>% MSHAPES %>% paper %>% draw_links(links=wings$links) %>% draw_landmarks %>% draw_labels(d=1/5)
#' @export
#' @rdname drawers
draw_title <- function(coo, main="", sub="", cex=c(1, 3/4), font=c(2, 1), padding=1/200, ...){
# preserve the par
old <- par(xpd=NA)
on.exit(par(old))
# deduce coordinates
u <- par("usr")
w <- .wdw()
x_left <- u[1] + w[1]*padding
y_top_main <- u[4] - w[2]*padding - strheight(main, cex=cex)
y_top_sub <- y_top_main - w[2]*padding*2 - strheight(sub, cex=cex)
# draw title and sub
text(x_left, y_top_main, main, cex=cex[1], adj=c(0, 0), font=font[1], ...)
text(x_left, y_top_sub, sub, cex=cex[2], adj=c(0, 0), font=font[2], ...)
# propagate
invisible(coo)
}
# draw_text
# draw_radii
# draw_contour
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.