diff --git a/.Rbuildignore b/.Rbuildignore index 4ed7736..ba7733f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,4 @@ +revdep ^.*\.Rproj$ ^\.Rproj\.user$ ^\.travis\.yml$ diff --git a/DESCRIPTION b/DESCRIPTION index 0290643..98f51cb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: directlabels Maintainer: Toby Dylan Hocking Author: Toby Dylan Hocking -Version: 2020.6.17 +Version: 2020.12.29 BugReports: https://github.com/tdhock/directlabels/issues License: GPL-3 Title: Direct Labels for Multicolor Plots @@ -16,7 +16,8 @@ URL: https://github.com/tdhock/directlabels LazyData: true Suggests: MASS, knitr, markdown, - inlinedocs, + inlinedocs, + RColorBrewer, ggplot2 (>= 2.0), rlang, lattice, alphahull, nlme, lars, latticeExtra, diff --git a/NAMESPACE b/NAMESPACE index 2d2d959..0e4a772 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,6 +4,7 @@ S3method("direct.label", "ggplot") import(grid) import(quadprog) S3method("drawDetails", "dlgrob") +importFrom("grDevices", "col2rgb") importFrom("grDevices", "dev.off", "png") importFrom("stats", "approx", "update", "var") importFrom("utils", "capture.output", "data") diff --git a/NEWS b/NEWS index 6e820f1..af6176d 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,10 @@ Implement a solver for vertical.qp, to avoid depending on the compiled code in quadprog which I guess is not always available. Define makeContent.dlgrob instead of drawDetails.dlgrob in R-3.0? +Grid test for text with descent inside polygon? +use makeContent instead of drawDetails, which would make it possible +to test rendered output using grid.force +https://journal.r-project.org/archive/2013/RJ-2013-035/RJ-2013-035.pdf image labels: draw a grob on screen instead of assuming it is text. Have a toggle for drawing images and/or text. Handle both in a @@ -26,18 +30,40 @@ Maybe remove contour plot support/examples? https://cloud.r-project.org/web/packages/isoband/vignettes/isoband3.html does much better labels. -Grid test for text with descent inside polygon? -use makeContent instead of drawDetails, which would make it possible -to test rendered output using grid.force -https://journal.r-project.org/archive/2013/RJ-2013-035/RJ-2013-035.pdf - How to use geom_dl with stat_smooth? added vignette example based on https://github.com/tdhock/directlabels/issues/24 Get dldoc working / web page updated with new pos methods. -Get lattice transformation functions working again + tests. (Error: -data must have a column named label for qqmath examples) +How to figure out if user assigned aes(group)? You can always deduce +if a group was explicitly assigned by seeing if the group column is +positive... The -1 is an indicator saying that everything +automatically belongs to the same group. group and PANEL are the two +single columns that are enforced to always exist in the layer data and +is used extensively during the data preparation pipeline so it is +unlikely that we will make their presence optional. + +rot parameter respected by polygons method? + +2020.12.29 + +fix for single ggplot with two geom_dl with same method. previously +this would create two grobs with the same name in a single gTree, +which is not allowed (as documented in ?gTree) and resulted in only +the first geom_dl being drawn. Now we append a unique integer id to +each name so that grid draws both geom_dl. + +fix for lattice: Get lattice transformation functions working again + +tests. (Error: data must have a column named label for qqmath +examples) + +dldoc no longer uses type="cairo" at request of CRAN. + +2020.6.30 + +custom.colors argument for polygon.method, default choice of white or +black depending on how dark the color would be if rendered as +grayscale. 2020.6.17 diff --git a/R/doc.R b/R/doc.R index 5d7b9cf..cc43206 100644 --- a/R/doc.R +++ b/R/doc.R @@ -99,7 +99,7 @@ dldoc <- function # Make directlabels documentation pngurls[f$name,p$name] <- pngfile if(!file.exists(pngfile)){ cat(" ",f$name,sep="") - png(pngfile, type="cairo") + png(pngfile) set.seed(1) tryCatch({ print(direct.label(p$plot,f$fun)) diff --git a/R/lattice.R b/R/lattice.R index dbab0bc..3d723a1 100644 --- a/R/lattice.R +++ b/R/lattice.R @@ -114,7 +114,7 @@ panel.superpose.dl <- structure(function if(is.null(method))method <- default.picker("trellis") groups <- as.factor(groups) groups <- groups[subscripts] - d <- data.frame(x,groups) + d <- data.frame(x,groups,label=groups) d$y <- if(missing(y))NA else y type <- type[type!="g"] ## printing the grid twice looks bad. col.text <- diff --git a/R/positioning.functions.R b/R/positioning.functions.R index c16cdc4..40f0cdd 100644 --- a/R/positioning.functions.R +++ b/R/positioning.functions.R @@ -66,31 +66,37 @@ drawDetails.dlgrob <- function ##browser() } text.name <- paste0( - "directlabels.text.", - if(is.character(x$method))x$method) + "directlabels.text.", x$name) with(cm.data, grid.text( label,x,y,hjust=hjust,vjust=vjust,rot=rot,default.units="cm", gp=gp, name=text.name)) } +### This environment holds an integer id that will be incremented to +### get a unique id for each dlgrob. +dl.env <- new.env() +dl.env$dlgrob.id <- 0L + dlgrob <- function ### Make a grid grob that will draw direct labels. (data, ### Data frame including points to plot in native coordinates. - method, + method, ### Positioning Method. - debug=FALSE, - axes2native=identity, - ... - ){ + debug=FALSE, + axes2native=identity, + ... +){ + ## increment dlgrob.id to get a unique name because as explaine on + ## ?grid::gTree "Grob names need not be unique in general, but all + ## children of a gTree must have different names." + dl.env$dlgrob.id <- dl.env$dlgrob.id+1L + mstr <- if(is.character(method))method[1] else "NA" + name <- sprintf("GRID.dlgrob.%d.%s", dl.env$dlgrob.id, mstr) grob(data=data,method=method,debug=debug,axes2native=axes2native, cl="dlgrob", - name=if(is.character(method)){ - sprintf("GRID.dlgrob.%s",method[1]) - }else{ - "GRID.dlgrob" - },...) + name=name,...) } direct.label <- structure(function # Direct labels for color decoding diff --git a/R/utility.function.R b/R/utility.function.R index 897cb9f..4ec0143 100644 --- a/R/utility.function.R +++ b/R/utility.function.R @@ -390,9 +390,23 @@ polygon.method <- function ### Character string indicating what side of the plot to label. offset.cm=0.1, ### Offset from the polygon to the most extreme data point. - padding.cm=0.05 + padding.cm=0.05, ### Padding inside the polygon. + custom.colors=NULL +### Positioning method applied just before draw.polygons, can set +### box.color and text.color for custom colors. ){ + if(is.null(custom.colors)){ + custom.colors <- gapply.fun({ + rgb.mat <- col2rgb(d[["colour"]]) + d$text.color <- with(data.frame(t(rgb.mat)), { + ifelse( + (0.3 * red) + (0.59 * green) + (0.11 * blue)/255 < 0.5, + "white", "black") + }) + d + }) + } opposite.side <- c( left="right", right="left", @@ -452,6 +466,7 @@ polygon.method <- function make.tiebreaker(min.or.max.xy, qp.target), limits.fun), "calc.borders", + custom.colors, "draw.polygons") } @@ -810,6 +825,7 @@ gapply <- function res <- apply.method(method,d,columns.to.check=c("x","y"),...) if(nrow(res)){ res[[groups]] <- d[[groups]][1] + res[["label"]] <- d[["label"]][1] } res } diff --git a/data/odd_timings.RData b/data/odd_timings.RData new file mode 100644 index 0000000..ab3896e Binary files /dev/null and b/data/odd_timings.RData differ diff --git a/man/dl.env.Rd b/man/dl.env.Rd new file mode 100644 index 0000000..d79638c --- /dev/null +++ b/man/dl.env.Rd @@ -0,0 +1,12 @@ +\name{dl.env} +\alias{dl.env} +\docType{data} +\title{dl env} +\description{This environment holds an integer id that will be incremented to +get a unique id for each \code{\link{dlgrob}}.} +\usage{"dl.env"} + + + + + diff --git a/man/odd_timings.Rd b/man/odd_timings.Rd new file mode 100644 index 0000000..5db5d80 --- /dev/null +++ b/man/odd_timings.Rd @@ -0,0 +1,26 @@ +\name{odd_timings} +\alias{odd_timings} +\docType{data} +\title{ + Odd timings +} +\description{ + These timings data made strange output labels with the + "right.polygons" method. +} +\usage{data("odd_timings")} +\format{ + A data frame with 116 observations on the following 4 variables. Plot + median.seconds versus N.col using a different line for each fun and a + different panel for each captures. + \describe{ + \item{\code{N.col}}{a numeric vector} + \item{\code{fun}}{a character vector} + \item{\code{captures}}{a numeric vector} + \item{\code{median.seconds}}{a numeric vector} + } +} +\source{ + \url{https://github.com/tdhock/nc-article} +} +\keyword{datasets} diff --git a/man/polygon.method.Rd b/man/polygon.method.Rd index 1648b63..ee88519 100644 --- a/man/polygon.method.Rd +++ b/man/polygon.method.Rd @@ -5,11 +5,14 @@ polygons at the first or last points.} \usage{polygon.method(top.bottom.left.right, offset.cm = 0.1, - padding.cm = 0.05)} + padding.cm = 0.05, + custom.colors = NULL)} \arguments{ \item{top.bottom.left.right}{Character string indicating what side of the plot to label.} \item{offset.cm}{Offset from the polygon to the most extreme data point.} \item{padding.cm}{Padding \code{\link{inside}} the polygon.} + \item{custom.colors}{Positioning method applied just before \code{\link{draw.polygons}}, can set +box.color and text.color for custom colors.} } diff --git a/tests/testthat/test_lattice.R b/tests/testthat/test_lattice.R new file mode 100644 index 0000000..dbeb9f2 --- /dev/null +++ b/tests/testthat/test_lattice.R @@ -0,0 +1,13 @@ +library(directlabels) +library(lattice) +library(testthat) +test_that("panel.superpose.dl works", { + loci <- data.frame( + ppp=c(rbeta(8,10,10),rbeta(2,0.15,1),rbeta(2,1,0.15)), + type=factor(c(rep("NEU",8),rep("POS",2),rep("BAL",2)))) + direct.label(densityplot(~ppp,loci,groups=type,n=500)) + computed <- suppressWarnings(with(loci, panel.superpose.dl( + x=ppp, groups = type, subscripts=seq_along(ppp), + method="top.bumptwice", panel.groups="panel.densityplot"))) + expect_identical(computed, NULL) +}) diff --git a/vignettes/examples.Rmd b/vignettes/examples.Rmd index e5fd049..1d1bc90 100644 --- a/vignettes/examples.Rmd +++ b/vignettes/examples.Rmd @@ -347,3 +347,108 @@ ggplot()+ labels=c("0", "0.5", "1")) ``` + +## white or black text on colored background + +The weighted method for rgb to grayscale conversion is used for the +default text.color in polygon.method, and explained here +https://www.tutorialspoint.com/dip/grayscale_to_rgb_conversion.htm + +```{r} +m <- RColorBrewer::brewer.pal.info +brewer.dt.list <- list() +for(brewer.row in 1:nrow(m)){ + brewer.name <- rownames(m)[[brewer.row]] + brewer.info <- m[brewer.name, ] + col.vec <- RColorBrewer::brewer.pal(brewer.info[, "maxcolors"], brewer.name) + rgb.mat <- col2rgb(col.vec) + hsv.mat <- rgb2hsv(rgb.mat) + brewer.dt.list[[brewer.name]] <- data.frame( + brewer.name, + brewer.fac=factor(brewer.name, rownames(m)), + brewer.row, + category=factor(brewer.info[, "category"], c("seq", "qual", "div")), + column=seq_along(col.vec), + color=col.vec, + t(rgb.mat), + t(hsv.mat)) +} +brewer.dt <- do.call(rbind, brewer.dt.list) +library(ggplot2) +ggplot()+ + theme_bw()+ + theme(panel.spacing=grid::unit(0, "lines"))+ + facet_grid(category ~ ., scales="free", space="free")+ + geom_tile(aes( + factor(column), brewer.fac, fill=color), + data=brewer.dt)+ + geom_text(aes( + factor(column), brewer.fac, label=brewer.fac, color=ifelse( + ((0.3 * red) + (0.59 * green) + (0.11 * blue))/255 < 0.5, "white", "black")), + data=brewer.dt)+ + scale_fill_identity()+ + scale_color_identity() +``` + +## odd qp labels for timings figure + +In the image below the strange thing in the labels is that the end of +the pointer of `nc::capture_melt_single` is inside of the pointer for +`cdata::unpivot_to_blocks` -- this is ok, but we could probably avoid +this by switching the order. we should be able to detect/avoid this +using a linear inequality constraint: bottom of label box must be +greater than next target down, etc. But if targets are too close +together this could lead to no feasible solution. + +```{r} + +data(odd_timings, package="directlabels") +odd4 <- subset(odd_timings, captures==4) +library(ggplot2) +gg <- ggplot()+ + geom_line(aes( + N.col, median.seconds, color=fun), + data=odd4)+ + scale_x_log10(limits=c(10, 1e6))+ + scale_y_log10() +directlabels::direct.label(gg, "right.polygons") + +``` + +TODO edit polygon.method so that the right panel labels do not cross +-- can this be added as a constraint in the qp, or do we just need to +re-order? + +## two dlgrobs + +This example has two `geom_dl` with the same method, but the grobs +need different names to render correctly +https://github.com/tdhock/directlabels/issues/30 + +```{r} +data(odd_timings, package="directlabels") +zero <- subset(odd_timings, captures==0) +on.right <- with(zero, N.col==max(N.col)) +funs.right <- unique(zero[on.right, "fun"]) +is.right <- zero$fun %in% funs.right +timings.right <- zero[is.right,] +timings.left <- zero[!is.right,] +library(ggplot2) +gg <- ggplot()+ + geom_line(aes( + N.col, median.seconds, color=fun), + data=zero)+ + directlabels::geom_dl(aes( + N.col, median.seconds, color=fun, label=fun), + method="right.polygons", + data=timings.left)+ + directlabels::geom_dl(aes( + N.col, median.seconds, color=fun, label=fun), + method="right.polygons", + data=timings.right)+ + scale_x_log10(limits=c(10, 1e6))+ + scale_y_log10() +gg + +``` +