@@ -9,7 +9,7 @@

 ##' @param align where to place gene label, default is 'centre' and can be set to 'left' and 'right'

 ##' @param ... additional parameters

 ##' @return geom layer

-##' @importFrom rvcheck get_aes_var

+##' @importFrom ggfun get_aes_var

 ##' @export

 ##' @author Guangchuang Yu

 geom_motif <- function(mapping, data, on, label, align = 'centre', ...) {

@@ -1,27 +1,3 @@

-##' filter data for tree annotation layer

-##'

-##' The 'tree_filter()' function returns another function that can be

-##' used to subset ggtree() plot data. The function can be passed to the 'data' parameter

-##' in geom layer to perform subsetting. All rows that satisy your conditions will be retained.

-##' @title tree_filter

-##' @param ... Expressions that return a logical value.

-##' @return A function to filter ggtree plot data using conditions defined by '...'.

-##' @seealso

-##' [filter][dplyr::filter] 

-##' @author Guangchuang Yu

-##' @examples

-##' tree <- rtree(30)

-##' ## similar to 'ggtree(tree) + geom_tippoint()'

-##' ggtree(tree) + geom_point(data = tree_filter(isTip))

-##' @export

-tree_filter <- function(...) {

-    dots <- rlang::quos(...)

-    function(.data) {

-        dplyr::filter(.data, !!!dots)

-    }

-}

-

-

 ##' geom layer to draw aligned motif

 ##'

 ##'

@@ -1,3 +1,27 @@

+##' filter data for tree annotation layer

+##'

+##' The 'tree_filter()' function returns another function that can be

+##' used to subset ggtree() plot data. The function can be passed to the 'data' parameter

+##' in geom layer to perform subsetting. All rows that satisy your conditions will be retained.

+##' @title tree_filter

+##' @param ... Expressions that return a logical value.

+##' @return A function to filter ggtree plot data using conditions defined by '...'.

+##' @seealso

+##' [filter][dplyr::filter] 

+##' @author Guangchuang Yu

+##' @examples

+##' tree <- rtree(30)

+##' ## similar to 'ggtree(tree) + geom_tippoint()'

+##' ggtree(tree) + geom_point(data = tree_filter(isTip))

+##' @export

+tree_filter <- function(...) {

+    dots <- rlang::quos(...)

+    function(.data) {

+        dplyr::filter(.data, !!!dots)

+    }

+}

+

+

 ##' geom layer to draw aligned motif

 ##'

 ##'

@@ -40,7 +40,8 @@ geom_motif <- function(mapping, data, on, label, align = 'centre', ...) {

          ly_lab)

 }

-

+##' @importFrom ggplot2 annotation_custom

