@@ -1,7 +1,7 @@

 Package: ggtree

 Type: Package

 Title: a phylogenetic tree viewer for different types of tree annotations

-Version: 1.3.10

+Version: 1.3.13

 Author: Guangchuang Yu and Tommy Tsan-Yuk Lam

 Maintainer: Guangchuang Yu <guangchuangyu@gmail.com>

 Description: ggtree extends the ggplot2 plotting system which implemented the

@@ -13,16 +13,16 @@ Depends:

 Imports:

     ape,

     Biostrings,

-    colorspace,

     grid,

-    gridExtra,

     jsonlite,

     magrittr,

     methods,

     stats4,

     tidyr

 Suggests:

+    colorspace,

     EBImage,

+    gridExtra,

     knitr,

     phylobase,

     phytools,

@@ -16,6 +16,7 @@ S3method(fortify,phangorn)

 S3method(fortify,phylip)

 S3method(fortify,phylo)

 S3method(fortify,phylo4)

+S3method(fortify,phyloseq)

 S3method(fortify,r8s)

 S3method(fortify,raxml)

 export("%<%")

@@ -41,11 +42,11 @@ export(geom_nodepoint)

 export(geom_point2)

 export(geom_rootpoint)

 export(geom_segment2)

-export(geom_text)

 export(geom_text2)

 export(geom_tiplab)

 export(geom_tippoint)

 export(geom_tree)

+export(geom_tree2)

 export(geom_treescale)

 export(get.fields)

 export(get.offspring.tip)

@@ -71,12 +72,14 @@ export(inset)

 export(mask)

 export(merge_tree)

 export(msaplot)

+export(multiplot)

 export(nodebar)

 export(nodepie)

 export(phyPML)

 export(phylopic)

 export(plot)

 export(pmlToSeq)

+export(raxml2nwk)

 export(read.baseml)

 export(read.beast)

 export(read.codeml)

@@ -90,6 +93,7 @@ export(read.r8s)

 export(read.raxml)

 export(read.tree)

 export(reroot)

+export(rescale_tree)

 export(rotate)

 export(rtree)

 export(scaleClade)

@@ -147,7 +151,6 @@ importFrom(ape,read.tree)

 importFrom(ape,reorder.phylo)

 importFrom(ape,which.edge)

 importFrom(ape,write.tree)

-importFrom(colorspace,rainbow_hcl)

 importFrom(ggplot2,"%+replace%")

 importFrom(ggplot2,GeomPoint)

 importFrom(ggplot2,GeomRect)

@@ -196,8 +199,12 @@ importFrom(ggplot2,xlim)

 importFrom(ggplot2,ylab)

 importFrom(grDevices,col2rgb)

 importFrom(grDevices,rgb)

+importFrom(grid,grid.layout)

+importFrom(grid,grid.newpage)

+importFrom(grid,pushViewport)

 importFrom(grid,rasterGrob)

-importFrom(gridExtra,grid.arrange)

+importFrom(grid,unit)

+importFrom(grid,viewport)

 importFrom(jsonlite,fromJSON)

 importFrom(magrittr,"%<>%")

 importFrom(magrittr,"%>%")

@@ -1,5 +1,33 @@

+CHANGES IN VERSION 1.3.13

+------------------------

+ o add example of rescale_tree function in treeAnnotation.Rmd <2016-02-07, Sun>

+ o geom_cladelabel work with collapse <2016-02-07, Sun>

+   + see https://github.com/GuangchuangYu/ggtree/issues/38 

+

+CHANGES IN VERSION 1.3.12

+------------------------

+ o exchange function name of geom_tree and geom_tree2  <2016-01-25, Mon>

+ o solved issues of geom_tree2 <2016-01-25, Mon>

+   + https://github.com/hadley/ggplot2/issues/1512

+ o colnames_level parameter in gheatmap <2016-01-25, Mon>

+ o raxml2nwk function for converting raxml bootstrap tree to newick format <2016-01-25, Mon> 

+ 

+CHANGES IN VERSION 1.3.11

+------------------------

+ o solved issues of geom_tree2 <2016-01-25, Mon>

+   + https://github.com/GuangchuangYu/ggtree/issues/36

+ o change compute_group() to compute_panel in geom_tree2() <2016-01-21, Thu>

