| 90df068e |
##' add tree layer
##'
|
| 4edbfa25 |
##'
|
| 90df068e |
##' @title geom_tree
##' @param mapping aesthetic mapping
##' @param data data
|
| e9896b76 |
##' @param layout one of 'rectangular', 'slanted', 'circular', 'radial', 'equal_angle' or 'daylight'
|
| 90df068e |
##' @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",
|
| aeda44db |
layout=layout, multiPhylo=multiPhylo, ...)
|
| 90df068e |
}
stat_tree <- function(mapping=NULL, data=NULL, geom="segment", position="identity",
layout="rectangular", multiPhylo=FALSE, lineend="round", ...,
|
| aeda44db |
show.legend=NA, inherit.aes=TRUE, na.rm=TRUE, check.param=TRUE) {
|
| 4edbfa25 |
|
| 90df068e |
default_aes <- aes_(x=~x, y=~y,node=~node, parent=~parent)
if (multiPhylo) {
default_aes <- modifyList(default_aes, aes_(.id=~.id))
}
|
| 4edbfa25 |
|
| 90df068e |
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,
|
| a92aaed1 |
...),
|
| fad06b2b |
check.aes = FALSE
|
| 90df068e |
),
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,
|
| a92aaed1 |
...),
|
| fad06b2b |
check.aes = FALSE
|
| 90df068e |
)
)
|
| e9896b76 |
} else if (layout %in% c("slanted", "radial", "equal_angle", "daylight")) {
|
| 90df068e |
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,
|
| a92aaed1 |
...),
|
| fad06b2b |
check.aes = FALSE
|
| 90df068e |
)
|
| 4edbfa25 |
}
|
| 90df068e |
}
StatTreeHorizontal <- ggproto("StatTreeHorizontal", Stat,
required_aes = c("node", "parent", "x", "y"),
|
| 4edbfa25 |
compute_group = function(data, params) {
data
},
|
| 90df068e |
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)
}
|
| 4edbfa25 |
|
| 90df068e |
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"),
|
| 4edbfa25 |
compute_group = function(data, params) {
data
},
|
| 90df068e |
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"),
|
| 4edbfa25 |
compute_group = function(data, params) {
data
},
|
| 90df068e |
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)
|
| 4edbfa25 |
|
| 90df068e |
data[match(unique(data$node), data$node),]
## data[order(data$node, decreasing = FALSE), ]
}
##' add tree layer
##'
|
| 4edbfa25 |
##'
|
| 90df068e |
##' @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, ...),
|
| 4edbfa25 |
|
| 90df068e |
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, ...)
}
}
|