+##' @importFrom ggplot2 ggplotGrob

 plot_fantree <- function(fantree, upper=TRUE) {

     if (upper) {

         ymin <- -.25

@@ -213,19 +214,3 @@ coplot <- function(tree1, tree2, hjust=0) {

-##' set legend for multiple geom_hilight layers

-##'

-##'

-##' @title set_hilight_legend

-##' @param p ggtree object

-##' @param color color vector

-##' @param label label vector

-##' @param alpha transparency of color

-##' @return updated ggtree object

-##' @export

-##' @author Guangchuang Yu

-set_hilight_legend <- function(p, color, label, alpha=1) {

-	d <- data.frame(color=color, clade=label, x=0, y=1, alpha=alpha)

-	p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

-		guides(fill=guide_legend(override.aes=list(fill=alpha(d$color, d$alpha))))

-}

@@ -5,26 +5,39 @@

 ##' @param mapping aes mapping

 ##' @param data data

 ##' @param on gene to center (i.e. set middle position of the `on` gene to 0)

+##' @param label specify a column to be used to label genes

+##' @param align where to place gene label, default is 'centre' and can be set to 'left' and 'right'

 ##' @param ... additional parameters

 ##' @return geom layer

 ##' @importFrom rvcheck get_aes_var

 ##' @export

 ##' @author Guangchuang Yu

-geom_motif <- function(mapping, data, on, ...) {

-

-    seqnames <- 'label' 

+geom_motif <- function(mapping, data, on, label, align = 'centre', ...) {

+   

     id <- get_aes_var(mapping, 'fill')

     dd <- data[data[, id] == on,]

     mid <- dd$start + (dd$end - dd$start)/2

-    names(mid) <- as.character(dd[, seqnames])

-    adj <- mid[as.character(data[, seqnames])]

+    names(mid) <- dd$label

+

+    adj <- mid[data$label]

     data$start <- data$start - adj

     data$end <- data$end - adj

     geom_gene_arrow <- get_fun_from_pkg("gggenes", "geom_gene_arrow")

     mapping <- modifyList(mapping, aes_(y = ~y))

-    geom_gene_arrow(mapping = mapping, data = data, inherit.aes = FALSE, ...)

+    ly_gene <- geom_gene_arrow(mapping = mapping, data = data, inherit.aes = FALSE, ...)

+    if (missing(label)) {

+        return(ly_gene)

+    }

+

+    geom_gene_label <- get_fun_from_pkg("gggenes", "geom_gene_label")

+    mapping <- modifyList(mapping, aes_string(label = label))

+    if (align == 'center') align <- 'centre'

+    ly_lab <- geom_gene_label(mapping = mapping, data = data, align = align,

+                              inherit.aes = FALSE,...)

+    list(ly_gene,

+         ly_lab)

 }

@@ -7,28 +7,24 @@

 ##' @param on gene to center (i.e. set middle position of the `on` gene to 0)

 ##' @param ... additional parameters

 ##' @return geom layer

+##' @importFrom rvcheck get_aes_var

 ##' @export

 ##' @author Guangchuang Yu

 geom_motif <- function(mapping, data, on, ...) {

-    if (is.null(unlist(mapping)$y)) {

-        seqnames <- as.character(unlist(mapping)$group)

-    } else {

-        seqnames <- as.character(unlist(mapping)$y)

-    }

-    if (is.null(unlist(mapping$fill))) {

-        id <- as.character(unlist(mapping$id))

-    } else {

-        id <- as.character(unlist(mapping$fill))

-    }

-    dd <- data[unlist(data[, id]) == on,]

+    seqnames <- 'label' 

+    id <- get_aes_var(mapping, 'fill')

+

+    dd <- data[data[, id] == on,]

     mid <- dd$start + (dd$end - dd$start)/2

-    names(mid) <- as.character(unlist(dd[, seqnames]))

-    adj <- mid[as.character(unlist(data[, seqnames]))]

+    names(mid) <- as.character(dd[, seqnames])

+

+    adj <- mid[as.character(data[, seqnames])]

     data$start <- data$start - adj

     data$end <- data$end - adj

     geom_gene_arrow <- get_fun_from_pkg("gggenes", "geom_gene_arrow")

-    geom_gene_arrow(mapping = mapping, data = as.data.frame(data), ...)

+    mapping <- modifyList(mapping, aes_(y = ~y))

+    geom_gene_arrow(mapping = mapping, data = data, inherit.aes = FALSE, ...)

 }

@@ -84,58 +84,6 @@ get_heatmap_column_position <- function(treeview, by="bottom") {

     return(mapping)

 }

-##' scale x for tree with heatmap

-##'

-##'

-##' @title scale_x_ggtree

-##' @param tree_view tree view

-##' @param breaks breaks for tree

-##' @param labels lables for corresponding breaks

-##' @return tree view

-##' @importFrom ggplot2 scale_x_continuous

-##' @importFrom ggplot2 scale_x_date

-##' @export

-##' @author Guangchuang Yu

-scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

-    p <- get_tree_view(tree_view)

-

-    mrsd <- get("mrsd", envir=tree_view$plot_env)

-    if (!is.null(mrsd) && class(p$data$x) == "Date") {

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

-    } else {

-        x <- p$data$x

-    }

-

-    if (is.null(breaks)) {

-        breaks <- graphics::hist(x, breaks=5, plot=FALSE)$breaks

-    }

-    m <- attr(p, "mapping")

-

-    if (!is.null(mrsd) &&class(m$to) == "Date") {

-        to <- Date2decimal(m$to)

-    } else {

-        to <- m$to

-    }

-

-    idx <- which(sapply(breaks, function(x) any(x > m$to)))

-    if (length(idx)) {

-        breaks <- breaks[-idx]

-    }

-

-    if (is.null(labels)) {

-        labels <- breaks

-    }

-

-    breaks <- c(breaks, to)

-    labels <- c(labels, gsub("\\.", "", as.character(m$from)))

-

-    if (!is.null(mrsd) && class(p$data$x) == "Date") {

-        p <- p + scale_x_date(breaks=decimal2Date(breaks), labels)

-    } else {

-        p <- p + scale_x_continuous(breaks=breaks, labels=labels)

-    }

-    return(p)

-}

@@ -8,7 +8,7 @@

 ##' @param ... additional parameters

 ##' @return geom layer

 ##' @export

-##' @author guangchuang yu

+##' @author Guangchuang Yu

 geom_motif <- function(mapping, data, on, ...) {

     if (is.null(unlist(mapping)$y)) {

         seqnames <- as.character(unlist(mapping)$group)

@@ -107,7 +107,7 @@ scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

     }

     if (is.null(breaks)) {

-        breaks <- hist(x, breaks=5, plot=FALSE)$breaks

+        breaks <- graphics::hist(x, breaks=5, plot=FALSE)$breaks

     }

     m <- attr(p, "mapping")

@@ -266,8 +266,7 @@ coplot <- function(tree1, tree2, hjust=0) {

 ##' @param alpha transparency of color

 ##' @return updated ggtree object

 ##' @export

-##' @importFrom scales alpha

-##' @author guangchuang yu

+##' @author Guangchuang Yu

 set_hilight_legend <- function(p, color, label, alpha=1) {

 	d <- data.frame(color=color, clade=label, x=0, y=1, alpha=alpha)

 	p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

@@ -156,7 +156,7 @@ scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

 ## ##' @export

 ## ##' @author Guangchuang Yu \url{http://ygc.name}

 ## ##' @examples

-## ##' nwk <- system.file("extdata", "sample.nwk", package="ggtree")

+## ##' nwk <- system.file("extdata", "sample.nwk", package="treeio")

 ## ##' tree <- read.tree(nwk)

 ## ##' p <- ggtree(tree)

 ## ##' d <- matrix(abs(rnorm(52)), ncol=4)

@@ -47,16 +47,12 @@ plot_fantree <- function(fantree, upper=TRUE) {

         annotation_custom(ggplotGrob(fantree),

                           xmin=-.15, xmax=1.15,

                           ymin=ymin, ymax=ymax)

-    ## d <- data.frame(x=c(0,1), y=c(0.5, 1))

-    ## ggplot(d, aes_(x=~x, y=~y)) %>%

-    ##     subview(fantree, 0.5, y, width=2, height=2.2) ##  %>%

-    ## subview(p2+theme_transparent(), 0.5, 0.45, width=2, height=2.2) + theme_tree()

 }

 plot_fantrees <- function(uppertree, lowertree) {

     ggplot() + xlim(0,1) + ylim(0.5, 1) + theme_tree() +

         annotation_custom(ggplotGrob(uppertree), xmin=-.15, xmax=1.15, ymin=0.52, ymax=1.02) +

-        annotation_custom(ggplotGrob(lowertree + theme_transparent()), xmin=-.15, xmax=1.15, ymin=0.48, ymax=0.98)

+        annotation_custom(ggplotGrob(lowertree + ggimage::theme_transparent()), xmin=-.15, xmax=1.15, ymin=0.48, ymax=0.98)

 }

@@ -267,11 +267,13 @@ coplot <- function(tree1, tree2, hjust=0) {

 ##' @param p ggtree object

 ##' @param color color vector

 ##' @param label label vector

+##' @param alpha transparency of color

 ##' @return updated ggtree object

 ##' @export

+##' @importFrom scales alpha

 ##' @author guangchuang yu

-set_hilight_legend <- function(p, color, label) {

-	d <- data.frame(color=color, clade=label, x=0, y=1)

+set_hilight_legend <- function(p, color, label, alpha=1) {

+	d <- data.frame(color=color, clade=label, x=0, y=1, alpha=alpha)

 	p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

-		guides(fill=guide_legend(override.aes=list(fill=d$color)))

+		guides(fill=guide_legend(override.aes=list(fill=alpha(d$color, d$alpha))))

 }

@@ -272,6 +272,6 @@ coplot <- function(tree1, tree2, hjust=0) {

 ##' @author guangchuang yu

 set_hilight_legend <- function(p, color, label) {

 	d <- data.frame(color=color, clade=label, x=0, y=1)

-	p <- p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

+	p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

 		guides(fill=guide_legend(override.aes=list(fill=d$color)))

 }

@@ -260,4 +260,18 @@ coplot <- function(tree1, tree2, hjust=0) {

-

+##' set legend for multiple geom_hilight layers

+##'

+##'

+##' @title set_hilight_legend

+##' @param p ggtree object

+##' @param color color vector

+##' @param label label vector

+##' @return updated ggtree object

+##' @export

+##' @author guangchuang yu

+set_hilight_legend <- function(p, color, label) {

+	d <- data.frame(color=color, clade=label, x=0, y=1)

+	p <- p + geom_rect(aes_(fill=~clade, xmin=~x, xmax=~x, ymin=~y, ymax=~y), data=d, inherit.aes=F) +

+		guides(fill=guide_legend(override.aes=list(fill=d$color)))

+}

@@ -1,3 +1,37 @@

+##' geom layer to draw aligned motif

+##'

+##'

+##' @title geom_motif

+##' @param mapping aes mapping

+##' @param data data

+##' @param on gene to center (i.e. set middle position of the `on` gene to 0)

+##' @param ... additional parameters

+##' @return geom layer

+##' @export

+##' @author guangchuang yu

+geom_motif <- function(mapping, data, on, ...) {

+    if (is.null(unlist(mapping)$y)) {

+        seqnames <- as.character(unlist(mapping)$group)

+    } else {

+        seqnames <- as.character(unlist(mapping)$y)

+    }

+

+    if (is.null(unlist(mapping$fill))) {

+        id <- as.character(unlist(mapping$id))

+    } else {

+        id <- as.character(unlist(mapping$fill))

+    }

+    dd <- data[unlist(data[, id]) == on,]

+    mid <- dd$start + (dd$end - dd$start)/2

+    names(mid) <- as.character(unlist(dd[, seqnames]))

+    adj <- mid[as.character(unlist(data[, seqnames]))]

+    data$start <- data$start - adj

+    data$end <- data$end - adj

+    geom_gene_arrow <- get_fun_from_pkg("gggenes", "geom_gene_arrow")

+    geom_gene_arrow(mapping = mapping, data = as.data.frame(data), ...)

+}

+

+

 plot_fantree <- function(fantree, upper=TRUE) {

     if (upper) {

         ymin <- -.25

@@ -1,3 +1,30 @@

+plot_fantree <- function(fantree, upper=TRUE) {

+    if (upper) {

+        ymin <- -.25

+        ymax <- 1.3

+        ## y <- 0.55

+    } else {

+        ymin <- .2

+        ymax <- 1.75

+        ## y <- 0.45

+    }

+

+    ggplot() + xlim(0,1) + ylim(0.5, 1) + theme_tree() +

+        annotation_custom(ggplotGrob(fantree),

+                          xmin=-.15, xmax=1.15,

+                          ymin=ymin, ymax=ymax)

+    ## d <- data.frame(x=c(0,1), y=c(0.5, 1))

+    ## ggplot(d, aes_(x=~x, y=~y)) %>%

+    ##     subview(fantree, 0.5, y, width=2, height=2.2) ##  %>%

+    ## subview(p2+theme_transparent(), 0.5, 0.45, width=2, height=2.2) + theme_tree()

+}

+

+plot_fantrees <- function(uppertree, lowertree) {

+    ggplot() + xlim(0,1) + ylim(0.5, 1) + theme_tree() +

+        annotation_custom(ggplotGrob(uppertree), xmin=-.15, xmax=1.15, ymin=0.52, ymax=1.02) +

+        annotation_custom(ggplotGrob(lowertree + theme_transparent()), xmin=-.15, xmax=1.15, ymin=0.48, ymax=0.98)

+}

+

 ##' return a data.frame that contains position information

@@ -1,9 +1,9 @@

-##' return a data.frame that contains position information 

+##' return a data.frame that contains position information

 ##' for labeling column names of heatmap produced by `gheatmap` function

 ##'

-##' 

+##'

 ##' @title get_heatmap_column_position

 ##' @param treeview output of `gheatmap`

 ##' @param by one of 'bottom' or 'top'

@@ -29,7 +29,7 @@ get_heatmap_column_position <- function(treeview, by="bottom") {

 ##' scale x for tree with heatmap

 ##'

-##' 

+##'

 ##' @title scale_x_ggtree

 ##' @param tree_view tree view

 ##' @param breaks breaks for tree

@@ -59,16 +59,16 @@ scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

     } else {

         to <- m$to

     }

-    

+

     idx <- which(sapply(breaks, function(x) any(x > m$to)))

     if (length(idx)) {

         breaks <- breaks[-idx]

     }

-    

+

     if (is.null(labels)) {

         labels <- breaks

     }

-    

+

     breaks <- c(breaks, to)

     labels <- c(labels, gsub("\\.", "", as.character(m$from)))

@@ -77,7 +77,7 @@ scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

     } else {

         p <- p + scale_x_continuous(breaks=breaks, labels=labels)

     }

-    return(p)    

+    return(p)

 }

@@ -134,37 +134,37 @@ scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

 ##     ## p <- p+geom_segment(aes(x=x*1.02, xend=max(x)*1.08, yend=y), subset=.(isTip), linetype="dashed", size=0.4)

 ##     df=p$data

 ##     df=df[df$isTip,]

-    

+

 ##     dd$Var1 <- factor(dd$Var1, levels = df$label[order(df$y)])

 ##     if (any(dd$value == "")) {

 ##         dd$value[dd$value == ""] <- NA

 ##     }

-    

+

 ##     p2 <- ggplot(dd, aes(Var2, Var1, fill=value))+geom_tile(color=color)

 ##     if (is(dd$value,"numeric")) {

 ##         p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white")

 ##     } else {

 ##         p2 <- p2 + scale_fill_discrete(na.value="white")

 ##     }

-    

+

 ##     p2 <- p2+xlab("")+ylab("")

 ##     p2 <- p2+theme_tree2() + theme(axis.ticks.x = element_blank(),

 ##                                    axis.line.x=element_blank())

 ##     ## p1 <- p1 + theme(axis.text.x = element_text(size = font.size))

-##     p2 <- p2 + theme(axis.ticks.margin = unit(0, "lines")) 

+##     p2 <- p2 + theme(axis.ticks.margin = unit(0, "lines"))

 ##     p2 <- p2 + theme(axis.text.x = element_text(size = font.size))

 ##     ## p2 <- p2 + theme(axis.text.y = element_text(size=font.size))

-    

-##     ## plot.margin   margin around entire plot (unit with the sizes of the top, right, bottom, and left margins) 

+

+##     ## plot.margin   margin around entire plot (unit with the sizes of the top, right, bottom, and left margins)

 ##     ## units can be given in "lines" or  something more specific like "cm"...

-    

+

 ##     p2 <- p2 + theme(panel.margin=unit(0, "null"))

 ##     p2 <- p2 + theme(plot.margin = unit(c(1, 1, .5, -0.5), "lines"))

 ##     p2 <- p2 + theme(legend.position = "right")

 ##     p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL)))

 ##     ## p2 <- p2 + labs(fill="")

-    

+

 ##     return(p2)

 ## }

@@ -185,7 +185,7 @@ coplot <- function(tree1, tree2, hjust=0) {

         geom_tree(layout="phylogram", subset=.(tree=="A")) +

             geom_tree(layout="phylogram", subset=.(tree=="B")) +

                 theme_tree()

- 

+

     p <- p  + geom_text(aes(label=label),

                         subset=.(isTip & tree == "A"),

                         hjust=-offset/40) +

@@ -200,4 +200,3 @@ coplot <- function(tree1, tree2, hjust=0) {

-

@@ -1,3 +1,5 @@

+

+

 ##' return a data.frame that contains position information 

 ##' for labeling column names of heatmap produced by `gheatmap` function

 ##'

@@ -25,120 +27,6 @@ get_heatmap_column_position <- function(treeview, by="bottom") {

     return(mapping)

 }

-##' multiple sequence alignment with phylogenetic tree

-##'

-##' 

-##' @title msaplot

-##' @param p tree view

-##' @param fasta fasta file, multiple sequence alignment

-##' @param offset offset of MSA to tree

-##' @param width total width of alignment, compare to width of tree

-##' @param color color 

-##' @param window specific a slice to display

-##' @return tree view

-##' @export

-##' @importFrom Biostrings readBStringSet

-##' @importMethodsFrom Biostrings width

-## @importFrom colorspace rainbow_hcl

-##' @importFrom ggplot2 geom_segment

-##' @importFrom ggplot2 geom_rect

-##' @importFrom ggplot2 scale_fill_manual

-##' @author Guangchuang Yu

-msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){

-    if (missingArg(fasta)) {

-        aln <- NULL

-    } else if (is(fasta, "BStringSet")) {

-        aln <- fasta

-    } else if (is(fasta, "character")) {

-        aln <- readBStringSet(fasta)

-    } else {

-        aln <- NULL

-    }

-        

-    if (is(p, "phylip")) {

-        aln <- p@sequence

-        p <- ggtree(p) + geom_tiplab()

-    }

-

-    if (is.null(aln)) {

-        stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...")

-    }

-    

-    if (is.null(window)) {

-        window <- c(1, width(aln)[1])

-    }

-    slice <- seq(window[1], window[2], by=1)

-    

-    seqs <- lapply(1:length(aln), function(i) {

-        x <- toString(aln[i])

-        seq <- substring(x, slice, slice)

-

-        seq[seq == '?'] <- '-'

-        seq[seq == '*'] <- '-'

-        seq[seq == ' '] <- '-'

-        return(seq)

-    })

-    names(seqs) <- names(aln)

-    

-    if(is.null(color)) {

-        alphabet <- unlist(seqs) %>% unique

-        alphabet <- alphabet[alphabet != '-']

-        ## color <- rainbow_hcl(length(alphabet))

-        color <- getCols(length(alphabet))

-        names(color) <- alphabet

-        color <- c(color, '-'=NA)

-    }

-

-    df <- p$data

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

-    ##     width <- (df$x %>% range %>% diff)/500

-    ## }

-

-    ## convert width to width of each cell

-    width <- width * (df$x %>% range %>% diff) / diff(window)

-    

-    df=df[df$isTip,]

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

-

-    seqs <- seqs[df$label[order(df$y)]]

-    ## seqs.df <- do.call("rbind", seqs)

-

-    h <- ceiling(diff(range(df$y))/length(df$y))

-    xmax <- start + seq_along(slice) * width

-    xmin <- xmax - width

-    y <- sort(df$y)

-    ymin <- y - 0.4 *h

-    ymax <- y + 0.4 *h

-

-    from <- to <- NULL

-    

-    lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y)

-

-    p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y))

-    msa <- lapply(1:length(y), function(i) {

-        data.frame(name=names(seqs)[i],

-                   xmin=xmin,

-                   xmax=xmax,

-                   ymin=ymin[i],

-                   ymax=ymax[i],

-                   seq=seqs[[i]])

-    })

-

-    msa.df <- do.call("rbind", msa)

-

-    p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, 

-                           xmin=xmin, xmax=xmax,

-                           ymin=ymin, ymax=ymax, fill=seq)) +

-                               scale_fill_manual(values=color)

-

-    breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks

-    pos <- start + breaks * width

-    mapping <- data.frame(from=breaks+1, to=pos)

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

-    

-    return(p)

-}

-

 ##' scale x for tree with heatmap

 ##'

 ##' 

@@ -1,2 +1,315 @@

+##' return a data.frame that contains position information 

+##' for labeling column names of heatmap produced by `gheatmap` function

+##'

+##' 

+##' @title get_heatmap_column_position

+##' @param treeview output of `gheatmap`

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

+##' @return data.frame

+##' @export

+##' @author Guangchuang Yu

+get_heatmap_column_position <- function(treeview, by="bottom") {

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

+

+    mapping <- attr(treeview, "mapping")

+    if (is.null(mapping)) {

+        stop("treeview is not an output of `gheatmap`...")

+    }

+

+    colnames(mapping) <- c("label", "x")

+    if (by == "bottom") {

+        mapping$y <- 0

+    } else {

+        mapping$y <- max(treeview$data$y) + 1

+    }

+    return(mapping)

+}

+

+##' multiple sequence alignment with phylogenetic tree

+##'

+##' 

+##' @title msaplot

+##' @param p tree view

+##' @param fasta fasta file, multiple sequence alignment

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

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

+##' @param color color 

+##' @param window specific a slice to display

+##' @return tree view

+##' @export

+##' @importFrom Biostrings readBStringSet

+##' @importMethodsFrom Biostrings width

+## @importFrom colorspace rainbow_hcl

+##' @importFrom ggplot2 geom_segment

+##' @importFrom ggplot2 geom_rect

+##' @importFrom ggplot2 scale_fill_manual

+##' @author Guangchuang Yu

+msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){

+    if (missingArg(fasta)) {

+        aln <- NULL

+    } else if (is(fasta, "BStringSet")) {

+        aln <- fasta

+    } else if (is(fasta, "character")) {

+        aln <- readBStringSet(fasta)

+    } else {

+        aln <- NULL

+    }

+        

+    if (is(p, "phylip")) {

+        aln <- p@sequence

+        p <- ggtree(p) + geom_tiplab()

+    }

+

+    if (is.null(aln)) {

+        stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...")

+    }

+    

+    if (is.null(window)) {

+        window <- c(1, width(aln)[1])

+    }

+    slice <- seq(window[1], window[2], by=1)

+    

+    seqs <- lapply(1:length(aln), function(i) {

+        x <- toString(aln[i])

+        seq <- substring(x, slice, slice)

+

+        seq[seq == '?'] <- '-'

+        seq[seq == '*'] <- '-'

+        seq[seq == ' '] <- '-'

+        return(seq)

+    })

+    names(seqs) <- names(aln)

+    

+    if(is.null(color)) {

+        alphabet <- unlist(seqs) %>% unique

+        alphabet <- alphabet[alphabet != '-']

+        ## color <- rainbow_hcl(length(alphabet))

+        color <- getCols(length(alphabet))

+        names(color) <- alphabet

+        color <- c(color, '-'=NA)

+    }

+

+    df <- p$data

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

+    ##     width <- (df$x %>% range %>% diff)/500

+    ## }

+

+    ## convert width to width of each cell

+    width <- width * (df$x %>% range %>% diff) / diff(window)

+    

+    df=df[df$isTip,]

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

+

+    seqs <- seqs[df$label[order(df$y)]]

+    ## seqs.df <- do.call("rbind", seqs)

+

+    h <- ceiling(diff(range(df$y))/length(df$y))

+    xmax <- start + seq_along(slice) * width

+    xmin <- xmax - width

+    y <- sort(df$y)

+    ymin <- y - 0.4 *h

+    ymax <- y + 0.4 *h

+

+    from <- to <- NULL

+    

+    lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y)

+

+    p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y))

+    msa <- lapply(1:length(y), function(i) {

+        data.frame(name=names(seqs)[i],

+                   xmin=xmin,

+                   xmax=xmax,

+                   ymin=ymin[i],

+                   ymax=ymax[i],

+                   seq=seqs[[i]])

+    })

+

+    msa.df <- do.call("rbind", msa)

+

+    p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, 

+                           xmin=xmin, xmax=xmax,

+                           ymin=ymin, ymax=ymax, fill=seq)) +

+                               scale_fill_manual(values=color)

+

+    breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks

+    pos <- start + breaks * width

+    mapping <- data.frame(from=breaks+1, to=pos)

+    attr(p, "mapping") <- mapping

+    

+    return(p)

+}

