r 子树与ggtree的三角形https://jean.manguy.eu/post/subtrees-as-triangles-with-ggtree/

Posted 2021-05-23

get_offsprings <- function(node_to_collapse, phylo) {
  # todo: assert that node is scalar
  phylo %>%
    tidytree::as_data_frame() %>%
    tidytree::offspring(.node = node_to_collapse) %>%
    dplyr::pull(node)
}

get_offspring_tips <- function(phylo, node_to_collapse) {
  # todo: assert that node is scalar
  phylo %>%
    ggtree::fortify() %>%
    tidytree::offspring(.node = node_to_collapse) %>%
    dplyr::filter(isTip) %>%
    dplyr::pull(node)
}

remove_collapsed_nodes <- function(phylo, nodes_to_collapse) {
  nodes <- purrr::map(nodes_to_collapse, get_offsprings, phylo = phylo) %>% unlist()
  phylo %>%
    ggtree::fortify() %>%
    tibble::as_tibble() %>%
    dplyr::filter(!node %in% nodes)
}

get_collapsed_offspring_nodes_coordinates <- function(phylo, nodes) {
  phylo %>%
    ggtree::fortify() %>%
    tibble::as_tibble() %>%
    dplyr::filter(node %in% nodes) %>%
    dplyr::summarise(xmax = max(x), xmin = min(x), ymax = max(y), ymin = min(y))
}

get_collapsed_node_coordinates <- function(phylo, node_to_collapse) {
  # todo: assert that node is scalar
  phylo %>%
    ggtree::fortify() %>%
    tibble::as_tibble() %>%
    dplyr::filter(node == node_to_collapse) %>%
    dplyr::select(x, y)
}


get_triangle_coordinates_ <- function(node, phylo, mode = c("max", "min", "mixed")) {
  mode <- match.arg(mode)
  # for one
  tips_to_collapse <- get_offspring_tips(phylo, node)
  node_to_collapse_xy <- get_collapsed_node_coordinates(phylo, node)
  tips_to_collapse_xy <- get_collapsed_offspring_nodes_coordinates(phylo, tips_to_collapse)

  triange_df <- mode %>% switch(
    max = dplyr::data_frame(
      x = c(node_to_collapse_xy$x, tips_to_collapse_xy$xmax, tips_to_collapse_xy$xmax),
      y = c(node_to_collapse_xy$y, tips_to_collapse_xy$ymin, tips_to_collapse_xy$ymax)
    ),
    min = data_frame(
      x = c(node_to_collapse_xy$x, tips_to_collapse_xy$xmin, tips_to_collapse_xy$xmin),
      y = c(node_to_collapse_xy$y, tips_to_collapse_xy$ymin, tips_to_collapse_xy$ymax)
    ),
    mixed = data_frame(
      x = c(node_to_collapse_xy$x, tips_to_collapse_xy$xmin, tips_to_collapse_xy$xmax),
      y = c(node_to_collapse_xy$y, tips_to_collapse_xy$ymin, tips_to_collapse_xy$ymax)
    )
  )
  return(triange_df)
}

get_triangle_coordinates <- function(phylo, nodes, mode = c("max", "min", "mixed")) {
  mode <- match.arg(mode)
  # todo: make sure there is no conflict between nodes (nesting...)
  purrr::map(nodes, get_triangle_coordinates_, phylo = phylo, mode = mode) %>%
    dplyr::bind_rows(.id = "node_collapsed")
}

library(magrittr)
library(ggplot2)

set.seed(1234)
test_tree <- ape::rtree(20)

nodes_to_collapse <- c(26, 31, 34, 22)
collapsed_tree_df <- test_tree %>%
  remove_collapsed_nodes(nodes = nodes_to_collapse)

triangles_df <- test_tree %>%
  get_triangle_coordinates(nodes_to_collapse)

ggtree::ggtree(collapsed_tree_df) +
  geom_polygon(
    data = triangles_df,
    mapping = aes(group = node_collapsed, fill = node_collapsed),
    color = "#333333"
  ) +
  scale_fill_brewer(palette = "Set1") +
  theme(
    strip.background = element_blank()
  )

# R version 3.4.4 (2018-03-15)
# Platform: x86_64-pc-linux-gnu (64-bit)
# Running under: Linux Mint 18.3
# 
# Matrix products: default
# BLAS: /usr/lib/libblas/libblas.so.3.6.0
# LAPACK: /usr/lib/lapack/liblapack.so.3.6.0
# 
# locale:
# [1] LC_CTYPE=en_IE.UTF-8       LC_NUMERIC=C              
# [3] LC_TIME=en_IE.UTF-8        LC_COLLATE=en_IE.UTF-8    
# [5] LC_MONETARY=en_IE.UTF-8    LC_MESSAGES=en_IE.UTF-8   
# [7] LC_PAPER=en_IE.UTF-8       LC_NAME=C                 
# [9] LC_ADDRESS=C               LC_TELEPHONE=C            
# [11] LC_MEASUREMENT=en_IE.UTF-8 LC_IDENTIFICATION=C       
# 
# attached base packages:
# [1] stats     graphics  grDevices utils     datasets  methods  
# [7] base     
# 
# other attached packages:
# [1] bindrcpp_0.2.2     ggplot2_2.2.1.9000 magrittr_1.5      
# 
# loaded via a namespace (and not attached):
# [1] Rcpp_0.12.16           pillar_1.2.2          
# [3] compiler_3.4.4         RColorBrewer_1.1-2    
# [5] plyr_1.8.4             bindr_0.1.1           
# [7] prettyunits_1.0.2      progress_1.1.2.9003   
# [9] tools_3.4.4            jsonlite_1.5          
# [11] tidytree_0.1.8         tibble_1.4.2          
# [13] nlme_3.1-137           gtable_0.2.0          
# [15] ggtree_1.11.6          lattice_0.20-35       
# [17] pkgconfig_2.0.1        rlang_0.2.0.9001      
# [19] rstudioapi_0.7.0-9000  cli_1.0.0.9002        
# [21] rvcheck_0.0.9          yaml_2.1.18           
# [23] parallel_3.4.4         treeio_1.3.13         
# [25] xml2_1.2.0             stringr_1.3.0         
# [27] withr_2.1.2            dplyr_0.7.4           
# [29] styler_1.0.1           hms_0.4.2             
# [31] enc_0.2.0              grid_3.4.4            
# [33] glue_1.2.0             R6_2.2.2              
# [35] selectr_0.4-1          purrr_0.2.4           
# [37] tidyr_0.8.0            rematch2_2.0.1        
# [39] scales_0.5.0.9000      backports_1.1.2       
# [41] ansistrings_1.0.0.9000 assertthat_0.2.0      
# [43] ape_5.1                colorspace_1.3-2      
# [45] labeling_0.3           stringi_1.1.7         
# [47] lazyeval_0.2.1         munsell_0.4.3         
# [49] crayon_1.3.4