Merge pull request #25 from tdhock/new-polygons

New draw.polygons and other features

.gitignore

@@ -1,3 +1,4 @@
+revdep
 .Rproj.user
 .Rhistory
 .RData

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: directlabels
 Maintainer: Toby Dylan Hocking <toby.hocking@r-project.org>
 Author: Toby Dylan Hocking
-Version: 2020.1.31
+Version: 2020.6.17
 BugReports: https://github.com/tdhock/directlabels/issues
 License: GPL-3
 Title: Direct Labels for Multicolor Plots
@@ -15,12 +15,15 @@ Description: An extensible framework
 URL: https://github.com/tdhock/directlabels
 LazyData: true
 Suggests: MASS,
-	  inlinedocs,
+	  knitr, markdown,
+	  inlinedocs, 
 	  ggplot2 (>= 2.0), rlang,
 	  lattice, alphahull, nlme,
 	  lars, latticeExtra,
+	  dplyr, ggthemes,
 	  testthat
 Imports: grid, quadprog
 Collate: utility.function.R compare.R dotplot.R lineplot.R
 	 densityplot.R ggplot2.R positioning.functions.R
 	 doc.R lattice.R scatterplot.R contourplot.R
+VignetteBuilder: knitr

NEWS

@@ -22,10 +22,59 @@ see etc/individual.R, and gabor.R
 see etc/xYplot.R for a problem with plotting some weird trellis
 objects.
 
-contourplot labels as in lattice::panel.contourplot or C source code
-in r-source/src/main/plot3d.c
+Maybe remove contour plot support/examples?
+https://cloud.r-project.org/web/packages/isoband/vignettes/isoband3.html
+does much better labels.
 
-other contourplots, see etc/contour.R
+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)
+
+2020.6.17
+
+grid grobs have names.
+
+vignette example / LOPART100 data for black/blue pos swapped for
+t=100. (bug fix in make.tiebreaker, use rule=2 in approx for no NA)
+
+using top.qp with one point gave an error: need at least two non-NA
+values to interpolate. (bug fix in make.tiebreaker, only run approx if
+there are at least two values)
+
+legends2hide inside tryCatch to fix error with parsing legends in
+ggplots with custom themes,
+https://github.com/tdhock/directlabels/issues/6
+
+fix test failures that showed up with new code.
+
+examples vignette for geom_dl with same aes(label), but different
+aes(label.group, color).
+
+draw.polygons/polygon.method support top/bottom as well as
+first/last/left/right. New *.polygons methods.
+
+2020.6.7
+
+initial code for:
+
+polygons below the point.
+
+aes(label) which may have the same value for two different aes(group)
+values, e.g. two algorithms/groups which both compute the same thing,
+optimal changepoint tau^*, but we want to compute and show a label for
+each of them.
+
+using stringDescent to compute height of boxes. maybe consider
+grobDescent or descentDetails?
 
 2020.1.31
 

R/compare.R