+   + fixed issue, https://github.com/GuangchuangYu/ggtree/issues/36

+ o support phyloseq object <2016-01-21, Thu>

+ o update geom_point2, geom_text2 and geom_segment2 to support setup_tree_data <2016-01-21, Thu>

+ o implement geom_tree2 layer that support duplicated node records via the setup_tree_data function <2016-01-21, Thu>

+ o rescale_tree function for rescaling branch length of tree object <2016-01-20, Wed>

+ o upgrade set_branch_length, now branch can be rescaled using feature in extraInfo slot <2016-01-20, Wed>

+ 

 CHANGES IN VERSION 1.3.10

 ------------------------

+ o remove dependency of gridExtra by implementing multiplot function instead of using grid.arrange <2016-01-20, Wed>

+ o remove dependency of colorspace <2016-01-20, Wed>

  o support phylip tree format and update vignette of phylip example <2016-01-15, Fri>

 CHANGES IN VERSION 1.3.9

@@ -7,7 +7,13 @@

 ##' @export

 ##' @author Guangchuang Yu

 Date2decimal <- function(x) {

-    x <- as.Date(x)

+    if (is(x, "numeric")) {

+        return(x)

+    }

+    

+    if (is(x, "character")) {

+        x <- as.Date(x)

+    }

     year <- format(x, "%Y")

     y <- x - as.Date(paste0(year, "-01-01"))

     as.numeric(year) + as.numeric(y)/365

@@ -24,7 +24,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,

     data <- NULL

     position <- "identity"

     show.legend <- NA

-    na.rm <- FALSE

+    na.rm <- TRUE

     inherit.aes <- FALSE

     if (geom == "text") {

@@ -133,7 +133,7 @@ StatCladeBar <- ggproto("StatCladBar", Stat,

 get_cladelabel_position <- function(data, node, offset, align, adjustRatio) {

     df <- get_cladelabel_position_(data, node)

     if (align) {

-        mx <- max(data$x)

+        mx <- max(data$x, na.rm=TRUE)

     } else {

         mx <- df$x

     }

@@ -144,9 +144,12 @@ get_cladelabel_position <- function(data, node, offset, align, adjustRatio) {

 get_cladelabel_position_ <- function(data, node) {

     sp <- get.offspring.df(data, node)

-    sp.df <- data[c(sp, node),]

+    sp2 <- c(sp, node)

+    sp.df <- data[match(sp2, data$node),]

+

     y <- sp.df$y

-    mx <- max(sp.df$x) 

+    y <- y[!is.na(y)]

+    mx <- max(sp.df$x, na.rm=TRUE) 

     data.frame(x=mx, y=min(y), yend=max(y))

 }

@@ -85,19 +85,28 @@ geom_rootpoint <- function(mapping = NULL, data = NULL, stat = "identity",

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

                        position = "identity", na.rm = FALSE,

                        show.legend = NA, inherit.aes = TRUE, ...) {

-  layer(

-    data = data,

-    mapping = mapping,

-    stat = stat,

-    geom = GeomPointGGtree,

-    position = position,

-    show.legend = show.legend,

-    inherit.aes = inherit.aes,

-    params = list(

-      na.rm = na.rm,

-      ...

+

+    

+    default_aes <- aes_(node=~node)

+    if (is.null(mapping)) {

+        mapping <- default_aes

+    } else {

+        mapping <- modifyList(mapping, default_aes)

+    }

+    

+    layer(

+        data = data,

+        mapping = mapping,

+        stat = StatTreePoint,

+        geom = GeomPointGGtree,

+        position = position,

+        show.legend = show.legend,

+        inherit.aes = inherit.aes,

+        params = list(

+            na.rm = na.rm,

+            ...

+        )

     )

-  )

 }

 ##' @importFrom ggplot2 ggproto

@@ -105,16 +114,26 @@ geom_point2 <- function(mapping = NULL, data = NULL, stat = "identity",

 ##' @importFrom ggplot2 draw_key_point

 GeomPointGGtree <- ggproto("GeomPointGGtree", GeomPoint,

                            setup_data = function(data, params) {

+                               if (is.null(data$subset))

+                                   return(data)

                                data[data$subset,]

                            }  ## ,

-##                            draw_panel = function(data, panel_scales, coord, na.rm = FALSE){

-##                                GeomPoint$draw_panel(data, panel_scales, coord, na.rm)

-##                            },

+                           ## draw_panel = function(data, panel_scales, coord, na.rm = FALSE){

+                           ##     GeomPoint$draw_panel(data, panel_scales, coord, na.rm)

+                           ## },

-##                            draw_key = draw_key_point,

+                           ## draw_key = draw_key_point,

-##                            required_aes = c("x", "y"),

-##                            default_aes = aes(shape = 19, colour = "black", size = 1.5, fill = NA,

-##                                alpha = NA, stroke = 0.5)

+                           ## required_aes = c("x", "y"),

+                           ## default_aes = aes(shape = 19, colour = "black", size = 1.5, fill = NA,

+                           ##                   alpha = NA, stroke = 0.5)

                             )

+

+

+StatTreePoint <-  ggproto("StatTreePoint", Stat,

+                          required_aes = "node",

+                          compute_group = function(data, scales) {

+                              setup_tree_data(data)

+                          }

+                          )

@@ -47,39 +47,59 @@ geom_segment2 <- function(mapping = NULL, data = NULL, stat = "identity",

                          position = "identity", arrow = NULL, lineend = "butt",

                          na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,

                          ...) {

-  layer(

-    data = data,

-    mapping = mapping,

-    stat = stat,

-    geom = GeomSegmentGGtree,

-    position = position,

-    show.legend = show.legend,

-    inherit.aes = inherit.aes,

-    params = list(

-      arrow = arrow,

-      lineend = lineend,

-      na.rm = na.rm,

-      ...

+

+    default_aes <- aes_(node=~node)

+    if (is.null(mapping)) {

+        mapping <- default_aes

+    } else {

+        mapping <- modifyList(mapping, default_aes)

+    }

+    

+    layer(

+        data = data,

+        mapping = mapping,

+        stat = StatTreeSegment,

+        geom = GeomSegmentGGtree,

+        position = position,

+        show.legend = show.legend,

+        inherit.aes = inherit.aes,

+        params = list(

+            arrow = arrow,

+            lineend = lineend,

+            na.rm = na.rm,

+            ...

+        )

     )

-  )

 }

 ##' @importFrom ggplot2 GeomSegment

 ##' @importFrom ggplot2 draw_key_path

 GeomSegmentGGtree <- ggproto("GeomSegmentGGtree", GeomSegment,

-                          setup_data = function(data, params) {

-                              data[data$subset,]

-                          },

-                          

-                          draw_panel = function(data, panel_scales, coord, arrow = NULL,

-                              lineend = "butt", na.rm = FALSE) {

+                             setup_data = function(data, params) {

+                                 if (is.null(data$subset))

+                                     return(data)

+                                 data[data$subset,]

+                             },

+                             

+                             draw_panel = function(data, panel_scales, coord, arrow = NULL,

+                                                   lineend = "butt", na.rm = FALSE) {

+                                 

+                                 GeomSegment$draw_panel(data, panel_scales, coord, arrow,

+                                                        lineend, na.rm)

+                             },

+                             

+                             required_aes = c("x", "y", "xend", "yend"),

+                             default_aes = aes(colour = "black", size = 0.5, linetype = 1, alpha = NA),

+                             

+                             draw_key = draw_key_path

+                             )

-                              GeomSegment$draw_panel(data, panel_scales, coord, arrow,

-                                                     lineend, na.rm)

-                          },

-                          

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

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

-                          

-                          draw_key = draw_key_path

+

+StatTreeSegment <-  ggproto("StatTreeSegment", Stat,

+                          required_aes = "node",

+                          compute_group = function(data, scales) {

+                              setup_tree_data(data)

+                          }

                           )

+

+

@@ -2,46 +2,6 @@

 ##'

 ##' 

 ##' @title geom_text2

-##' @inheritParams geom_text

-##' @return text layer

-##' @importFrom ggplot2 layer

-##' @importFrom ggplot2 position_nudge

-##' @export

-##' @seealso

-##' \link[ggplot2]{geom_text}

-##' @author Guangchuang Yu

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

-  position = "identity", parse = FALSE, na.rm=TRUE, show.legend = NA, inherit.aes = TRUE,

-  ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE)

-{

-  if (!missing(nudge_x) || !missing(nudge_y)) {

-    if (!missing(position)) {

-      stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)

-    }

-

-    position <- position_nudge(nudge_x, nudge_y)

-  }

-

-  layer(

-      data = data,

-      mapping = mapping,

-      stat = stat,

-      geom = GeomTextGGtree,

-      position = position,

-      show.legend = show.legend,

-      inherit.aes = inherit.aes,

-      params = list(

-          parse = parse,

-          check_overlap = check_overlap,

-          na.rm = na.rm,

-          ...

-          )

-      )

-}

-

-##' text annotations

-##' @export

-##' @rdname geom_text

 ##' @param mapping the aesthetic mapping

 ##' @param data A layer specific dataset -

 ##'             only needed if you want to override he plot defaults.

@@ -55,33 +15,76 @@ geom_text2 <- function(mapping = NULL, data = NULL, stat = "identity",

 ##' @param nudge_x horizontal adjustment

 ##' @param nudge_y vertical adjustment

 ##' @param check_overlap if TRUE, text that overlaps previous text in the same layer will not be plotted

-##' @source

-##' This is just the imported function

-##' from the ggplot2 package. The documentation you should

-##' read for the geom_text function can be found here: \link[ggplot2]{geom_text}

-##'

+##' @return text layer

+##' @importFrom ggplot2 layer

+##' @importFrom ggplot2 position_nudge

+##' @export

 ##' @seealso

 ##' \link[ggplot2]{geom_text}

-geom_text <- ggplot2::geom_text

+##' @author Guangchuang Yu

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

+                       position = "identity", parse = FALSE, na.rm=TRUE, show.legend = NA, inherit.aes = TRUE,

+                       ..., nudge_x = 0, nudge_y = 0, check_overlap = FALSE) {

+

+    if (!missing(nudge_x) || !missing(nudge_y)) {

+        if (!missing(position)) {

+            stop("Specify either `position` or `nudge_x`/`nudge_y`", call. = FALSE)

+        }

+        

+        position <- position_nudge(nudge_x, nudge_y)

+    }

+    

+    default_aes <- aes_(node=~node)

+    if (is.null(mapping)) {

+        mapping <- default_aes

+    } else {

+        mapping <- modifyList(mapping, default_aes)

+    }

+    

+    layer(

+        data = data,

+        mapping = mapping,

+        stat = StatTreeLabel,

+        geom = GeomTextGGtree,

+        position = position,

+        show.legend = show.legend,

+        inherit.aes = inherit.aes,

+        params = list(

+          parse = parse,

+          check_overlap = check_overlap,

+          na.rm = na.rm,

+          ...

+        )

+    )

+}

 ##' @importFrom ggplot2 GeomText

 ##' @importFrom ggplot2 draw_key_text

 GeomTextGGtree <- ggproto("GeomTextGGtree", GeomText,

                           setup_data = function(data, params) {

+                              if (is.null(data$subset))

+                                  return(data)

                               data[data$subset,]

                           },

-                          

                           draw_panel = function(data, panel_scales, coord, parse = FALSE,

-                              na.rm = FALSE, check_overlap = FALSE) {

+                              na.rm = TRUE, check_overlap = FALSE) {

                               GeomText$draw_panel(data, panel_scales, coord, parse,

                                                   na.rm, check_overlap)

                           },

-

-                          required_aes = c("x", "y", "label"),

+                          required_aes = c("node", "x", "y", "label"),

                           default_aes = aes(colour = "black", size = 3.88, angle = 0, hjust = 0.5,

                               vjust = 0.5, alpha = NA, family = "", fontface = 1, lineheight = 1.2),

                           draw_key = draw_key_text

                           )

+

+StatTreeLabel <-  ggproto("StatTreeLabel", Stat,

+                          required_aes = "node",

+                          compute_group = function(data, scales) {

+                              setup_tree_data(data)

+                          }

+                          )

+

+

new file mode 100644

@@ -0,0 +1,200 @@

+##' add tree layer

+##'

+##' 

+##' @title geom_tree

+##' @param mapping aesthetic mapping

+##' @param data data

+##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted'

+##' @param multiPhylo logical

+##' @param ... additional parameter

+##' @return tree layer

+##' @importFrom ggplot2 geom_segment

+##' @importFrom ggplot2 aes

+##' @export

+##' @author Yu Guangchuang

+geom_tree <- function(mapping=NULL, data=NULL, layout="rectangular", multiPhylo=FALSE, ...) {

+    stat_tree(data=data, mapping=mapping, geom="segment",

+              layout=layout, multiPhylo=multiPhylo, lineend="round", 

+              position='identity', show.legend=NA,

+              inherit.aes=TRUE, na.rm=TRUE, ...)

+}

+

+

+stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identity",

+                      layout="rectangular", multiPhylo=FALSE, lineend="round", ...,

+                      show.legend=NA, inherit.aes=TRUE, na.rm=FALSE) {

+    

+    default_aes <- aes_(x=~x, y=~y,node=~node, parent=~parent)

+    if (multiPhylo) {

+        default_aes <- modifyList(default_aes, aes_(.id=~.id))

+    }

+    

+    if (is.null(mapping)) {

+        mapping <- default_aes

+    } else {

+        mapping <- modifyList(mapping, default_aes)

+    }

+

+    if (layout %in% c("rectangular", "fan", "circular")) {

+        list(layer(data=data,

+                   mapping=mapping,

+                   stat=StatTreeHorizontal,

+                   geom = geom,

+                   position=position,

+                   show.legend = show.legend,

+                   inherit.aes = inherit.aes,

+                   params=list(layout = layout,

+                               lineend = lineend,

+                               na.rm = na.rm,

+                          ...)

+                   ),

+             layer(data=data,

+                   mapping=mapping,

+                   stat=StatTreeVertical,

+                   geom = geom,

+                   position=position,

+                   show.legend = show.legend,

+                   inherit.aes = inherit.aes,

+                   params=list(layout = layout,

+                               lineend = lineend,

+                               na.rm = na.rm,

+                               ...)

+                   )

+             )

+    } else if (layout %in% c("slanted", "radial", "unrooted")) {

+        layer(stat=StatTree,

+              data=data,

+              mapping=mapping,

+              geom = geom,

+              position=position,

+              show.legend = show.legend,

+              inherit.aes = inherit.aes,

+              params=list(layout = layout,

+                          lineend = lineend,

+                          na.rm = na.rm,

+                          ...)

+              )

+    }    

+}

+

+StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat,

+                              required_aes = c("node", "parent", "x", "y"),

+                              compute_panel = function(self, data, scales, params, layout, lineend) {

+                                  .fun <- function(data) {

+                                      df <- setup_tree_data(data)

+                                      x <- df$x

+                                      y <- df$y

+                                      df$xend <- x

+                                      df$yend <- y

+                                      ii <- with(df, match(parent, node))

+                                      df$x <- x[ii]

+                                      return(df)

+                                  }

+                                  

+                                  if ('.id' %in% names(data)) {

+                                      ldf <- split(data, data$.id)

+                                      df <- do.call(rbind, lapply(ldf, .fun))

+                                  } else {

+                                      df <- .fun(data)

+                                  }

+                                  return(df)

+                              }

+                              )

+

+StatTreeVertical <- ggproto("StatTreeVertical", Stat,

+                            required_aes = c("node", "parent", "x", "y"),

+                            compute_panel = function(self, data, scales, params, layout, lineend) {

+                                .fun <- function(data) {

+                                    df <- setup_tree_data(data)

+                                    x <- df$x

+                                    y <- df$y

+                                    ii <- with(df, match(parent, node))

+                                    df$x <- x[ii]

+                                    df$y <- y[ii]

+                                    df$xend <- x[ii]

+                                    df$yend <- y

+                                    return(df)

+                                }

+                                if ('.id' %in% names(data)) {

+                                    ldf <- split(data, data$.id)

+                                    df <- do.call(rbind, lapply(ldf, .fun))

+                                } else {

+                                    df <- .fun(data)

+                                }

+                                return(df)

+                            }

+                            )

+

+

+

+StatTree <- ggproto("StatTree", Stat,

+                    required_aes = c("node", "parent", "x", "y"),

+                    compute_panel = function(self, data, scales, params, layout, lineend) {

+                        .fun <- function(data) {

+                            df <- setup_tree_data(data)

+                            x <- df$x

+                            y <- df$y

+                            ii <- with(df, match(parent, node))

+                            df$x <- x[ii]

+                            df$y <- y[ii]

+                            df$xend <- x

+                            df$yend <- y

+                            return(df)

+                        }

+                        if ('.id' %in% names(data)) {

+                            ldf <- split(data, data$.id)

+                            df <- do.call(rbind, lapply(ldf, .fun))

+                        } else {

+                            df <- .fun(data)

+                        }

+                        return(df)

+                    }

+                    )

+

+

+setup_tree_data <- function(data) {

+    if (nrow(data) == length(unique(data$node)))

+        return(data)

+    

+    data[match(unique(data$node), data$node),]

+    ## data[order(data$node, decreasing = FALSE), ]

+}

+

+

+##' add tree layer

+##'

+##' 

+##' @title geom_tree2

+##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted'

+##' @param ... additional parameter

+##' @return tree layer

+##' @importFrom ggplot2 geom_segment

+##' @importFrom ggplot2 aes

+##' @export

+##' @author Yu Guangchuang

+geom_tree2 <- function(layout="rectangular", ...) {

+    x <- y <- parent <- NULL

+    lineend  = "round"

+    if (layout == "rectangular" || layout == "fan" || layout == "circular") {

+        list(

+            geom_segment(aes(x    = x[parent],

+                             xend = x,

+                             y    = y,

+                             yend = y),

+                         lineend  = lineend, ...),

+            

+            geom_segment(aes(x    = x[parent],

+                             xend = x[parent],

+                             y    = y[parent],

+                             yend = y),

+                         lineend  = lineend, ...)

+            )

+    } else if (layout == "slanted" || layout == "radial" || layout == "unrooted") {

+        geom_segment(aes(x    = x[parent],

+                         xend = x,

+                         y    = y[parent],

+                         yend = y),

+                     lineend  = lineend, ...)

+    }

+}

+

@@ -76,8 +76,17 @@ ggtree <- function(tr,

                 right         = right,

                 branch.length = branch.length,

                 ndigits       = ndigits, ...)

+

+    if (is(tr, "multiPhylo")) {

+        multiPhylo <- TRUE

+    } else {

+        multiPhylo <- FALSE

+    }

-    p <- p + geom_tree(layout, ...)  + theme_tree()

+    p <- p + geom_tree(layout=layout, multiPhylo=multiPhylo, ...)

+

+

+    p <- p + theme_tree()

     if (type == "circular" || type == "radial") {

         p <- p + coord_polar(theta = "y")

@@ -96,123 +105,5 @@ ggtree <- function(tr,

     return(p)

 }

-##' add tree layer

-##'

-##' 

-##' @title geom_tree

-##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial' or 'unrooted'

-##' @param ... additional parameter

-##' @return tree layer

-##' @importFrom ggplot2 geom_segment

-##' @importFrom ggplot2 aes

-##' @export

-##' @author Yu Guangchuang

-##' @examples

-##' require(ape)

-##' tr <- rtree(10)

-##' require(ggplot2)

-##' ggplot(tr) + geom_tree()

-geom_tree <- function(layout="rectangular", ...) {

-    x <- y <- parent <- NULL

-    lineend  = "round"

-    if (layout == "rectangular" || layout == "fan" || layout == "circular") {

-        list(

-            geom_segment(aes(x    = x[parent],

-                             xend = x,

-                             y    = y,

-                             yend = y),

-                         lineend  = lineend, ...),

-            

-            geom_segment(aes(x    = x[parent],

-                             xend = x[parent],

-                             y    = y[parent],

-                             yend = y),

-                         lineend  = lineend, ...)

-            )

-    } else if (layout == "slanted" || layout == "radial" || layout == "unrooted") {

-        geom_segment(aes(x    = x[parent],

-                         xend = x,

-                         y    = y[parent],

-                         yend = y),

-                     lineend  = lineend, ...)

-    }

-}

-

-

-

-

-

-

-

-

-

-##' add colorbar legend

-##'

-##' 

-##' @title add_colorbar

-##' @param p tree view

-##' @param color output of scale_color function

-##' @param x x position

-##' @param ymin ymin

-##' @param ymax ymax

-##' @param font.size font size 

-##' @return ggplot2 object

-##' @export

-##' @importFrom ggplot2 annotate

-##' @author Guangchuang Yu

-add_colorbar <- function(p, color, x=NULL, ymin=NULL, ymax=NULL, font.size=4) {

-    mrsd <- attr(p, "mrsd")

-    if (!is.null(mrsd)) {

-        attr(p, "mrsd") <- NULL

-        

-        p$data$x <- Date2decimal(p$data$x)

-        p$data$branch <- Date2decimal(p$data$branch)

-        ## annotation segment not support using Date as x-axis

-    }

-    

-    legend <- do.call("cbind", attr(color, "scale"))

-    

-    legend[,1] <- round(as.numeric(legend[,1]), 2)

-    

-    ## legend[nrow(legend),1] <- paste(">=", legend[nrow(legend),1])

-

-    if (is.null(x)) {

-        xx <- range(p$data$x)

-        x <- min(xx)+diff(xx)/100

-    }

-

-    yy <- range(p$data$y)

-    if (is.null(ymin)) {

-        if (is.null(ymax)) {        

-            ymax <- max(yy) - diff(yy)/100

-        }

-        ymin <- ymax - diff(yy)/15

-    }

-

-    if (is.null(ymax)) {

-        ymax <- ymin + diff(yy)/15

-    }

-        

-    yy <- seq(ymin, ymax, length.out=nrow(legend)+1)

-

-    ymin <- yy[1:nrow(legend)]

-    ymax <- yy[2:length(yy)]

-    y <- (ymin+ymax)/2

-

-    i <- seq(1, length(y), length.out = 5) %>% round(0)

-    offset <- diff(range(p$data$x))/40

-    barwidth <- offset/5

-    

-    p + annotate("text", x=x+offset*1.5, y=y[i], label=legend[i,1], size=font.size, hjust=0) +

-        annotate("rect", xmin=x, xmax=x+offset, ymin=ymin,

-                 ymax = ymax, fill=legend[,2], color=legend[,2]) +

-                     annotate("segment", x=x, xend=x+barwidth, y=y[i], yend=y[i], color="white") +

-                         annotate("segment", x=x+offset-barwidth, xend=x+offset, y=y[i], yend=y[i], color="white")

-    

-}

-

-

-

-

new file mode 100644

@@ -0,0 +1,93 @@

+##' append a heatmap of a matrix to right side of phylogenetic tree

+##'

+##' 

+##' @title gheatmap

+##' @param p tree view

+##' @param data matrix or data.frame

+##' @param offset offset of heatmap to tree

+##' @param width total width of heatmap, compare to width of tree

+##' @param low color of lowest value

+##' @param high color of highest value

+##' @param color color of heatmap cell border

+##' @param colnames logical, add matrix colnames or not

+##' @param colnames_position one of 'bottom' or 'top'

+##' @param colnames_level levels of colnames

+##' @param font.size font size of matrix colnames

+##' @return tree view

+##' @importFrom ggplot2 geom_tile

+##' @importFrom ggplot2 geom_text

+##' @importFrom ggplot2 theme

+##' @importFrom ggplot2 element_blank

+##' @importFrom ggplot2 guides

+##' @importFrom ggplot2 guide_legend

+##' @importFrom ggplot2 scale_fill_gradient

+##' @importFrom ggplot2 scale_fill_discrete

+##' @export

+##' @author Guangchuang Yu

+gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color="white",

+                     colnames=TRUE, colnames_position="bottom", colnames_level=NULL, font.size=4) {

+

+    colnames_position %<>% match.arg(c("bottom", "top"))

+    variable <- value <- lab <- y <- NULL

+    

+    ## if (is.null(width)) {

+    ##     width <- (p$data$x %>% range %>% diff)/30

+    ## }

+

+    ## convert width to width of each cell

+    width <- width * (p$data$x %>% range %>% diff) / ncol(data)

+    

+    isTip <- x <- y <- variable <- value <- from <- to <- NULL

+ 

+    df <- p$data

+    df <- df[df$isTip,]

+    start <- max(df$x) + offset

+