polygon.method dynamic default text.color, lattice, dlgrob ids

.Rbuildignore

@@ -1,3 +1,4 @@
+revdep
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^\.travis\.yml$

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: directlabels
 Maintainer: Toby Dylan Hocking <toby.hocking@r-project.org>
 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,

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")

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
 

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

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 <-

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

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
   }

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"}
+
+
+
+
+

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}

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.}
 }
 
 

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)
+})

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
+
+```
+