@@ -47,22 +47,26 @@ dlcompare <- structure(function # Direct label comparison plot
   for(col in seq_along(col.items)){
     if(!is.null(names(col.items))){
       pushViewport(viewport(layout.pos.col=col,layout.pos.row=1))
-      grid.text(names(col.items)[col])
+      grid.text(
+        names(col.items)[col],
+        name=paste0("dlcompare.text.col.", col))
       popViewport()
     }
     for(row in seq_along(row.items)){
       if(col==1&&!is.null(names(row.items))){
         pushViewport(viewport(layout.pos.col=length(col.items)+1,
                               layout.pos.row=row+rowadd))
-        grid.text(names(row.items)[row],rot=-90)
+        grid.text(
+          names(row.items)[row],rot=-90,
+          name=paste0("dlcompare.text.row", row))
         popViewport()
       }
       pushViewport(viewport(layout.pos.col=col,layout.pos.row=row+rowadd))
       p <- if(standard)
         direct.label(row.items[[row]],col.items[[col]],debug=debug)
       else direct.label(col.items[[col]],row.items[[row]],debug=debug)
       print(p,newpage=FALSE)
-      if(rects)grid.rect()
+      if(rects)grid.rect(name=paste0("dlcompare.rect.row.", row))
       popViewport()
     }
   }

R/densityplot.R

@@ -2,6 +2,10 @@
 top.points <-
   gapply.fun(transform(d[which.max(d$y),],hjust=0.5,vjust=0))
 
+### Positioning Method for the bottom of a group of points.
+bottom.points <-
+  gapply.fun(transform(d[which.min(d$y),],hjust=0.5,vjust=1))
+
 ### Label the tops, but bump labels up to avoid collisions.
 top.bumpup <- list("top.points","bumpup")
 

R/dotplot.R

@@ -2,8 +2,11 @@
 angled.endpoints <- list("last.points",rot=30)
 
 ### Label points at the top, making sure they don't collide.
-top.qp <- list("top.points","calc.boxes",
-               qp.labels("x","left","right",
-                         make.tiebreaker("y","x"),
-                         xlimits))
+top.qp <- list(
+  "top.points",
+  "calc.boxes",
+  qp.labels(
+    "x","left","right",
+    make.tiebreaker("y","x"),
+    xlimits))
 

R/ggplot2.R

@@ -20,12 +20,6 @@ geom_dl <- structure(function
 ### Positioning Method for direct label placement, passed to apply.method.
  debug=FALSE,
 ### Show directlabels debugging output?
- na.rm = TRUE,
-### passed to params.
- parse = FALSE,
-### parse text labels as plotmath expressions? not yet supported, but
-### I would be open to accepting a PR if somebody wants to implement
-### that.
  stat = "identity",
 ### passed to layer.
  position = "identity",
@@ -36,32 +30,26 @@ geom_dl <- structure(function
 ### ggproto object implementing direct labels.
   GeomDl <- ggplot2::ggproto(
     "GeomDl", ggplot2::Geom,
-    draw_panel = function(data, panel_scales, coord, method = NULL, debug = FALSE, parse=FALSE) {
-      stopifnot(is.logical(parse))
-      stopifnot(length(parse) == 1)
-      if(parse){
-        stop("parse=TRUE is not yet supported in directlabels, ",
-             "but if you want to do that, ",
-             "why don't you fork tdhock/directlabels and submit me a PR?")
-      }
-      data$rot <- as.integer(data$angle)
-      data$groups <- data$label
+    draw_panel = function(data, panel_scales, coord, method = NULL, debug = FALSE) {
+      data$rot <- as.numeric(data[["angle"]])
+      groups.col <- if(all(is.na(data[["label.group"]])))"label" else "label.group"
+      data$groups <- data[[groups.col]]
       axes2native <- function(data){
         coord$transform(data, panel_scales)
       }
       converted <- axes2native(data)
+      ## for some reason ggplot2 gives us a group column even when the
+      ## user does not specify one in aes.
       dldata <- converted[, names(converted) != "group"]
-
-      directlabels::dlgrob(
+      dlgrob(
         dldata, method, debug = debug, axes2native = axes2native)
     },
     draw_legend = ggplot2::draw_key_text,
     required_aes = c("x", "y", "label"),
     default_aes = ggplot2::aes(
       colour = "black", size = 5, angle = 0, hjust = 0.5,
-      vjust = 0.5, alpha = 1)
-    )
-
+      vjust = 0.5, alpha = 1, label.group = NA)
+  )
   ## Geom for direct labeling that creates dlgrobs in the draw()
   ## method.
   ggplot2::layer(
@@ -73,8 +61,6 @@ geom_dl <- structure(function
     show.legend = FALSE, # since direct labels replace a legend.
     inherit.aes = inherit.aes,
     params = list(
-      parse = parse,
-      na.rm = na.rm,
       method = method,
       debug = debug,
       ...)
@@ -184,7 +170,11 @@ direct.label.ggplot <- function
                     stat=L$stat,debug=debug,data=data)
   dlgeom$stat_params <- L$stat_params
   ## Look through legends for a colour/fill legend.
-  leg.info <- legends2hide(p)
+  leg.info <- tryCatch({
+    legends2hide(p)
+  }, error=function(E){
+    NULL #ignore errors in parsing custom/non-standard ggplots.
+  })
   guide.args <- as.list(rep("none", length(leg.info$hide)))
   names(guide.args) <- leg.info$hide
   guide.args$colour <- "none"
@@ -211,7 +201,6 @@ legends2hide <- function(p){
   position <- theme$legend.position
   # by default, guide boxes are vertically aligned
   theme$legend.box <- if(is.null(theme$legend.box)) "vertical" else theme$legend.box
-
   # size of key (also used for bar in colorbar guide)
   theme$legend.key.width <- if(is.null(theme$legend.key.width)) theme$legend.key.size
   theme$legend.key.height <- if(is.null(theme$legend.key.height)) theme$legend.key.size

R/lattice.R

@@ -133,7 +133,8 @@ panel.superpose.dl <- structure(function
     d <- apply.method(translator,d,...)
   }
   d$colour <- key[as.character(d$groups)]
-  g <- dlgrob(d,method,debug=debug)
+  g <- dlgrob(
+    d,method,debug=debug)
   grid.draw(g)
 },ex=function(){
   loci <- data.frame(ppp=c(rbeta(800,10,10),rbeta(100,0.15,1),rbeta(100,1,0.15)),

R/lineplot.R

@@ -36,6 +36,12 @@ first.points <- label.endpoints(min,1)
 ### Positioning Method for the last of a group of points.
 last.points <- label.endpoints(max,0)
 
+### Positioning Method for the first of a group of points.
+left.points <- first.points
+
+### Positioning Method for the last of a group of points.
+right.points <- last.points
+
 ### Do first or last, whichever has points most spread out.
 maxvar.points <- function(d,...){
   myrange <- function(x){
@@ -64,10 +70,22 @@ last.qp <- vertical.qp("last.points")
 first.qp <- vertical.qp("first.points")
 
 ### Draw a speech polygon to the first point.
-first.polygons <- polygon.method("first.points", -0.1, "right", "left")
+left.polygons <- polygon.method("left")
+
+### Draw a speech polygon to the last point.
+right.polygons <- polygon.method("right")
+
+### Draw a speech polygon to the first point.
+first.polygons <- left.polygons
 
 ### Draw a speech polygon to the last point.
-last.polygons <- polygon.method("last.points", 0.1, "left", "right")
+last.polygons <- right.polygons
+
+### Draw a speech polygon to the top point.
+top.polygons <- polygon.method("top")
+
+### Draw a speech polygon to the bottom point.
+bottom.polygons <- polygon.method("bottom")
 
 ### Label first or last points, whichever are more spread out, and use
 ### a QP solver to make sure the labels do not collide.

R/positioning.functions.R

@@ -36,8 +36,14 @@ drawDetails.dlgrob <- function
   names(code) <- as.character(levs$groups)
   ## apply ignore.na function -- these points are not plotted
   cm.data <- ignore.na(cm.data)
-  cm.data <- apply.method(x$method,cm.data,
-                          debug=x$debug,axes2native=x$axes2native)
+  if(is.null(cm.data$label)){
+    cm.data$label <- cm.data$groups
+  }
+  cm.data <- apply.method(
+    x$method,
+    cm.data,
+    debug=x$debug,
+    axes2native=x$axes2native)
   if(nrow(cm.data)==0)return()## empty data frames can cause many bugs
   ## Take col from colour or groups.
   colour <- cm.data[["colour"]]
@@ -59,10 +65,13 @@ drawDetails.dlgrob <- function
     print(cm.data)
     ##browser()
   }
-  with(cm.data,{
-    grid.text(groups,x,y,hjust=hjust,vjust=vjust,rot=rot,default.units="cm",
-              gp=gp)
-  })
+  text.name <- paste0(
+    "directlabels.text.",
+    if(is.character(x$method))x$method)
+  with(cm.data, grid.text(
+    label,x,y,hjust=hjust,vjust=vjust,rot=rot,default.units="cm",
+    gp=gp,
+    name=text.name))
 }
 
 dlgrob <- function
@@ -80,7 +89,7 @@ dlgrob <- function
        name=if(is.character(method)){
          sprintf("GRID.dlgrob.%s",method[1])
        }else{
-         NULL
+         "GRID.dlgrob"
        },...)
 }