git-svn-id: file:///home/git/hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ggtree@115874 bc3139a8-67e5-0310-9ffc-ced21a209358
Guangchuang Yu authored on 06/04/2016 08:34:24
| ... | ... |
@@ -1,2 +1,315 @@ |
| 1 |
+##' return a data.frame that contains position information |
|
| 2 |
+##' for labeling column names of heatmap produced by `gheatmap` function |
|
| 3 |
+##' |
|
| 4 |
+##' |
|
| 5 |
+##' @title get_heatmap_column_position |
|
| 6 |
+##' @param treeview output of `gheatmap` |
|
| 7 |
+##' @param by one of 'bottom' or 'top' |
|
| 8 |
+##' @return data.frame |
|
| 9 |
+##' @export |
|
| 10 |
+##' @author Guangchuang Yu |
|
| 11 |
+get_heatmap_column_position <- function(treeview, by="bottom") {
|
|
| 12 |
+ by %<>% match.arg(c("bottom", "top"))
|
|
| 13 |
+ |
|
| 14 |
+ mapping <- attr(treeview, "mapping") |
|
| 15 |
+ if (is.null(mapping)) {
|
|
| 16 |
+ stop("treeview is not an output of `gheatmap`...")
|
|
| 17 |
+ } |
|
| 18 |
+ |
|
| 19 |
+ colnames(mapping) <- c("label", "x")
|
|
| 20 |
+ if (by == "bottom") {
|
|
| 21 |
+ mapping$y <- 0 |
|
| 22 |
+ } else {
|
|
| 23 |
+ mapping$y <- max(treeview$data$y) + 1 |
|
| 24 |
+ } |
|
| 25 |
+ return(mapping) |
|
| 26 |
+} |
|
| 27 |
+ |
|
| 28 |
+##' multiple sequence alignment with phylogenetic tree |
|
| 29 |
+##' |
|
| 30 |
+##' |
|
| 31 |
+##' @title msaplot |
|
| 32 |
+##' @param p tree view |
|
| 33 |
+##' @param fasta fasta file, multiple sequence alignment |
|
| 34 |
+##' @param offset offset of MSA to tree |
|
| 35 |
+##' @param width total width of alignment, compare to width of tree |
|
| 36 |
+##' @param color color |
|
| 37 |
+##' @param window specific a slice to display |
|
| 38 |
+##' @return tree view |
|
| 39 |
+##' @export |
|
| 40 |
+##' @importFrom Biostrings readBStringSet |
|
| 41 |
+##' @importMethodsFrom Biostrings width |
|
| 42 |
+## @importFrom colorspace rainbow_hcl |
|
| 43 |
+##' @importFrom ggplot2 geom_segment |
|
| 44 |
+##' @importFrom ggplot2 geom_rect |
|
| 45 |
+##' @importFrom ggplot2 scale_fill_manual |
|
| 46 |
+##' @author Guangchuang Yu |
|
| 47 |
+msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
|
|
| 48 |
+ if (missingArg(fasta)) {
|
|
| 49 |
+ aln <- NULL |
|
| 50 |
+ } else if (is(fasta, "BStringSet")) {
|
|
| 51 |
+ aln <- fasta |
|
| 52 |
+ } else if (is(fasta, "character")) {
|
|
| 53 |
+ aln <- readBStringSet(fasta) |
|
| 54 |
+ } else {
|
|
| 55 |
+ aln <- NULL |
|
| 56 |
+ } |
|
| 57 |
+ |
|
| 58 |
+ if (is(p, "phylip")) {
|
|
| 59 |
+ aln <- p@sequence |
|
| 60 |
+ p <- ggtree(p) + geom_tiplab() |
|
| 61 |
+ } |
|
| 62 |
+ |
|
| 63 |
+ if (is.null(aln)) {
|
|
| 64 |
+ stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...")
|
|
| 65 |
+ } |
|
| 66 |
+ |
|
| 67 |
+ if (is.null(window)) {
|
|
| 68 |
+ window <- c(1, width(aln)[1]) |
|
| 69 |
+ } |
|
| 70 |
+ slice <- seq(window[1], window[2], by=1) |
|
| 71 |
+ |
|
| 72 |
+ seqs <- lapply(1:length(aln), function(i) {
|
|
| 73 |
+ x <- toString(aln[i]) |
|
| 74 |
+ seq <- substring(x, slice, slice) |
|
| 75 |
+ |
|
| 76 |
+ seq[seq == '?'] <- '-' |
|
| 77 |
+ seq[seq == '*'] <- '-' |
|
| 78 |
+ seq[seq == ' '] <- '-' |
|
| 79 |
+ return(seq) |
|
| 80 |
+ }) |
|
| 81 |
+ names(seqs) <- names(aln) |
|
| 82 |
+ |
|
| 83 |
+ if(is.null(color)) {
|
|
| 84 |
+ alphabet <- unlist(seqs) %>% unique |
|
| 85 |
+ alphabet <- alphabet[alphabet != '-'] |
|
| 86 |
+ ## color <- rainbow_hcl(length(alphabet)) |
|
| 87 |
+ color <- getCols(length(alphabet)) |
|
| 88 |
+ names(color) <- alphabet |
|
| 89 |
+ color <- c(color, '-'=NA) |
|
| 90 |
+ } |
|
| 91 |
+ |
|
| 92 |
+ df <- p$data |
|
| 93 |
+ ## if (is.null(width)) {
|
|
| 94 |
+ ## width <- (df$x %>% range %>% diff)/500 |
|
| 95 |
+ ## } |
|
| 96 |
+ |
|
| 97 |
+ ## convert width to width of each cell |
|
| 98 |
+ width <- width * (df$x %>% range %>% diff) / diff(window) |
|
| 99 |
+ |
|
| 100 |
+ df=df[df$isTip,] |
|
| 101 |
+ start <- max(df$x) * 1.02 + offset |
|
| 102 |
+ |
|
| 103 |
+ seqs <- seqs[df$label[order(df$y)]] |
|
| 104 |
+ ## seqs.df <- do.call("rbind", seqs)
|
|
| 105 |
+ |
|
| 106 |
+ h <- ceiling(diff(range(df$y))/length(df$y)) |
|
| 107 |
+ xmax <- start + seq_along(slice) * width |
|
| 108 |
+ xmin <- xmax - width |
|
| 109 |
+ y <- sort(df$y) |
|
| 110 |
+ ymin <- y - 0.4 *h |
|
| 111 |
+ ymax <- y + 0.4 *h |
|
| 112 |
+ |
|
| 113 |
+ from <- to <- NULL |
|
| 114 |
+ |
|
| 115 |
+ lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y) |
|
| 116 |
+ |
|
| 117 |
+ p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y)) |
|
| 118 |
+ msa <- lapply(1:length(y), function(i) {
|
|
| 119 |
+ data.frame(name=names(seqs)[i], |
|
| 120 |
+ xmin=xmin, |
|
| 121 |
+ xmax=xmax, |
|
| 122 |
+ ymin=ymin[i], |
|
| 123 |
+ ymax=ymax[i], |
|
| 124 |
+ seq=seqs[[i]]) |
|
| 125 |
+ }) |
|
| 126 |
+ |
|
| 127 |
+ msa.df <- do.call("rbind", msa)
|
|
| 128 |
+ |
|
| 129 |
+ p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, |
|
| 130 |
+ xmin=xmin, xmax=xmax, |
|
| 131 |
+ ymin=ymin, ymax=ymax, fill=seq)) + |
|
| 132 |
+ scale_fill_manual(values=color) |
|
| 133 |
+ |
|
| 134 |
+ breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks |
|
| 135 |
+ pos <- start + breaks * width |
|
| 136 |
+ mapping <- data.frame(from=breaks+1, to=pos) |
|
| 137 |
+ attr(p, "mapping") <- mapping |
|
| 138 |
+ |
|
| 139 |
+ return(p) |
|
| 140 |
+} |
|
| 141 |
+ |
|
| 142 |
+##' scale x for tree with heatmap |
|
| 143 |
+##' |
|
| 144 |
+##' |
|
| 145 |
+##' @title scale_x_ggtree |
|
| 146 |
+##' @param tree_view tree view |
|
| 147 |
+##' @param breaks breaks for tree |
|
| 148 |
+##' @param labels lables for corresponding breaks |
|
| 149 |
+##' @return tree view |
|
| 150 |
+##' @importFrom ggplot2 scale_x_continuous |
|
| 151 |
+##' @importFrom ggplot2 scale_x_date |
|
| 152 |
+##' @export |
|
| 153 |
+##' @author Guangchuang Yu |
|
| 154 |
+scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {
|
|
| 155 |
+ p <- get_tree_view(tree_view) |
|
| 156 |
+ |
|
| 157 |
+ mrsd <- get("mrsd", envir=tree_view$plot_env)
|
|
| 158 |
+ if (!is.null(mrsd) && class(p$data$x) == "Date") {
|
|
| 159 |
+ x <- Date2decimal(p$data$x) |
|
| 160 |
+ } else {
|
|
| 161 |
+ x <- p$data$x |
|
| 162 |
+ } |
|
| 163 |
+ |
|
| 164 |
+ if (is.null(breaks)) {
|
|
| 165 |
+ breaks <- hist(x, breaks=5, plot=FALSE)$breaks |
|
| 166 |
+ } |
|
| 167 |
+ m <- attr(p, "mapping") |
|
| 168 |
+ |
|
| 169 |
+ if (!is.null(mrsd) &&class(m$to) == "Date") {
|
|
| 170 |
+ to <- Date2decimal(m$to) |
|
| 171 |
+ } else {
|
|
| 172 |
+ to <- m$to |
|
| 173 |
+ } |
|
| 174 |
+ |
|
| 175 |
+ idx <- which(sapply(breaks, function(x) any(x > m$to))) |
|
| 176 |
+ if (length(idx)) {
|
|
| 177 |
+ breaks <- breaks[-idx] |
|
| 178 |
+ } |
|
| 179 |
+ |
|
| 180 |
+ if (is.null(labels)) {
|
|
| 181 |
+ labels <- breaks |
|
| 182 |
+ } |
|
| 183 |
+ |
|
| 184 |
+ breaks <- c(breaks, to) |
|
| 185 |
+ labels <- c(labels, gsub("\\.", "", as.character(m$from)))
|
|
| 186 |
+ |
|
| 187 |
+ if (!is.null(mrsd) && class(p$data$x) == "Date") {
|
|
| 188 |
+ p <- p + scale_x_date(breaks=decimal2Date(breaks), labels) |
|
| 189 |
+ } else {
|
|
| 190 |
+ p <- p + scale_x_continuous(breaks=breaks, labels=labels) |
|
| 191 |
+ } |
|
| 192 |
+ return(p) |
|
| 193 |
+} |
|
| 194 |
+ |
|
| 195 |
+ |
|
| 196 |
+ |
|
| 197 |
+## ##' view tree and associated matrix |
|
| 198 |
+## ##' |
|
| 199 |
+## ##' @title gplot |
|
| 200 |
+## ##' @param p tree view |
|
| 201 |
+## ##' @param data matrix |
|
| 202 |
+## ##' @param low low color |
|
| 203 |
+## ##' @param high high color |
|
| 204 |
+## ##' @param widths widths of sub plot |
|
| 205 |
+## ##' @param color color |
|
| 206 |
+## ##' @param font.size font size |
|
| 207 |
+## ##' @return list of figure |
|
| 208 |
+## ##' @importFrom gridExtra grid.arrange |
|
| 209 |
+## ##' @importFrom ggplot2 scale_x_continuous |
|
| 210 |
+## ##' @importFrom ggplot2 scale_y_continuous |
|
| 211 |
+## ##' @export |
|
| 212 |
+## ##' @author Guangchuang Yu \url{http://ygc.name}
|
|
| 213 |
+## ##' @examples |
|
| 214 |
+## ##' nwk <- system.file("extdata", "sample.nwk", package="ggtree")
|
|
| 215 |
+## ##' tree <- read.tree(nwk) |
|
| 216 |
+## ##' p <- ggtree(tree) |
|
| 217 |
+## ##' d <- matrix(abs(rnorm(52)), ncol=4) |
|
| 218 |
+## ##' rownames(d) <- tree$tip.label |
|
| 219 |
+## ##' colnames(d) <- paste0("G", 1:4)
|
|
| 220 |
+## ##' gplot(p, d, low="green", high="red") |
|
| 221 |
+## gplot <- function(p, data, low="green", high="red", widths=c(0.5, 0.5), color="white", font.size=14) {
|
|
| 222 |
+## ## p <- p + scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0.6)) |
|
| 223 |
+## p1 <- p + scale_y_continuous(expand = c(0, 0.6)) |
|
| 224 |
+## ## p1 <- p + theme(panel.margin=unit(0, "null")) |
|
| 225 |
+## ## p1 <- p1 + theme(plot.margin = unit(c(1, -1, 1.5, 1), "lines")) |
|
| 226 |
+## p2 <- gplot.heatmap(p, data, low, high, color, font.size) |
|
| 227 |
+## grid.arrange(p1, p2, ncol=2, widths=widths) |
|
| 228 |
+## invisible(list(p1=p1, p2=p2)) |
|
| 229 |
+## } |
|
| 230 |
+ |
|
| 231 |
+ |
|
| 232 |
+## ##' @importFrom grid unit |
|
| 233 |
+## ##' @importFrom ggplot2 scale_fill_gradient |
|
| 234 |
+## ##' @importFrom ggplot2 scale_fill_discrete |
|
| 235 |
+## ##' @importFrom ggplot2 element_text |
|
| 236 |
+## ##' @importFrom ggplot2 geom_tile |
|
| 237 |
+## ##' @importFrom ggplot2 labs |
|
| 238 |
+## ##' @importFrom ggplot2 guides |
|
| 239 |
+## ##' @importFrom ggplot2 guide_legend |
|
| 240 |
+## ##' @importFrom reshape2 melt |
|
| 241 |
+## gplot.heatmap <- function(p, data, low, high, color="white", font.size) {
|
|
| 242 |
+## isTip <- x <- Var1 <- Var2 <- value <- NULL |
|
| 243 |
+## dd=melt(as.matrix(data)) |
|
| 244 |
+## ## p <- ggtree(tree) ## + theme_tree2() |
|
| 245 |
+## ## p <- p + geom_text(aes(x = max(x)*1.1, label=label), subset=.(isTip), hjust=0) |
|
| 246 |
+## ## p <- p+geom_segment(aes(x=x*1.02, xend=max(x)*1.08, yend=y), subset=.(isTip), linetype="dashed", size=0.4) |
|
| 247 |
+## df=p$data |
|
| 248 |
+## df=df[df$isTip,] |
|
| 249 |
+ |
|
| 250 |
+## dd$Var1 <- factor(dd$Var1, levels = df$label[order(df$y)]) |
|
| 251 |
+## if (any(dd$value == "")) {
|
|
| 252 |
+## dd$value[dd$value == ""] <- NA |
|
| 253 |
+## } |
|
| 254 |
+ |
|
| 255 |
+## p2 <- ggplot(dd, aes(Var2, Var1, fill=value))+geom_tile(color=color) |
|
| 256 |
+## if (is(dd$value,"numeric")) {
|
|
| 257 |
+## p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white") |
|
| 258 |
+## } else {
|
|
| 259 |
+## p2 <- p2 + scale_fill_discrete(na.value="white") |
|
| 260 |
+## } |
|
| 261 |
+ |
|
| 262 |
+## p2 <- p2+xlab("")+ylab("")
|
|
| 263 |
+## p2 <- p2+theme_tree2() + theme(axis.ticks.x = element_blank(), |
|
| 264 |
+## axis.line.x=element_blank()) |
|
| 265 |
+## ## p1 <- p1 + theme(axis.text.x = element_text(size = font.size)) |
|
| 266 |
+## p2 <- p2 + theme(axis.ticks.margin = unit(0, "lines")) |
|
| 267 |
+## p2 <- p2 + theme(axis.text.x = element_text(size = font.size)) |
|
| 268 |
+## ## p2 <- p2 + theme(axis.text.y = element_text(size=font.size)) |
|
| 269 |
+ |
|
| 270 |
+## ## plot.margin margin around entire plot (unit with the sizes of the top, right, bottom, and left margins) |
|
| 271 |
+## ## units can be given in "lines" or something more specific like "cm"... |
|
| 272 |
+ |
|
| 273 |
+ |
|
| 274 |
+## p2 <- p2 + theme(panel.margin=unit(0, "null")) |
|
| 275 |
+## p2 <- p2 + theme(plot.margin = unit(c(1, 1, .5, -0.5), "lines")) |
|
| 276 |
+## p2 <- p2 + theme(legend.position = "right") |
|
| 277 |
+## p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL))) |
|
| 278 |
+## ## p2 <- p2 + labs(fill="") |
|
| 279 |
+ |
|
| 280 |
+## return(p2) |
|
| 281 |
+## } |
|
| 282 |
+ |
|
| 283 |
+ |
|
| 284 |
+coplot <- function(tree1, tree2, hjust=0) {
|
|
| 285 |
+ x <- y <- label <- isTip <- tree <- NULL |
|
| 286 |
+ dx <- fortify(tree1) |
|
| 287 |
+ dx$tree <- "A" |
|
| 288 |
+ |
|
| 289 |
+ offset <- max(dx$x) * 1.3 |
|
| 290 |
+ dy <- fortify(tree2) |
|
| 291 |
+ dy <- reverse.treeview.data(dy) |
|
| 292 |
+ dy$x <- dy$x + offset + hjust |
|
| 293 |
+ dy$tree <- "B" |
|
| 294 |
+ |
|
| 295 |
+ dd <- rbind(dx, dy) |
|
| 296 |
+ p <- ggplot(dd, aes(x, y)) + |
|
| 297 |
+ geom_tree(layout="phylogram", subset=.(tree=="A")) + |
|
| 298 |
+ geom_tree(layout="phylogram", subset=.(tree=="B")) + |
|
| 299 |
+ theme_tree() |
|
| 300 |
+ |
|
| 301 |
+ p <- p + geom_text(aes(label=label), |
|
| 302 |
+ subset=.(isTip & tree == "A"), |
|
| 303 |
+ hjust=-offset/40) + |
|
| 304 |
+ geom_text(aes(label=label), |
|
| 305 |
+ subset=.(isTip & tree == "B"), |
|
| 306 |
+ hjust = offset/20) |
|
| 307 |
+ return(p) |
|
| 308 |
+} |
|
| 309 |
+ |
|
| 310 |
+ |
|
| 311 |
+ |
|
| 312 |
+ |
|
| 313 |
+ |
|
| 1 | 314 |
|
| 2 | 315 |
|
| ... | ... |
@@ -94,16 +94,6 @@ ggtree <- function(tr, |
| 94 | 94 |
## and also have some space for tree scale (legend) |
| 95 | 95 |
p <- p + scale_y_continuous(limits=c(0, max(p$data$y))) |
| 96 | 96 |
} |
| 97 |
- |
|
| 98 |
- attr(p, "mrsd") <- mrsd |
|
| 99 |
- attr(p, "param") <- list(layout = layout, |
|
| 100 |
- yscale = yscale, |
|
| 101 |
- ladderize = ladderize, |
|
| 102 |
- right = right, |
|
| 103 |
- branch.length = branch.length, |
|
| 104 |
- ndigits = ndigits) |
|
| 97 |
+ |
|
| 105 | 98 |
return(p) |
| 106 | 99 |
} |
| 107 |
- |
|
| 108 |
- |
|
| 109 |
- |
| 110 | 100 |
deleted file mode 100644 |
| ... | ... |
@@ -1,315 +0,0 @@ |
| 1 |
-##' return a data.frame that contains position information |
|
| 2 |
-##' for labeling column names of heatmap produced by `gheatmap` function |
|
| 3 |
-##' |
|
| 4 |
-##' |
|
| 5 |
-##' @title get_heatmap_column_position |
|
| 6 |
-##' @param treeview output of `gheatmap` |
|
| 7 |
-##' @param by one of 'bottom' or 'top' |
|
| 8 |
-##' @return data.frame |
|
| 9 |
-##' @export |
|
| 10 |
-##' @author Guangchuang Yu |
|
| 11 |
-get_heatmap_column_position <- function(treeview, by="bottom") {
|
|
| 12 |
- by %<>% match.arg(c("bottom", "top"))
|
|
| 13 |
- |
|
| 14 |
- mapping <- attr(treeview, "mapping") |
|
| 15 |
- if (is.null(mapping)) {
|
|
| 16 |
- stop("treeview is not an output of `gheatmap`...")
|
|
| 17 |
- } |
|
| 18 |
- |
|
| 19 |
- colnames(mapping) <- c("label", "x")
|
|
| 20 |
- if (by == "bottom") {
|
|
| 21 |
- mapping$y <- 0 |
|
| 22 |
- } else {
|
|
| 23 |
- mapping$y <- max(treeview$data$y) + 1 |
|
| 24 |
- } |
|
| 25 |
- return(mapping) |
|
| 26 |
-} |
|
| 27 |
- |
|
| 28 |
-##' multiple sequence alignment with phylogenetic tree |
|
| 29 |
-##' |
|
| 30 |
-##' |
|
| 31 |
-##' @title msaplot |
|
| 32 |
-##' @param p tree view |
|
| 33 |
-##' @param fasta fasta file, multiple sequence alignment |
|
| 34 |
-##' @param offset offset of MSA to tree |
|
| 35 |
-##' @param width total width of alignment, compare to width of tree |
|
| 36 |
-##' @param color color |
|
| 37 |
-##' @param window specific a slice to display |
|
| 38 |
-##' @return tree view |
|
| 39 |
-##' @export |
|
| 40 |
-##' @importFrom Biostrings readBStringSet |
|
| 41 |
-##' @importMethodsFrom Biostrings width |
|
| 42 |
-## @importFrom colorspace rainbow_hcl |
|
| 43 |
-##' @importFrom ggplot2 geom_segment |
|
| 44 |
-##' @importFrom ggplot2 geom_rect |
|
| 45 |
-##' @importFrom ggplot2 scale_fill_manual |
|
| 46 |
-##' @author Guangchuang Yu |
|
| 47 |
-msaplot <- function(p, fasta, offset=0, width=1, color=NULL, window=NULL){
|
|
| 48 |
- if (missingArg(fasta)) {
|
|
| 49 |
- aln <- NULL |
|
| 50 |
- } else if (is(fasta, "BStringSet")) {
|
|
| 51 |
- aln <- fasta |
|
| 52 |
- } else if (is(fasta, "character")) {
|
|
| 53 |
- aln <- readBStringSet(fasta) |
|
| 54 |
- } else {
|
|
| 55 |
- aln <- NULL |
|
| 56 |
- } |
|
| 57 |
- |
|
| 58 |
- if (is(p, "phylip")) {
|
|
| 59 |
- aln <- p@sequence |
|
| 60 |
- p <- ggtree(p) + geom_tiplab() |
|
| 61 |
- } |
|
| 62 |
- |
|
| 63 |
- if (is.null(aln)) {
|
|
| 64 |
- stop("multiple sequence alignment is not available...\n-> check the parameter 'fasta'...")
|
|
| 65 |
- } |
|
| 66 |
- |
|
| 67 |
- if (is.null(window)) {
|
|
| 68 |
- window <- c(1, width(aln)[1]) |
|
| 69 |
- } |
|
| 70 |
- slice <- seq(window[1], window[2], by=1) |
|
| 71 |
- |
|
| 72 |
- seqs <- lapply(1:length(aln), function(i) {
|
|
| 73 |
- x <- toString(aln[i]) |
|
| 74 |
- seq <- substring(x, slice, slice) |
|
| 75 |
- |
|
| 76 |
- seq[seq == '?'] <- '-' |
|
| 77 |
- seq[seq == '*'] <- '-' |
|
| 78 |
- seq[seq == ' '] <- '-' |
|
| 79 |
- return(seq) |
|
| 80 |
- }) |
|
| 81 |
- names(seqs) <- names(aln) |
|
| 82 |
- |
|
| 83 |
- if(is.null(color)) {
|
|
| 84 |
- alphabet <- unlist(seqs) %>% unique |
|
| 85 |
- alphabet <- alphabet[alphabet != '-'] |
|
| 86 |
- ## color <- rainbow_hcl(length(alphabet)) |
|
| 87 |
- color <- getCols(length(alphabet)) |
|
| 88 |
- names(color) <- alphabet |
|
| 89 |
- color <- c(color, '-'=NA) |
|
| 90 |
- } |
|
| 91 |
- |
|
| 92 |
- df <- p$data |
|
| 93 |
- ## if (is.null(width)) {
|
|
| 94 |
- ## width <- (df$x %>% range %>% diff)/500 |
|
| 95 |
- ## } |
|
| 96 |
- |
|
| 97 |
- ## convert width to width of each cell |
|
| 98 |
- width <- width * (df$x %>% range %>% diff) / diff(window) |
|
| 99 |
- |
|
| 100 |
- df=df[df$isTip,] |
|
| 101 |
- start <- max(df$x) * 1.02 + offset |
|
| 102 |
- |
|
| 103 |
- seqs <- seqs[df$label[order(df$y)]] |
|
| 104 |
- ## seqs.df <- do.call("rbind", seqs)
|
|
| 105 |
- |
|
| 106 |
- h <- ceiling(diff(range(df$y))/length(df$y)) |
|
| 107 |
- xmax <- start + seq_along(slice) * width |
|
| 108 |
- xmin <- xmax - width |
|
| 109 |
- y <- sort(df$y) |
|
| 110 |
- ymin <- y - 0.4 *h |
|
| 111 |
- ymax <- y + 0.4 *h |
|
| 112 |
- |
|
| 113 |
- from <- to <- NULL |
|
| 114 |
- |
|
| 115 |
- lines.df <- data.frame(from=min(xmin), to=max(xmax), y = y) |
|
| 116 |
- |
|
| 117 |
- p <- p + geom_segment(data=lines.df, aes(x=from, xend=to, y=y, yend=y)) |
|
| 118 |
- msa <- lapply(1:length(y), function(i) {
|
|
| 119 |
- data.frame(name=names(seqs)[i], |
|
| 120 |
- xmin=xmin, |
|
| 121 |
- xmax=xmax, |
|
| 122 |
- ymin=ymin[i], |
|
| 123 |
- ymax=ymax[i], |
|
| 124 |
- seq=seqs[[i]]) |
|
| 125 |
- }) |
|
| 126 |
- |
|
| 127 |
- msa.df <- do.call("rbind", msa)
|
|
| 128 |
- |
|
| 129 |
- p <- p + geom_rect(data=msa.df, aes(x=xmin, y=ymin, |
|
| 130 |
- xmin=xmin, xmax=xmax, |
|
| 131 |
- ymin=ymin, ymax=ymax, fill=seq)) + |
|
| 132 |
- scale_fill_manual(values=color) |
|
| 133 |
- |
|
| 134 |
- breaks <- hist(seq_along(slice), breaks=10, plot=FALSE)$breaks |
|
| 135 |
- pos <- start + breaks * width |
|
| 136 |
- mapping <- data.frame(from=breaks+1, to=pos) |
|
| 137 |
- attr(p, "mapping") <- mapping |
|
| 138 |
- |
|
| 139 |
- return(p) |
|
| 140 |
-} |
|
| 141 |
- |
|
| 142 |
-##' scale x for tree with heatmap |
|
| 143 |
-##' |
|
| 144 |
-##' |
|
| 145 |
-##' @title scale_x_ggtree |
|
| 146 |
-##' @param tree_view tree view |
|
| 147 |
-##' @param breaks breaks for tree |
|
| 148 |
-##' @param labels lables for corresponding breaks |
|
| 149 |
-##' @return tree view |
|
| 150 |
-##' @importFrom ggplot2 scale_x_continuous |
|
| 151 |
-##' @importFrom ggplot2 scale_x_date |
|
| 152 |
-##' @export |
|
| 153 |
-##' @author Guangchuang Yu |
|
| 154 |
-scale_x_ggtree <- function(tree_view, breaks=NULL, labels=NULL) {
|
|
| 155 |
- p <- get_tree_view(tree_view) |
|
| 156 |
- |
|
| 157 |
- mrsd <- attr(p, "mrsd") |
|
| 158 |
- if (!is.null(mrsd) && class(p$data$x) == "Date") {
|
|
| 159 |
- x <- Date2decimal(p$data$x) |
|
| 160 |
- } else {
|
|
| 161 |
- x <- p$data$x |
|
| 162 |
- } |
|
| 163 |
- |
|
| 164 |
- if (is.null(breaks)) {
|
|
| 165 |
- breaks <- hist(x, breaks=5, plot=FALSE)$breaks |
|
| 166 |
- } |
|
| 167 |
- m <- attr(p, "mapping") |
|
| 168 |
- |
|
| 169 |
- if (!is.null(mrsd) &&class(m$to) == "Date") {
|
|
| 170 |
- to <- Date2decimal(m$to) |
|
| 171 |
- } else {
|
|
| 172 |
- to <- m$to |
|
| 173 |
- } |
|
| 174 |
- |
|
| 175 |
- idx <- which(sapply(breaks, function(x) any(x > m$to))) |
|
| 176 |
- if (length(idx)) {
|
|
| 177 |
- breaks <- breaks[-idx] |
|
| 178 |
- } |
|
| 179 |
- |
|
| 180 |
- if (is.null(labels)) {
|
|
| 181 |
- labels <- breaks |
|
| 182 |
- } |
|
| 183 |
- |
|
| 184 |
- breaks <- c(breaks, to) |
|
| 185 |
- labels <- c(labels, gsub("\\.", "", as.character(m$from)))
|
|
| 186 |
- |
|
| 187 |
- if (!is.null(mrsd) && class(p$data$x) == "Date") {
|
|
| 188 |
- p <- p + scale_x_date(breaks=decimal2Date(breaks), labels) |
|
| 189 |
- } else {
|
|
| 190 |
- p <- p + scale_x_continuous(breaks=breaks, labels=labels) |
|
| 191 |
- } |
|
| 192 |
- return(p) |
|
| 193 |
-} |
|
| 194 |
- |
|
| 195 |
- |
|
| 196 |
- |
|
| 197 |
-## ##' view tree and associated matrix |
|
| 198 |
-## ##' |
|
| 199 |
-## ##' @title gplot |
|
| 200 |
-## ##' @param p tree view |
|
| 201 |
-## ##' @param data matrix |
|
| 202 |
-## ##' @param low low color |
|
| 203 |
-## ##' @param high high color |
|
| 204 |
-## ##' @param widths widths of sub plot |
|
| 205 |
-## ##' @param color color |
|
| 206 |
-## ##' @param font.size font size |
|
| 207 |
-## ##' @return list of figure |
|
| 208 |
-## ##' @importFrom gridExtra grid.arrange |
|
| 209 |
-## ##' @importFrom ggplot2 scale_x_continuous |
|
| 210 |
-## ##' @importFrom ggplot2 scale_y_continuous |
|
| 211 |
-## ##' @export |
|
| 212 |
-## ##' @author Guangchuang Yu \url{http://ygc.name}
|
|
| 213 |
-## ##' @examples |
|
| 214 |
-## ##' nwk <- system.file("extdata", "sample.nwk", package="ggtree")
|
|
| 215 |
-## ##' tree <- read.tree(nwk) |
|
| 216 |
-## ##' p <- ggtree(tree) |
|
| 217 |
-## ##' d <- matrix(abs(rnorm(52)), ncol=4) |
|
| 218 |
-## ##' rownames(d) <- tree$tip.label |
|
| 219 |
-## ##' colnames(d) <- paste0("G", 1:4)
|
|
| 220 |
-## ##' gplot(p, d, low="green", high="red") |
|
| 221 |
-## gplot <- function(p, data, low="green", high="red", widths=c(0.5, 0.5), color="white", font.size=14) {
|
|
| 222 |
-## ## p <- p + scale_x_continuous(expand = c(0, 0)) + scale_y_continuous(expand = c(0, 0.6)) |
|
| 223 |
-## p1 <- p + scale_y_continuous(expand = c(0, 0.6)) |
|
| 224 |
-## ## p1 <- p + theme(panel.margin=unit(0, "null")) |
|
| 225 |
-## ## p1 <- p1 + theme(plot.margin = unit(c(1, -1, 1.5, 1), "lines")) |
|
| 226 |
-## p2 <- gplot.heatmap(p, data, low, high, color, font.size) |
|
| 227 |
-## grid.arrange(p1, p2, ncol=2, widths=widths) |
|
| 228 |
-## invisible(list(p1=p1, p2=p2)) |
|
| 229 |
-## } |
|
| 230 |
- |
|
| 231 |
- |
|
| 232 |
-## ##' @importFrom grid unit |
|
| 233 |
-## ##' @importFrom ggplot2 scale_fill_gradient |
|
| 234 |
-## ##' @importFrom ggplot2 scale_fill_discrete |
|
| 235 |
-## ##' @importFrom ggplot2 element_text |
|
| 236 |
-## ##' @importFrom ggplot2 geom_tile |
|
| 237 |
-## ##' @importFrom ggplot2 labs |
|
| 238 |
-## ##' @importFrom ggplot2 guides |
|
| 239 |
-## ##' @importFrom ggplot2 guide_legend |
|
| 240 |
-## ##' @importFrom reshape2 melt |
|
| 241 |
-## gplot.heatmap <- function(p, data, low, high, color="white", font.size) {
|
|
| 242 |
-## isTip <- x <- Var1 <- Var2 <- value <- NULL |
|
| 243 |
-## dd=melt(as.matrix(data)) |
|
| 244 |
-## ## p <- ggtree(tree) ## + theme_tree2() |
|
| 245 |
-## ## p <- p + geom_text(aes(x = max(x)*1.1, label=label), subset=.(isTip), hjust=0) |
|
| 246 |
-## ## p <- p+geom_segment(aes(x=x*1.02, xend=max(x)*1.08, yend=y), subset=.(isTip), linetype="dashed", size=0.4) |
|
| 247 |
-## df=p$data |
|
| 248 |
-## df=df[df$isTip,] |
|
| 249 |
- |
|
| 250 |
-## dd$Var1 <- factor(dd$Var1, levels = df$label[order(df$y)]) |
|
| 251 |
-## if (any(dd$value == "")) {
|
|
| 252 |
-## dd$value[dd$value == ""] <- NA |
|
| 253 |
-## } |
|
| 254 |
- |
|
| 255 |
-## p2 <- ggplot(dd, aes(Var2, Var1, fill=value))+geom_tile(color=color) |
|
| 256 |
-## if (is(dd$value,"numeric")) {
|
|
| 257 |
-## p2 <- p2 + scale_fill_gradient(low=low, high=high, na.value="white") |
|
| 258 |
-## } else {
|
|
| 259 |
-## p2 <- p2 + scale_fill_discrete(na.value="white") |
|
| 260 |
-## } |
|
| 261 |
- |
|
| 262 |
-## p2 <- p2+xlab("")+ylab("")
|
|
| 263 |
-## p2 <- p2+theme_tree2() + theme(axis.ticks.x = element_blank(), |
|
| 264 |
-## axis.line.x=element_blank()) |
|
| 265 |
-## ## p1 <- p1 + theme(axis.text.x = element_text(size = font.size)) |
|
| 266 |
-## p2 <- p2 + theme(axis.ticks.margin = unit(0, "lines")) |
|
| 267 |
-## p2 <- p2 + theme(axis.text.x = element_text(size = font.size)) |
|
| 268 |
-## ## p2 <- p2 + theme(axis.text.y = element_text(size=font.size)) |
|
| 269 |
- |
|
| 270 |
-## ## plot.margin margin around entire plot (unit with the sizes of the top, right, bottom, and left margins) |
|
| 271 |
-## ## units can be given in "lines" or something more specific like "cm"... |
|
| 272 |
- |
|
| 273 |
- |
|
| 274 |
-## p2 <- p2 + theme(panel.margin=unit(0, "null")) |
|
| 275 |
-## p2 <- p2 + theme(plot.margin = unit(c(1, 1, .5, -0.5), "lines")) |
|
| 276 |
-## p2 <- p2 + theme(legend.position = "right") |
|
| 277 |
-## p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL))) |
|
| 278 |
-## ## p2 <- p2 + labs(fill="") |
|
| 279 |
- |
|
| 280 |
-## return(p2) |
|
| 281 |
-## } |
|
| 282 |
- |
|
| 283 |
- |
|
| 284 |
-coplot <- function(tree1, tree2, hjust=0) {
|
|
| 285 |
- x <- y <- label <- isTip <- tree <- NULL |
|
| 286 |
- dx <- fortify(tree1) |
|
| 287 |
- dx$tree <- "A" |
|
| 288 |
- |
|
| 289 |
- offset <- max(dx$x) * 1.3 |
|
| 290 |
- dy <- fortify(tree2) |
|
| 291 |
- dy <- reverse.treeview.data(dy) |
|
| 292 |
- dy$x <- dy$x + offset + hjust |
|
| 293 |
- dy$tree <- "B" |
|
| 294 |
- |
|
| 295 |
- dd <- rbind(dx, dy) |
|
| 296 |
- p <- ggplot(dd, aes(x, y)) + |
|
| 297 |
- geom_tree(layout="phylogram", subset=.(tree=="A")) + |
|
| 298 |
- geom_tree(layout="phylogram", subset=.(tree=="B")) + |
|
| 299 |
- theme_tree() |
|
| 300 |
- |
|
| 301 |
- p <- p + geom_text(aes(label=label), |
|
| 302 |
- subset=.(isTip & tree == "A"), |
|
| 303 |
- hjust=-offset/40) + |
|
| 304 |
- geom_text(aes(label=label), |
|
| 305 |
- subset=.(isTip & tree == "B"), |
|
| 306 |
- hjust = offset/20) |
|
| 307 |
- return(p) |
|
| 308 |
-} |
|
| 309 |
- |
|
| 310 |
- |
|
| 311 |
- |
|
| 312 |
- |
|
| 313 |
- |
|
| 314 |
- |
|
| 315 |
- |
| ... | ... |
@@ -48,14 +48,23 @@ |
| 48 | 48 |
} |
| 49 | 49 |
|
| 50 | 50 |
`%place%` <- function(pg, tree) {
|
| 51 |
- param <- attr(pg, "param") |
|
| 51 |
+ mrsd <- get("mrsd", envir=pg$plot_env)
|
|
| 52 |
+ layout <- get("layout", envir = pg$plot_env)
|
|
| 53 |
+ yscale <- get("yscale", envir = pg$plot_env)
|
|
| 54 |
+ ladderize <- get("ladderize", envir = pg$plot_env)
|
|
| 55 |
+ right <- get("right", envir = pg$plot_env)
|
|
| 56 |
+ branch.length <- get("branch.length", envir = pg$plot_env)
|
|
| 57 |
+ ndigits <- get("ndigits", envir = pg$plot_env)
|
|
| 58 |
+ |
|
| 59 |
+ |
|
| 52 | 60 |
pg$data <- fortify(tree, |
| 53 |
- layout = param[["layout"]], |
|
| 54 |
- yscale = param[["yscale"]], |
|
| 55 |
- ladderize = param[["ladderize"]], |
|
| 56 |
- right = param[["right"]], |
|
| 57 |
- branch.length = param[["branch.length"]], |
|
| 58 |
- ndigits = param[["ndigits"]]) |
|
| 61 |
+ layout = layout, |
|
| 62 |
+ yscale = yscale, |
|
| 63 |
+ ladderize = ladderize, |
|
| 64 |
+ right = right, |
|
| 65 |
+ branch.length = branch.length, |
|
| 66 |
+ ndigits = ndigits, |
|
| 67 |
+ mrsd = mrsd) |
|
| 59 | 68 |
return(pg) |
| 60 | 69 |
} |
| 61 | 70 |
|
| ... | ... |
@@ -1,3 +1,4 @@ |
| 1 |
+ |
|
| 1 | 2 |
##' @importFrom ggplot2 last_plot |
| 2 | 3 |
get_tree_view <- function(tree_view) {
|
| 3 | 4 |
if (is.null(tree_view)) |
| ... | ... |
@@ -460,7 +461,6 @@ roundDigit <- function(d) {
|
| 460 | 461 |
} |
| 461 | 462 |
|
| 462 | 463 |
|
| 463 |
- |
|
| 464 | 464 |
## from ChIPseeker |
| 465 | 465 |
##' @importFrom grDevices colorRampPalette |
| 466 | 466 |
getCols <- function (n) {
|