admin/PlantAI-dev
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases 1 Wiki Activity
Files
7097ecdec5e75fa1e21cbfa2bb2a641f670d9e51
PlantAI-dev/scripts/combo_tree_motif_structure_domain.R
T

960 lines
32 KiB
R
Raw Normal View History

Initial commit: PlantAI-dev
2026-08-03 18:42:47 +08:00
#!/usr/bin/env Rscript
## =========================================================
## combo_tree_motif_structure_domain.R
## Panel A：Phylogenetic tree（含基因 ID）
## Panel B：Subfamily 竖线
## Panel C：Motif（按 XML 实际长度比例）
## Panel D：Gene structure（按 GFF3 实际长度比例，只画 CDS + UTR）
## Panel E：Domain（按蛋白长度 qlen 比例；来自 hmmscan domtblout）
##
## 底部：为 Panel C/D/E 各画一条“坐标尺”（motif 位置 / gene 坐标 / aa 位置）
##
## 用法:
## Rscript combo_tree_motif_structure_domain.R \
## <treefile> <subfamily_file> <meme_xml> <gff3_file> <domtblout_file> \
## [evalue_cutoff] [coverage_percent] [output_pdf]
##
## 说明:
## evalue_cutoff 默认 1e-5（按 i-Evalue 或 full E 过滤）
## coverage_percent 为可选，只有你提供时才启用 coverage 过滤
## （覆盖度 = (ali_to - ali_from + 1) / qlen）
## =========================================================
args <- commandArgs(trailingOnly = TRUE)
if (length(args) < 5) {
stop(
"用法:\n",
" Rscript combo_tree_motif_structure_domain.R \\\n",
" <treefile> <subfamily_file> <meme_xml> <gff3_file> <domtblout_file> \\\n",
" [evalue_cutoff] [coverage_percent] [output_pdf]\n\n",
call. = FALSE
)
}
treefile <- args[1]
subfamily_file <- args[2]
meme_xml <- args[3]
gff3_file <- args[4]
domtblout_file <- args[5]
## E-value 阈值（默认 1e-5）
if (length(args) >= 6 && nzchar(args[6])) {
e_cutoff <- suppressWarnings(as.numeric(args[6]))
if (is.na(e_cutoff)) e_cutoff <- 1e-5
} else {
e_cutoff <- 1e-5
}
## 覆盖度阈值（可选）：命令行用百分数，如 50 = 50%；不提供则不启用 coverage 过滤
if (length(args) >= 7 && nzchar(args[7])) {
tmp_cov <- suppressWarnings(as.numeric(args[7]))
if (is.na(tmp_cov) || tmp_cov <= 0) {
cov_cutoff <- NA_real_ # 非法或 <=0 表示不启用 coverage 过滤
} else {
cov_cutoff <- tmp_cov / 100
}
} else {
cov_cutoff <- NA_real_ # 默认不启用 coverage 过滤
}
## 输出 pdf 名称（可选）
if (length(args) >= 8 && nzchar(args[8])) {
output_pdf <- args[8]
} else {
prefix <- sub("\\.[^.]*$", "", treefile)
output_pdf <- paste0(prefix, ".tree_motif_structure_domain.pdf")
}
parse_panels <- function(panel_arg) {
allowed <- c("motif", "structure", "domain")
if (!nzchar(panel_arg)) return(allowed)
parts <- trimws(unlist(strsplit(panel_arg, "[,;]")))
parts <- parts[nzchar(parts)]
parts <- tolower(gsub(" ", "_", parts, fixed = TRUE))
parts[parts %in% c("motifs")] <- "motif"
parts[parts %in% c("gene_structure", "gene-structure", "genestructure")] <- "structure"
parts[parts %in% c("domains")] <- "domain"
if (any(parts == "all")) return(allowed)
bad <- setdiff(parts, allowed)
if (length(bad) > 0) {
stop("不支持的 combo panel: ", paste(bad, collapse = ", "), "; 可选: ", paste(allowed, collapse = ", "), call. = FALSE)
}
selected <- unique(parts)
if (length(selected) < 2) {
stop("combo 至少需要选择两个数据类型；单类型图请使用 motif/structure/domain 阶段已有结果。", call. = FALSE)
}
selected
}
selected_panels <- parse_panels(if (length(args) >= 9 && nzchar(args[9])) args[9] else "motif,structure,domain")
has_panel <- function(panel_name) panel_name %in% selected_panels
target_marker_species <- if (length(args) >= 10 && nzchar(args[10])) args[10] else ""
reference_marker_species <- if (length(args) >= 11 && nzchar(args[11])) args[11] else ""
classify_tip_role <- function(label) {
label <- as.character(label)
if (!nzchar(target_marker_species) && !nzchar(reference_marker_species)) return("gene")
if (nzchar(reference_marker_species)) {
# Support both normalized labels such as At|At1g01010 and native
# reference labels such as At1g01010 used in IQ-TREE outputs.
if (grepl(paste0("^", reference_marker_species, "\\|"), label) || grepl(paste0("^", reference_marker_species, "[0-9]"), label)) {
return("reference")
}
}
"target"
}
cat("树文件: ", treefile, "\n")
cat("亚家族文件: ", subfamily_file, "\n")
cat("MEME XML 文件: ", meme_xml, "\n")
cat("GFF3 文件: ", gff3_file, "\n")
cat("domtblout 文件: ", domtblout_file, "\n")
cat("E-value 阈值: ", e_cutoff, "\n")
if (is.na(cov_cutoff)) {
cat("覆盖度过滤: 未启用（仅按 E-value 过滤）\n")
} else {
cat("覆盖度阈值: ", cov_cutoff * 100, "%\n", sep = "")
}
cat("输出文件: ", output_pdf, "\n")
cat("展示 panel: ", paste(selected_panels, collapse = ", "), "\n\n")
## ===================== 2. 加载 R 包 =====================
script_args_all <- commandArgs(trailingOnly = FALSE)
script_file_arg <- grep("^--file=", script_args_all, value = TRUE)
script_dir <- if (length(script_file_arg) > 0) dirname(normalizePath(sub("^--file=", "", script_file_arg[1]))) else getwd()
source(file.path(script_dir, "subfamily_palette.R"))
suppressPackageStartupMessages({
library(ape)
library(ggtree)
library(tidytree)
library(dplyr)
library(RColorBrewer)
library(ggplot2)
library(xml2)
library(ggnewscale)
})
normalize_gene_id <- function(x) {
x <- as.character(x)
x <- sub("^[^|]+\\|", "", x)
repeat {
y <- sub("^(gene|transcript|CDS|mRNA)[:_]", "", x, ignore.case = TRUE)
if (identical(y, x)) break
x <- y
}
x <- sub("_[PT][0-9]+$", "", x, ignore.case = TRUE)
x <- sub("\\.[0-9]+$", "", x)
tolower(x)
}
make_distinct_cols <- function(n) {
if (n <= 0) return(character(0))
base <- c(
"#0072B2", "#D55E00", "#009E73", "#CC79A7", "#E69F00",
"#56B4E9", "#F0E442", "#000000", "#882255", "#44AA99",
"#AA4499", "#117733", "#332288", "#DDCC77", "#88CCEE"
)
if (n <= length(base)) return(base[seq_len(n)])
if (exists("hcl.colors", where = asNamespace("grDevices"), inherits = FALSE)) {
return(grDevices::hcl.colors(n, palette = "Dark 3"))
}
grDevices::colorRampPalette(base)(n)
}
## ===================== 3. 读亚家族文件 + 深色配色 =====================
add_confidence_labels <- function(subfam_df, subfamily_file) {
add_subfamily_confidence_labels(subfam_df, subfamily_file)
}
# 检查亚家族文件是否为 "NONE" 或不存在
has_subfamily <- subfamily_file != "NONE" && file.exists(subfamily_file)
if (has_subfamily) {
subfam <- read_subfamily_plot_table(subfamily_file)
subfam <- add_confidence_labels(subfam, subfamily_file)
subfam_levels <- sort(unique(subfam$subfamily))
n_subfam <- length(subfam_levels)
if (n_subfam == 0) {
warning("在亚家族文件中没有检测到任何 subfamily，将不显示亚家族")
has_subfamily <- FALSE
}
} else {
cat("[INFO] 未提供亚家族文件，将不显示亚家族\n")
# 创建空的 subfam 数据框
subfam <- data.frame(label = character(), subfamily = character(), low_confidence = logical(), display_label = character(), stringsAsFactors = FALSE)
subfam_levels <- character()
n_subfam <- 0
}
## 跨图一致的亚家族配色
if (n_subfam > 0) {
subfam_cols <- make_subfamily_cols(subfam_levels)
} else {
subfam_cols <- character()
}
## ===================== 4. 树绘图函数 =====================
plot_iqtree_by_subfamily <- function(treefile, subfam_df, subfam_cols, label_offset = 0.4) {
tree <- read.tree(treefile)
tree_df <- as_tibble(tree)
tree_df$isTip <- tree_df$node <= length(tree$tip.label)
tree_df <- dplyr::left_join(tree_df, subfam_df, by = "label")
tree_df$display_label <- ifelse(is.na(tree_df$display_label), tree_df$label, tree_df$display_label)
tree_df$tip_role <- ifelse(tree_df$isTip, vapply(tree_df$label, classify_tip_role, character(1)), NA_character_)
tree_df$support <- ifelse(
tree_df$isTip,
NA_real_,
suppressWarnings(as.numeric(tree_df$label))
)
p <- ggtree(tree, branch.length = "none") %<+% tree_df +
## bootstrap
geom_nodepoint(
aes(fill = cut(support, c(0, 50, 75, 100))),
shape = 21,
size = 2,
na.rm = TRUE
) +
scale_fill_manual(
values = c("black", "grey40", "grey80"),
guide = "legend",
name = "Bootstrap Percentage (BP)",
breaks = c("(75,100]", "(50,75]", "(0,50]"),
labels = expression(BP > 75,
50 < BP * "<=75",
BP <= 50)
) +
geom_text2(
aes(label = ifelse(!isTip & !is.na(support), round(support), "")),
hjust = -0.2, vjust = -0.4, size = 2.2,
na.rm = TRUE, show.legend = FALSE
) +
## tip 颜色 = subfamily
geom_tippoint(
aes(color = subfamily, shape = tip_role),
size = 2,
na.rm = TRUE
) +
scale_color_manual(
values = subfam_cols,
name = "Subfamily"
) +
scale_shape_manual(
values = c(target = 17, reference = 16, gene = 16),
breaks = c("target", "reference"),
labels = c("Target", "Reference"),
name = "Species role",
na.translate = FALSE
) +
## 基因 ID 标签
geom_tiplab(aes(label = display_label), offset = label_offset, size = 3, hjust = 0) +
ggtitle(NULL) +
theme_tree() +
theme(
legend.background = element_rect(color = "#969696",
fill = "#d9d9d9")
)
attr(p, "label_offset") <- label_offset
return(p)
}
## ===================== 5. 解析 MEME XML =====================
parse_meme_xml <- function(meme_file) {
doc <- xml2::read_xml(meme_file)
## 所有序列的 id/name/length
seq_nodes <- xml2::xml_find_all(doc, ".//sequence")
seq_ids <- xml2::xml_attr(seq_nodes, "id")
seq_names <- xml2::xml_attr(seq_nodes, "name")
## 兼容 length / Length 大小写
seq_lengths <- xml2::xml_attr(seq_nodes, "length")
if (any(is.na(seq_lengths))) {
seq_lengths2 <- xml2::xml_attr(seq_nodes, "Length")
idx <- which(is.na(seq_lengths) & !is.na(seq_lengths2))
seq_lengths[idx] <- seq_lengths2[idx]
}
seq_lengths <- suppressWarnings(as.numeric(seq_lengths))
name_map <- setNames(seq_names, seq_ids) # id -> gene
length_map <- setNames(seq_lengths, seq_names) # gene -> seqlen
motif_nodes <- xml2::xml_find_all(doc, ".//motif")
site_list <- list()
motif_index <- 1L
for (m in motif_nodes) {
motif_id <- xml2::xml_attr(m, "id")
if (is.na(motif_id) || motif_id == "") {
motif_id <- xml2::xml_attr(m, "name")
}
if (is.na(motif_id) || motif_id == "") {
motif_id <- paste0("Motif_", motif_index)
}
motif_width <- xml2::xml_attr(m, "width")
motif_width <- suppressWarnings(as.numeric(motif_width))
if (is.na(motif_width)) motif_width <- 10
sites <- xml2::xml_find_all(m, ".//contributing_site")
if (length(sites) == 0) next
seq_id <- xml2::xml_attr(sites, "sequence_id")
start <- xml2::xml_attr(sites, "position")
start <- suppressWarnings(as.numeric(start))
width <- rep(motif_width, length(sites))
df <- data.frame(
seq_id = seq_id,
start = start,
width = width,
motif = motif_id,
stringsAsFactors = FALSE
)
site_list[[length(site_list) + 1L]] <- df
motif_index <- motif_index + 1L
}
if (length(site_list) == 0) {
stop("在 MEME XML 中没有找到任何 motif site，请检查文件或 XML 结构。", call. = FALSE)
}
sites <- dplyr::bind_rows(site_list)
## 序列名 & 序列长度来自 XML 中的 sequence 区
sites$gene <- unname(name_map[sites$seq_id])
sites$seqlen <- length_map[sites$gene]
## motif 终点坐标
sites$end <- sites$start + sites$width - 1
sites
}
## ===================== 6. 解析 GFF3（基因结构） =====================
parse_gff3_gene_structure <- function(gff3_file, tree_genes) {
tree_lookup <- setNames(tree_genes, normalize_gene_id(tree_genes))
gff <- read.table(gff3_file,
sep = "\t",
comment.char = "#",
quote = "",
stringsAsFactors = FALSE,
fill = TRUE)
if (ncol(gff) < 9) {
stop("GFF3 文件列数不足 9 列，请检查格式。", call. = FALSE)
}
colnames(gff)[1:9] <- c("seqid", "source", "type", "start",
"end", "score", "strand", "phase",
"attributes")
gff$start <- as.numeric(gff$start)
gff$end <- as.numeric(gff$end)
## 只保留关心的 feature 类型
feat_types <- c("exon", "CDS", "UTR",
"five_prime_UTR", "three_prime_UTR",
"5UTR", "3UTR")
feat_df <- gff[gff$type %in% feat_types, ]
if (nrow(feat_df) == 0) {
stop("在 GFF3 中没有找到 exon/CDS/UTR 等特征。", call. = FALSE)
}
## 解析 attributes 里的 Parent=...
get_attr <- function(attr_vec, key) {
sapply(strsplit(attr_vec, ";"), function(fields) {
kv <- strsplit(fields, "=")
res <- NA_character_
for (p in kv) {
if (length(p) == 2 && p[1] == key) {
res <- p[2]
break
}
}
res
})
}
## NCBI/Gnomon GFF3 often stores mRNA/CDS IDs as XP_* protein accessions,
## while the tree tips are XM_* transcript accessions in Name/transcript_id.
## Build an ID -> tree-tip alias map from mRNA rows before matching features.
mrna_df <- gff[tolower(gff$type) %in% c("mrna", "transcript"), ]
transcript_alias <- character(0)
if (nrow(mrna_df) > 0) {
mrna_id <- get_attr(mrna_df$attributes, "ID")
mrna_name <- get_attr(mrna_df$attributes, "Name")
mrna_tx <- get_attr(mrna_df$attributes, "transcript_id")
mrna_gene <- get_attr(mrna_df$attributes, "gene")
for (i in seq_len(nrow(mrna_df))) {
candidates <- c(mrna_name[i], mrna_tx[i], mrna_id[i], mrna_gene[i])
candidates <- candidates[!is.na(candidates) & nzchar(candidates)]
target <- NA_character_
for (cand in candidates) {
key <- normalize_gene_id(cand)
if (key %in% names(tree_lookup)) {
target <- unname(tree_lookup[key])
break
}
}
if (!is.na(target) && !is.na(mrna_id[i]) && nzchar(mrna_id[i])) {
transcript_alias[mrna_id[i]] <- target
}
}
}
feat_df$Parent <- get_attr(feat_df$attributes, "Parent")
feat_df$Parent_resolved <- ifelse(!is.na(feat_df$Parent) & feat_df$Parent %in% names(transcript_alias),
unname(transcript_alias[feat_df$Parent]),
feat_df$Parent)
feat_df$Parent_key <- normalize_gene_id(feat_df$Parent_resolved)
## 只保留 Parent/别名 出现在树 tip.label 的转录本
feat_df <- feat_df[!is.na(feat_df$Parent_resolved) &
feat_df$Parent_key %in% names(tree_lookup), ]
if (nrow(feat_df) == 0) {
stop("GFF3 中的 Parent 与树 tip.label 无交集，请检查 ID 是否一致。", call. = FALSE)
}
feat_df$gene <- unname(tree_lookup[feat_df$Parent_key])
## 每个 gene 的基因区域：真实 genomic 坐标范围
gene_ranges <- feat_df %>%
dplyr::group_by(gene) %>%
dplyr::summarise(
gene_start = min(start, end, na.rm = TRUE),
gene_end = max(start, end, na.rm = TRUE),
gene_len = gene_end - gene_start + 1,
.groups = "drop"
)
## 特征相对该基因起点的坐标
feat_df <- feat_df %>%
dplyr::left_join(gene_ranges, by = "gene") %>%
dplyr::mutate(
rel_start = pmin(start, end) - gene_start,
rel_end = pmax(start, end) - gene_start
) %>%
dplyr::mutate(
Type = dplyr::case_when(
type %in% c("five_prime_UTR", "three_prime_UTR",
"5UTR", "3UTR", "UTR") ~ "UTR",
TRUE ~ type
)
)
list(features = feat_df, ranges = gene_ranges)
}
## ===================== 7. 解析 domtblout（domain） =====================
parse_domtblout <- function(domtbl_file, e_cutoff = 1e-5,
cov_cutoff = NA_real_, tree_genes = NULL) {
dom <- read.table(domtbl_file,
header = FALSE,
comment.char = "#",
stringsAsFactors = FALSE,
fill = TRUE)
if (ncol(dom) < 22) {
stop("domtblout 文件列数少于 22 列，请检查 hmmscan 输出是否为 --domtblout 格式。", call. = FALSE)
}
## HMMER3 domtblout 固定前 22 列
colnames(dom)[1:22] <- c(
"target_name", "t_accession", "tlen",
"query_name", "q_accession", "qlen",
"E_full", "score_full", "bias_full",
"dom_index", "dom_of",
"c_Evalue", "i_Evalue", "dom_score", "dom_bias",
"hmm_from", "hmm_to",
"ali_from", "ali_to",
"env_from", "env_to",
"acc"
)
## 余下列合并为 description
if (ncol(dom) > 22) {
desc_cols <- dom[, 23:ncol(dom), drop = FALSE]
dom$description <- apply(desc_cols, 1, function(x) paste(x, collapse = " "))
} else {
dom$description <- NA_character_
}
## 转成数值
num_cols <- c(
"tlen", "qlen",
"E_full", "score_full", "bias_full",
"dom_index", "dom_of",
"c_Evalue", "i_Evalue", "dom_score", "dom_bias",
"hmm_from", "hmm_to",
"ali_from", "ali_to",
"env_from", "env_to",
"acc"
)
for (cn in intersect(num_cols, colnames(dom))) {
dom[[cn]] <- suppressWarnings(as.numeric(dom[[cn]]))
}
## 只保留树上的基因（若指定）
if (!is.null(tree_genes)) {
tree_lookup <- setNames(tree_genes, normalize_gene_id(tree_genes))
dom$query_key <- normalize_gene_id(dom$query_name)
dom <- dom[dom$query_key %in% names(tree_lookup), , drop = FALSE]
if (nrow(dom) > 0) {
dom$query_name <- unname(tree_lookup[dom$query_key])
}
}
if (nrow(dom) == 0) {
warning("domtblout 中没有与树上的基因匹配的记录。")
return(dom)
}
## 计算 domain 覆盖度（按蛋白长度 qlen）
dom <- dom %>%
dplyr::mutate(
dom_len = ali_to - ali_from + 1,
cov = ifelse(is.na(qlen) | qlen <= 0, NA_real_, dom_len / qlen)
)
## 使用 i_Evalue 作为 domain 显著性（若不存在则退回 full E）
dom_e <- if ("i_Evalue" %in% colnames(dom)) dom$i_Evalue else dom$E_full
dom_filt <- dom %>%
dplyr::mutate(evalue = dom_e) %>%
dplyr::filter(!is.na(evalue), evalue <= e_cutoff)
## 只有在 cov_cutoff 非 NA 时才启用覆盖度过滤
if (!is.na(cov_cutoff)) {
dom_filt <- dom_filt %>%
dplyr::filter(is.na(cov) | cov >= cov_cutoff)
}
if (nrow(dom_filt) == 0) {
warning("在 domtblout 中按 E-value/coverage 筛选后没有 domain 命中。")
}
dom_filt
}
## ===================== 8. 底部坐标轴辅助函数 =====================
make_axis_df <- function(max_len, scale_val, x_left, axis_y, n_breaks = 5) {
empty_line <- data.frame(x = numeric(0), xend = numeric(0),
y = numeric(0), yend = numeric(0))
empty_labels <- data.frame(x = numeric(0), y = numeric(0),
label = character(0))
if (!is.finite(max_len) || max_len <= 0 ||
!is.finite(scale_val) || scale_val <= 0) {
return(list(line = empty_line, ticks = empty_line, labels = empty_labels))
}
brks <- pretty(c(0, max_len), n = n_breaks)
brks <- brks[brks >= 0 & brks <= max_len]
line_df <- data.frame(
x = x_left,
xend = x_left + max_len * scale_val,
y = axis_y,
yend = axis_y
)
ticks_df <- data.frame(
x = x_left + brks * scale_val,
xend = x_left + brks * scale_val,
y = axis_y,
yend = axis_y + 0.2
)
labels_df <- data.frame(
x = x_left + brks * scale_val,
y = axis_y - 0.3,
label = as.integer(brks)
)
list(line = line_df, ticks = ticks_df, labels = labels_df)
}
## ===================== 9. 画树 & 基本坐标信息 =====================
label_offset <- 0.4
p_tree <- plot_iqtree_by_subfamily(treefile, subfam, subfam_cols,
label_offset = label_offset)
tree_dat <- p_tree$data
tip_dat <- tree_dat %>%
dplyr::filter(isTip) %>%
dplyr::select(label, x, y, subfamily)
if (nrow(tip_dat) == 0) {
stop("树中没有 tip 节点，请检查 treefile。", call. = FALSE)
}
x_tree_min <- min(tree_dat$x, na.rm = TRUE)
x_tip_max <- max(tip_dat$x, na.rm = TRUE)
max_y <- max(tree_dat$y, na.rm = TRUE)
min_y <- min(tree_dat$y, na.rm = TRUE)
axis_y <- min_y - 1.5
tree_core_width <- x_tip_max - x_tree_min
if (!is.finite(tree_core_width) || tree_core_width <= 0) {
stop("树的宽度计算异常，请检查 treefile。", call. = FALSE)
}
x_label_left <- x_tip_max + label_offset
label_panel_width <- max(1.5, tree_core_width * 0.6)
x_A_left <- x_tree_min
x_A_right <- x_label_left + label_panel_width
tip_lookup <- setNames(tip_dat$label, normalize_gene_id(tip_dat$label))
empty_axis <- make_axis_df(NA_real_, NA_real_, NA_real_, axis_y)
## ===================== 10. 按需解析 panel 数据 =====================
if (has_panel("motif")) {
if (meme_xml == "NONE" || !file.exists(meme_xml)) {
stop("已选择 motif panel，但 MEME XML 不存在。", call. = FALSE)
}
motif_sites <- parse_meme_xml(meme_xml)
motif_sites <- motif_sites %>%
dplyr::filter(!is.na(gene)) %>%
dplyr::mutate(gene_key = normalize_gene_id(gene)) %>%
dplyr::filter(gene_key %in% names(tip_lookup)) %>%
dplyr::mutate(gene = unname(tip_lookup[gene_key])) %>%
dplyr::left_join(tip_dat, by = c("gene" = "label")) %>%
dplyr::filter(!is.na(seqlen), !is.na(y))
if (nrow(motif_sites) == 0) {
stop("在 MEME 结果中没有找到与树 tip.label 匹配的基因。", call. = FALSE)
}
cat("motif 序列长度范围 (XML): ",
min(motif_sites$seqlen, na.rm = TRUE), " ~ ",
max(motif_sites$seqlen, na.rm = TRUE), "\n")
motif_levels <- sort(unique(motif_sites$motif))
motif_cols <- setNames(make_distinct_cols(length(motif_levels)), motif_levels)
motif_sites$motif <- factor(motif_sites$motif, levels = motif_levels)
} else {
motif_sites <- data.frame()
motif_cols <- character()
}
if (has_panel("structure")) {
if (gff3_file == "NONE" || !file.exists(gff3_file)) {
stop("已选择 structure panel，但 GFF3 文件不存在。", call. = FALSE)
}
gs <- parse_gff3_gene_structure(gff3_file, tip_dat$label)
gene_feat <- gs$features
gene_ranges <- gs$ranges
gene_ranges <- gene_ranges %>%
dplyr::left_join(tip_dat, by = c("gene" = "label")) %>%
dplyr::filter(!is.na(y))
gene_feat <- gene_feat %>%
dplyr::left_join(tip_dat, by = c("gene" = "label")) %>%
dplyr::filter(!is.na(y))
if (nrow(gene_feat) == 0) {
stop("GFF3 中匹配到树 tip.label 的基因结构为空。", call. = FALSE)
}
cat("基因长度范围 (GFF3): ",
min(gene_ranges$gene_len, na.rm = TRUE), " ~ ",
max(gene_ranges$gene_len, na.rm = TRUE), "\n")
} else {
gene_feat <- data.frame()
gene_ranges <- data.frame()
}
if (has_panel("domain")) {
if (domtblout_file == "NONE" || !file.exists(domtblout_file)) {
stop("已选择 domain panel，但 domtblout 文件不存在。", call. = FALSE)
}
domain_hits <- parse_domtblout(domtblout_file,
e_cutoff = e_cutoff,
cov_cutoff = cov_cutoff,
tree_genes = tip_dat$label)
domain_hits <- domain_hits %>%
dplyr::left_join(tip_dat, by = c("query_name" = "label")) %>%
dplyr::filter(!is.na(y))
if (nrow(domain_hits) > 0) {
cat("蛋白长度范围 (domtblout qlen): ",
min(domain_hits$qlen, na.rm = TRUE), " ~ ",
max(domain_hits$qlen, na.rm = TRUE), "\n")
} else {
cat("注意：筛选后没有任何 domain 命中，将不会绘制 domain 命中矩形。\n")
}
} else {
domain_hits <- data.frame()
}
## ===================== 11. 动态 X 布局 =====================
gap <- max(0.3, tree_core_width * 0.10)
r_B <- 0.6
panel_ratio <- c(motif = 2.0, structure = 2.8, domain = 2.0)
panel_label <- c(motif = "Motif", structure = "Gene structure", domain = "Domain")
x_B_left <- x_A_right + gap
width_B <- tree_core_width * r_B
x_B_right <- x_B_left + width_B
x_subfam <- (x_B_left + x_B_right) / 2
panel_layout <- data.frame(
panel = character(), x_left = numeric(), x_right = numeric(), width = numeric(), label = character(),
stringsAsFactors = FALSE
)
cursor <- x_B_right
for (panel_name in selected_panels) {
width <- tree_core_width * panel_ratio[[panel_name]]
x_left <- cursor + gap
x_right <- x_left + width
panel_layout <- rbind(panel_layout, data.frame(
panel = panel_name,
x_left = x_left,
x_right = x_right,
width = width,
label = panel_label[[panel_name]],
stringsAsFactors = FALSE
))
cursor <- x_right
}
panel_left <- function(panel_name) panel_layout$x_left[match(panel_name, panel_layout$panel)]
panel_width <- function(panel_name) panel_layout$width[match(panel_name, panel_layout$panel)]
panel_right <- function(panel_name) panel_layout$x_right[match(panel_name, panel_layout$panel)]
x_plot_right <- if (nrow(panel_layout) > 0) max(panel_layout$x_right) else x_B_right
## ===================== 12. panel 坐标计算 =====================
if (has_panel("motif")) {
x_C_left <- panel_left("motif")
width_C <- panel_width("motif")
max_len_motif <- max(motif_sites$seqlen, na.rm = TRUE)
scale_motif <- width_C / max_len_motif
cat("最长 motif 序列长度: ", max_len_motif,
"；motif 面板宽度: ", width_C,
"；scale_motif: ", scale_motif, "\n")
motif_gene_tracks <- motif_sites %>%
dplyr::distinct(gene, y, seqlen) %>%
dplyr::mutate(
x_gene_start = x_C_left,
x_gene_end = x_C_left + seqlen * scale_motif
)
motif_rect <- motif_sites %>%
dplyr::mutate(
xmin = x_C_left + (start - 1) * scale_motif,
xmax = x_C_left + end * scale_motif,
ymin = y - 0.25,
ymax = y + 0.25
)
motif_axis <- make_axis_df(max_len_motif, scale_motif, x_C_left, axis_y)
} else {
motif_gene_tracks <- data.frame()
motif_rect <- data.frame()
motif_axis <- empty_axis
}
if (has_panel("structure")) {
x_D_left <- panel_left("structure")
width_D <- panel_width("structure")
max_gene_len <- max(gene_ranges$gene_len, na.rm = TRUE)
scale_gene <- width_D / max_gene_len
cat("最长基因长度: ", max_gene_len,
"；gene 面板宽度: ", width_D,
"；scale_gene: ", scale_gene, "\n")
gene_tracks <- gene_ranges %>%
dplyr::mutate(
x_gene_start = x_D_left,
x_gene_end = x_D_left + gene_len * scale_gene
)
gene_feat_rect <- gene_feat %>%
dplyr::mutate(
xmin = x_D_left + rel_start * scale_gene,
xmax = x_D_left + rel_end * scale_gene,
ymin = y - 0.25,
ymax = y + 0.25
) %>%
dplyr::filter(Type %in% c("CDS", "UTR"))
gene_palette <- c(CDS = "#1b9e77", UTR = "#d95f02")
gene_types <- sort(unique(gene_feat_rect$Type))
gene_cols_vec <- gene_palette[gene_types]
names(gene_cols_vec) <- gene_types
gene_axis <- make_axis_df(max_gene_len, scale_gene, x_D_left, axis_y)
} else {
gene_tracks <- data.frame()
gene_feat_rect <- data.frame()
gene_cols_vec <- character()
gene_axis <- empty_axis
}
if (has_panel("domain")) {
x_E_left <- panel_left("domain")
width_E <- panel_width("domain")
max_qlen <- NA_real_
scale_domain <- NA_real_
if (nrow(domain_hits) > 0) {
max_qlen <- max(domain_hits$qlen, na.rm = TRUE)
scale_domain <- width_E / max_qlen
cat("最长蛋白长度: ", max_qlen,
"；domain 面板宽度: ", width_E,
"；scale_domain: ", scale_domain, "\n")
domain_gene_tracks <- domain_hits %>%
dplyr::distinct(query_name, y, qlen) %>%
dplyr::mutate(
x_gene_start = x_E_left,
x_gene_end = x_E_left + qlen * scale_domain
)
domain_rect <- domain_hits %>%
dplyr::mutate(
xmin = x_E_left + (ali_from - 1) * scale_domain,
xmax = x_E_left + ali_to * scale_domain,
ymin = y - 0.25,
ymax = y + 0.25
)
domain_levels <- sort(unique(domain_rect$target_name))
domain_cols <- setNames(make_distinct_cols(length(domain_levels)), domain_levels)
domain_rect$target_name <- factor(domain_rect$target_name, levels = domain_levels)
} else {
domain_gene_tracks <- data.frame()
domain_rect <- data.frame()
domain_cols <- character()
}
domain_axis <- make_axis_df(max_qlen, scale_domain, x_E_left, axis_y)
} else {
domain_gene_tracks <- data.frame()
domain_rect <- data.frame()
domain_cols <- character()
domain_axis <- empty_axis
}
subfam_ranges <- make_subfamily_ranges(tip_dat)
tree_header_x <- (x_A_left + x_A_right) / 2
header_y <- max_y + 1.2
## ===================== 13. 拼合整图 =====================
p_combo <- p_tree
if (has_panel("motif")) {
p_combo <- p_combo +
geom_segment(
data = motif_gene_tracks, inherit.aes = FALSE,
aes(x = x_gene_start, xend = x_gene_end, y = y, yend = y),
colour = "grey70", linewidth = 0.4
) +
ggnewscale::new_scale_fill() +
geom_rect(
data = motif_rect, inherit.aes = FALSE,
aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = motif),
color = NA
) +
scale_fill_manual(values = motif_cols, name = "Motif") +
geom_segment(data = motif_axis$line, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.4) +
geom_segment(data = motif_axis$ticks, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.3) +
geom_text(data = motif_axis$labels, inherit.aes = FALSE, aes(x = x, y = y, label = label), size = 2.5)
}
if (has_panel("structure")) {
p_combo <- p_combo +
geom_segment(
data = gene_tracks, inherit.aes = FALSE,
aes(x = x_gene_start, xend = x_gene_end, y = y, yend = y),
colour = "grey70", linewidth = 0.4
) +
ggnewscale::new_scale_fill() +
geom_rect(
data = gene_feat_rect, inherit.aes = FALSE,
aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = Type),
color = NA
) +
scale_fill_manual(values = gene_cols_vec, name = "Gene structure") +
geom_segment(data = gene_axis$line, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.4) +
geom_segment(data = gene_axis$ticks, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.3) +
geom_text(data = gene_axis$labels, inherit.aes = FALSE, aes(x = x, y = y, label = label), size = 2.5)
}
if (has_panel("domain") && nrow(domain_rect) > 0) {
p_combo <- p_combo +
geom_segment(
data = domain_gene_tracks, inherit.aes = FALSE,
aes(x = x_gene_start, xend = x_gene_end, y = y, yend = y),
colour = "grey70", linewidth = 0.4
) +
ggnewscale::new_scale_fill() +
geom_rect(
data = domain_rect, inherit.aes = FALSE,
aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = target_name),
color = NA
) +
scale_fill_manual(values = domain_cols, name = "Domain") +
geom_segment(data = domain_axis$line, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.4) +
geom_segment(data = domain_axis$ticks, inherit.aes = FALSE, aes(x = x, xend = xend, y = y, yend = yend), colour = "black", linewidth = 0.3) +
geom_text(data = domain_axis$labels, inherit.aes = FALSE, aes(x = x, y = y, label = label), size = 2.5)
}
p_combo <- p_combo +
geom_segment(
data = subfam_ranges, inherit.aes = FALSE,
aes(x = x_subfam, xend = x_subfam, y = ymin, yend = ymax, colour = subfamily),
linewidth = 1
) +
geom_text(
data = subfam_ranges, inherit.aes = FALSE,
aes(x = x_subfam + width_B * 0.05, y = ymid, label = subfamily, colour = subfamily),
hjust = 0, size = 3
) +
annotate("text", x = tree_header_x, y = header_y, label = "Phylogenetic tree", fontface = "bold", size = 4)
for (i in seq_len(nrow(panel_layout))) {
p_combo <- p_combo + annotate(
"text",
x = (panel_layout$x_left[i] + panel_layout$x_right[i]) / 2,
y = header_y,
label = panel_layout$label[i],
fontface = "bold",
size = 4
)
}
p_combo <- p_combo +
coord_cartesian(xlim = c(x_A_left, x_plot_right + tree_core_width * 0.1)) +
expand_limits(y = header_y + 0.5) +
theme(
legend.position = "right",
legend.background = element_rect(color = "#969696", fill = "#d9d9d9")
)
plot_width <- c(`1` = 12, `2` = 16, `3` = 20)[as.character(length(selected_panels))]
if (is.na(plot_width)) plot_width <- 20
ggsave(output_pdf, p_combo, width = plot_width, height = 10)
output_png <- sub("\\.pdf$", ".png", output_pdf)
ggsave(output_png, p_combo, width = plot_width, height = 10, dpi = 150, bg = "white")
cat("已输出 combo 图到: ", output_pdf, "\n")
cat("[OK] PNG: ", output_png, "\n", sep = "")
Reference in New Issue Copy Permalink