+

+##' scale x for tree with heatmap

+##'

+##' 

+##' @title scale_x_ggtree

+##' @param tree_view tree view

+##' @param breaks breaks for tree

+##' @param labels lables for corresponding breaks

+##' @return tree view

+##' @importFrom ggplot2 scale_x_continuous

+##' @importFrom ggplot2 scale_x_date

+##' @export

+##' @author Guangchuang Yu

+scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {

+    p <- get_tree_view(tree_view)

+

+    mrsd <- get("mrsd", envir=tree_view$plot_env)

+    if (!is.null(mrsd) && class(p$data$x) == "Date") {

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

+    } else {

+        x <- p$data$x

+    }

+

+    if (is.null(breaks)) {

+        breaks <- hist(x, breaks=5, plot=FALSE)$breaks

+    }

+    m <- attr(p, "mapping")

+

+    if (!is.null(mrsd) &&class(m$to) == "Date") {

+        to <- Date2decimal(m$to)

+    } else {

+        to <- m$to

+    }

+    

+    idx <- which(sapply(breaks, function(x) any(x > m$to)))

+    if (length(idx)) {

+        breaks <- breaks[-idx]

+    }

+    

+    if (is.null(labels)) {

+        labels <- breaks

+    }

+    

+    breaks <- c(breaks, to)

+    labels <- c(labels, gsub("\\.", "", as.character(m$from)))

+

+    if (!is.null(mrsd) && class(p$data$x) == "Date") {

+        p <- p + scale_x_date(breaks=decimal2Date(breaks), labels)

+    } else {

+        p <- p + scale_x_continuous(breaks=breaks, labels=labels)

+    }

+    return(p)    

+}

+

+

+

+## ##' view tree and associated matrix

+## ##'

+## ##' @title gplot