R/geom_treescale.R
3e4b5998
 ##' add tree scale
 ##'
 ##' 
 ##' @title geom_treescale
 ##' @param x x position
 ##' @param y y position
 ##' @param width width of scale
 ##' @param offset offset of text to line
 ##' @param color color
 ##' @param linesize size of line
 ##' @param fontsize size of text
51f3c877
 ##' @param family sans by default, can be any supported font
3e4b5998
 ##' @return ggplot layers
 ##' @export
 ##' @author Guangchuang Yu
 geom_treescale <- function(x=NULL, y=NULL, width=NULL, offset=NULL, color="black",
51f3c877
                            linesize=0.5, fontsize=3.88, family="sans") {
3e4b5998
     
     data=NULL
     position="identity"
     show.legend=NA
17714487
     na.rm=TRUE
3e4b5998
     inherit.aes=FALSE
 
     default_aes <- aes_(x=~x, y=~y)
     mapping <- default_aes
     
     list(
         stat_treeScaleLine(xx=x, yy=y, width=width, color=color, offset=offset, size=linesize,
                            mapping=mapping, data=data,
                            position=position, show.legend = show.legend,
                            inherit.aes = inherit.aes, na.rm=na.rm),
51f3c877
         stat_treeScaleText(xx=x, yy=y, width=width, color=color, offset=offset,
                            size=fontsize, family = family, 
3e4b5998
                            mapping=mapping, data=data,
                            position=position, show.legend = show.legend,
                            inherit.aes = inherit.aes, na.rm=na.rm)
     )
 }
 
 
 
 stat_treeScaleLine <- function(mapping=NULL, data=NULL,
                            geom="segment", position="identity",
                            xx, yy, width, offset, color, ..., 
                            show.legend=NA, inherit.aes=FALSE, na.rm=FALSE){
     
5662ae9e
     default_aes <- aes_(x=~x, y=~y, xend=~x, yend=~y)
3e4b5998
     if (is.null(mapping)) {
         mapping <- default_aes
     } else {
         mapping <- modifyList(mapping, default_aes)
     }
     layer(
         stat=StatTreeScaleLine,
         data=data,
         mapping=mapping,
         geom = geom,
         position=position,
         show.legend=show.legend,
         inherit.aes=inherit.aes,
         params=list(xx=xx,
                     yy=yy,
                     width=width,
                     offset=offset,
                     color=color,
                     na.rm=na.rm,
                     ...)
     )
 }
 
 stat_treeScaleText <- function(mapping=NULL, data=NULL,
                                geom="text", position="identity",
                                xx, yy, width, offset, color, ...,
                                show.legend=NA, inherit.aes=TRUE, na.rm=FALSE) {
 
17714487
     default_aes <- aes_(x=~x, y=~y, label=~x)
3e4b5998
     if (is.null(mapping)) {
         mapping <- default_aes
     } else {
         mapping <- modifyList(mapping, default_aes)
     }
     layer(
         stat=StatTreeScaleText,
         data=data,
         mapping=mapping,
         geom=GeomText,
         position=position,
         show.legend = show.legend,
         inherit.aes = inherit.aes,
         params = list(xx=xx,
                       yy=yy,
                       width=width,
                       offset=offset,
                       color=color,
                       na.rm=na.rm,
                       ...)
     )
 }
 
 
 StatTreeScaleLine <- ggproto("StatTreeScaleLine", Stat,
                              compute_group = function(self, data, scales, params, xx, yy, width, offset) {
                                  get_treescale_position(data, xx, yy, width, offset)[[1]]
                              },
                              required_aes = c("x", "y", "xend", "yend")
                              )
 
 
 StatTreeScaleText <- ggproto("StatTreeScaleText", Stat,
                              compute_group = function(self, data, scales, params, xx, yy, width, offset) {
                                  get_treescale_position(data, xx, yy, width, offset)[[2]]
                              },
                              required_aes = c("x", "y", "label")
                              )
 
 
 
 get_treescale_position <- function(data, xx, yy, width, offset=NULL) {
     x <- xx
     y <- yy
     dx <- data$x %>% range %>% diff
     
     if (is.null(x)) {
         x <- dx/2
     }
     
     if (is.null(y)) {
         y <- 0
     }
 
     if (is.null(width) || is.na(width)) {
         d <- dx/10 
         n <- 0
         while (d < 1) {
             d <- d*10
             n <- n + 1
         }
         d <- floor(d)/(10^n)
     } else {
         d <- width
     }
     
     if (is.null(offset)) {
         offset <- 0.4
     }
     
     list(LinePosition=data.frame(x=x, xend=x+d, y=y, yend=y),
          TextPosition=data.frame(x=x+d/2, y=y+offset, label=d))
 }
 
17714487
 ## ##' add evolution distance legend
 ## ##'
 ## ##' 
3e4b5998
 ## ##' @title add_legend
 ## ##' @param p tree view
 ## ##' @param width width of legend
 ## ##' @param x x position
 ## ##' @param y y position
 ## ##' @param offset offset of text and line
 ## ##' @param font.size font size
 ## ##' @param ... additional parameter
 ## ##' @return tree view
 ## ##' @importFrom grid linesGrob
 ## ##' @importFrom grid textGrob
 ## ##' @importFrom grid gpar
 ## ##' @importFrom ggplot2 ylim
 ## ##' @export
 ## ##' @author Guangchuang Yu
 ## add_legend <- function(p, width=NULL, x=NULL, y=NULL, offset=NULL, font.size=4, ...) {
 ##     dd <- get_treescale_position(p$data, x, y, width, offset)
 ##     x <- dd[[1]]$x
 ##     y <- dd[[1]]$y
 ##     d <- dd[[1]]$xend -x
 ##     p <- p + annotation_custom(linesGrob(), xmin=x, xmax=x+d, ymin=y, ymax=y) +
 ##         annotation_custom(textGrob(label=d, gp = gpar(fontsize = font.size)),
 ##                           xmin=x+d/2, xmax=x+d/2, ymin=y+offset, ymax=y+offset)
 ##     return(p)
 ## }