| cc06d22b |
##' annotate a clade with bar and text label
##'
|
| 102483c0 |
##'
|
| cc06d22b |
##' @title geom_cladelabel
##' @param node selected node
##' @param label clade label
##' @param offset offset of bar and text from the clade
##' @param offset.text offset of text from bar
##' @param align logical
##' @param barsize size of bar
##' @param fontsize size of text
##' @param angle angle of text
##' @param geom one of 'text' or 'label'
|
| af18d052 |
##' @param hjust hjust
|
| c1e35f48 |
##' @param color color for clade & label, of length 1 or 2
|
| cc06d22b |
##' @param fill fill label background, only work with geom='label'
|
| 49838f33 |
##' @param family sans by default, can be any supported font
|
| c1e35f48 |
##' @param parse logical, whether parse label
|
| cc06d22b |
##' @param ... additional parameter
##' @return ggplot layers
##' @export
##' @author Guangchuang Yu
geom_cladelabel <- function(node, label, offset=0, offset.text=0,
align=FALSE, barsize=0.5, fontsize=3.88,
|
| c1e35f48 |
angle=0, geom="text", hjust = 0,
color = NULL, fill=NA,
family="sans", parse=FALSE, ...) {
|
| cc06d22b |
mapping <- NULL
data <- NULL
position <- "identity"
show.legend <- NA
|
| e4ea056a |
na.rm <- TRUE
|
| cc06d22b |
inherit.aes <- FALSE
|
| c1e35f48 |
if (!is.null(color)) {
if (length(color) > 2) {
stop("color should be of length 1 or 2")
}
if (length(color) == 0) {
color = NULL
} else if (length(color) == 1) {
barcolor <- color
labelcolor <- color
} else {
barcolor <- color[1]
labelcolor <- color[2]
}
}
if (is.null(color)) {
if (geom == "text") {
## no fill parameter
layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
align=align, size=fontsize, angle=angle, family=family,
mapping=mapping, data=data, geom=geom, hjust=hjust,
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm, parse=parse, ...)
|
| 102483c0 |
|
| c1e35f48 |
} else {
layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
align=align, size=fontsize, angle=angle, fill=fill,family=family,
mapping=mapping, data=data, geom=geom, hjust=hjust,
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm,
parse = parse, ...)
}
layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
size=barsize,
|
| 102483c0 |
mapping=mapping, data=data,
|
| c1e35f48 |
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm, ...)
|
| cc06d22b |
} else {
|
| c1e35f48 |
if (geom == "text") {
## no fill parameter
layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
align=align, size=fontsize, angle=angle, color=labelcolor, family=family,
mapping=mapping, data=data, geom=geom, hjust=hjust,
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm, parse=parse, ...)
|
| 102483c0 |
|
| c1e35f48 |
} else {
layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
align=align, size=fontsize, angle=angle, color=labelcolor, fill=fill,family=family,
mapping=mapping, data=data, geom=geom, hjust=hjust,
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm,
parse = parse, ...)
}
layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
size=barsize, color = barcolor,
|
| 102483c0 |
mapping=mapping, data=data,
|
| c1e35f48 |
position=position, show.legend = show.legend,
inherit.aes = inherit.aes, na.rm=na.rm, ...)
|
| 102483c0 |
|
| cc06d22b |
}
|
| 102483c0 |
|
| cc06d22b |
list(
|
| c1e35f48 |
layer_bar,
layer_text
|
| cc06d22b |
)
}
stat_cladeText <- function(mapping=NULL, data=NULL,
geom="text", position="identity",
node, label, offset, align, ...,
|
| c1e35f48 |
show.legend=NA, inherit.aes=FALSE,
na.rm=FALSE, parse=FALSE) {
|
| cc06d22b |
default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent)
if (is.null(mapping)) {
mapping <- default_aes
} else {
mapping <- modifyList(mapping, default_aes)
}
|
| 102483c0 |
|
| cc06d22b |
layer(stat=StatCladeText,
data=data,
mapping=mapping,
geom=geom,
position=position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params=list(node=node,
|
| c1e35f48 |
label = label,
offset = offset,
align = align,
na.rm = na.rm,
parse = parse,
|
| bedefde1 |
...),
|
| da0f0f7f |
if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
|
| cc06d22b |
)
|
| 102483c0 |
|
| cc06d22b |
}
stat_cladeBar <- function(mapping=NULL, data=NULL,
geom="segment", position="identity",
node, offset, align, ...,
show.legend=NA, inherit.aes=FALSE, na.rm=FALSE) {
|
| c1e35f48 |
default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, xend=~x, yend=~y)
|
| cc06d22b |
if (is.null(mapping)) {
mapping <- default_aes
} else {
mapping <- modifyList(mapping, default_aes)
}
|
| 102483c0 |
|
| cc06d22b |
layer(stat=StatCladeBar,
data=data,
mapping=mapping,
geom=geom,
position=position,
show.legend = show.legend,
inherit.aes = inherit.aes,
params=list(node=node,
offset=offset,
align=align,
na.rm=na.rm,
|
| bedefde1 |
...),
|
| da0f0f7f |
if (packageVersion('ggplot2') > '2.1.0') check.aes = FALSE
|
| cc06d22b |
)
}
StatCladeText <- ggproto("StatCladeText", Stat,
compute_group = function(self, data, scales, params, node, label, offset, align) {
df <- get_cladelabel_position(data, node, offset, align, adjustRatio = 1.03)
df$y <- mean(c(df$y, df$yend))
df$label <- label
return(df)
},
required_aes = c("x", "y", "label")
)
|
| 102483c0 |
|
| cc06d22b |
StatCladeBar <- ggproto("StatCladBar", Stat,
compute_group = function(self, data, scales, params, node, offset, align) {
get_cladelabel_position(data, node, offset, align, adjustRatio=1.02)
},
required_aes = c("x", "y", "xend", "yend")
)
get_cladelabel_position <- function(data, node, offset, align, adjustRatio) {
df <- get_cladelabel_position_(data, node)
if (align) {
|
| e4ea056a |
mx <- max(data$x, na.rm=TRUE)
|
| cc06d22b |
} else {
mx <- df$x
}
mx <- mx * adjustRatio + offset
data.frame(x=mx, xend=mx, y=df$y, yend=df$yend)
}
get_cladelabel_position_ <- function(data, node) {
sp <- get.offspring.df(data, node)
|
| e4ea056a |
sp2 <- c(sp, node)
sp.df <- data[match(sp2, data$node),]
|
| cc06d22b |
y <- sp.df$y
|
| e4ea056a |
y <- y[!is.na(y)]
|
| 102483c0 |
mx <- max(sp.df$x, na.rm=TRUE)
|
| cc06d22b |
data.frame(x=mx, y=min(y), yend=max(y))
}
|
