New geom with custom grid grob. Nothing gets drawn

[Thomas]

Hi

For a very special case I have needed some more functionality to the segment geom. Specifically I want to control a shrinkage of the segment in absolute values (linke 1 cm) and not in values relative to the coordinate system. After some research I found that the best approach would be to develop a new segment grob and an accompanying geom. I have tested the new grob with basic grid.draw and it behaves as expected. The new geom function also works as expected if it just calls segmentsGrob (the grob provided by grid), but when I switch to using my new grob nothing gets drawn. Examining the gtable also reveals that while an encompassing node in the gTree gets created, it is empty.

Following is my current code. Most of it is just modified ggplot2 and grid source code. I would welcome any hints as to why the ggplot2 and grid functionality breaks when they are combined

best

Thomas

geom_segment2 <- function (mapping = NULL, data = NULL, stat = "identity",

                           position = "identity", arrow = NULL, lineend = "butt", na.rm = FALSE, startAdjust = NULL, endAdjust = NULL, ...) {

    

    GeomSegment2$new(mapping = mapping, data = data, stat = stat,

                     position = position, arrow = arrow, lineend = lineend, na.rm = na.rm, startAdjust = startAdjust, endAdjust = endAdjust, ...)

}

GeomSegment2 <- proto(ggplot2:::Geom, {

    objname <- "segment2"

    

    draw <- function(., data, scales, coordinates, arrow = NULL,

                     lineend = "butt", na.rm = FALSE, startAdjust = startAdjust, endAdjust = endAdjust, ...) {

        

        data <- remove_missing(data, na.rm = na.rm,

                               c("x", "y", "xend", "yend", "linetype", "size", "shape"),

                               name = "geom_segment")

        if (empty(data)) return(zeroGrob())

        

        if (is.linear(coordinates)) {

            return(with(coord_transform(coordinates, data, scales), {

                segmentsGrob2(x, y, xend, yend, default.units="native", startAdjust=startAdjust, endAdjust=endAdjust,

                              gp = gpar(col=alpha(colour, alpha), fill = alpha(colour, alpha),

                                        lwd=size * .pt, lty=linetype, lineend = lineend),

                                        arrow = arrow)

            }

            ))

        }

        

        data$group <- 1:nrow(data)

        starts <- subset(data, select = c(-xend, -yend))

        ends <- rename(subset(data, select = c(-x, -y)), c("xend" = "x", "yend" = "y"),

                       warn_missing = FALSE)

        

        pieces <- rbind(starts, ends)

        pieces <- pieces[order(pieces$group),]

        

        GeomPath$draw_groups(pieces, scales, coordinates, arrow = arrow, ...)

    }

    

    

    default_stat <- function(.) StatIdentity

    required_aes <- c("x", "y", "xend", "yend")

    default_aes <- function(.) aes(colour="black", size=0.5, linetype=1, alpha = NA)

    guide_geom <- function(.) "path"

})

segmentsGrob2 <- function(x0 = unit(0, "npc"), y0 = unit(0, "npc"), x1 = unit(1, "npc"), y1 = unit(1, "npc"), 

                          startAdjust = unit(0, 'npc'), endAdjust = unit(0, 'npc'), default.units = "npc", 

                          arrow = NULL, name = NULL, gp = gpar(), vp = NULL) {

    if (!is.unit(x0)) 

        x0 <- unit(x0, default.units)

    if (!is.unit(x1)) 

        x1 <- unit(x1, default.units)

    if (!is.unit(y0)) 

        y0 <- unit(y0, default.units)

    if (!is.unit(y1)) 

        y1 <- unit(y1, default.units)

    grid.draw(grob(x0 = x0, y0 = y0, x1 = x1, y1 = y1, startAdjust=startAdjust, endAdjust=endAdjust, 

              arrow = arrow, name=name, gp=gp, vp=vp, cl="segments2"))

}

drawDetails.segments2 <- function(x, recording=TRUE) {

    devSize <- dev.size()

    transformation <- matrix(c(devSize[1], 0, 0, devSize[2]), ncol=2)

    newVec <- cbind(as.numeric(x$x1)-as.numeric(x$x0), as.numeric(x$y1)-as.numeric(x$y0)) %*% transformation

    segAngle <- atan2(newVec[,2], newVec[, 1])

    xAdjust <- cos(segAngle)

    yAdjust <- sin(segAngle)

    if(!is.null(x$startAdjust)) {

        x$x0 <- x$x0 + unit(as.numeric(x$startAdjust)*xAdjust, attributes(x$startAdjust)$unit)

        x$y0 <- x$y0 + unit(as.numeric(x$startAdjust)*yAdjust, attributes(x$startAdjust)$unit)

    }

    if(!is.null(x$endAdjust)) {

        x$x1 <- x$x1 - unit(as.numeric(x$endAdjust)*xAdjust, attributes(x$endAdjust)$unit)

        x$y1 <- x$y1 - unit(as.numeric(x$endAdjust)*yAdjust, attributes(x$endAdjust)$unit)

    }

    if(!is.null(x$arrow)) {

        x$x0 <- x$x0 + unit(ifelse(x$arrow$ends %in% c(1,3), xAdjust*(x$size * ggplot2:::.pt)/96, 0), 'inch')

        x$y0 <- x$y0 + unit(ifelse(x$arrow$ends %in% c(1,3), yAdjust*(x$size * ggplot2:::.pt)/96, 0), 'inch')

        x$x1 <- x$x1 - unit(ifelse(x$arrow$ends %in% c(2,3), xAdjust*(x$size * ggplot2:::.pt)/96, 0), 'inch')

        x$y1 <- x$y1 - unit(ifelse(x$arrow$ends %in% c(2,3), yAdjust*(x$size * ggplot2:::.pt)/96, 0), 'inch')

    }

    grid.segments(x0 = x$x0, y0 = x$y0, x1 = x$x1, y1 = x$y1, arrow = x$arrow, name=x$name, gp=x$gp, vp=x$vp)

}

[Thomas]

I would like to bump this question - It hasn't garnered any interest but I think it touches on a very important topic. As ggplot2 is now feature frozen, custom geoms are now the only way to introduce truly new functionality to ggplots, but is an area with close to no documentation - getting debugging help in this forum is more or less the only option when you are stuck...