diff --git a/Clinics/BlandAltmanPlot.qmd b/Clinics/BlandAltmanPlot.qmd index 93db2f3d2..759c7e387 100644 --- a/Clinics/BlandAltmanPlot.qmd +++ b/Clinics/BlandAltmanPlot.qmd @@ -190,7 +190,7 @@ On the percentage scale the bias is −6.4% with limits of about −25% to +13%: ::: callout-tip ### 5. Bland-Altman with Slope Test (Constant Bias Assessment) -The reference workflow adds a **slope test**: regress the differences on the averages and test whether the slope differs from zero \[6\]. A non-significant slope supports the constant-bias assumption; a significant slope indicates proportional bias. +The reference workflow adds a **slope test**: regress the differences on the averages and test whether the slope differs from zero \[4\]. A non-significant slope supports the constant-bias assumption; a significant slope indicates proportional bias. ```{r} #| label: fig-5.1SlopeTest @@ -260,4 +260,4 @@ Method-comparison plots are required when laboratories introduce a new assay or \[3\] Datta D. blandr: a Bland-Altman Method Comparison package for R. Zenodo. 2017. doi:10.5281/zenodo.824514 -\[6\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/BlandAltmanPlot.zh.qmd b/Clinics/BlandAltmanPlot.zh.qmd index 45d7f0e48..c38620135 100644 --- a/Clinics/BlandAltmanPlot.zh.qmd +++ b/Clinics/BlandAltmanPlot.zh.qmd @@ -190,7 +190,7 @@ ggplot(method_data, aes(x = avg, y = pct_diff)) + ::: callout-tip ### 5. 带\u659c率检验的 Bland-Altman 图(恒定偏倚评估) -参考工作流增加了**斜率检验**:将差值对均值做回归,检验斜率是否偏离零 \[6\]。斜率不显著支持标准 Bland-Altman 方法的恒定偏倚假设;斜率显著则提示比例偏倚。 +参考工作流增加了**斜率检验**:将差值对均值做回归,检验斜率是否偏离零 \[4\]。斜率不显著支持标准 Bland-Altman 方法的恒定偏倚假设;斜率显著则提示比例偏倚。 ```{r} #| label: fig-5.1SlopeTest @@ -238,8 +238,6 @@ legend("topleft", bty = "n", cex = 0.8, - 临界差异为 ±1.96 × 差值标准差;斜率 ≠ 0 意味着该值在全范围内非常数。 ::: -## Practice tips - ## 实践要点 - x 轴应使用两种方法的*均值*(真值的最佳估计),切勿只用其中一种方法——以单一方法为横轴会在差值中引入虚假相关。 @@ -262,4 +260,4 @@ legend("topleft", bty = "n", cex = 0.8, \[3\] Datta D. blandr: a Bland-Altman Method Comparison package for R. Zenodo. 2017. doi:10.5281/zenodo.824514 -\[6\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/DCAPlot.qmd b/Clinics/DCAPlot.qmd index a280983bc..5c951275c 100644 --- a/Clinics/DCAPlot.qmd +++ b/Clinics/DCAPlot.qmd @@ -181,6 +181,73 @@ ggplot(impact, aes(x = threshold)) + The gap between the two lines is the number of unnecessary interventions per 1000 patients at each threshold — small gaps at clinically relevant thresholds indicate a useful model. +### 5. Many Models at One Horizon: Value and Over-Intervention + +The FigureYa33 layout \[4\] puts **every candidate model on one decision curve** — including a deliberately weak single-variable model — so the reader sees both halves of the clinical argument: above "treat all" a model justifies *intervening* on high-risk patients (opt-in), and the interventions-avoided view quantifies whom you may safely *spare* (opt-out). The simulated cohort below carries four risk scores for the same 2-year mortality horizon: a full model, its clinical-only and biomarker-only components, and age alone. + +```{r} +#| label: fig-5.1FourModelDCA +#| fig-cap: "Decision curves for four risk models at the 2-year horizon (simulated cohort, n = 500): net benefit against treat-all and treat-none defaults." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 5.5 + +set.seed(3311) +n_dc <- 500 +lc <- data.frame( + age = rnorm(n_dc, 60, 9), + stage = factor(sample(c("I", "II", "III"), n_dc, TRUE)), + ecog = sample(0:2, n_dc, TRUE, prob = c(0.5, 0.35, 0.15))) +lp <- -0.9 + 0.024 * (lc$age - 60) + c(0, 0.4, 0.8)[as.integer(lc$stage)] + 0.25 * lc$ecog +H <- exp(lp) * 0.4 # cumulative hazard at 730 days +S730 <- exp(-H) +event_time <- -log(runif(n_dc)) / H * 730 +cens <- rexp(n_dc, 1 / 1500) +lc$time <- pmin(event_time, cens, 1095) +lc$event <- as.integer(event_time <= lc$time) +## name the columns what the legend should say (dcurves uses variable names) +lc$`Full model` <- 1 - S730 +lc$`Clinical only` <- 1 - exp(-exp(-0.9 + 0.024 * (lc$age - 60) + + c(0, 0.4, 0.8)[as.integer(lc$stage)]) * 0.4) +lc$`Biomarker only` <- pmin(0.95, pmax(0.01, 0.2 + 0.14 * lc$ecog + rnorm(n_dc, 0, 0.12))) +lc$`Age only (weak)` <- pmin(0.9, pmax(0.01, (lc$age - 40) / 60)) + +dca4 <- dca(Surv(time, event) ~ `Full model` + `Clinical only` + + `Biomarker only` + `Age only (weak)`, + data = lc, time = 730, thresholds = seq(0, 0.5, 0.01)) +plot(dca4, smooth = FALSE) + + labs(x = "Threshold probability (2-year mortality)", y = "Net benefit") + + theme_bw(base_size = 11) + + theme(legend.position = "top") +``` + +```{r} +#| label: fig-5.2FourModelNIA +#| fig-cap: "Net interventions avoided per 100 patients for the same four models: the value of a model is how many treat-all interventions it can spare at equal missed events." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 5.5 + +nia4 <- net_intervention_avoided(dca4, nper = 100) +plot(nia4, smooth = FALSE) + + labs(x = "Threshold probability (2-year mortality)", + y = "Interventions avoided per 100 (vs treat all)") + + theme_bw(base_size = 11) + + theme(legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- Always include a **weak reference model** (one variable, or a noisy biomarker): it anchors the reader's expectations, and a candidate model that cannot beat it has no place in the clinic. +- `dcurves::dca()` accepts `labels =` to rename models in the legend — display model names a clinical reader knows, not R variable names. +- The net-benefit and interventions-avoided views are two readings of the same curve: report both when the paper's question is *whom to spare* rather than *whom to treat*. +::: + ## Application Decision curves are routinely reported in clinical prediction-model studies next to ROC and calibration curves. The panel below shows the typical pairing: (A) decision curves across thresholds and (B) the clinical impact curve. @@ -195,4 +262,6 @@ Decision curves are routinely reported in clinical prediction-model studies next \[3\] Sjoberg DD. dcurves: Decision Curve Analysis for Model Evaluation. R package version 0.5.1. doi:10.32614/CRAN.package.dcurves +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + \[4\] Loprinzi CL, Laurie JA, Wieand HS, et al. Prospective evaluation of prognostic variables from patient-completed questionnaires. North Central Cancer Treatment Group. J Clin Oncol. 1994;12(3):601-607. doi:10.1200/JCO.1994.12.3.601 diff --git a/Clinics/DCAPlot.zh.qmd b/Clinics/DCAPlot.zh.qmd index ca2055222..fb1f088cf 100644 --- a/Clinics/DCAPlot.zh.qmd +++ b/Clinics/DCAPlot.zh.qmd @@ -181,6 +181,73 @@ ggplot(impact, aes(x = threshold)) + 两条线之间的差值就是每个阈值下每 1000 名患者中“不必要的干预”数量——在临床相关阈值处差值越小,说明模型越有用。 +### 5. 一个 horizon 上的多模型比较:获益与避免过度干预 + +FigureYa33 版式 \[5\] 把**所有候选模型放进同一张决策曲线**——包括一个刻意弱化的单变量模型——让读者同时看到临床论证的两半:高于"全部干预"基线时,模型支持对高危者*干预*(opt-in);"避免干预数"视角则量化可以安全*放过*谁(opt-out)。下面的模拟队列对同一个 2 年死亡 horizon 构造四个风险评分:完整模型、其临床与生物标志物成分、以及单独年龄。 + +```{r} +#| label: fig-5.1FourModelDCA +#| fig-cap: "四个风险模型在 2 年 horizon 的决策曲线(模拟队列,n = 500):相对 treat-all 与 treat-none 默认策略的净获益。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 5.5 + +set.seed(3311) +n_dc <- 500 +lc <- data.frame( + age = rnorm(n_dc, 60, 9), + stage = factor(sample(c("I", "II", "III"), n_dc, TRUE)), + ecog = sample(0:2, n_dc, TRUE, prob = c(0.5, 0.35, 0.15))) +lp <- -0.9 + 0.024 * (lc$age - 60) + c(0, 0.4, 0.8)[as.integer(lc$stage)] + 0.25 * lc$ecog +H <- exp(lp) * 0.4 # 730 天的累积风险 +S730 <- exp(-H) +event_time <- -log(runif(n_dc)) / H * 730 +cens <- rexp(n_dc, 1 / 1500) +lc$time <- pmin(event_time, cens, 1095) +lc$event <- as.integer(event_time <= lc$time) +## 列名即图例名(dcurves 直接用变量名) +lc$`Full model` <- 1 - S730 +lc$`Clinical only` <- 1 - exp(-exp(-0.9 + 0.024 * (lc$age - 60) + + c(0, 0.4, 0.8)[as.integer(lc$stage)]) * 0.4) +lc$`Biomarker only` <- pmin(0.95, pmax(0.01, 0.2 + 0.14 * lc$ecog + rnorm(n_dc, 0, 0.12))) +lc$`Age only (weak)` <- pmin(0.9, pmax(0.01, (lc$age - 40) / 60)) + +dca4 <- dca(Surv(time, event) ~ `Full model` + `Clinical only` + + `Biomarker only` + `Age only (weak)`, + data = lc, time = 730, thresholds = seq(0, 0.5, 0.01)) +plot(dca4, smooth = FALSE) + + labs(x = "Threshold probability (2-year mortality)", y = "Net benefit") + + theme_bw(base_size = 11) + + theme(legend.position = "top") +``` + +```{r} +#| label: fig-5.2FourModelNIA +#| fig-cap: "同一四个模型每 100 名患者避免的干预数:模型的价值在于同等漏检下能省下多少 treat-all 干预。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 5.5 + +nia4 <- net_intervention_avoided(dca4, nper = 100) +plot(nia4, smooth = FALSE) + + labs(x = "Threshold probability (2-year mortality)", + y = "Interventions avoided per 100 (vs treat all)") + + theme_bw(base_size = 11) + + theme(legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- 务必放一个**弱参照模型**(单变量或含噪声的标志物):它锚定读者的预期——候选模型若赢不了它,就没有进临床的资格。 +- `dcurves::dca()` 的图例直接使用变量名——把列命名为临床读者认识的名字(本例用反引号列名实现),而不是 R 变量名。 +- 净获益与避免干预数是同一条曲线的两种读法:论文问题如果是"放过谁"而非"治疗谁",两个视角都要报告。 +::: + ## 应用 决策曲线通常与 ROC 曲线、校准曲线一同出现在临床预测模型研究中。下图展示典型的组合方式:(A) 各阈值下的决策曲线;(B) 临床影响曲线。 @@ -196,3 +263,5 @@ ggplot(impact, aes(x = threshold)) + \[3\] Sjoberg DD. dcurves: Decision Curve Analysis for Model Evaluation. R package version 0.5.1. doi:10.32614/CRAN.package.dcurves \[4\] Loprinzi CL, Laurie JA, Wieand HS, et al. Prospective evaluation of prognostic variables from patient-completed questionnaires. North Central Cancer Treatment Group. J Clin Oncol. 1994;12(3):601-607. doi:10.1200/JCO.1994.12.3.601 + +\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/KaplanMeierPlot.qmd b/Clinics/KaplanMeierPlot.qmd index b08c262bc..1f3a6a497 100644 --- a/Clinics/KaplanMeierPlot.qmd +++ b/Clinics/KaplanMeierPlot.qmd @@ -19,7 +19,7 @@ Survival analysis studies the time that passes before an event occurs. The most - Programming language: R -- Dependent packages: `survival`, `survminer`, `ggplot2`, `dplyr`, `tidyr`, `zoo`, `patchwork` +- Dependent packages: `survival`, `survminer`, `ggplot2`, `dplyr`, `tidyr`, `zoo`, `patchwork`, `ggpp`, `gridExtra`, `RColorBrewer` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Install packages @@ -44,15 +44,27 @@ if (!requireNamespace("zoo", quietly = TRUE)) { if (!requireNamespace("patchwork", quietly = TRUE)) { install.packages("patchwork") } +if (!requireNamespace("ggpp", quietly = TRUE)) { + install.packages("ggpp") +} +if (!requireNamespace("gridExtra", quietly = TRUE)) { + install.packages("gridExtra") +} +if (!requireNamespace("RColorBrewer", quietly = TRUE)) { + install.packages("RColorBrewer") +} # Load packages -library(survival) -library(survminer) -library(ggplot2) +library(survival) +library(survminer) +library(ggplot2) library(dplyr) library(tidyr) library(zoo) library(patchwork) +library(ggpp) +library(gridExtra) +library(RColorBrewer) ``` ```{r} @@ -342,7 +354,7 @@ Beautified survival curve ### Multi-Group Survival Curves with Confidence Ribbons -Two- and three-arm comparisons extend the same `ggsurvplot()` call: pass one colour per stratum to `palette`, per-group labels to `legend.labs`, and switch on the confidence ribbon with `conf.int` \[7\]. +Two- and three-arm comparisons extend the same `ggsurvplot()` call: pass one colour per stratum to `palette`, per-group labels to `legend.labs`, and switch on the confidence ribbon with `conf.int` \[3\]. ```{r} #| label: fig-2.2MultiGroupKM @@ -387,7 +399,7 @@ ggsurvplot(fit3, data = km3, ### Risk Table Below the KM Curve -The **risk table** below a KM curve shows the number of patients at risk at each time point \[7\] — it is what reviewers check to assess the reliability of the curve at late follow-up times. `survminer::ggsurvplot()` draws it with `risk.table = TRUE`. +The **risk table** below a KM curve shows the number of patients at risk at each time point \[3\] — it is what reviewers check to assess the reliability of the curve at late follow-up times. `survminer::ggsurvplot()` draws it with `risk.table = TRUE`. ```{r} #| label: fig-risktable @@ -427,6 +439,225 @@ ggsurvplot(fit_rt, data = km_data, - `tables.theme = theme_cleantable()` removes the table grid lines for a cleaner look. ::: +### Pairwise Log-rank Comparisons Across Many Groups + +With three or more strata, the single overall log-rank p-value answers *"do the curves differ somewhere?"* but not *"which pairs differ?"* \[3\]. The natural companion is a matrix of pairwise log-rank tests from `survminer::pairwise_survdiff()`, reported next to the curves — the layout of FigureYa284pairwiseLogrank, which reproduces Fig. 2a of a soft-tissue-sarcoma study with five PAM50-like strata \[3\]. Below, five simulated strata (A–E) with different hazard rates are plotted with their risk table, the overall log-rank p-value, and the full pairwise matrix embedded in the empty lower-left corner of the panel via `ggpp::geom_table()`. + +```{r} +#| label: fig-2.3pairwise +#| fig-cap: "Five-stratum KM curves with risk table; the lower-left table gives Holm-adjusted pairwise log-rank p-values (columns vs rows), and the overall log-rank test gives p < 0.001." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 8.5 + +set.seed(4284) +n_g <- 60 +grp <- factor(rep(c("A", "B", "C", "D", "E"), each = n_g), + levels = c("A", "B", "C", "D", "E")) +rate <- c(A = 0.030, B = 0.022, C = 0.008, D = 0.016, E = 0.012) +t_event <- rexp(5 * n_g, rate = rate[as.character(grp)]) +t_cens <- rexp(5 * n_g, rate = 0.008) +km5 <- data.frame(OS.time = pmin(t_event, t_cens), + OS = as.integer(t_event <= t_cens), + group = grp) + +# overall log-rank test +fitd <- survdiff(Surv(OS.time, OS) ~ group, data = km5) +p_overall <- 1 - pchisq(fitd$chisq, length(fitd$n) - 1) +p_lab <- paste0("Log-rank test P", + ifelse(p_overall < 0.001, " < 0.001", + paste0(" = ", round(p_overall, 3)))) + +# pairwise log-rank tests, Holm-adjusted (the survminer default; +# the source figure used p.adjust.method = "none" to match its published table) +ps <- pairwise_survdiff(Surv(OS.time, OS) ~ group, data = km5, + p.adjust.method = "holm") + +fit <- survfit(Surv(OS.time, OS) ~ group, data = km5) +names(fit$strata) <- gsub("group=", "", names(fit$strata)) +mycol <- brewer.pal(n = 10, "Paired")[c(2, 4, 6, 8, 10)] + +addTab <- as.data.frame(as.matrix(ifelse(round(ps$p.value, 3) < 0.001, + "<0.001", round(ps$p.value, 3)))) +addTab[is.na(addTab)] <- "-" + +p <- ggsurvplot(fit, data = km5, + conf.int = FALSE, + risk.table = TRUE, risk.table.col = "strata", + palette = mycol, + xlim = c(0, 120), break.time.by = 24, + size = 0.9, + legend.title = "", + xlab = "Time (months)", ylab = "Overall survival", + risk.table.y.text = FALSE, + tables.height = 0.28, + ggtheme = theme_classic(base_size = 11)) + +p$plot <- p$plot + + annotate("text", x = 55, y = 0.95, hjust = 0, fontface = 4, size = 3.4, + label = p_lab) + + annotate("text", x = 0, y = 0.315, hjust = 0, size = 3, fontface = 3, + label = "Pairwise log-rank P (Holm)") + + geom_table(data = tibble::tibble(x = 0, y = 0.02, tb = list(addTab)), + aes(x = x, y = y, label = tb), + table.rownames = TRUE, + table.theme = ttheme_minimal(base_size = 8, + core = list(fg_params = list(fontsize = 7.5)))) +p +``` + +::: callout-tip +**Practice tips** + +- Prefer adjusted pairwise p-values (`p.adjust.method = "holm"`, the package default); the reproduced paper printed unadjusted tests to match its published table — either is fine, but state the choice in your methods. +- The matrix is symmetric with `-` on the diagonal; print the lower triangle only, and keep the row/column order identical to the legend order of the curves. +- `geom_table()` anchors the table at data coordinates: the lower-left of a KM panel is usually empty (curves start at survival = 1), so it is a safe anchor; check for overlap with late-descending curves before export. +::: + +### Batch Optimal Cutpoints (Best Separation) + +Screening many markers for the cutoff that best splits a cohort is `survminer::surv_cutpoint()` — for each variable it scans cutpoints and maximises the log-rank statistic (`minprop = 0.3` keeps both groups ≥30% of the cohort), then `surv_categorize()` applies the found cutoffs. The reference workflow (FigureYa35batch_bestSeparationV3_update \[3\]) loops the resulting high/low groups through KM curves with HR + 95% CI computed from `survdiff` Observed/Expected ratios: + +```{r} +#| label: fig-3.4BestSeparation +#| fig-cap: "Batch best-separation screen of 8 simulated markers: KM curves for the markers whose maximally-selected log-rank p passes 0.05, with the optimal cutoff, n per group, HR and 95% CI printed in each panel." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 6 + +set.seed(3511) +n_km <- 160 +svdata <- data.frame(futime = rexp(n_km, 0.02), fustat = rbinom(n_km, 1, 0.75)) +g_expr <- matrix(rnorm(n_km * 8, 5, 1.2), n_km, 8, + dimnames = list(NULL, paste0("GENE", 1:8))) +## plant effects: GENE1 high = worse, GENE3 high = protective, GENE5 = no effect +g_expr[, 1] <- g_expr[, 1] + (svdata$futime < quantile(svdata$futime, 0.45)) * 2.2 +g_expr[, 3] <- g_expr[, 3] - (svdata$futime < quantile(svdata$futime, 0.45)) * 2.0 +svdata <- cbind(svdata, as.data.frame(g_expr)) + +res.cut <- surv_cutpoint(svdata, time = "futime", event = "fustat", + variables = paste0("GENE", 1:8), minprop = 0.3) +res.cat <- surv_categorize(res.cut) +cuts <- summary(res.cut)$cutpoint + +my.surv <- with(res.cat, Surv(futime, fustat)) +pl <- list() +for (i in paste0("GENE", 1:8)) { + group <- factor(res.cat[[i]], levels = c("low", "high")) + sd1 <- survdiff(my.surv ~ group) + p.val <- 1 - pchisq(sd1$chisq, length(sd1$n) - 1) + HR <- (sd1$obs[2] / sd1$exp[2]) / (sd1$obs[1] / sd1$exp[1]) + up95 <- exp(log(HR) + qnorm(0.975) * sqrt(1 / sd1$exp[2] + 1 / sd1$exp[1])) + low95 <- exp(log(HR) - qnorm(0.975) * sqrt(1 / sd1$exp[2] + 1 / sd1$exp[1])) + if (p.val > 0.05) next + fit <- survfit(my.surv ~ group) + svsort <- svdata[order(svdata[, i]), ] + pl[[i]] <- ggsurvplot(fit, data = data.frame(group = group), + conf.int = FALSE, censor = FALSE, + palette = c("#D95F02", "#1B9E77"), + legend.title = i, + legend.labs = c(paste0("high >", round(svsort[fit$n[2], i], 2), " (n=", fit$n[1], ")"), + paste0("low <=", round(svsort[fit$n[2], i], 2), " (n=", fit$n[2], ")")), + pval = paste(ifelse(p.val < 0.001, "p < 0.001", paste0("p = ", round(p.val, 3))), + paste0("HR = ", round(HR, 2)), + paste0("95% CI: ", round(low95, 2), "-", round(up95, 2)), sep = "\n")) +} +patchwork::wrap_plots(lapply(pl, function(x) x$plot), ncol = 2, guides = "collect") +``` + +::: callout-tip +**Practice tips** + +- Maximally selected statistics search the cutoff that flatters the data — screening 8 markers at p > 0.05 lets chance hit ~1 in 3 screens (GENE7 above is exactly such a borderline hit). Confirm the screen with a multiple-testing correction (e.g. Bonferroni at 0.05/8) or treat it as exploratory and validate the cutoff in an independent cohort. +- `minprop = 0.3` prevents a cutoff that isolates a handful of long survivors — the classic source of spuriously "significant" splits. +- The HR and CI from `survdiff` Observed/Expected are cohort-specific (cutoff optimized in the same data); report them as descriptive, not as an independent validation. +::: + +### The Optimal-Split Landscape for One Marker + +The companion view of the batch screen above (FigureYa4bestSeparation \[3\]): rank the cohort by one marker's expression, compute the log-rank p-value and hazard ratio **at every possible split**, and plot −log10(P) against log2(HR). The dashed lines mark p = 0.05 and HR = 2 / 0.5; the red point is the split the eye would pick — and, because this is a maximally selected statistic, also the one most prone to optimism: + +```{r} +#| label: fig-3.5SplitLandscape +#| fig-cap: "The split landscape of one simulated marker (200 samples): log-rank p-value and HR at every possible dichotomisation; dashed lines at p = 0.05 and HR = 2 / 0.5; the minimum-p split is highlighted." +#| out.width: "70%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(4041) +n_bs <- 200 +bs <- data.frame(futime = rexp(n_bs, 0.02), fustat = rbinom(n_bs, 1, 0.8), + expression = rnorm(n_bs, 5, 1.3)) +bs$expression <- bs$expression - (bs$futime < quantile(bs$futime, 0.42)) * 2.0 +sortsv <- bs[order(bs$expression), ] +pvals <- c(); hrs <- c() +for (n in 1:(nrow(sortsv) - 1)) { + gp <- rep(c("low", "high"), c(n, nrow(sortsv) - n)) + d1 <- survdiff(Surv(futime, fustat) ~ gp, data = sortsv, rho = 0) + pvals <- c(pvals, pchisq(d1$chisq, length(d1$n) - 1, lower.tail = FALSE)) + hrs <- c(hrs, d1$obs[1] * d1$exp[2] / (d1$obs[2] * d1$exp[1])) +} +fd <- data.frame(Tag = 1:(nrow(sortsv) - 1), HR = hrs, Pvalue = pvals) +best <- which.min(pvals) + +ggplot(fd, aes(log2(HR), -log10(Pvalue))) + + geom_point(shape = 21, aes(fill = Tag), colour = "grey25", size = 2.1) + + scale_fill_gradientn(colours = c("#4477AA", "#77AADD", "#FFFFFF", "#EE9988", "#BB4444"), + guide = "none") + + geom_hline(yintercept = -log10(0.05), linetype = "dashed") + + geom_vline(xintercept = c(-1, 1), linetype = "dashed") + + annotate("text", x = log2(hrs[best]), y = -log10(pvals[best]) + 0.6, + label = "min-P split", size = 3.2, colour = "#BB4444") + + geom_point(data = fd[best, ], aes(log2(HR), -log10(Pvalue)), + shape = 21, fill = "#BB4444", colour = "black", size = 3.4) + + labs(x = "log2 hazard ratio at each split", + y = "-log10(P), maximally selected log-rank", + title = "Every split of 200 samples ranked by expression (simulated marker)") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +The landscape makes the *cost of choosing* visible — compare the KM curves of the min-P split against the boring median split: + +```{r} +#| label: fig-3.6SplitKMs +#| fig-cap: "KM curves of the same marker dichotomised two ways: the min-P split (left) versus the median split (right); the difference in reported p-values is the optimism the landscape warns about." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 4.2 + +gp_best <- rep(c("low", "high"), c(best, nrow(sortsv) - best)) +fit_best <- survfit(Surv(futime, fustat) ~ gp_best, data = sortsv) +gp_med <- ifelse(sortsv$expression > median(sortsv$expression), "high", "low") +fit_med <- survfit(Surv(futime, fustat) ~ gp_med, data = sortsv) +p_best <- ggsurvplot(fit_best, linetype = "strata", conf.int = FALSE, + pval = TRUE, palette = c("#D95F02", "#1B9E77"), + legend.title = "", legend.labs = c("High", "Low"), + ggtheme = theme_bw(base_size = 11), + title = "Best separation (min-P split)") +p_med <- ggsurvplot(fit_med, linetype = "strata", conf.int = FALSE, + pval = TRUE, palette = c("#D95F02", "#1B9E77"), + legend.title = "", legend.labs = c("High", "Low"), + ggtheme = theme_bw(base_size = 11), + title = "Median separation") +patchwork::wrap_plots(list(p_best$plot, p_med$plot), ncol = 2) +``` + +::: callout-tip +**Practice tips** + +- The `Tag` fill colour encodes the split position along the ranked expression axis — it shows that extreme splits (tiny groups) trade p-value for interpretability; a split keeping 5% of the cohort "high" is not a usable rule. +- Report the **median-split p-value next to the min-P one** whenever a marker is screened: the gap between the two curves' p-values is the optimism in one glance. +- This landscape is the manual twin of `surv_cutpoint()`; use it for one marker and the batch screen for panels. +::: + ## Application ::: {#fig-KaplanMeierPlotApplications1} @@ -445,4 +676,4 @@ This figure shows the comparison of the generated survival time between the thre -\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/KaplanMeierPlot.zh.qmd b/Clinics/KaplanMeierPlot.zh.qmd index 9769a37f7..cb041b8da 100644 --- a/Clinics/KaplanMeierPlot.zh.qmd +++ b/Clinics/KaplanMeierPlot.zh.qmd @@ -16,7 +16,7 @@ author: ```{r} #| echo: false #| output: asis -bizard_setup("survival", "survminer", "ggplot2", "dplyr", "tidyr", "zoo", "patchwork", lang = "zh") +bizard_setup("survival", "survminer", "ggplot2", "dplyr", "tidyr", "zoo", "patchwork", "ggpp", "gridExtra", "RColorBrewer", lang = "zh") ``` ```{r} @@ -306,7 +306,7 @@ final_plot ### 多组生存曲线与置信区间带 -两臂与三臂比较沿用同一个 `ggsurvplot()` 调用:为每个分层在 `palette` 中传入一种颜色,在 `legend.labs` 中传入各组标签,并用 `conf.int` 开启置信区间带 \[7\]。 +两臂与三臂比较沿用同一个 `ggsurvplot()` 调用:为每个分层在 `palette` 中传入一种颜色,在 `legend.labs` 中传入各组标签,并用 `conf.int` 开启置信区间带 \[3\]。 ```{r} #| label: fig-2.2MultiGroupKM @@ -351,7 +351,7 @@ ggsurvplot(fit3, data = km3, ### Risk Table(风险表) -KM 曲线下方的**风险表**展示每个时间点仍在随访的患者数 \[7\]——审稿人用它评估曲线在晚期随访时的可靠性。`survminer::ggsurvplot()` 通过 `risk.table = TRUE` 绘制。 +KM 曲线下方的**风险表**展示每个时间点仍在随访的患者数 \[3\]——审稿人用它评估曲线在晚期随访时的可靠性。`survminer::ggsurvplot()` 通过 `risk.table = TRUE` 绘制。 ```{r} #| label: fig-risktable @@ -391,6 +391,224 @@ ggsurvplot(fit_rt, data = km_data, - `tables.theme = theme_cleantable()` 去除表格网格线,使画面更干净。 ::: +### 多组间的两两 log-rank 比较 + +三组及以上分层时,单一的总体 log-rank p 值只回答"曲线在某处是否存在差异",回答不了"具体哪两组不同" \[3\]。自然的补充是 `survminer::pairwise_survdiff()` 给出的两两 log-rank 检验矩阵,与曲线一起呈现——这正是 FigureYa284pairwiseLogrank 的版式:复现某软组织肉瘤研究中五个 PAM50 样分层的 Fig. 2a \[3\]。下面用五个不同风险率的模拟分层(A–E)绘制带风险表的 KM 曲线,标注总体 log-rank p 值,并用 `ggpp::geom_table()` 把完整的两两比较矩阵嵌入面板左下角的空白区。 + +```{r} +#| label: fig-2.3pairwise +#| fig-cap: "五分层 KM 曲线 + 风险表;左下表格为 Holm 校正的两两 log-rank p 值(列为组、行为组),总体 log-rank 检验 p < 0.001。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 8.5 + +set.seed(4284) +n_g <- 60 +grp <- factor(rep(c("A", "B", "C", "D", "E"), each = n_g), + levels = c("A", "B", "C", "D", "E")) +rate <- c(A = 0.030, B = 0.022, C = 0.008, D = 0.016, E = 0.012) +t_event <- rexp(5 * n_g, rate = rate[as.character(grp)]) +t_cens <- rexp(5 * n_g, rate = 0.008) +km5 <- data.frame(OS.time = pmin(t_event, t_cens), + OS = as.integer(t_event <= t_cens), + group = grp) + +# 总体 log-rank 检验 +fitd <- survdiff(Surv(OS.time, OS) ~ group, data = km5) +p_overall <- 1 - pchisq(fitd$chisq, length(fitd$n) - 1) +p_lab <- paste0("Log-rank test P", + ifelse(p_overall < 0.001, " < 0.001", + paste0(" = ", round(p_overall, 3)))) + +# 两两 log-rank 检验,Holm 校正(survminer 默认;原文为与已发表表格一致使用了不校正) +ps <- pairwise_survdiff(Surv(OS.time, OS) ~ group, data = km5, + p.adjust.method = "holm") + +fit <- survfit(Surv(OS.time, OS) ~ group, data = km5) +names(fit$strata) <- gsub("group=", "", names(fit$strata)) +mycol <- brewer.pal(n = 10, "Paired")[c(2, 4, 6, 8, 10)] + +addTab <- as.data.frame(as.matrix(ifelse(round(ps$p.value, 3) < 0.001, + "<0.001", round(ps$p.value, 3)))) +addTab[is.na(addTab)] <- "-" + +p <- ggsurvplot(fit, data = km5, + conf.int = FALSE, + risk.table = TRUE, risk.table.col = "strata", + palette = mycol, + xlim = c(0, 120), break.time.by = 24, + size = 0.9, + legend.title = "", + xlab = "Time (months)", ylab = "Overall survival", + risk.table.y.text = FALSE, + tables.height = 0.28, + ggtheme = theme_classic(base_size = 11)) + +p$plot <- p$plot + + annotate("text", x = 55, y = 0.95, hjust = 0, fontface = 4, size = 3.4, + label = p_lab) + + annotate("text", x = 0, y = 0.315, hjust = 0, size = 3, fontface = 3, + label = "Pairwise log-rank P (Holm)") + + geom_table(data = tibble::tibble(x = 0, y = 0.02, tb = list(addTab)), + aes(x = x, y = y, label = tb), + table.rownames = TRUE, + table.theme = ttheme_minimal(base_size = 8, + core = list(fg_params = list(fontsize = 7.5)))) +p +``` + +::: callout-tip +**实践要点** + +- 优先使用校正后的两两 p 值(`p.adjust.method = "holm"`,包默认值);原文为与已发表表格一致打印了未校正的检验——两种做法都可以,但要在方法学部分说明。 +- 矩阵是对称的,对角线为 `-`;只打印下三角,且行/列顺序与曲线图例顺序保持一致。 +- `geom_table()` 以数据坐标为锚点:KM 面板左下角通常是空的(曲线从生存率 = 1 开始),是安全的锚点;导出前检查是否与晚期下降的曲线重叠。 +::: + +### 批量最优截断值(最佳分离) + +为大量标志物筛选"最佳分离"截断值用 `survminer::surv_cutpoint()`——它对每个变量扫描截断点、最大化 log-rank 统计量(`minprop = 0.3` 保证两组各占队列至少 30%),再用 `surv_categorize()` 应用所得截断。参考工作流(FigureYa35batch_bestSeparationV3_update \[3\])把所得高/低组逐个过 KM 曲线,并用 `survdiff` 的 Observed/Expected 比值计算 HR 与 95% CI: + +```{r} +#| label: fig-3.4BestSeparation +#| fig-cap: "8 个模拟标志物的批量最佳分离筛选:对最大化 log-rank p 通过 0.05 的标志物绘制 KM 曲线,面板内打印最优截断值、各组 n、HR 与 95% CI。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 6 + +set.seed(3511) +n_km <- 160 +svdata <- data.frame(futime = rexp(n_km, 0.02), fustat = rbinom(n_km, 1, 0.75)) +g_expr <- matrix(rnorm(n_km * 8, 5, 1.2), n_km, 8, + dimnames = list(NULL, paste0("GENE", 1:8))) +## 植入效应:GENE1 高表达 = 更差,GENE3 高表达 = 保护,GENE5 = 无效应 +g_expr[, 1] <- g_expr[, 1] + (svdata$futime < quantile(svdata$futime, 0.45)) * 2.2 +g_expr[, 3] <- g_expr[, 3] - (svdata$futime < quantile(svdata$futime, 0.45)) * 2.0 +svdata <- cbind(svdata, as.data.frame(g_expr)) + +res.cut <- surv_cutpoint(svdata, time = "futime", event = "fustat", + variables = paste0("GENE", 1:8), minprop = 0.3) +res.cat <- surv_categorize(res.cut) +cuts <- summary(res.cut)$cutpoint + +my.surv <- with(res.cat, Surv(futime, fustat)) +pl <- list() +for (i in paste0("GENE", 1:8)) { + group <- factor(res.cat[[i]], levels = c("low", "high")) + sd1 <- survdiff(my.surv ~ group) + p.val <- 1 - pchisq(sd1$chisq, length(sd1$n) - 1) + HR <- (sd1$obs[2] / sd1$exp[2]) / (sd1$obs[1] / sd1$exp[1]) + up95 <- exp(log(HR) + qnorm(0.975) * sqrt(1 / sd1$exp[2] + 1 / sd1$exp[1])) + low95 <- exp(log(HR) - qnorm(0.975) * sqrt(1 / sd1$exp[2] + 1 / sd1$exp[1])) + if (p.val > 0.05) next + fit <- survfit(my.surv ~ group) + svsort <- svdata[order(svdata[, i]), ] + pl[[i]] <- ggsurvplot(fit, data = data.frame(group = group), + conf.int = FALSE, censor = FALSE, + palette = c("#D95F02", "#1B9E77"), + legend.title = i, + legend.labs = c(paste0("high >", round(svsort[fit$n[2], i], 2), " (n=", fit$n[1], ")"), + paste0("low <=", round(svsort[fit$n[2], i], 2), " (n=", fit$n[2], ")")), + pval = paste(ifelse(p.val < 0.001, "p < 0.001", paste0("p = ", round(p.val, 3))), + paste0("HR = ", round(HR, 2)), + paste0("95% CI: ", round(low95, 2), "-", round(up95, 2)), sep = "\n")) +} +patchwork::wrap_plots(lapply(pl, function(x) x$plot), ncol = 2, guides = "collect") +``` + +::: callout-tip +**实践要点** + +- 最大化选择统计量会搜索"最讨好数据"的截断——8 个标志物按 p > 0.05 筛选,纯随机也有约三分之一的批次出现假命中(上图的 GENE7 正是这种边界命中)。请用多重检验校正确认(如 0.05/8 的 Bonferroni),或明确作为探索性结果,并在独立队列验证截断值。 +- `minprop = 0.3` 防止把一小撮长生存者单独隔离——这是"虚假显著"分离的经典来源。 +- 由 `survdiff` Observed/Expected 计算的 HR 与 CI 是队列特异的(截断在同一数据上优化过),只能作为描述性结果,不能当作独立验证。 +::: + +### 单标志物的最优分离景观图 + +上面批量筛选的姊妹视角(FigureYa4bestSeparation \[3\]):把队列按一个标志物的表达排序,在**每一个可能的切分点**计算 log-rank p 值与 HR,然后画 −log10(P) 对 log2(HR)。虚线标记 p = 0.05 与 HR = 2 / 0.5;红点就是肉眼会选中的切分——而由于这是最大化选择统计量,它同时也是最容易乐观的那个: + +```{r} +#| label: fig-3.5SplitLandscape +#| fig-cap: "单标志物的切分景观图(200 样本):每个可能的二分方式的 log-rank p 值与 HR;虚线在 p = 0.05 与 HR = 2 / 0.5;最小 p 切分已高亮。" +#| out.width: "70%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(4041) +n_bs <- 200 +bs <- data.frame(futime = rexp(n_bs, 0.02), fustat = rbinom(n_bs, 1, 0.8), + expression = rnorm(n_bs, 5, 1.3)) +bs$expression <- bs$expression - (bs$futime < quantile(bs$futime, 0.42)) * 2.0 +sortsv <- bs[order(bs$expression), ] +pvals <- c(); hrs <- c() +for (n in 1:(nrow(sortsv) - 1)) { + gp <- rep(c("low", "high"), c(n, nrow(sortsv) - n)) + d1 <- survdiff(Surv(futime, fustat) ~ gp, data = sortsv, rho = 0) + pvals <- c(pvals, pchisq(d1$chisq, length(d1$n) - 1, lower.tail = FALSE)) + hrs <- c(hrs, d1$obs[1] * d1$exp[2] / (d1$obs[2] * d1$exp[1])) +} +fd <- data.frame(Tag = 1:(nrow(sortsv) - 1), HR = hrs, Pvalue = pvals) +best <- which.min(pvals) + +ggplot(fd, aes(log2(HR), -log10(Pvalue))) + + geom_point(shape = 21, aes(fill = Tag), colour = "grey25", size = 2.1) + + scale_fill_gradientn(colours = c("#4477AA", "#77AADD", "#FFFFFF", "#EE9988", "#BB4444"), + guide = "none") + + geom_hline(yintercept = -log10(0.05), linetype = "dashed") + + geom_vline(xintercept = c(-1, 1), linetype = "dashed") + + annotate("text", x = log2(hrs[best]), y = -log10(pvals[best]) + 0.6, + label = "min-P split", size = 3.2, colour = "#BB4444") + + geom_point(data = fd[best, ], aes(log2(HR), -log10(Pvalue)), + shape = 21, fill = "#BB4444", colour = "black", size = 3.4) + + labs(x = "log2 hazard ratio at each split", + y = "-log10(P), maximally selected log-rank", + title = "Every split of 200 samples ranked by expression (simulated marker)") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +景观图把"选择的代价"可视化——对比 min-P 切分与朴素中位数切分的 KM 曲线: + +```{r} +#| label: fig-3.6SplitKMs +#| fig-cap: "同一标志物两种二分方式的 KM 曲线:min-P 切分(左)与中位数切分(右);两者 p 值之差就是景观图警示的乐观量。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 4.2 + +gp_best <- rep(c("low", "high"), c(best, nrow(sortsv) - best)) +fit_best <- survfit(Surv(futime, fustat) ~ gp_best, data = sortsv) +gp_med <- ifelse(sortsv$expression > median(sortsv$expression), "high", "low") +fit_med <- survfit(Surv(futime, fustat) ~ gp_med, data = sortsv) +p_best <- ggsurvplot(fit_best, linetype = "strata", conf.int = FALSE, + pval = TRUE, palette = c("#D95F02", "#1B9E77"), + legend.title = "", legend.labs = c("High", "Low"), + ggtheme = theme_bw(base_size = 11), + title = "Best separation (min-P split)") +p_med <- ggsurvplot(fit_med, linetype = "strata", conf.int = FALSE, + pval = TRUE, palette = c("#D95F02", "#1B9E77"), + legend.title = "", legend.labs = c("High", "Low"), + ggtheme = theme_bw(base_size = 11), + title = "Median separation") +patchwork::wrap_plots(list(p_best$plot, p_med$plot), ncol = 2) +``` + +::: callout-tip +**实践要点** + +- `Tag` 填充色编码切分点在排序表达轴上的位置——它揭示极端切分(极小组)在用可解释性换 p 值;让 5% 样本充当"高"组的切分不是可用规则。 +- 筛选标志物时**把中位数切分的 p 值与 min-P 并排报告**:两条曲线 p 值的差距就是一眼可见的乐观量。 +- 这张景观图是 `surv_cutpoint()` 的手工孪生:单标志物用它,多标志物面板用批量筛选。 +::: + ## 应用场景 ### 1. 疾病分布 @@ -411,4 +629,4 @@ ggsurvplot(fit_rt, data = km_data, -\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/MetaForestPlot.qmd b/Clinics/MetaForestPlot.qmd index a8a42290f..821f89f7a 100644 --- a/Clinics/MetaForestPlot.qmd +++ b/Clinics/MetaForestPlot.qmd @@ -444,6 +444,7 @@ forest(m, comb.fixed = FALSE, comb.random = TRUE, - Keep all three heterogeneity prints (`print.pval.Q/I2/tau2`): reviewers check them to decide which pooling model applies. ::: +## Application ### 1. Visualization of Meta-analysis Results diff --git a/Clinics/MetaForestPlot.zh.qmd b/Clinics/MetaForestPlot.zh.qmd index e6af24aa4..1f2e47c65 100644 --- a/Clinics/MetaForestPlot.zh.qmd +++ b/Clinics/MetaForestPlot.zh.qmd @@ -444,6 +444,7 @@ forest(m, comb.fixed = FALSE, comb.random = TRUE, - 三项异质性打印(`print.pval.Q/I2/tau2`)全部保留:审稿人据此判断该用哪种合并模型。 ::: +## 应用场景 ### 1. Meta分析结果可视化 diff --git a/Clinics/Nomogram.qmd b/Clinics/Nomogram.qmd index ee0131dd5..4dfe0f393 100644 --- a/Clinics/Nomogram.qmd +++ b/Clinics/Nomogram.qmd @@ -204,6 +204,62 @@ regplot(lihccox, Beautify Nomogram2 ::: +### 3. Calibrate the Nomogram + +A nomogram is a prediction model, so before it is used — or published — it must be **calibrated**: do predicted survival probabilities match observed ones? The reference workflow \[3\] fits the same Cox model with `rms::cph(..., surv = TRUE, time.inc = ...)` and uses `rms::calibrate()` (bootstrap bias correction, Kaplan–Meier observed probabilities at the horizon time). An ideal nomogram tracks the 45° dashed line; the distance between the apparent (×) and bias-corrected (•) curves shows how much overfitting the optimism correction removes. + +```{r} +#| label: fig-3.1Calibration3y +#| fig-cap: "Bootstrap calibration of the Cox nomogram at 3 years (u = 1095 days): apparent (×) vs bias-corrected (•) survival against the ideal 45° line." +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 5.5 + +## consolidate TCGA stage labels (Stage IA/IB -> Stage I) so every level has support +lihc_cal <- LIHC +lihc_cal$stage3 <- factor(sub("[ABCD]$", "", as.character(lihc_cal$stage))) +lihc_cal$gender <- factor(lihc_cal$gender) +lihc_cal <- lihc_cal[complete.cases(lihc_cal[, c("time", "status", "age", "gender", "stage3")]), ] +dd2 <- datadist(lihc_cal) +options(datadist = "dd2") + +f3y <- cph(Surv(time, status) ~ age + gender + stage3, data = lihc_cal, + x = TRUE, y = TRUE, surv = TRUE, time.inc = 1095) +cal3y <- calibrate(f3y, cmethod = "KM", method = "boot", u = 1095, B = 200) +plot(cal3y, xlab = "Predicted 3-year survival probability", + ylab = "Observed survival (KM)", subtitles = FALSE) +``` + +```{r} +#| label: fig-3.2Calibration5y +#| fig-cap: "Bootstrap calibration of the Cox nomogram at 5 years (u = 1825 days): the model tracks the ideal line within the bootstrap confidence bars." +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 5.5 + +f5y <- cph(Surv(time, status) ~ age + gender + stage3, data = lihc_cal, + x = TRUE, y = TRUE, surv = TRUE, time.inc = 1825) +cal5y <- calibrate(f5y, cmethod = "KM", method = "boot", u = 1825, B = 200) +plot(cal5y, xlab = "Predicted 5-year survival probability", + ylab = "Observed survival (KM)", subtitles = FALSE) +``` + +::: callout-tip +**Practice tips** + +- `time.inc` and `u` must be the **same horizon**, and `surv = TRUE` must be set at fit time — `calibrate()` re-uses the survival function stored inside the fit; mismatched horizons silently calibrate the wrong endpoint. +- `cmethod = "KM"` compares against Kaplan–Meier estimates in prediction bands; report B (here 200) — small B makes the error bars themselves noisy. +- Two horizons on one page (3-year and 5-year) is the standard clinical presentation: a model can calibrate well early and drift late. + +::: callout-note +**Interactive variant.** FigureYa30Plus ships a browser-based nomogram app (a PWA you can open offline): . It lets a clinician drag each variable and read the predicted probability instantly — useful for teaching and clinical discussion; for publication, the static nomogram plus a calibration plot above remains the required pair. +::: +::: + ## Application ::: {#fig-NomogramApplications} @@ -220,3 +276,5 @@ This figure shows two schematics of clinical applications that integrate a 6-miR \[2\] Zhang JX, Song W, Chen ZH, et al. Prognostic and predictive value of a microRNA signature in stage II colon cancer: a microRNA expression analysis [published correction appears in Lancet Oncol. 2014 Jan;15(1):e4]. Lancet Oncol. 2013;14(13):1295-1306. doi:10.1016/S1470-2045(13)70491-1 +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + diff --git a/Clinics/Nomogram.zh.qmd b/Clinics/Nomogram.zh.qmd index 1c64227fd..f3fb30559 100644 --- a/Clinics/Nomogram.zh.qmd +++ b/Clinics/Nomogram.zh.qmd @@ -205,6 +205,62 @@ regplot(lihccox, 美化诺莫图2 ::: +### 3. 校准诺莫图 + +诺莫图是一个预测模型,因此在使用(或发表)之前必须做**校准**:预测的生存概率与观测值是否一致?参考工作流 \[3\] 用 `rms::cph(..., surv = TRUE, time.inc = ...)` 拟合同一个 Cox 模型,再用 `rms::calibrate()`(bootstrap 偏差校正,观测值取 horizon 时刻的 Kaplan–Meier 估计)。理想的诺莫图贴着 45° 虚线;表观(×)与偏差校正(•)曲线之间的距离显示了乐观校正所扣除的过拟合量。 + +```{r} +#| label: fig-3.1Calibration3y +#| fig-cap: "Cox 诺莫图 3 年(u = 1095 天)的 bootstrap 校准:表观(×)与偏差校正(•)生存相对 45° 理想线。" +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 5.5 + +## 合并 TCGA 分期标签(Stage IA/IB -> Stage I),保证每个水平都有足够样本 +lihc_cal <- LIHC +lihc_cal$stage3 <- factor(sub("[ABCD]$", "", as.character(lihc_cal$stage))) +lihc_cal$gender <- factor(lihc_cal$gender) +lihc_cal <- lihc_cal[complete.cases(lihc_cal[, c("time", "status", "age", "gender", "stage3")]), ] +dd2 <- datadist(lihc_cal) +options(datadist = "dd2") + +f3y <- cph(Surv(time, status) ~ age + gender + stage3, data = lihc_cal, + x = TRUE, y = TRUE, surv = TRUE, time.inc = 1095) +cal3y <- calibrate(f3y, cmethod = "KM", method = "boot", u = 1095, B = 200) +plot(cal3y, xlab = "Predicted 3-year survival probability", + ylab = "Observed survival (KM)", subtitles = FALSE) +``` + +```{r} +#| label: fig-3.2Calibration5y +#| fig-cap: "Cox 诺莫图 5 年(u = 1825 天)的 bootstrap 校准:模型在 bootstrap 误差条内贴合理想线。" +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 5.5 + +f5y <- cph(Surv(time, status) ~ age + gender + stage3, data = lihc_cal, + x = TRUE, y = TRUE, surv = TRUE, time.inc = 1825) +cal5y <- calibrate(f5y, cmethod = "KM", method = "boot", u = 1825, B = 200) +plot(cal5y, xlab = "Predicted 5-year survival probability", + ylab = "Observed survival (KM)", subtitles = FALSE) +``` + +::: callout-tip +**实践要点** + +- `time.inc` 与 `u` 必须是**同一个 horizon**,且拟合时要设 `surv = TRUE`——`calibrate()` 复用拟合对象内部保存的生存函数;horizon 不一致会静默地校准错误的终点。 +- `cmethod = "KM"` 在预测分带内与 Kaplan–Meier 估计比较;请报告 B(此处 200)——B 太小会让误差条本身不可靠。 +- 两个 horizon 并排展示(3 年与 5 年)是标准的临床呈现:模型可能早期校准良好、晚期漂移。 + +::: callout-note +**交互式变体。** FigureYa30Plus 提供一个基于浏览器的诺莫图应用(可离线打开的 PWA):。临床医生拖动各变量即可即时读出预测概率——适合教学与临床讨论;发表论文时,静态诺莫图加上文所示的校准曲线仍是必需组合。 +::: +::: + ## 应用场景 ::: {#fig-NomogramApplications} @@ -221,3 +277,5 @@ regplot(lihccox, \[2\] Zhang JX, Song W, Chen ZH, et al. Prognostic and predictive value of a microRNA signature in stage II colon cancer: a microRNA expression analysis [published correction appears in Lancet Oncol. 2014 Jan;15(1):e4]. Lancet Oncol. 2013;14(13):1295-1306. doi:10.1016/S1470-2045(13)70491-1 +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + diff --git a/Clinics/RegressionTable.qmd b/Clinics/RegressionTable.qmd index f8747ffc2..5dbb4ef57 100644 --- a/Clinics/RegressionTable.qmd +++ b/Clinics/RegressionTable.qmd @@ -20,7 +20,7 @@ The figure below shows a regression analysis based on the pbc dataset built into - Programming language: R -- Dependent packages: `survival`, `gtsummary`, `dplyr`, `datawizard` +- Dependent packages: `survival`, `gtsummary`, `dplyr`, `datawizard`, `kableExtra` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Installing packages @@ -45,7 +45,13 @@ library(survival) library(gtsummary) library(dplyr) library(datawizard) +# Install kableExtra if missing (used by the grouped HR table) +if (!requireNamespace("kableExtra", quietly = TRUE)) { + install.packages("kableExtra", repos = "https://cloud.r-project.org") +} library(broom.helpers) +library(kableExtra) +library(kableExtra) ``` ```{r} @@ -279,7 +285,158 @@ tbl_stack(list(t1, t2), group_header = c("Patients without hepato", "Patients wi This table uses `tbl_stack` to longitudinally integrate the results of the Cox proportional hazards model for the two groups of pdb patients with and without hepato. -## Application +### 7. HR Table: Univariate + Multivariate, Training vs Validation Cohorts + +The FigureYa47 layout \[3\] is the publication-grade companion table: every covariate runs through **batch univariate Cox**, the p < 0.05 survivors enter a **multivariate model**, and the whole thing repeats on an independent validation cohort — printed as one grouped kable table with `HR (95% CI)` and p-value columns per cohort: + +```{r} +#| label: tbl-7.1HrTable +#| tbl-cap: "Univariate and multivariate Cox analyses of simulated covariates: training cohort (70%) and validation cohort (30%); multivariate columns only carry the covariates significant in the training univariate screen." +#| warning: false +#| message: false + +set.seed(4701) +n_hr <- 260 +hrdata <- data.frame( + age = factor(ifelse(rnorm(n_hr, 62, 10) > 62, ">=median", "=median")), + stage = factor(sample(c("I-II", "III-IV"), n_hr, TRUE), levels = c("I-II", "III-IV")), + invasion = factor(sample(c("no", "yes"), n_hr, TRUE, c(0.6, 0.4)), levels = c("no", "yes")), + marker = factor(ifelse(rnorm(n_hr) > 0, ">=median", "=median"))) +lp <- -3.4 + 0.35 * (hrdata$stage == "III-IV") + 0.5 * (hrdata$invasion == "yes") - + 0.45 * (hrdata$marker == ">=median") +hrdata$time <- rexp(n_hr, exp(lp) * 0.02) +hrdata$event <- rbinom(n_hr, 1, 0.8) +vars <- c("age", "stage", "invasion", "marker") + +uni_cox <- function(dat) { + do.call(rbind, lapply(vars, function(v) { + sm <- summary(coxph(as.formula(paste0("Surv(time, event) ~ ", v)), data = dat)) + data.frame(characteristics = v, + HR = round(sm$coefficients[, "exp(coef)"], 2), + CI = paste0(round(sm$conf.int[, "lower .95"], 2), "-", + round(sm$conf.int[, "upper .95"], 2)), + p = sm$coefficients[, "Pr(>|z|)"]) + })) +} +set.seed(4702) +train_idx <- sample(n_hr, round(n_hr * 0.7)) +tr <- hrdata[train_idx, ]; va <- hrdata[-train_idx, ] +uni_tr <- uni_cox(tr); uni_va <- uni_cox(va) +sig_vars <- uni_tr$characteristics[uni_tr$p < 0.05] + +mk_rows <- function(sm, sig_vars) { + cm <- sm$coefficients; ci <- sm$conf.int + do.call(rbind, lapply(vars, function(v) { + idx <- which(startsWith(rownames(cm), v)) # factor contrasts: "stageIII-IV" + if (length(idx) == 1) { + data.frame(characteristics = v, HR = round(cm[idx, "exp(coef)"], 2), + CI = paste0(round(ci[idx, "lower .95"], 2), "-", + round(ci[idx, "upper .95"], 2)), + p = ifelse(cm[idx, "Pr(>|z|)"] < 0.001, "< 0.001", + round(cm[idx, "Pr(>|z|)"], 3))) + } else { + data.frame(characteristics = v, HR = NA, CI = NA, p = NA) + } + })) +} +m_tr <- mk_rows(summary(coxph(as.formula(paste("Surv(time, event) ~", + paste(sig_vars, collapse = "+"))), data = tr)), sig_vars) +m_va <- mk_rows(summary(coxph(as.formula(paste("Surv(time, event) ~", + paste(sig_vars, collapse = "+"))), data = va)), sig_vars) + +fmt <- function(df) dplyr::mutate( + df, + characteristics = dplyr::case_when( + characteristics == "age" ~ "Age (>=median vs =median vs % + dplyr::select(characteristics, `HR (95% CI)`, `P value`) + +tbl <- data.frame( + characteristics = c("", "Training cohort (n = 182)", fmt(uni_tr)$characteristics, + "Validation cohort (n = 78)", fmt(uni_va)$characteristics), + uni_hr = c("", "", fmt(uni_tr)$`HR (95% CI)`, "", fmt(uni_va)$`HR (95% CI)`), + uni_p = c("", "", fmt(uni_tr)$`P value`, "", fmt(uni_va)$`P value`), + multi_hr = c("HR (95% CI)", "", fmt(m_tr)$`HR (95% CI)`, "", fmt(m_va)$`HR (95% CI)`), + multi_p = c("P value", "", fmt(m_tr)$`P value`, "", fmt(m_va)$`P value`), + stringsAsFactors = FALSE) + +kableExtra::kable(tbl, booktabs = TRUE, escape = FALSE, + col.names = c("Characteristics", "Univariate analysis", "", + "Multivariate analysis", ""), + caption = "Univariate and multivariate Cox analyses, training vs validation (simulated)") %>% + kableExtra::kable_styling(c("striped", "scale_down"), font_size = 11) %>% + kableExtra::add_header_above(c(" " = 1, "Training cohort" = 2, "Validation cohort" = 2)) +``` + +::: callout-tip +**Practice tips** + +- Factor contrast rows in a Cox summary are named `stageIII-IV`, not `stage` — match them with `startsWith(rownames(cm), v)` when assembling the table programmatically, or the multivariate column silently fills with blanks. +- The multivariate column shows **only the covariates that survived the training univariate screen**, and the same formula (not re-screened) is applied to the validation cohort — re-screening per cohort is a subtle double-dipping. +- `add_header_above()` places the cohort names over the column pairs; keep `escape = FALSE` so the bracketed CI strings render. +::: + +### 8. Batch Univariate Cox Forest Plot (FigureYa66UnivariateCox) + +FigureYa66 \[11\] loops a Cox model over **every gene's expression** and draws the survivors as a forest: diamond point = HR, error bars = 95% CI, x on log2, viridis colour = p-value, HR = 1 dashed. The reference's `theme_ggstatsplot()` needs a sourced helper file, so the block below uses the plain `theme_bw()` equivalent. The same loop feeds FigureYa6rHRs forest variants by renaming the columns to HR / lower / upper: + +```{r} +#| label: tbl-8.1UnivariateCoxForest +#| tbl-cap: "Batch univariate Cox screen of 24 simulated genes: only genes with p < 0.05 and HR outside the 0.92-1.15 band are drawn; viridis colour encodes the p-value." +#| warning: false +#| message: false + +## freeze:auto re-executes only new chunks in a fresh session — +## re-attach the needed packages here +suppressPackageStartupMessages({library(survival); library(ggplot2); library(dplyr)}) +set.seed(6601) +n_ux <- 240 +ux <- data.frame(futime = rexp(n_ux, 0.02), fustat = rbinom(n_ux, 1, 0.8)) +gene_expr <- matrix(rnorm(n_ux * 24, 5, 1.2), n_ux, 24, + dimnames = list(NULL, paste0("GENE", sprintf("%02d", 1:24)))) +## plant one protective and one risk gene so the screen has a signal +gene_expr[, 1] <- gene_expr[, 1] - (ux$futime < quantile(ux$futime, 0.4)) * 1.8 +gene_expr[, 5] <- gene_expr[, 5] + (ux$futime < quantile(ux$futime, 0.4)) * 1.8 +ux_all <- cbind(ux, as.data.frame(gene_expr)) +Coxoutput <- do.call(rbind, lapply(paste0("GENE", sprintf("%02d", 1:24)), function(g) { + sm <- summary(coxph(as.formula(paste0("Surv(futime, fustat) ~ ", g)), data = ux_all)) + data.frame(gene = g, + HR = sm$coefficients[, "exp(coef)"], + lower = sm$conf.int[, "lower .95"], + upper = sm$conf.int[, "upper .95"], + pvalue = sm$coefficients[, "Pr(>|z|)"]) +})) +Coxoutput <- dplyr::arrange(Coxoutput, pvalue) %>% dplyr::filter(pvalue < 0.05) +plotCoxoutput <- dplyr::filter(Coxoutput, HR <= 0.92 | HR >= 1.15) + +ggplot(data = plotCoxoutput, aes(x = HR, y = gene, color = pvalue)) + + geom_errorbarh(aes(xmax = upper, xmin = lower), color = "black", + height = 0, linewidth = 1.1) + + geom_point(aes(x = HR, y = gene), size = 3.5, shape = 18) + + geom_vline(xintercept = 1, linetype = "dashed", linewidth = 1) + + coord_trans(x = "log2") + + scale_color_viridis_c() + + labs(x = "Hazard ratio, univariate Cox (simulated LUAD-like cohort)", + y = "Gene", colour = "P value", + title = "Univariate Cox regression screen") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**Practice tips** + +- Screen, then filter for *effect size too* (the reference's HR ≤ 0.92 | ≥ 1.15): with enough genes, pure noise still produces p < 0.05 hits whose HR is clinically meaningless. +- The p-value colour ramp adds nothing the error bars don't already show — but it makes the reader's eye rank the hits exactly as the table would; keep it and say the scale. +- Like any p < 0.05 screen over 24 genes, expect ~1 false hit; validate the survivors in an independent cohort before drawing conclusions. +::: + +## Application## Application ::: {#fig-RegressionTableApplications1} ![](../images/Clinics/RegressionTable_app1.png){fig-alt="RegressionTableApp1" fig-align="center" width="60%"} @@ -302,3 +459,5 @@ This regression analysis table shows the independent predictors of late total mo \[1\] CHEN J X, HUANG W T, ZHANG Q Y, et al. The optimal intravesical maintenance chemotherapy scheme for the intermediate-risk group non-muscle-invasive bladder cancer[J]. BMC Cancer, 2023,23(1): 1018. \[2\] BENKE K, ÁGG B, SZABÓ L, et al. Bentall procedure: quarter century of clinical experiences of a single surgeon[J]. J Cardiothorac Surg, 2016,11: 19. + +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/RegressionTable.zh.qmd b/Clinics/RegressionTable.zh.qmd index 314938341..7af7975fa 100644 --- a/Clinics/RegressionTable.zh.qmd +++ b/Clinics/RegressionTable.zh.qmd @@ -45,7 +45,12 @@ library(survival) library(gtsummary) library(dplyr) library(datawizard) +# Install kableExtra if missing (used by the grouped HR table) +if (!requireNamespace("kableExtra", quietly = TRUE)) { + install.packages("kableExtra", repos = "https://cloud.r-project.org") +} library(broom.helpers) +library(kableExtra) ``` ```{r} @@ -279,7 +284,157 @@ tbl_stack(list(t1, t2), group_header = c("Patients without hepato", "Patients wi 该表使用`tbl_stack`纵向整合了有无hepato的两组pdb患者的Cox比例风险模型的结果。 -## 应用场景 +### 7. HR 表:单因素 + 多因素,训练 vs 验证队列 + +FigureYa47 版式 \[3\] 是论文级的配套表格:每个协变量做**批量单因素 Cox**,p < 0.05 者进入**多因素模型**,整套流程在独立验证队列上重跑——以一张分组 kable 表输出,每个队列各带 `HR (95% CI)` 与 p 值列: + +```{r} +#| label: tbl-7.1HrTable +#| tbl-cap: "模拟协变量的单因素与多因素 Cox 分析:训练队列(70%)与验证队列(30%);多因素列仅保留训练集单因素筛选显著(p < 0.05)的协变量。" +#| warning: false +#| message: false + +set.seed(4701) +n_hr <- 260 +hrdata <- data.frame( + age = factor(ifelse(rnorm(n_hr, 62, 10) > 62, ">=median", "=median")), + stage = factor(sample(c("I-II", "III-IV"), n_hr, TRUE), levels = c("I-II", "III-IV")), + invasion = factor(sample(c("no", "yes"), n_hr, TRUE, c(0.6, 0.4)), levels = c("no", "yes")), + marker = factor(ifelse(rnorm(n_hr) > 0, ">=median", "=median"))) +lp <- -3.4 + 0.35 * (hrdata$stage == "III-IV") + 0.5 * (hrdata$invasion == "yes") - + 0.45 * (hrdata$marker == ">=median") +hrdata$time <- rexp(n_hr, exp(lp) * 0.02) +hrdata$event <- rbinom(n_hr, 1, 0.8) +vars <- c("age", "stage", "invasion", "marker") + +uni_cox <- function(dat) { + do.call(rbind, lapply(vars, function(v) { + sm <- summary(coxph(as.formula(paste0("Surv(time, event) ~ ", v)), data = dat)) + data.frame(characteristics = v, + HR = round(sm$coefficients[, "exp(coef)"], 2), + CI = paste0(round(sm$conf.int[, "lower .95"], 2), "-", + round(sm$conf.int[, "upper .95"], 2)), + p = sm$coefficients[, "Pr(>|z|)"]) + })) +} +set.seed(4702) +train_idx <- sample(n_hr, round(n_hr * 0.7)) +tr <- hrdata[train_idx, ]; va <- hrdata[-train_idx, ] +uni_tr <- uni_cox(tr); uni_va <- uni_cox(va) +sig_vars <- uni_tr$characteristics[uni_tr$p < 0.05] + +mk_rows <- function(sm, sig_vars) { + cm <- sm$coefficients; ci <- sm$conf.int + do.call(rbind, lapply(vars, function(v) { + idx <- which(startsWith(rownames(cm), v)) # 因子对比行名形如 "stageIII-IV" + if (length(idx) == 1) { + data.frame(characteristics = v, HR = round(cm[idx, "exp(coef)"], 2), + CI = paste0(round(ci[idx, "lower .95"], 2), "-", + round(ci[idx, "upper .95"], 2)), + p = ifelse(cm[idx, "Pr(>|z|)"] < 0.001, "< 0.001", + round(cm[idx, "Pr(>|z|)"], 3))) + } else { + data.frame(characteristics = v, HR = NA, CI = NA, p = NA) + } + })) +} +m_tr <- mk_rows(summary(coxph(as.formula(paste("Surv(time, event) ~", + paste(sig_vars, collapse = "+"))), data = tr)), sig_vars) +m_va <- mk_rows(summary(coxph(as.formula(paste("Surv(time, event) ~", + paste(sig_vars, collapse = "+"))), data = va)), sig_vars) + +fmt <- function(df) dplyr::mutate( + df, + characteristics = dplyr::case_when( + characteristics == "age" ~ "Age (>=median vs =median vs % + dplyr::select(characteristics, `HR (95% CI)`, `P value`) + +tbl <- data.frame( + characteristics = c("", "Training cohort (n = 182)", fmt(uni_tr)$characteristics, + "Validation cohort (n = 78)", fmt(uni_va)$characteristics), + uni_hr = c("", "", fmt(uni_tr)$`HR (95% CI)`, "", fmt(uni_va)$`HR (95% CI)`), + uni_p = c("", "", fmt(uni_tr)$`P value`, "", fmt(uni_va)$`P value`), + multi_hr = c("HR (95% CI)", "", fmt(m_tr)$`HR (95% CI)`, "", fmt(m_va)$`HR (95% CI)`), + multi_p = c("P value", "", fmt(m_tr)$`P value`, "", fmt(m_va)$`P value`), + stringsAsFactors = FALSE) + +kableExtra::kable(tbl, booktabs = TRUE, escape = FALSE, + col.names = c("Characteristics", "Univariate analysis", "", + "Multivariate analysis", ""), + caption = "Univariate and multivariate Cox analyses, training vs validation (simulated)") %>% + kableExtra::kable_styling(c("striped", "scale_down"), font_size = 11) %>% + kableExtra::add_header_above(c(" " = 1, "Training cohort" = 2, "Validation cohort" = 2)) +``` + +::: callout-tip +**实践要点** + +- Cox 摘要中因子对比行名是 `stageIII-IV` 而非 `stage`——程序化装配表格时用 `startsWith(rownames(cm), v)` 匹配,否则多因素列会静默地填满空白。 +- 多因素列**只显示训练集单因素筛选存活者**,且同一公式(不再逐队重筛)用于验证队列——逐队重筛是隐性双重 dipping。 +- `add_header_above()` 把队列名放到列对上方;保留 `escape = FALSE` 让括号 CI 字符串正常渲染。 +::: + +### 8. 批量单因素 Cox 森林图(FigureYa66UnivariateCox) + +FigureYa66 \[11\] 对**每个基因的表达**循环拟合 Cox 模型,把幸存者画成森林图:菱形点 = HR,误差线 = 95% CI,x 轴 log2,viridis 颜色 = p 值,HR = 1 虚线。参考文档的 `theme_ggstatsplot()` 需要外部 helper 文件,下块改用等价的朴素 `theme_bw()`。同一循环把列改名为 HR / lower / upper 后即可衔接 FigureYa6rHRs 的各种森林变体: + +```{r} +#| label: tbl-8.1UnivariateCoxForest +#| tbl-cap: "24 个模拟基因的批量单因素 Cox 筛选:仅绘制 p < 0.05 且 HR 落在 0.92-1.15 带外的基因;viridis 颜色编码 p 值。" +#| warning: false +#| message: false + +## freeze:auto 只对新 chunk 在新会话中重跑——在此重新挂载所需包 +suppressPackageStartupMessages({library(survival); library(ggplot2); library(dplyr)}) +set.seed(6601) +n_ux <- 240 +ux <- data.frame(futime = rexp(n_ux, 0.02), fustat = rbinom(n_ux, 1, 0.8)) +gene_expr <- matrix(rnorm(n_ux * 24, 5, 1.2), n_ux, 24, + dimnames = list(NULL, paste0("GENE", sprintf("%02d", 1:24)))) +## 植入一个保护基因与一个风险基因,让筛选有信号 +gene_expr[, 1] <- gene_expr[, 1] - (ux$futime < quantile(ux$futime, 0.4)) * 1.8 +gene_expr[, 5] <- gene_expr[, 5] + (ux$futime < quantile(ux$futime, 0.4)) * 1.8 +ux_all <- cbind(ux, as.data.frame(gene_expr)) +Coxoutput <- do.call(rbind, lapply(paste0("GENE", sprintf("%02d", 1:24)), function(g) { + sm <- summary(coxph(as.formula(paste0("Surv(futime, fustat) ~ ", g)), data = ux_all)) + data.frame(gene = g, + HR = sm$coefficients[, "exp(coef)"], + lower = sm$conf.int[, "lower .95"], + upper = sm$conf.int[, "upper .95"], + pvalue = sm$coefficients[, "Pr(>|z|)"]) +})) +Coxoutput <- dplyr::arrange(Coxoutput, pvalue) %>% dplyr::filter(pvalue < 0.05) +plotCoxoutput <- dplyr::filter(Coxoutput, HR <= 0.92 | HR >= 1.15) + +ggplot(data = plotCoxoutput, aes(x = HR, y = gene, color = pvalue)) + + geom_errorbarh(aes(xmax = upper, xmin = lower), color = "black", + height = 0, linewidth = 1.1) + + geom_point(aes(x = HR, y = gene), size = 3.5, shape = 18) + + geom_vline(xintercept = 1, linetype = "dashed", linewidth = 1) + + coord_trans(x = "log2") + + scale_color_viridis_c() + + labs(x = "Hazard ratio, univariate Cox (simulated LUAD-like cohort)", + y = "Gene", colour = "P value", + title = "Univariate Cox regression screen") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**实践要点** + +- 筛选后还要过滤*效应量*(参考的 HR ≤ 0.92 | ≥ 1.15):基因足够多时,纯噪声也会产生 HR 临床上毫无意义的 p < 0.05 命中。 +- p 值色带并不提供误差线之外的信息——但它让读者的眼睛按表格顺序排列命中;保留它并写明标尺。 +- 24 个基因的 p < 0.05 筛选预期约 1 个假命中;在独立队列验证幸存者后再下结论。 +::: + +## 应用场景## 应用场景 ::: {#fig-RegressionTableApplications1} ![](../images/Clinics/RegressionTable_app1.png){fig-alt="RegressionTableApp1" fig-align="center" width="60%"} @@ -302,3 +457,5 @@ tbl_stack(list(t1, t2), group_header = c("Patients without hepato", "Patients wi \[1\] CHEN J X, HUANG W T, ZHANG Q Y, et al. The optimal intravesical maintenance chemotherapy scheme for the intermediate-risk group non-muscle-invasive bladder cancer[J]. BMC Cancer, 2023,23(1): 1018. \[2\] BENKE K, ÁGG B, SZABÓ L, et al. Bentall procedure: quarter century of clinical experiences of a single surgeon[J]. J Cardiothorac Surg, 2016,11: 19. + +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Clinics/SubgroupForestPlot.qmd b/Clinics/SubgroupForestPlot.qmd index 36eca7777..e262a2d30 100644 --- a/Clinics/SubgroupForestPlot.qmd +++ b/Clinics/SubgroupForestPlot.qmd @@ -233,7 +233,7 @@ clin <- data.frame( stage = rep(c("Stage I-II", "Stage III-IV"), times = n / 2), time = rexp(n, 0.05), event = sample(0:1, n, replace = TRUE, prob = c(0.4, 0.6))) -# treatment effect varies by subgroup +# event times differ by age group (younger patients live longer here) clin$time[clin$age_group == "Age > 60" & clin$event == 1] <- clin$time[clin$age_group == "Age > 60" & clin$event == 1] * 0.6 diff --git a/Clinics/SubgroupForestPlot.zh.qmd b/Clinics/SubgroupForestPlot.zh.qmd index 039d87cd7..23aec8612 100644 --- a/Clinics/SubgroupForestPlot.zh.qmd +++ b/Clinics/SubgroupForestPlot.zh.qmd @@ -260,8 +260,6 @@ patchwork::wrap_plots(p1$plot, p2$plot, ncol = 2) ## Application -## Application - 亚组森林图是临床试验报告的标配(多数 NEJM/Lancet 肿瘤试验正文的第 1 张图),也常见于观察性病因学研究与生物标志物驱动的研究——核心问题是治疗*对谁*有效。下图模拟典型论文版式:(A) 标准亚组森林图,(B) 区间跨越一个数量级时使用的对数坐标展示。 ![](../images/Clinics/SubgroupForestPlot_app1.png){fig-alt="SubgroupForestPlot Application" fig-align="center" width="60%"} diff --git a/Clinics/TumorIndexPlot.qmd b/Clinics/TumorIndexPlot.qmd index a96b8248a..d79798297 100644 --- a/Clinics/TumorIndexPlot.qmd +++ b/Clinics/TumorIndexPlot.qmd @@ -45,7 +45,7 @@ sessioninfo::session_info("attached") ## Data Preparation -The reference workflow trains a random forest / elastic-net model on RNA-seq from control vs tumour samples and scores external cohorts. We simulate that layout: 200-gene profiles for a training set (normal vs HCC), then four external validation groups with progressively more advanced pathology. +The reference workflow trains a random forest / elastic-net model on RNA-seq from control vs tumour samples and scores external cohorts. We simulate that layout: 50-gene profiles for a training set (normal vs HCC), then four external validation groups with progressively more advanced pathology. ```{r load data, message=FALSE, warning=FALSE} set.seed(1501) @@ -69,7 +69,7 @@ val_lab <- factor(rep(stages, each = 30), levels = stages) colnames(val_expr) <- paste0("VA_", sprintf("%04d", 1:n_gene)) ``` -## Train the Model and Score the Validation Cohorts +## Score the Validation Cohorts with a Signature-Based Tumor Index ```{r model, message=FALSE, warning=FALSE} ## Elastic-net logistic on the training split (the reference uses random @@ -107,7 +107,7 @@ ggplot(val_df, aes(stage, TI, fill = stage)) + stat_compare_means(method = "kruskal.test", label.y = max(val_df$TI) + 0.06) + scale_fill_manual(values = c(Normal = "#4D4D4D", Fibrosis = "#445EAD", Dysplasia = "#EABF00", HCC = "#B2182B")) + - labs(x = "Pathological stage", y = "Tumor index (0 = normal, 1 = cancer)", + labs(x = "Pathological stage", y = "Tumor index (mean of up genes − mean of down genes)", fill = "Stage") + theme_classic(base_size = 11) + theme(legend.position = "top", legend.key.size = unit(3, "mm")) @@ -125,12 +125,15 @@ ggplot(val_df, aes(stage, TI, fill = stage)) + #| fig-height: 4 ## two simulated external cohorts to mirror the multi-panel layout -val_df$cohort <- ifelse(seq_len(nrow(val_df)) <= 60, "GSE36376-like", "GSE6764-like") +## alternate samples into two cohorts so each spans all four stages +## (a block split would confound cohort with stage) +val_df$cohort <- ifelse(seq_len(nrow(val_df)) %% 2 == 1, + "GSE36376-like", "GSE6764-like") ggplot(val_df, aes(stage, TI, fill = stage)) + geom_boxplot(outlier.shape = NA, width = 0.6) + facet_wrap(~cohort, nrow = 1) + - stat_compare_means(method = "kruskal.test", label.x = 0.6, size = 3.2) + + stat_compare_means(method = "kruskal.test", label.x = 2, size = 3.2) + scale_fill_manual(values = c(Normal = "#4D4D4D", Fibrosis = "#445EAD", Dysplasia = "#EABF00", HCC = "#B2182B")) + labs(x = NULL, y = "Tumor index", fill = "Stage") + diff --git a/Clinics/TumorIndexPlot.zh.qmd b/Clinics/TumorIndexPlot.zh.qmd index 93bda026d..ca06d4afa 100644 --- a/Clinics/TumorIndexPlot.zh.qmd +++ b/Clinics/TumorIndexPlot.zh.qmd @@ -45,7 +45,7 @@ sessioninfo::session_info("attached") ## Data Preparation -参考工作流在对照 vs 肿瘤的 RNA-seq 上训练随机森林/弹性网络模型,并对外部队列打分。我们模拟该版式:训练集(正常 vs HCC)的 200 基因谱,以及病理逐渐进展的四个外部验证组。 +参考工作流在对照 vs 肿瘤的 RNA-seq 上训练随机森林/弹性网络模型,并对外部队列打分。我们模拟该版式:训练集(正常 vs HCC)的 50 基因谱,以及病理逐渐进展的四个外部验证组。 ```{r load data, message=FALSE, warning=FALSE} set.seed(1501) @@ -69,7 +69,7 @@ val_lab <- factor(rep(stages, each = 30), levels = stages) colnames(val_expr) <- paste0("VA_", sprintf("%04d", 1:n_gene)) ``` -## 训练模型并为验证队列打分 +## 用 signature 型肿瘤指数为验证队列打分 ```{r model, message=FALSE, warning=FALSE} ## 在训练集上拟合弹性网络 logistic(参考文献用随机森林; @@ -107,7 +107,7 @@ ggplot(val_df, aes(stage, TI, fill = stage)) + stat_compare_means(method = "kruskal.test", label.y = max(val_df$TI) + 0.06) + scale_fill_manual(values = c(Normal = "#4D4D4D", Fibrosis = "#445EAD", Dysplasia = "#EABF00", HCC = "#B2182B")) + - labs(x = "Pathological stage", y = "Tumor index (0 = normal, 1 = cancer)", + labs(x = "Pathological stage", y = "Tumor index (mean of up genes − mean of down genes)", fill = "Stage") + theme_classic(base_size = 11) + theme(legend.position = "top", legend.key.size = unit(3, "mm")) @@ -125,12 +125,15 @@ ggplot(val_df, aes(stage, TI, fill = stage)) + #| fig-height: 4 ## two simulated external cohorts to mirror the multi-panel layout -val_df$cohort <- ifelse(seq_len(nrow(val_df)) <= 60, "GSE36376-like", "GSE6764-like") +## alternate samples into two cohorts so each spans all four stages +## (a block split would confound cohort with stage) +val_df$cohort <- ifelse(seq_len(nrow(val_df)) %% 2 == 1, + "GSE36376-like", "GSE6764-like") ggplot(val_df, aes(stage, TI, fill = stage)) + geom_boxplot(outlier.shape = NA, width = 0.6) + facet_wrap(~cohort, nrow = 1) + - stat_compare_means(method = "kruskal.test", label.x = 0.6, size = 3.2) + + stat_compare_means(method = "kruskal.test", label.x = 2, size = 3.2) + scale_fill_manual(values = c(Normal = "#4D4D4D", Fibrosis = "#445EAD", Dysplasia = "#EABF00", HCC = "#B2182B")) + labs(x = NULL, y = "Tumor index", fill = "Stage") + diff --git a/Colors.qmd b/Colors.qmd index b062047fb..40ddd552e 100644 --- a/Colors.qmd +++ b/Colors.qmd @@ -17,12 +17,12 @@ Color is the most-used — and most-abused — encoding channel in scientific fi - Programming Language: R (Python equivalents are shown in Part II) -- Dependencies: `tidyverse`; `colorspace`; `RColorBrewer`; `viridisLite`; `paletteer`; `ggsci`; `patchwork` +- Dependencies: `tidyverse`; `colorspace`; `RColorBrewer`; `viridisLite`; `paletteer`; `ggsci`; `patchwork`; `png` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Installing necessary packages pkgs <- c("tidyverse", "colorspace", "RColorBrewer", "viridisLite", - "paletteer", "ggsci", "patchwork") + "paletteer", "ggsci", "patchwork", "png") for (pkg in pkgs) { if (!requireNamespace(pkg, quietly = TRUE)) { install.packages(pkg, repos = "https://cloud.r-project.org") @@ -36,6 +36,7 @@ library(RColorBrewer) library(viridisLite) library(ggsci) library(patchwork) +library(png) # The standard 8-color Okabe-Ito palette (Okabe & Ito 2008; black variant popularized by Wong 2011) okabe <- c("#000000", "#E69F00", "#56B4E9", "#009E73", @@ -706,6 +707,144 @@ embed |> legend.position = "bottom") ``` +## Visualization · Part III — borrowing a palette from a figure you admire + +When a published figure has exactly the palette you want, extract it from the image instead of eyeballing hex codes — the FigureYa collection demonstrates this workflow with `rPlotter::extract_colours()` \[14\]. That package needs EBImage and a GitHub install, but the same job needs only two tools already in this page's toolkit: read the pixels with `png::readPNG()` and cluster them with base `kmeans()`. The pipeline: subsample the pixel grid, drop achromatic pixels (the white background, black text and grey anti-aliasing edges), k-means the remaining RGB triples with k = the number of visible hues, and order the cluster centres by pixel count — the dominant color comes first. + +To keep the example self-contained, the "reference figure" below is generated by the code itself; in practice you would point `readPNG()` at any figure image you admire: + +```{r} +#| label: pal-extract-ref +#| fig-cap: "The stand-in 'reference figure' whose colors we will borrow — five clusters, one hue each, black text on a white background." +#| fig-alt: "A scatter plot of five simulated sample clusters, each in a distinct saturated color, with regression lines per cluster." +#| out.width: "75%" +#| warning: false +#| message: false +#| fig-width: 6.2 +#| fig-height: 4.6 + +set.seed(2828) +ref_cols <- c("#E64B35", "#4DBBD5", "#00A087", "#3C5488", "#7E6148") +sim_pts <- purrr::map_dfr(1:5, function(i) { + tibble(x = rnorm(90, c(1, 2.4, 3.8, 5.2, 6.6)[i], 0.34), + y = rnorm(90, c(1, 3.4, 2.1, 4.2, 1.6)[i], 0.42), + cl = factor(i)) +}) +p_ref <- ggplot(sim_pts, aes(x, y, colour = cl)) + + geom_point(size = 1.7, alpha = 0.85, show.legend = FALSE) + + geom_smooth(method = "lm", linewidth = 0.7, se = FALSE, show.legend = FALSE) + + scale_colour_manual(values = ref_cols) + + labs(title = "Figure 2 | Simulated reference figure", x = NULL, y = NULL) + + theme_bw(base_size = 13) + + theme(panel.grid = element_blank()) +# write to a temp file; the next chunk reads the pixels back +ref_png <- file.path(tempdir(), "bizard_ref_figure.png") +ggsave(ref_png, p_ref, width = 6.2, height = 4.6, dpi = 200) +p_ref +``` + +```{r} +#| label: pal-extract +#| fig-cap: "Palette extracted from the reference figure: k-means (k = 5) on RGB after dropping achromatic pixels, clusters ordered by pixel count." +#| fig-alt: "Five color swatches extracted by k-means from the reference figure: light blue, brown, dark blue, teal and red, each labeled with its hex code." +#| out.width: "90%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 3 + + +img <- png::readPNG(ref_png) # height x width x 4, values in [0, 1] +px <- img[, , 1:3] +dim(px) <- c(dim(px)[1] * dim(px)[2], 3) +px <- px[seq(1, nrow(px), by = 2), ] # subsample every other pixel +mx <- apply(px, 1, max); mn <- apply(px, 1, min) +keep <- mx < 0.94 & mx > 0.10 & (mx - mn) > 0.10 # drop white bg, black text, grey AA +pxk <- px[keep, ] + +set.seed(2828) +km <- kmeans(pxk, centers = 5, nstart = 20) +ord <- order(table(km$cluster), decreasing = TRUE) +pal_ext <- rgb(km$centers[ord, 1], km$centers[ord, 2], km$centers[ord, 3]) + +tibble(col = pal_ext, x = seq_along(pal_ext)) |> + ggplot(aes(x, .82, fill = col)) + + geom_tile(width = 1, height = .72, colour = "grey35", linewidth = .25) + + scale_fill_identity() + + scale_x_continuous(breaks = seq_along(pal_ext), labels = pal_ext, expand = c(.01, 0)) + + coord_cartesian(ylim = c(.42, 1.05)) + + labs(title = "k-means palette extracted from the reference figure (k = 5)", + x = NULL, y = NULL) + + theme_minimal(base_size = 11) + + theme(plot.title = element_text(size = 10.5, colour = "grey20"), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.x = element_text(size = 7.6, colour = "grey20", angle = 45, hjust = 1), + panel.grid = element_blank()) +``` + +The five hues survive extraction almost exactly. Two refinements complete the workflow. First, interpolation: `colorRampPalette()` fabricates transition colors inside a subset of the palette — the "add colors" step of the FigureYa recipe \[14\] — for when a design needs more steps than the extracted set provides. Second, the obligation every borrowed palette carries: it is **aesthetic, not validated** — run the Part II checks before adoption, because nothing in the extraction process optimizes for CVD separation or luminance monotonicity: + +```{r} +#| label: pal-extract-cvd +#| fig-cap: "The extracted palette under normal vision, deuteranopia and protanopia (colorspace::deutan/protan): the brown and dark-blue rows lose separation under CVD simulation." +#| fig-alt: "Three swatch strips of the same five extracted colors under normal vision, deuteranopia and protanopia; several hues converge under the deficiency simulations." +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 3.6 + +cvd_rows <- list( + "normal vision" = pal_ext, + "deuteranopia" = deutan(pal_ext), + "protanopia" = protan(pal_ext)) +purrr::imap_dfr(cvd_rows, ~ tibble(col = .x, x = seq_along(.x), pal = .y)) |> + mutate(pal = factor(pal, levels = names(cvd_rows))) |> + ggplot(aes(x, 1, fill = col)) + + geom_tile(width = 1, height = .8, colour = "white", linewidth = .3) + + facet_wrap(~pal, ncol = 1, strip.position = "left") + + scale_fill_identity() + scale_y_continuous(expand = c(0, 0)) + + theme_minimal(base_size = 11) + + theme(axis.text = element_blank(), axis.title = element_blank(), panel.grid = element_blank(), + strip.text.y.left = element_text(angle = 0, hjust = 0, size = 10), + strip.background = element_blank(), panel.spacing.y = unit(3, "mm")) +``` + +```{r} +#| label: pal-extract-interp +#| fig-cap: "colorRampPalette(pal[1:4], alpha = TRUE)(9): nine transition colors interpolated inside the first four extracted hues." +#| fig-alt: "A nine-swatch strip of interpolated colors spanning the light blue to dark blue range of the extracted palette." +#| out.width: "90%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 3 + +pal_plus <- colorRampPalette(pal_ext[1:4], alpha = TRUE)(9) +tibble(col = pal_plus, x = seq_along(pal_plus)) |> + ggplot(aes(x, .82, fill = col)) + + geom_tile(width = 1, height = .72, colour = "grey35", linewidth = .25) + + scale_fill_identity() + + scale_x_continuous(breaks = seq_along(pal_plus), labels = pal_plus, expand = c(.01, 0)) + + coord_cartesian(ylim = c(.42, 1.05)) + + labs(title = "colorRampPalette(pal[1:4], alpha = TRUE)(9): transition colors", + x = NULL, y = NULL) + + theme_minimal(base_size = 11) + + theme(plot.title = element_text(size = 10.5, colour = "grey20"), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.x = element_text(size = 7.6, colour = "grey20", angle = 45, hjust = 1), + panel.grid = element_blank()) +``` + +::: callout-tip +**Practical notes for image extraction** + +- Achro­matic pixels (white background, black text, grey anti-aliasing) form their own huge clusters and corrupt the k-means centres — the `(max - min) > 0.10` saturation filter removes them before clustering. +- JPEG artifacts blur every edge; prefer PNG screenshots of vector figures, and increase the subsampling stride for large images. +- Choose k = the number of hues you can *see* in the reference, not a fixed value; run `nstart = 20` — k-means is initialization-sensitive. +- An extracted palette inherits no perceptual guarantees: check CVD simulation and luminance spread (Part II) before it enters a real figure, and reorder the colors by meaning, not by pixel count. +::: + ## Visualization · Part III — one palette everywhere The final discipline: a paper is a *system*, not a collection of figures. Define one palette per meaning, reuse it across every panel and every figure type, and document the hex codes. The triptych below uses the same four colors for the same four groups — with the group labels left visible and a shared legend — in a box plot, a line chart and a bar chart. @@ -788,3 +927,5 @@ c3 <- ggplot(counts, aes(g, n, fill = g)) + geom_col(width = .6, show.legend = F \[12\] Okabe M, Ito K. Color Universal Design (CUD): How to make figures and presentations that are friendly to colorblind people. 2008. \[13\] W3C. Web Content Accessibility Guidelines (WCAG) 2.2. W3C Recommendation, 2023. + +\[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Colors.zh.qmd b/Colors.zh.qmd index fa1fe7623..a239bff6f 100644 --- a/Colors.zh.qmd +++ b/Colors.zh.qmd @@ -17,12 +17,12 @@ author: - 编程语言:R(第二部分附 Python 对应物与 R↔Python 映射表) -- 依赖包:`tidyverse`; `colorspace`; `RColorBrewer`; `viridisLite`; `paletteer`; `ggsci`; `patchwork` +- 依赖包:`tidyverse`; `colorspace`; `RColorBrewer`; `viridisLite`; `paletteer`; `ggsci`; `patchwork`; `png` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Installing necessary packages pkgs <- c("tidyverse", "colorspace", "RColorBrewer", "viridisLite", - "paletteer", "ggsci", "patchwork") + "paletteer", "ggsci", "patchwork", "png") for (pkg in pkgs) { if (!requireNamespace(pkg, quietly = TRUE)) { install.packages(pkg, repos = "https://cloud.r-project.org") @@ -36,6 +36,7 @@ library(RColorBrewer) library(viridisLite) library(ggsci) library(patchwork) +library(png) # The standard 8-color Okabe-Ito palette (Okabe & Ito 2008; black variant popularized by Wong 2011) okabe <- c("#000000", "#E69F00", "#56B4E9", "#009E73", @@ -706,6 +707,143 @@ embed |> legend.position = "bottom") ``` +## Visualization · 第三部分 — 向心仪的图借一套配色 + +当某篇已发表论文的配色恰好是你想要的效果,直接从图像中提取它,别靠肉眼猜 hex 码——FigureYa 合集用 `rPlotter::extract_colours()` 演示了这一工作流 \[14\]。那个包需要 EBImage 并从 GitHub 安装,而同样的工作只需要本页工具箱里的两件工具:用 `png::readPNG()` 读入像素,用基础 `kmeans()` 聚类。流程是:对像素网格抽样、剔除消色差像素(白色背景、黑色文字、灰色抗锯齿边缘)、对剩下的 RGB 三元组以 k = 可见色相数做 k-means、按像素数给聚类中心排序——主色排最前。 + +为了让示例自包含,下面的"参考图"由代码自己生成;实践中把 `readPNG()` 指向任意一张你心仪的论文图即可: + +```{r} +#| label: pal-extract-ref +#| fig-cap: "作为取色来源的替代'参考图'——五个簇、每簇一个色相、白底黑字。" +#| fig-alt: "五个模拟样本簇的散点图,每簇一种饱和色,并带各簇回归线。" +#| out.width: "75%" +#| warning: false +#| message: false +#| fig-width: 6.2 +#| fig-height: 4.6 + +set.seed(2828) +ref_cols <- c("#E64B35", "#4DBBD5", "#00A087", "#3C5488", "#7E6148") +sim_pts <- purrr::map_dfr(1:5, function(i) { + tibble(x = rnorm(90, c(1, 2.4, 3.8, 5.2, 6.6)[i], 0.34), + y = rnorm(90, c(1, 3.4, 2.1, 4.2, 1.6)[i], 0.42), + cl = factor(i)) +}) +p_ref <- ggplot(sim_pts, aes(x, y, colour = cl)) + + geom_point(size = 1.7, alpha = 0.85, show.legend = FALSE) + + geom_smooth(method = "lm", linewidth = 0.7, se = FALSE, show.legend = FALSE) + + scale_colour_manual(values = ref_cols) + + labs(title = "Figure 2 | Simulated reference figure", x = NULL, y = NULL) + + theme_bw(base_size = 13) + + theme(panel.grid = element_blank()) +# 写入临时文件;下一个 chunk 读回像素 +ref_png <- file.path(tempdir(), "bizard_ref_figure.png") +ggsave(ref_png, p_ref, width = 6.2, height = 4.6, dpi = 200) +p_ref +``` + +```{r} +#| label: pal-extract +#| fig-cap: "从参考图提取的调色板:剔除消色差像素后对 RGB 做 k-means(k = 5),按像素数排序。" +#| fig-alt: "从参考图经 k-means 提取的五个色块:浅蓝、棕、深蓝、青、红,各带 hex 标签。" +#| out.width: "90%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 3 + +img <- png::readPNG(ref_png) # 高 x 宽 x 4,取值 [0, 1] +px <- img[, , 1:3] +dim(px) <- c(dim(px)[1] * dim(px)[2], 3) +px <- px[seq(1, nrow(px), by = 2), ] # 每两个像素抽一个 +mx <- apply(px, 1, max); mn <- apply(px, 1, min) +keep <- mx < 0.94 & mx > 0.10 & (mx - mn) > 0.10 # 剔除白背景、黑文字、灰色抗锯齿 +pxk <- px[keep, ] + +set.seed(2828) +km <- kmeans(pxk, centers = 5, nstart = 20) +ord <- order(table(km$cluster), decreasing = TRUE) +pal_ext <- rgb(km$centers[ord, 1], km$centers[ord, 2], km$centers[ord, 3]) + +tibble(col = pal_ext, x = seq_along(pal_ext)) |> + ggplot(aes(x, .82, fill = col)) + + geom_tile(width = 1, height = .72, colour = "grey35", linewidth = .25) + + scale_fill_identity() + + scale_x_continuous(breaks = seq_along(pal_ext), labels = pal_ext, expand = c(.01, 0)) + + coord_cartesian(ylim = c(.42, 1.05)) + + labs(title = "k-means palette extracted from the reference figure (k = 5)", + x = NULL, y = NULL) + + theme_minimal(base_size = 11) + + theme(plot.title = element_text(size = 10.5, colour = "grey20"), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.x = element_text(size = 7.6, colour = "grey20", angle = 45, hjust = 1), + panel.grid = element_blank()) +``` + +五个色相几乎原样保留。接下来是两个收尾步骤。第一,插值:`colorRampPalette()` 在调色板的子集内部合成过渡色——即 FigureYa 配方里的"增色"步骤 \[14\]——供设计需要比提取集更多档位时使用。第二,任何借来的调色板都背负同一义务:它是**美学产物,未经检验**——采纳前请先跑第二部分的检查,因为提取过程不为 CVD 区分度或亮度单调性做任何优化: + +```{r} +#| label: pal-extract-cvd +#| fig-cap: "提取调色板在正常视觉、绿色盲(deutan)与红色盲(protan)模拟下的表现(colorspace::deutan/protan):CVD 模拟下棕色与深蓝的区分度明显下降。" +#| fig-alt: "同一组五个提取色在正常视觉、绿色盲与红色盲模拟下的三条色带;缺陷模拟下多个色相互相靠拢。" +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 3.6 + +cvd_rows <- list( + "normal vision" = pal_ext, + "deuteranopia" = deutan(pal_ext), + "protanopia" = protan(pal_ext)) +purrr::imap_dfr(cvd_rows, ~ tibble(col = .x, x = seq_along(.x), pal = .y)) |> + mutate(pal = factor(pal, levels = names(cvd_rows))) |> + ggplot(aes(x, 1, fill = col)) + + geom_tile(width = 1, height = .8, colour = "white", linewidth = .3) + + facet_wrap(~pal, ncol = 1, strip.position = "left") + + scale_fill_identity() + scale_y_continuous(expand = c(0, 0)) + + theme_minimal(base_size = 11) + + theme(axis.text = element_blank(), axis.title = element_blank(), panel.grid = element_blank(), + strip.text.y.left = element_text(angle = 0, hjust = 0, size = 10), + strip.background = element_blank(), panel.spacing.y = unit(3, "mm")) +``` + +```{r} +#| label: pal-extract-interp +#| fig-cap: "colorRampPalette(pal[1:4], alpha = TRUE)(9):在前四个提取色相内部插值出的九个过渡色。" +#| fig-alt: "九个插值色组成的色带,覆盖提取调色板中浅蓝到深蓝的范围。" +#| out.width: "90%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 3 + +pal_plus <- colorRampPalette(pal_ext[1:4], alpha = TRUE)(9) +tibble(col = pal_plus, x = seq_along(pal_plus)) |> + ggplot(aes(x, .82, fill = col)) + + geom_tile(width = 1, height = .72, colour = "grey35", linewidth = .25) + + scale_fill_identity() + + scale_x_continuous(breaks = seq_along(pal_plus), labels = pal_plus, expand = c(.01, 0)) + + coord_cartesian(ylim = c(.42, 1.05)) + + labs(title = "colorRampPalette(pal[1:4], alpha = TRUE)(9): transition colors", + x = NULL, y = NULL) + + theme_minimal(base_size = 11) + + theme(plot.title = element_text(size = 10.5, colour = "grey20"), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.x = element_text(size = 7.6, colour = "grey20", angle = 45, hjust = 1), + panel.grid = element_blank()) +``` + +::: callout-tip +**图像取色的实用提示** + +- 消色差像素(白背景、黑文字、灰色抗锯齿)会自成巨型聚类并污染 k-means 中心——聚类前先用 `(max - min) > 0.10` 的饱和度过滤剔掉它们。 +- JPEG 压缩伪影会模糊所有边缘;优先用矢量图的 PNG 截图,大图加大抽样步长。 +- k 取参考图中*肉眼可见*的色相数,而非固定值;务必 `nstart = 20`——k-means 对初始化敏感。 +- 提取的调色板不继承任何感知保证:进入正式图之前先做 CVD 模拟与亮度跨度检查(第二部分),且按含义而非像素数重排颜色。 +::: + ## Visualization · 第三部分 — 全文一套配色 最后一项纪律:一篇论文是一个*系统*,而非图形的集合。为每种含义定义一套配色,在所有面板与所有图形类型中复用,并记录十六进制码。下面的三联图在同一份数据的箱线图、折线图与柱状图中使用同样的四种颜色代表同样的四组——保留组标签,并共享一个图例。 @@ -788,3 +926,5 @@ c3 <- ggplot(counts, aes(g, n, fill = g)) + geom_col(width = .6, show.legend = F \[12\] Okabe M, Ito K. Color Universal Design (CUD): How to make figures and presentations that are friendly to colorblind people. 2008. \[13\] W3C. Web Content Accessibility Guidelines (WCAG) 2.2. W3C Recommendation, 2023. + +\[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Composition/PieChart.qmd b/Composition/PieChart.qmd index f57622006..9b54987f1 100644 --- a/Composition/PieChart.qmd +++ b/Composition/PieChart.qmd @@ -283,7 +283,7 @@ The labels on the pie chart have corresponding line segments pointing to specifi ### 8. Grouped Pie Charts and Scatterpie -When samples are divided into groups (e.g. High/Low risk), **grouped pie charts** show the category distribution within each group \[9\]. The scatterpie variant places multiple small pies on a 2D scatter plot. +When samples are divided into groups (e.g. High/Low risk), **grouped pie charts** show the category distribution within each group \[4\]. The scatterpie variant places multiple small pies on a 2D scatter plot. ```{r} #| label: fig-8.1GroupedPie @@ -392,4 +392,4 @@ The chart shows the number of publications on TAO in each country. Japan has pub -\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Composition/PieChart.zh.qmd b/Composition/PieChart.zh.qmd index 94d4734a4..acc8ed046 100644 --- a/Composition/PieChart.zh.qmd +++ b/Composition/PieChart.zh.qmd @@ -283,7 +283,7 @@ p ### 8. 分组饼图与 Scatterpie -样本分为多组时,**分组饼图**展示各组内类别分布 \[9\]。scatterpie 变体在 2D 散点图上放置多个小饼图。 +样本分为多组时,**分组饼图**展示各组内类别分布 \[4\]。scatterpie 变体在 2D 散点图上放置多个小饼图。 ```{r} #| label: fig-8.1GroupedPie @@ -392,4 +392,4 @@ ggplot() + -\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Correlation/Bubble.qmd b/Correlation/Bubble.qmd index 7dc83903b..630da429a 100644 --- a/Correlation/Bubble.qmd +++ b/Correlation/Bubble.qmd @@ -239,7 +239,57 @@ Applications of Bubble Plot This bubble plot demonstrates the agreement between extreme temperature anomalies estimated from mooring observations and historical temperature profile measurements. a. Bubble plot of the 95th percentile EHTA estimated from a mooring site and the corresponding historical temperature distribution measurements within a 5×5° grid box centered at the mooring site. Colors indicate observations from different locations, and dot size indicates observation depths from 10 to 1000 meters. b. Same as a, but for the 5th percentile ELTA. Note that ELTAs below -3°C (at the KEO site) are not plotted. c, d. Same as a(c) and b(d), but with different percentages (p) of EHTA measurements observed within AE (c) and ELTA measurements observed within CE (d). The solid black line with gray shading represents the corresponding linear regression with a 95% confidence level. \[2\] -## Reference +### 3. Bubble Grid: Motif P-Value Size × TF Expression Fill (FigureYa5bubbles) + +The FigureYa5bubbles grid \[7\] answers "which TF is enriched *and* expressed where" in one picture: rows = motifs/TFs, columns = stages, **dot size = -log10(P) of the motif enrichment**, **dot fill = the TF's expression (FPKM)**. The block below reproduces the geometry from a simulated Homer-style motif table: + +```{r} +#| label: fig-3.1MotifBubbles +#| fig-cap: "Bubble grid of 14 simulated motifs across 5 differentiation stages: dot size = -log10(P) of motif enrichment, fill = the TF's simulated FPKM; both clamped to the plotting range as in the reference." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 8 + +set.seed(5011) +motifs <- paste0("TF", sprintf("%02d", 1:14)) +types <- c("2cell", "4cell", "8cell", "ICM", "mESC") +enrich <- expand.grid(motif = motifs, type = types, stringsAsFactors = FALSE) +enrich$logP <- runif(nrow(enrich), 5, 50) # this column already is -log10(P) +tf_expr <- data.frame( + motif = rep(motifs, each = length(types)), + type = rep(types, length(motifs)), + FPKM = c(t(sapply(motifs, function(m) { + base <- runif(1, 2, 14) + rnorm(length(types), base, 2.5) + })))) +enrich <- merge(enrich, tf_expr, by = c("motif", "type")) +## clamp to the plotting range exactly like the reference (P and FPKM quantiles) +enrich$logP <- pmin(pmax(enrich$logP, 10), 500) +enrich$FPKM <- pmin(enrich$FPKM, 20) +enrich$motif <- factor(enrich$motif, levels = rev(motifs)) + +ggplot(enrich, aes(type, motif, size = logP)) + + geom_point(shape = 21, aes(fill = FPKM)) + + scale_size_continuous(range = c(1, 8), name = "-log10(P)") + + scale_fill_gradientn(colours = c("#2381B3", "#F0E366"), name = "TF FPKM") + + labs(x = NULL, y = NULL, + title = "Motif enrichment (-log10(P), size) vs TF expression (fill)") + + theme_minimal(base_size = 11) + + theme(legend.position = "bottom", legend.box = "vertical", + panel.grid.major = element_blank()) +``` + +::: callout-tip +**Practice tips** + +- The clamps matter as much as the mapping: a handful of extreme -log10(P) values flattens every other dot — clamp to the 90-95% quantile (the reference clamps to 10-500 and FPKM ≤ 20) and say so in the caption. +- `shape = 21` puts the fill *inside* a stroked circle — with a dark stroke the bubbles stay visible when fill sits at the light end of the ramp. +- For real Homer output, each `knownResults.txt` row order differs — merge on the motif name (paste of motif + p-value columns) against a fixed index, exactly as the reference does. +::: + +## Reference## Reference \[1\] Oh KK, Adnan M, Cho DH. Network pharmacology approach to decipher signaling pathways associated with target proteins of NSAIDs against COVID-19. Sci Rep. 2021 May 5;11(1):9606. doi: 10.1038/s41598-021-88313-5. PMID: 33953223; PMCID: PMC8100301. @@ -257,3 +307,5 @@ This bubble plot demonstrates the agreement between extreme temperature anomalie \[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Correlation/Bubble.zh.qmd b/Correlation/Bubble.zh.qmd index e5bd21ef9..f4bc1bc35 100644 --- a/Correlation/Bubble.zh.qmd +++ b/Correlation/Bubble.zh.qmd @@ -238,7 +238,57 @@ plot_grid(p_down, p_up, labels = c("Down-regulated", "Up-regulated"), 这个气泡图展示了根据系泊观测和历史温度剖面测量估计的极端温度异常之间的一致性。a、 根据系泊点估算的第95百分位EHTA气泡图和以系泊点为中心的5×5°网格框内的相应历史温度分布测量值。颜色表示来自不同地点的观测结果,点的大小表示10至1000米的观测深度。b与a相同,但适用于第5百分位ELTA。请注意,未绘制低于-3°C的ELTA(在KEO现场)。c、 d,与a(c)和b(d)相同,但AE(c)内观察到的EHTA测量值和CE(d)内观察的ELTA测量值的百分比(p)不同。带有灰色阴影的实心黑线表示具有95%置信水平的相应线性回归。\[2\] -## 参考文献 +### 3. 气泡网格:motif P 值作大小 × TF 表达作填充(FigureYa5bubbles) + +FigureYa5bubbles 网格 \[7\] 在一张图中回答"哪个 TF 在哪里既富集又高表达":行 = motif/TF,列 = 分期,**点大小 = motif 富集的 -log10(P)**,**点填充 = 该 TF 的表达量(FPKM)**。下块用模拟的 Homer 风格 motif 表复现该几何结构: + +```{r} +#| label: fig-3.1MotifBubbles +#| fig-cap: "14 个模拟 motif 在 5 个分化阶段的气泡网格:点大小 = motif 富集 -log10(P),填充 = TF 的模拟 FPKM;两者均按参考做法截断到作图范围。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 8 + +set.seed(5011) +motifs <- paste0("TF", sprintf("%02d", 1:14)) +types <- c("2cell", "4cell", "8cell", "ICM", "mESC") +enrich <- expand.grid(motif = motifs, type = types, stringsAsFactors = FALSE) +enrich$logP <- runif(nrow(enrich), 5, 50) # 该列本身已是 -log10(P) +tf_expr <- data.frame( + motif = rep(motifs, each = length(types)), + type = rep(types, length(motifs)), + FPKM = c(t(sapply(motifs, function(m) { + base <- runif(1, 2, 14) + rnorm(length(types), base, 2.5) + })))) +enrich <- merge(enrich, tf_expr, by = c("motif", "type")) +## 与参考一致:截断到作图范围(P 与 FPKM 分位数) +enrich$logP <- pmin(pmax(enrich$logP, 10), 500) +enrich$FPKM <- pmin(enrich$FPKM, 20) +enrich$motif <- factor(enrich$motif, levels = rev(motifs)) + +ggplot(enrich, aes(type, motif, size = logP)) + + geom_point(shape = 21, aes(fill = FPKM)) + + scale_size_continuous(range = c(1, 8), name = "-log10(P)") + + scale_fill_gradientn(colours = c("#2381B3", "#F0E366"), name = "TF FPKM") + + labs(x = NULL, y = NULL, + title = "Motif enrichment (-log10(P), size) vs TF expression (fill)") + + theme_minimal(base_size = 11) + + theme(legend.position = "bottom", legend.box = "vertical", + panel.grid.major = element_blank()) +``` + +::: callout-tip +**实践要点** + +- 截断与映射同样重要:少数极端 -log10(P) 会把其他点全部压扁——截断到 90-95% 分位(参考截断为 10-500、FPKM ≤ 20)并在图注中说明。 +- `shape = 21` 把填充放进带描边的圆内——深描边让填充落在浅端的气泡依然可见。 +- 真实 Homer 输出中各 `knownResults.txt` 行序不同——按 motif 名(motif + p 值列拼接)对齐到固定索引,与参考做法一致。 +::: + +## 参考文献## 参考文献 \[1\] Oh KK, Adnan M, Cho DH. Network pharmacology approach to decipher signaling pathways associated with target proteins of NSAIDs against COVID-19. Sci Rep. 2021 May 5;11(1):9606. doi: 10.1038/s41598-021-88313-5. PMID: 33953223; PMCID: PMC8100301. @@ -256,3 +306,4 @@ plot_grid(p_down, p_up, labels = c("Down-regulated", "Up-regulated"), \[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Correlation/ComplexHeatmap.qmd b/Correlation/ComplexHeatmap.qmd index bd18341e4..fbc5dc90f 100644 --- a/Correlation/ComplexHeatmap.qmd +++ b/Correlation/ComplexHeatmap.qmd @@ -418,7 +418,7 @@ Add graphics ### 6. Correlation-Ordered Heatmap with Annotations -In biomarker studies \[4\] the columns are samples **ordered by the expression of one target gene**, the rows are genes significantly positively or negatively correlated with it, and the top annotation carries subtype/mutation information. Turning clustering off makes the target gene's gradient (and the wedges of correlated genes) directly visible — an unclustered correlation heatmap. +In biomarker studies \[8\] the columns are samples **ordered by the expression of one target gene**, the rows are genes significantly positively or negatively correlated with it, and the top annotation carries subtype/mutation information. Turning clustering off makes the target gene's gradient (and the wedges of correlated genes) directly visible — an unclustered correlation heatmap. ```{r} #| label: fig-6.1CorrOrdered @@ -487,7 +487,7 @@ Heatmap(mat_sel, name = "Z-score", top_annotation = ha, ### 7. Single-Cell Cluster-Mean Marker Heatmap -Single-cell marker panels read best as **cluster-mean** heatmaps: average each marker gene within every cluster, z-score the rows and clip extremes so one loud gene cannot saturate the colour scale \[4\]. Rows stay in marker-set order (`cluster_rows = FALSE`) while the columns are complete-linked, and the `annotation_row` bar names the cell type each block belongs to — the diagonal marker-by-cell-type layout standard in scRNA-seq papers. +Single-cell marker panels read best as **cluster-mean** heatmaps: average each marker gene within every cluster, z-score the rows and clip extremes so one loud gene cannot saturate the colour scale \[8\]. Rows stay in marker-set order (`cluster_rows = FALSE`) while the columns are complete-linked, and the `annotation_row` bar names the cell type each block belongs to — the diagonal marker-by-cell-type layout standard in scRNA-seq papers. ```{r} #| label: fig-7.1ScMarkerHeatmap @@ -513,13 +513,13 @@ for (k in 1:n_clust) { clip_scale <- function(x, lo = -2, hi = 2) matrix(pmin(pmax(x, lo), hi), nrow = nrow(x), dimnames = dimnames(x)) # per-gene z-score, clipped to +-2 so one loud gene cannot saturate the scale -ph_data <- clip_scale(scale(avg)) +ph_data <- clip_scale(t(scale(t(avg)))) ann <- data.frame(cluster = rep(clusters, each = n_genes_per)) cl_cols <- setNames(c("#B2182B", "#2166AC", "#EABF00", "#4D9342"), clusters) hm <- ComplexHeatmap::pheatmap(ph_data, color = colorRampPalette(c("darkblue", "white", "red3"))(99), - scale = "row", cluster_rows = FALSE, cluster_cols = TRUE, + scale = "none", cluster_rows = FALSE, cluster_cols = TRUE, clustering_method = "complete", show_rownames = FALSE, annotation_row = ann, annotation_colors = list(cluster = cl_cols), border_color = NA) @@ -537,12 +537,12 @@ stopifnot(sum(diag_hits) == n_clust) **Practice tips** - `cluster_rows = FALSE` keeps marker sets contiguous; letting the rows cluster breaks the diagonal reading. -- Clipping at ±2 after per-gene z-scoring is what makes all four blocks equally colourful: each block is scaled by its own contrast. +- The per-gene z-score (`t(scale(t(avg)))`) is what makes all four blocks equally colourful — each row is scaled by its own contrast; the ±2 clip is only a guard against residual outliers. - The `darkblue-white-red3` 99-step ramp matches the classic style; build it once with `colorRampPalette()` and reuse it across panels. ::: ### 8. Multi-Block Horizontal Heatmap Composition -An entire publication panel — a binary trait bar, an expression matrix, and a numeric score column with in-cell labels — assembles from one row-aligned horizontal `pheatmap` list \[4\]. The `display_numbers` + `number_color` mechanism turns any block into a table-style column with per-cell control; missing values draw as `NA`. +An entire publication panel — a binary trait bar, an expression matrix, and a numeric score column with in-cell labels — assembles from one row-aligned horizontal `pheatmap` list \[8\]. The `display_numbers` + `number_color` mechanism turns any block into a table-style column with per-cell control; missing values draw as `NA`. ```{r} #| label: fig-8.1MultiBlockHeatmap @@ -614,8 +614,6 @@ The figure above is an unsupervised hierarchical clustering heatmap of 59 differ \[3\] Tal Galili (2015). dendextend: an R package for visualizing, adjusting, and comparing trees of hierarchical clustering. Bioinformatics. DOI:10.1093/bioinformatics/btv428 -\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 - \[4\] Wickham H, Vaughan D, Girlich M (2024). tidyr: Tidy Messy Data. R package version 1.3.1, CRAN: Package tidyr. \[5\] Gu, Z. (2014) circlize implements and enhances circular visualization in R. Bioinformatics. @@ -624,3 +622,5 @@ The figure above is an unsupervised hierarchical clustering heatmap of 59 differ \[7\] Kolde R (2019). pheatmap: Pretty Heatmaps. R package version 1.0.12, CRAN: Package pheatmap. +\[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + diff --git a/Correlation/ComplexHeatmap.zh.qmd b/Correlation/ComplexHeatmap.zh.qmd index 41228b952..091c95a13 100644 --- a/Correlation/ComplexHeatmap.zh.qmd +++ b/Correlation/ComplexHeatmap.zh.qmd @@ -418,7 +418,7 @@ Heatmap(small_mat, name = "Methylation", col = col_fun, ### 6. 按相关系数排序的带注释热图 -在生物标志物研究中 \[4\],列是**按某个目标基因表达量排序**的样本,行是与目标基因显著正/负相关的基因,顶部注释承载亚型/突变信息。关闭聚类后,目标基因的梯度(以及相关基因的楔形分布)一目了然——这就是无聚类的相关性热图。 +在生物标志物研究中 \[8\],列是**按某个目标基因表达量排序**的样本,行是与目标基因显著正/负相关的基因,顶部注释承载亚型/突变信息。关闭聚类后,目标基因的梯度(以及相关基因的楔形分布)一目了然——这就是无聚类的相关性热图。 ```{r} #| label: fig-6.1CorrOrdered @@ -513,13 +513,13 @@ for (k in 1:n_clust) { clip_scale <- function(x, lo = -2, hi = 2) matrix(pmin(pmax(x, lo), hi), nrow = nrow(x), dimnames = dimnames(x)) # 按基因 z-score 并截断至 ±2,防止单个高表达基因使色标饱和 -ph_data <- clip_scale(scale(avg)) +ph_data <- clip_scale(t(scale(t(avg)))) ann <- data.frame(cluster = rep(clusters, each = n_genes_per)) cl_cols <- setNames(c("#B2182B", "#2166AC", "#EABF00", "#4D9342"), clusters) hm <- ComplexHeatmap::pheatmap(ph_data, color = colorRampPalette(c("darkblue", "white", "red3"))(99), - scale = "row", cluster_rows = FALSE, cluster_cols = TRUE, + scale = "none", cluster_rows = FALSE, cluster_cols = TRUE, clustering_method = "complete", show_rownames = FALSE, annotation_row = ann, annotation_colors = list(cluster = cl_cols), border_color = NA) @@ -537,7 +537,7 @@ stopifnot(sum(diag_hits) == n_clust) **实践要点** - `cluster_rows = FALSE` 令各标记基因集保持连续;若让行参与聚类,对角式阅读逻辑即被破坏。 -- 按基因 z-score 后截断至 ±2 是四组标记块色彩等浓的关键:每块对比度由自身定标。 +- 让四组标记块色彩等浓的是按基因 z-score(`t(scale(t(avg)))`)——每行由自身对比度定标;±2 截断只是对残余离群值的保护。 - `darkblue-white-red3` 99 级渐变匹配经典图风;用 `colorRampPalette()` 构建一次即可跨面板复用。 ::: ### 8. 多区块水平拼接热图 diff --git a/Correlation/Correlogram.qmd b/Correlation/Correlogram.qmd index c49772b4f..8ce554213 100644 --- a/Correlation/Correlogram.qmd +++ b/Correlation/Correlogram.qmd @@ -24,7 +24,7 @@ For example, the above diagram is a correlation heatmap of various groups of dat - Programming Language: R -- Dependencies: `GGally`; `corrplot`; `ggcorrplot`; `corrgram` +- Dependencies: `GGally`; `corrplot`; `ggcorrplot`; `corrgram`; `circlize` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Install packages @@ -40,12 +40,16 @@ if (!requireNamespace("ggcorrplot", quietly = TRUE)) { if (!requireNamespace("corrgram", quietly = TRUE)) { install.packages("corrgram") } +if (!requireNamespace("circlize", quietly = TRUE)) { + install.packages("circlize") +} # Load packages library(GGally) library(corrplot) library(ggcorrplot) library(corrgram) +library(circlize) ``` ```{r} @@ -256,7 +260,7 @@ corrgram(data_mtcars, order=NULL, ### 5. Multi-Gene Correlation with FDR Correction -When testing correlations for many genes simultaneously, **false discovery rate (FDR) correction** is essential \[5\]. This recipe computes pairwise correlations between a target gene and all others, applies BH correction, and visualises the results as a sorted bar chart. +When testing correlations for many genes simultaneously, **false discovery rate (FDR) correction** is essential \[7\]. This recipe computes pairwise correlations between a target gene and all others, applies BH correction, and visualises the results as a sorted bar chart. ```{r} #| label: fig-5.1MultiGeneCor @@ -304,6 +308,98 @@ ggplot(cor_df, aes(r, reorder(gene, r), fill = sig)) + - For Spearman correlation, replace `cor.test(method = "pearson")` with `method = "spearman"`. ::: +### 6. Correlation Chord Around the Circle (circlize) + +The FigureYa37 layout \[8\] turns a gene-gene correlation table into a **chord diagram**: every gene is a coloured arc around the circle, and each selected gene pair is a link whose **width encodes |cor|** and whose colour encodes the signed coefficient (green negative, red positive). Links attach to sub-segments of each arc sized by the cumulative widths, so a gene involved in many correlations gets proportionally sliced. The block below keeps the reference's construction, screening the top 16 Spearman pairs of a 10-gene simulated panel: + +```{r} +#| label: fig-6.1CorrChord +#| fig-cap: "Spearman correlation chord of the top 16 pairs among 10 simulated genes: gene arcs coloured with the d3 palette, link width = |cor|, link colour = signed cor (green = negative, red = positive), gradient bar as the legend." +#| out.width: "70%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 7.5 + +set.seed(3701) +n_s <- 120 +genes10 <- paste0("GENE", sprintf("%02d", 1:10)) +expr_c <- matrix(rnorm(n_s * 10), n_s, 10, dimnames = list(NULL, genes10)) +expr_c[, 2] <- expr_c[, 1] * 0.85 + rnorm(n_s, 0, 0.5) +expr_c[, 3] <- -expr_c[, 1] * 0.8 + rnorm(n_s, 0, 0.5) +expr_c[, 5] <- expr_c[, 4] * 0.9 + rnorm(n_s, 0, 0.4) +expr_c[, 6] <- -expr_c[, 4] * 0.75 + rnorm(n_s, 0, 0.5) +expr_c[, 8] <- expr_c[, 7] * 0.8 + rnorm(n_s, 0, 0.5) + +cors <- expand.grid(Gene_1 = genes10, Gene_2 = genes10, stringsAsFactors = FALSE) +cors <- cors[cors$Gene_1 < cors$Gene_2, ] +cors$cor <- mapply(function(a, b) cor(expr_c[, a], expr_c[, b], method = "spearman"), + cors$Gene_1, cors$Gene_2) +cors <- cors[order(-abs(cors$cor)), ][1:16, ] + +## slice each gene's arc into per-pair sub-segments of width |cor| +pairs <- cors +long <- rbind(data.frame(pid = seq_len(nrow(pairs)), gene = pairs$Gene_1, cor = pairs$cor), + data.frame(pid = seq_len(nrow(pairs)), gene = pairs$Gene_2, cor = pairs$cor)) +long <- long[order(long$gene), ] +seg <- do.call(rbind, lapply(split(long, long$gene), function(x) { + end <- cumsum(abs(x$cor)) + data.frame(key = paste(x$gene, x$pid, sep = "_"), + gene = x$gene[1], start = c(0, head(end, -1)), end = end) +})) +key1 <- paste(pairs$Gene_1, seq_len(nrow(pairs)), sep = "_") +key2 <- paste(pairs$Gene_2, seq_len(nrow(pairs)), sep = "_") +pairs$start_1 <- seg$start[match(key1, seg$key)]; pairs$end_1 <- seg$end[match(key1, seg$key)] +pairs$start_2 <- seg$start[match(key2, seg$key)]; pairs$end_2 <- seg$end[match(key2, seg$key)] + +gene_sum <- tapply(abs(long$cor), long$gene, sum) +GeneID <- data.frame(gene = names(gene_sum), Gene_End = as.numeric(gene_sum)) +GeneID$Gene_Start <- 0 +GeneID <- GeneID[order(GeneID$gene), ] +GeneID$Color <- ggsci::pal_d3("category20")(nrow(GeneID)) + +color_ramp <- colorRampPalette(c("#67BE54", "#FFFFFF", "#F82C2B"))(201) +pairs$color <- color_ramp[round((pairs$cor + 1) / 2 * 200) + 1] + +circos.clear() +circos.par(start.degree = 90, gap.degree = 5, track.margin = c(0, 0.23), + cell.padding = c(0, 0, 0, 0)) +circos.initialize(factors = GeneID$gene, xlim = cbind(GeneID$Gene_Start, GeneID$Gene_End)) +circos.trackPlotRegion(ylim = c(0, 1), factors = GeneID$gene, track.height = 0.05, + panel.fun = function(x, y) { + name <- get.cell.meta.data("sector.index") + i <- get.cell.meta.data("sector.numeric.index") + xlim <- get.cell.meta.data("xlim") + ylim <- get.cell.meta.data("ylim") + circos.text(x = mean(xlim), y = 1, labels = name, cex = 0.95, + niceFacing = TRUE, facing = "bending", + adj = c(0.5, -2.6), font = 2) + circos.rect(xlim[1], ylim[1], xlim[2], ylim[2], + col = GeneID$Color[i], border = GeneID$Color[i]) + }) +for (i in seq_len(nrow(pairs))) { + circos.link(sector.index1 = pairs$Gene_1[i], + point1 = c(pairs$start_1[i], pairs$end_1[i]), + sector.index2 = pairs$Gene_2[i], + point2 = c(pairs$start_2[i], pairs$end_2[i]), + col = paste0(pairs$color[i], "C9"), border = FALSE, rou = 0.7) +} +i0 <- seq(0, 0.995, 0.005) +rect(-1 + i0 / 2, -1, -0.9975 + i0 / 2, -0.96, + col = paste0(as.character(color_ramp), "FF"), + border = paste0(as.character(color_ramp), "FF")) +text(-0.97, -1.03, "-1"); text(-0.51, -1.03, "1") +circos.clear() +``` + +::: callout-tip +**Practice tips** + +- Screen pairs by |cor| before drawing: a full 45-pair chord diagram of 10 genes is unreadable; the top 16 keep the strong structure. +- The sub-segment slicing (`cumsum(abs(cor))` per gene) is what makes link widths honest — draw full-width links instead and a hub gene with six links visually overstates its strongest correlation. +- `circos.clear()` before AND after: a stale circos layout hijacks the next base plot. +::: + ## Applications ::: {#fig-CorrelogramApplications} @@ -336,4 +432,6 @@ Applications of Correlogram \[6\] Wright K (2021). *corrgram: Plot a Correlogram*. R package version 1.14, [CRAN: Package corrgram](https://CRAN.R-project.org/package=corrgram). -\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Correlation/Correlogram.zh.qmd b/Correlation/Correlogram.zh.qmd index 2dc949ca8..1504edcf4 100644 --- a/Correlation/Correlogram.zh.qmd +++ b/Correlation/Correlogram.zh.qmd @@ -24,7 +24,7 @@ author: - 编程语言:R -- 依赖包:`GGally`; `corrplot`; `ggcorrplot`; `corrgram` +- 依赖包:`GGally`; `corrplot`; `ggcorrplot`; `corrgram`; `circlize` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # 安装包 @@ -46,6 +46,7 @@ library(GGally) library(corrplot) library(ggcorrplot) library(corrgram) +library(circlize) ``` ```{r} @@ -256,7 +257,7 @@ corrgram(data_mtcars, order=NULL, ### 5. 多基因相关分析 + FDR 校正 -同时检验多个基因的相关性时,**假发现率(FDR)校正**必不可少 \[5\]。此配方计算目标基因与所有其他基因的成对相关,BH 校正后按相关系数排序画柱形图。 +同时检验多个基因的相关性时,**假发现率(FDR)校正**必不可少 \[7\]。此配方计算目标基因与所有其他基因的成对相关,BH 校正后按相关系数排序画柱形图。 ```{r} #| label: fig-5.1MultiGeneCor @@ -303,6 +304,98 @@ ggplot(cor_df, aes(r, reorder(gene, r), fill = sig)) + - Spearman 相关将 `cor.test(method = "pearson")` 替换为 `method = "spearman"` 即可。 ::: +### 6. 环形相关弦图(circlize) + +FigureYa37 版式 \[8\] 把基因-基因相关表变成**弦图**:每个基因是圆周上的一条彩色弧,每对选出的基因之间一条连线,**宽度编码 |cor|**、颜色编码带符号的系数(绿负红正)。连线接到按累计宽度切分的弧段子段上,因此参与多个相关关系的基因会被按比例"切片"。下块保留参考文档的构造方式,从 10 基因模拟面板中筛出 Spearman 相关最强的 16 对: + +```{r} +#| label: fig-6.1CorrChord +#| fig-cap: "10 个模拟基因中最强 16 对的 Spearman 相关弦图:基因弧用 d3 配色,连线宽度 = |cor|,颜色 = 带符号系数(绿 = 负、红 = 正),底部渐变条即图例。" +#| out.width: "70%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 7.5 + +set.seed(3701) +n_s <- 120 +genes10 <- paste0("GENE", sprintf("%02d", 1:10)) +expr_c <- matrix(rnorm(n_s * 10), n_s, 10, dimnames = list(NULL, genes10)) +expr_c[, 2] <- expr_c[, 1] * 0.85 + rnorm(n_s, 0, 0.5) +expr_c[, 3] <- -expr_c[, 1] * 0.8 + rnorm(n_s, 0, 0.5) +expr_c[, 5] <- expr_c[, 4] * 0.9 + rnorm(n_s, 0, 0.4) +expr_c[, 6] <- -expr_c[, 4] * 0.75 + rnorm(n_s, 0, 0.5) +expr_c[, 8] <- expr_c[, 7] * 0.8 + rnorm(n_s, 0, 0.5) + +cors <- expand.grid(Gene_1 = genes10, Gene_2 = genes10, stringsAsFactors = FALSE) +cors <- cors[cors$Gene_1 < cors$Gene_2, ] +cors$cor <- mapply(function(a, b) cor(expr_c[, a], expr_c[, b], method = "spearman"), + cors$Gene_1, cors$Gene_2) +cors <- cors[order(-abs(cors$cor)), ][1:16, ] + +## 把每个基因的弧按 |cor| 切成逐对子段 +pairs <- cors +long <- rbind(data.frame(pid = seq_len(nrow(pairs)), gene = pairs$Gene_1, cor = pairs$cor), + data.frame(pid = seq_len(nrow(pairs)), gene = pairs$Gene_2, cor = pairs$cor)) +long <- long[order(long$gene), ] +seg <- do.call(rbind, lapply(split(long, long$gene), function(x) { + end <- cumsum(abs(x$cor)) + data.frame(key = paste(x$gene, x$pid, sep = "_"), + gene = x$gene[1], start = c(0, head(end, -1)), end = end) +})) +key1 <- paste(pairs$Gene_1, seq_len(nrow(pairs)), sep = "_") +key2 <- paste(pairs$Gene_2, seq_len(nrow(pairs)), sep = "_") +pairs$start_1 <- seg$start[match(key1, seg$key)]; pairs$end_1 <- seg$end[match(key1, seg$key)] +pairs$start_2 <- seg$start[match(key2, seg$key)]; pairs$end_2 <- seg$end[match(key2, seg$key)] + +gene_sum <- tapply(abs(long$cor), long$gene, sum) +GeneID <- data.frame(gene = names(gene_sum), Gene_End = as.numeric(gene_sum)) +GeneID$Gene_Start <- 0 +GeneID <- GeneID[order(GeneID$gene), ] +GeneID$Color <- ggsci::pal_d3("category20")(nrow(GeneID)) + +color_ramp <- colorRampPalette(c("#67BE54", "#FFFFFF", "#F82C2B"))(201) +pairs$color <- color_ramp[round((pairs$cor + 1) / 2 * 200) + 1] + +circos.clear() +circos.par(start.degree = 90, gap.degree = 5, track.margin = c(0, 0.23), + cell.padding = c(0, 0, 0, 0)) +circos.initialize(factors = GeneID$gene, xlim = cbind(GeneID$Gene_Start, GeneID$Gene_End)) +circos.trackPlotRegion(ylim = c(0, 1), factors = GeneID$gene, track.height = 0.05, + panel.fun = function(x, y) { + name <- get.cell.meta.data("sector.index") + i <- get.cell.meta.data("sector.numeric.index") + xlim <- get.cell.meta.data("xlim") + ylim <- get.cell.meta.data("ylim") + circos.text(x = mean(xlim), y = 1, labels = name, cex = 0.95, + niceFacing = TRUE, facing = "bending", + adj = c(0.5, -2.6), font = 2) + circos.rect(xlim[1], ylim[1], xlim[2], ylim[2], + col = GeneID$Color[i], border = GeneID$Color[i]) + }) +for (i in seq_len(nrow(pairs))) { + circos.link(sector.index1 = pairs$Gene_1[i], + point1 = c(pairs$start_1[i], pairs$end_1[i]), + sector.index2 = pairs$Gene_2[i], + point2 = c(pairs$start_2[i], pairs$end_2[i]), + col = paste0(pairs$color[i], "C9"), border = FALSE, rou = 0.7) +} +i0 <- seq(0, 0.995, 0.005) +rect(-1 + i0 / 2, -1, -0.9975 + i0 / 2, -0.96, + col = paste0(as.character(color_ramp), "FF"), + border = paste0(as.character(color_ramp), "FF")) +text(-0.97, -1.03, "-1"); text(-0.51, -1.03, "1") +circos.clear() +``` + +::: callout-tip +**实践要点** + +- 先按 |cor| 筛选再作图:10 个基因的完整 45 对弦图无法阅读,前 16 对足以保留强结构。 +- 子段切分(每个基因内 `cumsum(abs(cor))`)是连线宽度诚实的关键——改画全宽连线,枢纽基因的六条连线会夸大其最强相关。 +- `circos.clear()` 前后都要调用:残留的 circos 布局会劫持下一张 base 图。 +::: + ## 应用场景 ::: {#fig-CorrelogramApplications} @@ -335,4 +428,6 @@ ggplot(cor_df, aes(r, reorder(gene, r), fill = sig)) + \[6\] Wright K (2021). *corrgram: Plot a Correlogram*. R package version 1.14, [CRAN: Package corrgram](https://CRAN.R-project.org/package=corrgram). -\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Correlation/Heatmap.qmd b/Correlation/Heatmap.qmd index f448d6639..a1b6a4289 100644 --- a/Correlation/Heatmap.qmd +++ b/Correlation/Heatmap.qmd @@ -474,7 +474,7 @@ Similarly, the `heatmaply` package generates interactive heatmaps, allowing for #### 2.5 Diagonally Split Heatmap: Two Opposing Levels per Cell -When each cell carries **two opposing values** — e.g. copy-number amplification (upper triangle) versus deletion (lower triangle) per gene across cancer types \[8\] — split every cell into two triangles. A single diverging scale (red = gain, blue = loss) encodes both levels with one legend, and `geom_polygon()` does the splitting: +When each cell carries **two opposing values** — e.g. copy-number amplification (upper triangle) versus deletion (lower triangle) per gene across cancer types \[17\] — split every cell into two triangles. A single diverging scale (red = gain, blue = loss) encodes both levels with one legend, and `geom_polygon()` does the splitting: ```{r} #| label: fig-DiagSplitHeatmap @@ -761,7 +761,7 @@ These three heatmaps use different color palettes to showcase the differences in #### 4.6 Ternary Status Heatmap Against Normal Samples -Pathway-dysregulation studies often encode each gene as a **three-state** variable relative to normal samples: a gene is "up" in a tumour when its log2 expression exceeds the 97.5% quantile of the normals, "down" below the 2.5% quantile, otherwise "no-change" [10]. The resulting −1/0/1 matrix, clustered with Ward's method and drawn with a three-colour scale plus the fraction of up-regulated samples in each row label, exposes subtype structure inside one pathway. +Pathway-dysregulation studies often encode each gene as a **three-state** variable relative to normal samples: a gene is "up" in a tumour when its log2 expression exceeds the 97.5% quantile of the normals, "down" below the 2.5% quantile, otherwise "no-change" [17]. The resulting −1/0/1 matrix, clustered with Ward's method and drawn with a three-colour scale plus the fraction of up-regulated samples in each row label, exposes subtype structure inside one pathway. ```{r} #| label: fig-TernaryStatusPheatmap @@ -844,7 +844,7 @@ pheatmap(status, #### 4.7 Heatmap with Per-Gene Group-Comparison P Values -Expression heatmaps become evidence figures when each row carries its **group-comparison P value** \[11\]: four tests cover all designs (t.test / Wilcoxon for two groups, ANOVA / Kruskal-Wallis for more), BH-adjust, and the verdict rides next to the profile as a colour-coded annotation column. +Expression heatmaps become evidence figures when each row carries its **group-comparison P value** \[17\]: four tests cover all designs (t.test / Wilcoxon for two groups, ANOVA / Kruskal-Wallis for more), BH-adjust, and the verdict rides next to the profile as a colour-coded annotation column. ```{r} #| label: fig-4.7PvalueHeatmap @@ -904,7 +904,7 @@ Heatmap(z_mat, name = "Expression (z)", #### 4.8 Subtype-Specific Diagonal Heatmap -With ≥3 subtypes, one-vs-rest differential tests produce a **subtype-specific gene set per subtype**; stacking those sets into one unclustered heatmap of z-scored expression yields the diagonal layout \[12\] — each subtype's specific genes light up only in its own columns. +With ≥3 subtypes, one-vs-rest differential tests produce a **subtype-specific gene set per subtype**; stacking those sets into one unclustered heatmap of z-scored expression yields the diagonal layout \[17\] — each subtype's specific genes light up only in its own columns. ```{r} #| label: fig-4.8DiagonalSubtype @@ -1007,16 +1007,16 @@ annColors <- list(class = c(Readers = "#51B743", Writers = "#FAC67A", Erasers = "#5AC9FA")) colPattern <- c("#183869", "#4195C1", "white", "#CB5746", "#62011D") -hm <- pheatmap(as.matrix(lfc), - border_color = "black", - cluster_rows = TRUE, cluster_cols = FALSE, - clustering_method = "ward.D", - show_rownames = TRUE, show_colnames = TRUE, - annotation_row = annRow, annotation_colors = annColors, - cellwidth = 22, cellheight = 14, - color = colorRampPalette(colPattern)(64), - name = "log2FoldChange") -hm +## pheatmap draws when called; keep it as the bare last expression so the +## figure renders exactly once (no `name=` legend title exists in pheatmap) +pheatmap(as.matrix(lfc), + border_color = "black", + cluster_rows = TRUE, cluster_cols = FALSE, + clustering_method = "ward.D", + show_rownames = TRUE, show_colnames = TRUE, + annotation_row = annRow, annotation_colors = annColors, + cellwidth = 22, cellheight = 14, + color = colorRampPalette(colPattern)(64)) ``` ::: callout-tip @@ -1028,6 +1028,90 @@ hm ::: +### 4.10 Subtype-Centroid Heatmap with Signature-Score Annotations (PAM50-Style) + +Molecular-subtyping papers (the PAM50 figure behind FigureYa311 \[17\]) stack three layers in one heatmap: samples **ordered by predicted subtype** (columns split into blocks), a mean-centred expression matrix of the classifier's genes, and **top annotations** carrying the subtype call plus continuous signature scores. The classifier itself is a nearest-centroid rule — build centroids on a training split, assign each held-out sample by correlation — which here stands in for `genefu::intrinsic.cluster.predict()` (PAM50 needs the package plus gene IDs; not in this repository's lockfile), and the signature scores are simple gene-set means, the dependency-free stand-in for GSVA used elsewhere on this site. + +```{r} +#| label: fig-4.10SubtypeCentroid +#| fig-cap: "Subtype-centroid heatmap (50 simulated PAM50-style genes, 60 samples): samples ordered and split by nearest-centroid prediction; top annotations show the subtype call, two signature-score lines (AR-like: Basal-high; proliferation: LumB-high) and the AR phenotype." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 6 + +set.seed(3110) +subtypes <- c("LumA", "LumB", "Basal") +n_per <- 20 +genes <- paste0("PAM50_", sprintf("%02d", 1:50)) +n_samp <- length(subtypes) * n_per +sub_lab <- factor(rep(subtypes, each = n_per), levels = subtypes) +base <- matrix(rnorm(50 * n_samp, sd = 0.6), 50, n_samp, + dimnames = list(genes, paste0("S", sprintf("%02d", 1:n_samp)))) +sig_blocks <- list( + LumA = list(up = 1:10, dn = NULL, eff = 1.1), + LumB = list(up = 11:20, dn = NULL, eff = 1.2), + Basal = list(up = 21:30, dn = 31:40, eff = 1.3)) +for (st in subtypes) { + idx <- which(sub_lab == st) + base[sig_blocks[[st]]$up, idx] <- base[sig_blocks[[st]]$up, idx] + sig_blocks[[st]]$eff + if (!is.null(sig_blocks[[st]]$dn)) + base[sig_blocks[[st]]$dn, idx] <- base[sig_blocks[[st]]$dn, idx] - sig_blocks[[st]]$eff +} +## proliferation genes: high in LumB only +base[41:50, sub_lab == "LumB"] <- base[41:50, sub_lab == "LumB"] + 1.2 + +## nearest-centroid classification from a training split (SSP stand-in) +train <- c(TRUE, FALSE)[rep(1:2, length.out = n_samp)] +cent <- sapply(subtypes, function(st) rowMeans(base[, train & sub_lab == st])) +pred <- apply(base[, !train], 2, function(x) { + corrs <- sapply(seq_len(ncol(cent)), function(k) cor(x, cent[, k])) + subtypes[which.max(corrs)] }) +pred <- factor(pred, levels = subtypes) +cat("held-out accuracy:", round(mean(pred == sub_lab[!train]), 2), "\n") + +sig_scores <- rbind( + `AR score` = colMeans(base[21:30, ]) - colMeans(base[31:40, ]), # Basal-high + `Prolif score` = colMeans(base[41:50, ])) # LumB-high +pheno <- ifelse(sig_scores["AR score", ] > 0, "AR-high", "AR-low") + +## mean-centre each gene (no scaling, the reference's fold-difference scale) and clip +mat <- t(scale(t(base), center = TRUE, scale = FALSE)) +mat[mat > 4] <- 4; mat[mat < -4] <- -4 +ord <- order(pred) +pred_o <- pred[ord]; mat_o <- mat[, ord] +pheno_o <- factor(pheno[ord], levels = c("AR-low", "AR-high")) +ar_o <- sig_scores["AR score", ord]; pro_o <- sig_scores["Prolif score", ord] + +col_fun <- colorRamp2(c(-2, 0, 2), c("#170B88", "#FFFFFF", "#D23C30")) +ha <- HeatmapAnnotation( + Subtype = pred_o, + `AR score` = anno_lines(ar_o, border = FALSE), + `Prolif score` = anno_lines(pro_o, border = FALSE), + Phenotype = pheno_o, + gap = unit(2.5, "mm"), + annotation_name_gp = gpar(fontsize = 8.5), + col = list(Subtype = c(LumA = "#395790", LumB = "#6BBD2A", Basal = "#FFA652"), + Phenotype = c("AR-low" = "#07C7CF", "AR-high" = "#CE0706"))) +draw(Heatmap(mat_o, name = "Expression", + top_annotation = ha, + cluster_columns = FALSE, + column_split = pred_o, + column_title = "Samples ordered by predicted subtype", + show_row_names = FALSE, show_column_names = FALSE, + column_title_gp = gpar(fontsize = 10), + col = col_fun)) +``` + +::: callout-tip +**Practice tips** + +- Keep the classifier's own gene set as the heatmap rows and **do not re-cluster rows** if you want the block structure the classifier saw; cluster only when presenting discovery, not prediction. +- Mean-centre rows *without* scaling (the reference's fold-difference scale) and clip at ±4 — z-scaling would flatten the amplitude differences between signature blocks. +- Report held-out accuracy next to the figure (printed above); a heatmap ordered by a classifier that predicts at chance level is decoration, not evidence. +::: + ### 5. complexheatmap Heatmaps The `ComplexHeatmap` package, based on the `grid` package, uses an object-oriented approach to implement heatmaps and their components. It mainly includes the following classes: @@ -1282,7 +1366,7 @@ Heatmap(logfc_cat, name = "logFC band", ### 6. Cluster-Correlation Heatmap -Unsupervised (consensus) clustering of samples splits a cohort into gene-driven subtypes; correlating **each gene with the numeric cluster label** then splits the gene set into a positively correlated signature (A) and a negatively correlated one (B), which is exactly the "identification of immunogenic gene subtypes" figure \[17\]. With real data, `ConsensusClusterPlus::ConsensusCluster()` chooses k and returns the class vector; here the clusters are simulated and only the correlation + annotated heatmap is reproduced. +Unsupervised (consensus) clustering of samples splits a cohort into gene-driven subtypes; correlating **each gene with the numeric cluster label** then splits the gene set into a positively correlated signature (A) and a negatively correlated one (B), which is exactly the "identification of immunogenic gene subtypes" figure \[17\]. With real data, `ConsensusClusterPlus::ConsensusClusterPlus()` chooses k and returns the class vector; here the clusters are simulated and only the correlation + annotated heatmap is reproduced. ```{r} #| label: fig-6.1ClusterCorrelation diff --git a/Correlation/Heatmap.zh.qmd b/Correlation/Heatmap.zh.qmd index 4e1afe557..bf7f415c6 100644 --- a/Correlation/Heatmap.zh.qmd +++ b/Correlation/Heatmap.zh.qmd @@ -477,7 +477,7 @@ p #### 2.5 对角分割热图:每格承载两个对立水平 -当每个单元格携带**两个对立数值**——例如每个基因在各癌种中的拷贝数扩增(上三角)与缺失(下三角)\[8\]——就把每格切成两个三角形。单一 diverging 色标(红 = 扩增,蓝 = 缺失)用一个图例编码两个水平,`geom_polygon()` 负责切分: +当每个单元格携带**两个对立数值**——例如每个基因在各癌种中的拷贝数扩增(上三角)与缺失(下三角)\[17\]——就把每格切成两个三角形。单一 diverging 色标(红 = 扩增,蓝 = 缺失)用一个图例编码两个水平,`geom_polygon()` 负责切分: ```{r} #| label: fig-DiagSplitHeatmap @@ -852,7 +852,7 @@ pheatmap(status, #### 4.7 带组间比较 P 值的表达热图 -表达热图加上每行的**组间比较 P 值**就成为证据图 \[11\]:四种检验覆盖所有设计(两组用 t.test/Wilcoxon,多组用 ANOVA/Kruskal-Wallis),BH 校正后把结论以颜色标注列放在热图旁。 +表达热图加上每行的**组间比较 P 值**就成为证据图 \[17\]:四种检验覆盖所有设计(两组用 t.test/Wilcoxon,多组用 ANOVA/Kruskal-Wallis),BH 校正后把结论以颜色标注列放在热图旁。 ```{r} #| label: fig-4.7PvalueHeatmap @@ -911,7 +911,7 @@ Heatmap(z_mat, name = "Expression (z)", #### 4.8 亚型特异性对角热图 -≥3 个亚型时,one-vs-rest 差异检验产生**每个亚型特异的基因集**;把这些集合堆进同一张不聚类的 z-score 表达热图,就得到对角线布局 \[12\]——每个亚型的特异基因只在它自己的列亮起。 +≥3 个亚型时,one-vs-rest 差异检验产生**每个亚型特异的基因集**;把这些集合堆进同一张不聚类的 z-score 表达热图,就得到对角线布局 \[17\]——每个亚型的特异基因只在它自己的列亮起。 ```{r} #| label: fig-4.8DiagonalSubtype @@ -1013,16 +1013,16 @@ annColors <- list(class = c(Readers = "#51B743", Writers = "#FAC67A", Erasers = "#5AC9FA")) colPattern <- c("#183869", "#4195C1", "white", "#CB5746", "#62011D") -hm <- pheatmap(as.matrix(lfc), - border_color = "black", - cluster_rows = TRUE, cluster_cols = FALSE, - clustering_method = "ward.D", - show_rownames = TRUE, show_colnames = TRUE, - annotation_row = annRow, annotation_colors = annColors, - cellwidth = 22, cellheight = 14, - color = colorRampPalette(colPattern)(64), - name = "log2FoldChange") -hm +## pheatmap draws when called; keep it as the bare last expression so the +## figure renders exactly once (no `name=` legend title exists in pheatmap) +pheatmap(as.matrix(lfc), + border_color = "black", + cluster_rows = TRUE, cluster_cols = FALSE, + clustering_method = "ward.D", + show_rownames = TRUE, show_colnames = TRUE, + annotation_row = annRow, annotation_colors = annColors, + cellwidth = 22, cellheight = 14, + color = colorRampPalette(colPattern)(64)) ``` ::: callout-tip @@ -1034,6 +1034,90 @@ hm ::: +### 4.10 亚型质心热图 + signature 评分注释(PAM50 风格) + +分子分型论文(FigureYa311 背后的 PAM50 图 \[17\])在同一张热图里叠三层:样本**按预测亚型排序**(列分块)、分类器基因的均值中心化表达矩阵、以及携带亚型判定与连续 signature 评分的**顶部注释**。分类器本身是最近质心规则——训练集上建质心、按相关性给留出样本分类——此处替代 `genefu::intrinsic.cluster.predict()`(PAM50 需要该包与基因 ID 映射,不在本仓库 lockfile 中);signature 评分用简单的基因集均值,即本站其他页面使用的 GSVA 免依赖替身。 + +```{r} +#| label: fig-4.10SubtypeCentroid +#| fig-cap: "亚型质心热图(50 个模拟 PAM50 风格基因,60 个样本):样本按最近质心预测排序分块;顶部注释为亚型判定、两条 signature 评分线(AR 样:Basal 高;增殖:LumB 高)与 AR 表型。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 6 + +set.seed(3110) +subtypes <- c("LumA", "LumB", "Basal") +n_per <- 20 +genes <- paste0("PAM50_", sprintf("%02d", 1:50)) +n_samp <- length(subtypes) * n_per +sub_lab <- factor(rep(subtypes, each = n_per), levels = subtypes) +base <- matrix(rnorm(50 * n_samp, sd = 0.6), 50, n_samp, + dimnames = list(genes, paste0("S", sprintf("%02d", 1:n_samp)))) +sig_blocks <- list( + LumA = list(up = 1:10, dn = NULL, eff = 1.1), + LumB = list(up = 11:20, dn = NULL, eff = 1.2), + Basal = list(up = 21:30, dn = 31:40, eff = 1.3)) +for (st in subtypes) { + idx <- which(sub_lab == st) + base[sig_blocks[[st]]$up, idx] <- base[sig_blocks[[st]]$up, idx] + sig_blocks[[st]]$eff + if (!is.null(sig_blocks[[st]]$dn)) + base[sig_blocks[[st]]$dn, idx] <- base[sig_blocks[[st]]$dn, idx] - sig_blocks[[st]]$eff +} +## 增殖基因:仅在 LumB 中高表达 +base[41:50, sub_lab == "LumB"] <- base[41:50, sub_lab == "LumB"] + 1.2 + +## 训练折上的最近质心分类(SSP 替身) +train <- c(TRUE, FALSE)[rep(1:2, length.out = n_samp)] +cent <- sapply(subtypes, function(st) rowMeans(base[, train & sub_lab == st])) +pred <- apply(base[, !train], 2, function(x) { + corrs <- sapply(seq_len(ncol(cent)), function(k) cor(x, cent[, k])) + subtypes[which.max(corrs)] }) +pred <- factor(pred, levels = subtypes) +cat("held-out accuracy:", round(mean(pred == sub_lab[!train]), 2), "\n") + +sig_scores <- rbind( + `AR score` = colMeans(base[21:30, ]) - colMeans(base[31:40, ]), # Basal 高 + `Prolif score` = colMeans(base[41:50, ])) # LumB 高 +pheno <- ifelse(sig_scores["AR score", ] > 0, "AR-high", "AR-low") + +## 每个基因均值中心化(不缩放,即参考文献的倍数差异标度)并截断 +mat <- t(scale(t(base), center = TRUE, scale = FALSE)) +mat[mat > 4] <- 4; mat[mat < -4] <- -4 +ord <- order(pred) +pred_o <- pred[ord]; mat_o <- mat[, ord] +pheno_o <- factor(pheno[ord], levels = c("AR-low", "AR-high")) +ar_o <- sig_scores["AR score", ord]; pro_o <- sig_scores["Prolif score", ord] + +col_fun <- colorRamp2(c(-2, 0, 2), c("#170B88", "#FFFFFF", "#D23C30")) +ha <- HeatmapAnnotation( + Subtype = pred_o, + `AR score` = anno_lines(ar_o, border = FALSE), + `Prolif score` = anno_lines(pro_o, border = FALSE), + Phenotype = pheno_o, + gap = unit(2.5, "mm"), + annotation_name_gp = gpar(fontsize = 8.5), + col = list(Subtype = c(LumA = "#395790", LumB = "#6BBD2A", Basal = "#FFA652"), + Phenotype = c("AR-low" = "#07C7CF", "AR-high" = "#CE0706"))) +draw(Heatmap(mat_o, name = "Expression", + top_annotation = ha, + cluster_columns = FALSE, + column_split = pred_o, + column_title = "Samples ordered by predicted subtype", + show_row_names = FALSE, show_column_names = FALSE, + column_title_gp = gpar(fontsize = 10), + col = col_fun)) +``` + +::: callout-tip +**实践要点** + +- 热图行保持分类器自身的基因集,且**不要重新聚类行**——否则会破坏分类器所见的块结构;聚类用于呈现发现,不用于呈现预测。 +- 行只做均值中心化*不缩放*(参考文献的倍数差异标度)并截断于 ±4——z-score 会抹平不同 signature 块之间的振幅差异。 +- 在图旁报告留出集准确率(上方已打印);按机会水平分类器排序的热图只是装饰,不是证据。 +::: + ### 5. complexheatmap 热图 `ComplexHeatmap`包是基于`grid`包的,使用面向对象的方式实现热图及其组件,主要包含以下几个类: @@ -1286,7 +1370,7 @@ Heatmap(logfc_cat, name = "logFC band", ### 6. 聚类-相关性热图 -Unsupervised (consensus) clustering of samples splits a cohort into gene-driven subtypes; correlating **each gene with the numeric cluster label** then splits the gene set into a positively correlated signature (A) and a negatively correlated one (B), which is exactly the "identification of immunogenic gene subtypes" figure \[17\]. With real data, `ConsensusClusterPlus::ConsensusCluster()` chooses k and returns the class vector; here the clusters are simulated and only the correlation + annotated heatmap is reproduced. +Unsupervised (consensus) clustering of samples splits a cohort into gene-driven subtypes; correlating **each gene with the numeric cluster label** then splits the gene set into a positively correlated signature (A) and a negatively correlated one (B), which is exactly the "identification of immunogenic gene subtypes" figure \[17\]. With real data, `ConsensusClusterPlus::ConsensusClusterPlus()` chooses k and returns the class vector; here the clusters are simulated and only the correlation + annotated heatmap is reproduced. ```{r} #| label: fig-6.1ClusterCorrelation diff --git a/Correlation/PCAplot.qmd b/Correlation/PCAplot.qmd index 248420f20..f405f692b 100644 --- a/Correlation/PCAplot.qmd +++ b/Correlation/PCAplot.qmd @@ -292,7 +292,7 @@ plotly::plot_ly(scores3, x = ~PC1, y = ~PC2, z = ~PC3, ```{r} #| label: fig-5.2PCA3DStatic -#| fig-cap: "Static companion: PC1 × PC3 projection with 80% ellipses; the third dimension is colour-coded via PC2." +#| fig-cap: "Static companion: PC1 × PC3 projection with 80% ellipses; colour and shape encode the subgroup (PC2 is not shown in this projection)." #| out.width: "85%" #| warning: false #| message: false @@ -342,7 +342,7 @@ exprB <- matrix(rnorm(12 * n_s, sd = 0.6), 12) exprA[, subtype == "A"] <- exprA[, subtype == "A"] + 1.6 exprB[, subtype == "C"] <- exprB[, subtype == "C"] + 1.6 -# z-score per sample (genes in columns), then PC1 of each signature +# z-score per gene (rows = genes), then PC1 of each signature exprA <- t(scale(t(exprA))) exprB <- t(scale(t(exprB))) pcA <- prcomp(t(exprA), scale. = FALSE)$x[, 1] @@ -375,7 +375,7 @@ ggplot(score_df, aes(subtype, score, fill = subtype)) + - `prcomp()` returns an arbitrary PC1 sign — always orient it against a known reference subtype (as above) before comparing scores across runs or papers. - With a real Boruta step, run `Boruta::Boruta(x = t(expr), y = factor(cluster), maxRuns = 100, ntree = 500)` and keep rows with `decision == "Confirmed"` from `attStats()`; filter the A and B signatures **separately** so the dominant sign does not drown the minority set. -- Score on z-scored expression (per sample) so a high-expressed housekeeping gene cannot dominate PC1. +- Score on per-gene z-scored expression so a high-expressed housekeeping gene cannot dominate PC1. ::: ### 7. Gene Loadings Along PC1 Read the Expression Programme @@ -480,7 +480,7 @@ var2 <- round(pa$sdev[2]^2 / sum(pa$sdev^2) * 100, 1) hull_rows <- list() for (k in levels(dat$cluster)) { d <- dat[dat$cluster == k, ] - hi <- chull(d$PC1, d$PC2) # re-exported by ggplot2 from scales + hi <- chull(d$PC1, d$PC2) # base grDevices function hull_rows[[k]] <- data.frame(PC1 = d$PC1[hi], PC2 = d$PC2[hi], cluster = factor(k, levels = levels(dat$cluster))) } @@ -509,6 +509,81 @@ ggplot() + - The confusion-matrix assertion catches a failed run before the figure does: on real cohorts, recovery below ~0.9 is the cue to revisit k or prune features. ::: +### 9. Top-N Loading Arrows with Multi-Level Confidence Ellipses + +The FigureYa38 recipe \[2\] closes the interpretability gap of a plain PCA plot: rank genes by their contribution to the displayed plane (loading x sqrt(eigenvalue), summed over PC1 and PC2), draw **arrows for the top N** so the reader sees which genes pull each group apart, and wrap every group in **nested confidence ellipses** (90% dashed inside 95% solid) computed from the group's covariance. ggord/gglayer do this interactively; the version below is dependency-free ggplot2 and runs on a simulated 3-cancer, 30-gene panel: + +```{r} +#| label: fig-9.1LoadingArrows +#| fig-cap: "PCA of a simulated 3-cancer panel (30 genes): arrows point along the top-3 contributing genes (loading x sqrt(eigenvalue) over PC1-PC2); each group carries nested 90% (dashed) and 95% (solid) confidence ellipses." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7 +#| fig-height: 6 + +set.seed(3801) +grp2 <- factor(rep(c("BRCA", "OV", "LUSC"), each = 20)) +expr_pg <- matrix(rnorm(30 * 60, 5, 1), 60, 30) +expr_pg[grp2 == "BRCA", 1:2] <- expr_pg[grp2 == "BRCA", 1:2] + 2.4 +expr_pg[grp2 == "OV", 3:4] <- expr_pg[grp2 == "OV", 3:4] + 2.2 +expr_pg[grp2 == "LUSC", 5] <- expr_pg[grp2 == "LUSC", 5] + 2.0 +colnames(expr_pg) <- c("GATA3", "XBP1", "MUC1", "FOLR1", "KRT17", + paste0("G", sprintf("%02d", 6:30))) +pca_pg <- prcomp(expr_pg, center = TRUE, scale. = FALSE) +pv_pg <- summary(pca_pg)$importance[2, ] +contrib <- rowSums(abs(pca_pg$rotation[, 1:2]) * pv_pg[1:2]) +top_genes <- names(sort(contrib, decreasing = TRUE))[1:3] +scores_pg <- as.data.frame(pca_pg$x[, 1:2]) +scores_pg$grp <- grp2 + +## nested covariance ellipses at two coverage levels +ell <- do.call(rbind, lapply(c(0.9, 0.95), function(pro) { + do.call(rbind, lapply(levels(grp2), function(g) { + d <- scores_pg[scores_pg$grp == g, 1:2] + ctr <- colMeans(d); eg <- eigen(cov(d)) + ang <- seq(0, 2 * pi, length.out = 120) + r <- sqrt(qchisq(pro, df = 2)) + data.frame( + x = ctr[1] + r * (cos(ang) * sqrt(eg$values[1]) * eg$vectors[1, 1] - + sin(ang) * sqrt(eg$values[2]) * eg$vectors[1, 2]), + y = ctr[2] + r * (cos(ang) * sqrt(eg$values[1]) * eg$vectors[2, 1] - + sin(ang) * sqrt(eg$values[2]) * eg$vectors[2, 2]), + grp = g, pro = pro) + })) +})) + +sc_arrow <- max(abs(scores_pg[, 1:2])) * 0.32 +load_top <- pca_pg$rotation[top_genes, 1:2] +load_top <- load_top / apply(abs(load_top), 1, max) * sc_arrow + +ggplot(scores_pg, aes(PC1, PC2, colour = grp)) + + geom_point(size = 2, alpha = 0.75) + + geom_path(data = ell, aes(x, y, colour = grp, linetype = factor(pro)), + linewidth = 0.6, inherit.aes = FALSE, show.legend = FALSE) + + geom_segment(data = as.data.frame(load_top), + aes(x = 0, y = 0, xend = PC1, yend = PC2), + arrow = arrow(length = unit(0.14, "cm")), + colour = "brown", linewidth = 0.7, inherit.aes = FALSE) + + geom_text(data = as.data.frame(load_top), + aes(x = PC1 * 1.15, y = PC2 * 1.15, label = top_genes), + colour = "brown", size = 3.4, fontface = "bold", inherit.aes = FALSE) + + scale_linetype_manual(values = c("0.9" = 2, "0.95" = 1), guide = "none") + + labs(x = sprintf("PC1 (%.0f%%)", 100 * pv_pg[1]), + y = sprintf("PC2 (%.0f%%)", 100 * pv_pg[2]), + title = "PCA with top-3 loading arrows and 90/95% ellipses", + colour = NULL) + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**Practice tips** + +- Rank loadings by **loading x sqrt(eigenvalue)** over exactly the plotted PCs — ranking by raw PC1 loading alone misses genes that act through PC2. +- The arrow scale is a display choice: normalise each loading vector to the plot's extent (`sc_arrow` above) — the *direction* is the interpretable part, not the length across different pages. +- Nested ellipses (0.9 inside 0.95) double as a group-size honesty check: a tiny group's 95% ellipse swamps the panel — annotate n per group. +::: + ## Application ::: {#fig-UpsetApplications} diff --git a/Correlation/PCAplot.zh.qmd b/Correlation/PCAplot.zh.qmd index 706d9d277..deab47fcd 100644 --- a/Correlation/PCAplot.zh.qmd +++ b/Correlation/PCAplot.zh.qmd @@ -288,7 +288,7 @@ plotly::plot_ly(scores3, x = ~PC1, y = ~PC2, z = ~PC3, ```{r} #| label: fig-5.2PCA3DStatic -#| fig-cap: "静态伴随图:PC1 × PC3 投影 + 80% 椭圆;第三维经 PC2 用颜色编码。" +#| fig-cap: "静态伴随图:PC1 × PC3 投影 + 80% 椭圆;颜色与形状编码亚组(本投影未展示 PC2)。" #| out.width: "85%" #| warning: false #| message: false @@ -314,13 +314,13 @@ ggplot(scores3, aes(PC1, PC3, colour = group)) + - `plotly` 轴不自动加标题;如上在 `layout(scene = list(...))` 中设置。 ::: -### 6. 由第主成分构建 signature 得分 +### 6. 由第一主成分构建 signature 得分 -基于 PCA 的方按,是 LASSO/Cox 系数乘表达量之外的另一条路:由两组方向相反的基因集的第主成分构建 **signature 得分**:score = signature A 的 PC1 减去 signature B 的 PC1 \[2\]。因每个 PC1 即该基因集内部的主导共变轴,两者之差就是一个紧凑的单样本标记,无需生存模型即可排列分子亚型。(真实流程中两组基因来自 Boruta 筛选后的聚类-相关 signature,见聚类-相关热图教程。) +基于 PCA 的方案,是 LASSO/Cox 系数乘表达量之外的另一条路:由两组方向相反的基因集的第一主成分构建 **signature 得分**:score = signature A 的 PC1 减去 signature B 的 PC1 \[2\]。因每个 PC1 即该基因集内部的主导共变轴,两者之差就是一个紧凑的单样本标记,无需生存模型即可排列分子亚型。(真实流程中两组基因来自 Boruta 筛选后的聚类-相关 signature,见聚类-相关热图教程。) ```{r} #| label: fig-6.1SignatureScore -#| fig-cap: "单样本 signature 得分 PC1(A) - PC1(B):取两组基因各自的第主成分相减,得到可排列三个分子亚型的单一坐标。" +#| fig-cap: "单样本 signature 得分 PC1(A) - PC1(B):取两组基因各自的第一主成分相减,得到可排列三个分子亚型的单一坐标。" #| out.width: "85%" #| warning: false #| message: false @@ -338,7 +338,7 @@ exprB <- matrix(rnorm(12 * n_s, sd = 0.6), 12) exprA[, subtype == "A"] <- exprA[, subtype == "A"] + 1.6 exprB[, subtype == "C"] <- exprB[, subtype == "C"] + 1.6 -# z-score per sample (genes in columns), then PC1 of each signature +# 按基因 z-score(行 = 基因),再取各 signature 的 PC1 exprA <- t(scale(t(exprA))) exprB <- t(scale(t(exprB))) pcA <- prcomp(t(exprA), scale. = FALSE)$x[, 1] @@ -371,7 +371,7 @@ ggplot(score_df, aes(subtype, score, fill = subtype)) + - `prcomp()` 返回的 PC1 符号是任意的——跨运行或跨论文比较得分前,务必以已知参照亚型定向(如上)。 - 使用真实 Boruta 步骤时,运行 `Boruta::Boruta(x = t(expr), y = factor(cluster), maxRuns = 100, ntree = 500)`,取 `attStats()` 中 `decision == "Confirmed"` 的行;A、B 两组 signature 需**分别**筛选,以免占优符号淹没少数集。 -- 在 z-score(按样本)后的表达式上计得分,避免高表达管家基因主导 PC1。 +- 在按基因 z-score 后的表达式上计得分,避免高表达管家基因主导 PC1。 ::: ### 7. PC1 载荷解读表达程序 @@ -505,6 +505,81 @@ ggplot() + - 混淆矩阵断言在图先于肉眼拦下失败运行:真实队列恢复率低于 ~0.9 即提示重审 k 或修剪特征。 ::: +### 9. Top-N 载荷箭头 + 多层置信椭圆 + +FigureYa38 配方 \[2\] 弥补朴素 PCA 图的可解释性缺口:按基因对展示平面的贡献排序(载荷 × sqrt(特征值),对 PC1/PC2 求和),为 **Top N 基因画箭头**让读者看到是哪些基因拉开各组,并用**嵌套置信椭圆**(实线 95% 内套虚线 90%)包裹每个组。ggord/gglayer 以交互方式做这件事;下版本是无依赖的 ggplot2 实现,运行在模拟的三癌种 30 基因面板上: + +```{r} +#| label: fig-9.1LoadingArrows +#| fig-cap: "模拟三癌种面板(30 基因)的 PCA:箭头指向贡献前三的基因(PC1-PC2 上的载荷 × sqrt(特征值));每组带嵌套的 90%(虚线)与 95%(实线)置信椭圆。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7 +#| fig-height: 6 + +set.seed(3801) +grp2 <- factor(rep(c("BRCA", "OV", "LUSC"), each = 20)) +expr_pg <- matrix(rnorm(30 * 60, 5, 1), 60, 30) +expr_pg[grp2 == "BRCA", 1:2] <- expr_pg[grp2 == "BRCA", 1:2] + 2.4 +expr_pg[grp2 == "OV", 3:4] <- expr_pg[grp2 == "OV", 3:4] + 2.2 +expr_pg[grp2 == "LUSC", 5] <- expr_pg[grp2 == "LUSC", 5] + 2.0 +colnames(expr_pg) <- c("GATA3", "XBP1", "MUC1", "FOLR1", "KRT17", + paste0("G", sprintf("%02d", 6:30))) +pca_pg <- prcomp(expr_pg, center = TRUE, scale. = FALSE) +pv_pg <- summary(pca_pg)$importance[2, ] +contrib <- rowSums(abs(pca_pg$rotation[, 1:2]) * pv_pg[1:2]) +top_genes <- names(sort(contrib, decreasing = TRUE))[1:3] +scores_pg <- as.data.frame(pca_pg$x[, 1:2]) +scores_pg$grp <- grp2 + +## 两个覆盖水平的嵌套协方差椭圆 +ell <- do.call(rbind, lapply(c(0.9, 0.95), function(pro) { + do.call(rbind, lapply(levels(grp2), function(g) { + d <- scores_pg[scores_pg$grp == g, 1:2] + ctr <- colMeans(d); eg <- eigen(cov(d)) + ang <- seq(0, 2 * pi, length.out = 120) + r <- sqrt(qchisq(pro, df = 2)) + data.frame( + x = ctr[1] + r * (cos(ang) * sqrt(eg$values[1]) * eg$vectors[1, 1] - + sin(ang) * sqrt(eg$values[2]) * eg$vectors[1, 2]), + y = ctr[2] + r * (cos(ang) * sqrt(eg$values[1]) * eg$vectors[2, 1] - + sin(ang) * sqrt(eg$values[2]) * eg$vectors[2, 2]), + grp = g, pro = pro) + })) +})) + +sc_arrow <- max(abs(scores_pg[, 1:2])) * 0.32 +load_top <- pca_pg$rotation[top_genes, 1:2] +load_top <- load_top / apply(abs(load_top), 1, max) * sc_arrow + +ggplot(scores_pg, aes(PC1, PC2, colour = grp)) + + geom_point(size = 2, alpha = 0.75) + + geom_path(data = ell, aes(x, y, colour = grp, linetype = factor(pro)), + linewidth = 0.6, inherit.aes = FALSE, show.legend = FALSE) + + geom_segment(data = as.data.frame(load_top), + aes(x = 0, y = 0, xend = PC1, yend = PC2), + arrow = arrow(length = unit(0.14, "cm")), + colour = "brown", linewidth = 0.7, inherit.aes = FALSE) + + geom_text(data = as.data.frame(load_top), + aes(x = PC1 * 1.15, y = PC2 * 1.15, label = top_genes), + colour = "brown", size = 3.4, fontface = "bold", inherit.aes = FALSE) + + scale_linetype_manual(values = c("0.9" = 2, "0.95" = 1), guide = "none") + + labs(x = sprintf("PC1 (%.0f%%)", 100 * pv_pg[1]), + y = sprintf("PC2 (%.0f%%)", 100 * pv_pg[2]), + title = "PCA with top-3 loading arrows and 90/95% ellipses", + colour = NULL) + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**实践要点** + +- 载荷排序要**用载荷 × sqrt(特征值)** 且恰好针对展示的 PC——只按 PC1 原始载荷排序会漏掉经由 PC2 起作用的基因。 +- 箭头的缩放是展示选择:把每个载荷向量归一化到图面范围(上例 `sc_arrow`)——可解释的是*方向*,不是跨页可比的长度。 +- 嵌套椭圆(0.9 内套 0.95)兼任样本量的诚实性检查:小组的 95% 椭圆会吞掉整个面板——请标注各组 n。 +::: + ## 应用场景 ::: {#fig-UpsetApplications} diff --git a/Correlation/Scatter.qmd b/Correlation/Scatter.qmd index f749ebb6d..552f4a9d0 100644 --- a/Correlation/Scatter.qmd +++ b/Correlation/Scatter.qmd @@ -573,7 +573,7 @@ p ### 10. Enriched Two-Group Scatter + Fisher r-to-z -Two upgrades over a plain scatter, from the reference figure \[5\]: (1) **point size encodes |y − x|**, so samples whose two measurements disagree grow visually; (2) two groups share one panel, and **Fisher's r-to-z transformation** tests whether their correlation coefficients differ significantly. +Two upgrades over a plain scatter, from the reference figure \[4\]: (1) **point size encodes |y − x|**, so samples whose two measurements disagree grow visually; (2) two groups share one panel, and **Fisher's r-to-z transformation** tests whether their correlation coefficients differ significantly. ```{r} #| label: fig-10.1TwoGroupCor @@ -661,4 +661,4 @@ The figure explores the association between CXCR4 and various immune cells. \[3\ \[3\]Zhang S, Hou L, Sun Q. Correlation analysis of intestinal flora and immune function in patients with primary hepatocellular carcinoma\[J\]. J Gastrointest Oncol, 2022,13(3):1308-1316. -\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Correlation/Scatter.zh.qmd b/Correlation/Scatter.zh.qmd index d512fc891..57046b801 100644 --- a/Correlation/Scatter.zh.qmd +++ b/Correlation/Scatter.zh.qmd @@ -574,7 +574,7 @@ p ### 10. 富集两组散点 + Fisher r-to-z -相比普通散点的两处升级,来自参考图 \[5\]:(1)**点大小编码 |y − x|**,两个测量分歧大的样本视觉放大;(2)两组同图,并用 **Fisher r-to-z 变换**检验两组相关系数是否有统计学差异。 +相比普通散点的两处升级,来自参考图 \[4\]:(1)**点大小编码 |y − x|**,两个测量分歧大的样本视觉放大;(2)两组同图,并用 **Fisher r-to-z 变换**检验两组相关系数是否有统计学差异。 ```{r} #| label: fig-10.1TwoGroupCor @@ -662,4 +662,4 @@ ggplot(df_sc, aes(age, dnam, colour = group, size = abs(dnam - age))) + \[3\]Zhang S, Hou L, Sun Q. Correlation analysis of intestinal flora and immune function in patients with primary hepatocellular carcinoma\[J\]. J Gastrointest Oncol, 2022,13(3):1308-1316. -\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Correlation/TernaryPlot.qmd b/Correlation/TernaryPlot.qmd index 2bca63333..5baf66a1c 100644 --- a/Correlation/TernaryPlot.qmd +++ b/Correlation/TernaryPlot.qmd @@ -199,7 +199,58 @@ Display transcriptomics of cell subpopulations The three corners represent three subpopulations of epithelial cells, corresponding to basal cells, luminal progenitor cells (LP), and mature luminal cells (ML), respectively. From the figure, it can be seen that the cell type composition and differentiation at different stages, as well as the subpopulation status corresponding to clusters. -## Reference +### 4. Mutation-Frequency Composition Across Three Subtypes (FigureYa64triangle) + +FigureYa64 \[10\] places mutations in a **ternary diagram**: each mutation's alteration frequencies in three glioma subtypes (pGBM / LGG / sGBM) are normalised to sum to 1, so every point reads as "where does this mutation concentrate?" — the corner means subtype-specific, the centre means shared. Dot size encodes the overall alteration frequency; the reference's segmented scaling (10^f x 3 for large f, linear 50f otherwise) keeps rare mutations visible without letting one huge mutation swamp the panel: + +```{r} +#| label: fig-4.1TernaryMut +#| fig-cap: "Ternary plot of 22 simulated mutations across pGBM/LGG/sGBM: axes are the within-mutation subtype frequency shares (sum = 1); dot size uses the reference's segmented scaling (10^f x 3 above 0.1, linear 50f below)." +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 6 + +## freeze:auto re-executes only new chunks in a fresh session — +## re-attach the needed packages here +suppressPackageStartupMessages({library(ggtern); library(ggplot2)}) +set.seed(6411) +df114 <- data.frame( + Mutation = paste0("Mut", sprintf("%02d", 1:22)), + pGBM = runif(22, 0.1, 0.8), + LGG = runif(22, 0.05, 0.5), + sGBM = runif(22, 0.05, 0.5)) +## normalise each row to a composition (frequencies must sum to 1) +df114 <- transform(df114, + pGBM = pGBM / (pGBM + LGG + sGBM), + LGG = LGG / (pGBM + LGG + sGBM), + sGBM = sGBM / (pGBM + LGG + sGBM)) +afreq <- runif(22, 0.02, 0.35) +## segmented size scaling: linear for rare, exponential for common — +## keeps rare mutations visible without one huge dot swamping the panel +df114$allfrequency <- ifelse(afreq >= 0.1, 10^(afreq) * 3, 50 * afreq) + +ggtern(data = df114, + aes(x = pGBM, y = LGG, z = sGBM)) + + geom_point(size = df114$allfrequency, shape = 21, + fill = "#5E9BD3", colour = "grey25") + + labs(x = "pGBM", y = "LGG", z = "sGBM", + title = "Mutation frequency composition across three glioma subtypes (simulated)") + + theme_bw(base_size = 11) + + theme(tern.panel.background = element_rect(fill = "grey97", colour = NA), + tern.axis.text = element_text(size = 9)) +``` + +::: callout-tip +**Practice tips** + +- The axes are **within-mutation shares**, not raw frequencies: normalise each row (f / sum(f)) or the points will scatter off the diagram for no reason. +- Keep the segmented size rule in the caption with its threshold (0.1 here) — the size axis is non-linear and readers will otherwise compare dots 1:1. +- ggtern requires `ggtern(...)` as the base call (not `ggplot()`) and its own theme hooks (`tern.panel.background`); mixing plain ggplot2 theme elements silently does nothing. +::: + +## Reference## Reference \[1\] Zhang L, Zhang M, Huang S, Li L, Gao Q, Wang Y, Zhang S, Huang S, Yuan L, Wen Y, Liu K, Yu X, Li D, Zhang L, Xu X, Wei H, He P, Zhou W, Philippot L, Ai C. A highly conserved core bacterial microbiota with nitrogen-fixation capacity inhabits the xylem sap in maize plants. Nat Commun. 2022 Jun 11;13(1):3361. doi: 10.1038/s41467-022-31113-w. PMID: 35688828; PMCID: PMC9187771. @@ -208,3 +259,5 @@ The three corners represent three subpopulations of epithelial cells, correspond \[3\] Hamilton, N. E., & Ferry, M. (2018). ggtern: Ternary Diagrams Using ggplot2 \[R package\]. [https://CRAN.R-project.org/package=ggtern](https://cran.r-project.org/package=ggtern) \[4\] Arnold, J. (2024). ggthemes: Extra Themes, Scales and Geoms for 'ggplot2' \[R package\]. [https://CRAN.R-project.org/package=ggthemes](https://cran.r-project.org/package=ggthemes) + +\[10\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Correlation/TernaryPlot.zh.qmd b/Correlation/TernaryPlot.zh.qmd index 5d4bc9724..077bc1c78 100644 --- a/Correlation/TernaryPlot.zh.qmd +++ b/Correlation/TernaryPlot.zh.qmd @@ -199,7 +199,56 @@ p3_1 三个角代表上皮细胞的三个亚群,分别对应基底细胞、管腔祖细胞(LP)和成熟管腔细胞(ML)。从图中可以看出不同阶段的细胞类型组成和分化情况,以及对应簇的亚群状态。 -## 参考文献 +### 4. 三个亚型间的突变频率构成(FigureYa64triangle) + +FigureYa64 \[10\] 把突变放进**三元图**:每个突变在三种胶质瘤亚型(pGBM / LGG / sGBM)中的改变频率归一化为和为 1,每个点的读法是"该突变集中在哪个亚型"——顶角意味着亚型特异,中心意味着共享。点大小编码总体改变频率;参考文档的分段缩放(大 f 用 10^f × 3,小 f 用线性 50f)让稀有突变可见而不被一个巨型突变吞掉整个面板: + +```{r} +#| label: fig-4.1TernaryMut +#| fig-cap: "22 个模拟突变在 pGBM/LGG/sGBM 上的三元图:轴为突变内亚型频率占比(和 = 1);点大小采用参考的分段缩放(0.1 以上用 10^f × 3,以下线性 50f)。" +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 6.5 +#| fig-height: 6 + +## freeze:auto 只对新 chunk 在新会话中重跑——在此重新挂载所需包 +suppressPackageStartupMessages({library(ggtern); library(ggplot2)}) +set.seed(6411) +df114 <- data.frame( + Mutation = paste0("Mut", sprintf("%02d", 1:22)), + pGBM = runif(22, 0.1, 0.8), + LGG = runif(22, 0.05, 0.5), + sGBM = runif(22, 0.05, 0.5)) +## 逐行归一化为构成比(频率之和必须为 1) +df114 <- transform(df114, + pGBM = pGBM / (pGBM + LGG + sGBM), + LGG = LGG / (pGBM + LGG + sGBM), + sGBM = sGBM / (pGBM + LGG + sGBM)) +afreq <- runif(22, 0.02, 0.35) +## 分段大小缩放:稀有者线性、常见者指数——稀有突变可见,巨型突变不吞面板 +df114$allfrequency <- ifelse(afreq >= 0.1, 10^(afreq) * 3, 50 * afreq) + +ggtern(data = df114, + aes(x = pGBM, y = LGG, z = sGBM)) + + geom_point(size = df114$allfrequency, shape = 21, + fill = "#5E9BD3", colour = "grey25") + + labs(x = "pGBM", y = "LGG", z = "sGBM", + title = "Mutation frequency composition across three glioma subtypes (simulated)") + + theme_bw(base_size = 11) + + theme(tern.panel.background = element_rect(fill = "grey97", colour = NA), + tern.axis.text = element_text(size = 9)) +``` + +::: callout-tip +**实践要点** + +- 轴是**突变内占比**而非原始频率:逐行归一化(f / sum(f)),否则点会无故散到图外。 +- 分段缩放规则要连同阈值(此处 0.1)写进图注——大小轴非线性,读者会 1:1 比较点大小。 +- ggtern 必须以 `ggtern(...)` 作为基础调用(而非 `ggplot()`),并使用其专属主题钩子(`tern.panel.background`);混用普通 ggplot2 主题元素会静默失效。 +::: + +## 参考文献## 参考文献 \[1\] Zhang L, Zhang M, Huang S, Li L, Gao Q, Wang Y, Zhang S, Huang S, Yuan L, Wen Y, Liu K, Yu X, Li D, Zhang L, Xu X, Wei H, He P, Zhou W, Philippot L, Ai C. A highly conserved core bacterial microbiota with nitrogen-fixation capacity inhabits the xylem sap in maize plants. Nat Commun. 2022 Jun 11;13(1):3361. doi: 10.1038/s41467-022-31113-w. PMID: 35688828; PMCID: PMC9187771. @@ -209,5 +258,4 @@ p3_1 \[4\] Arnold, J. (2024). ggthemes: Extra Themes, Scales and Geoms for 'ggplot2' \[R package\]. [https://CRAN.R-project.org/package=ggthemes](https://cran.r-project.org/package=ggthemes) - - +\[10\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Correlation/WgcnaPlot.qmd b/Correlation/WgcnaPlot.qmd index 320135e8d..3ea7fd954 100644 --- a/Correlation/WgcnaPlot.qmd +++ b/Correlation/WgcnaPlot.qmd @@ -4,7 +4,7 @@ author: - "**[Editor]** ZCode (GLM) — AI-generated, independently AI-reviewed;" --- -Weighted Gene Co-expression Network Analysis (WGCNA) requires choosing a **soft-thresholding power β** such that the scale-free topology fit index reaches a plateau \[1\]. The canonical figure is a two-panel plot: (left) the scale-free fit index vs β and (right) the mean connectivity vs β. This tutorial simulates expression data and walks through the fitting step. +Weighted Gene Co-expression Network Analysis (WGCNA) requires choosing a **soft-thresholding power β** such that the scale-free topology fit index reaches a plateau \[1\]. The canonical figure is a two-panel plot: (left) the scale-free fit index vs β and (right) the mean connectivity vs β — the layout standardized by the FigureYa collection \[2\]. This tutorial simulates expression data and walks through the fitting step. ## Example diff --git a/Correlation/WgcnaPlot.zh.qmd b/Correlation/WgcnaPlot.zh.qmd index 0f8a3d339..3e15ed48c 100644 --- a/Correlation/WgcnaPlot.zh.qmd +++ b/Correlation/WgcnaPlot.zh.qmd @@ -4,7 +4,7 @@ author: - "**[编辑]** ZCode (GLM) — AI 生成,独立 AI 复核" --- -加权基因共表达网络分析(WGCNA)需要选择一个**软阈值幂 β** 使无标度拓扑拟合指数达到平台期 \[1\]。经典图是双面板:(左) 拟合指数 vs β,(右) 平均连接度 vs β。本教程模拟表达数据并走完拟合步骤。 +加权基因共表达网络分析(WGCNA)需要选择一个**软阈值幂 β** 使无标度拓扑拟合指数达到平台期 \[1\]。经典图是双面板:(左) 拟合指数 vs β,(右) 平均连接度 vs β——该版式由 FigureYa 合集标准化 \[2\]。本教程模拟表达数据并走完拟合步骤。 ## Example @@ -16,7 +16,7 @@ author: - 编程语言:R -- 依赖包: `ggplot2`; `dplyr` +- 依赖包: `ggplot2`; `dplyr`; `patchwork` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} if (!requireNamespace("ggplot2", quietly = TRUE)) install.packages("ggplot2") diff --git a/DataOverTime/LineChart.qmd b/DataOverTime/LineChart.qmd index 78c9ddac3..1e297e606 100644 --- a/DataOverTime/LineChart.qmd +++ b/DataOverTime/LineChart.qmd @@ -586,7 +586,66 @@ Applications of line chart 3 The figure shows: (A) Distribution of the number of comorbidities in HCC patients; (B) Average number of comorbidities in HCC patients of different ages and sexes; (C) Distribution of the number of comorbidities in male HCC patients of different age groups; (D) Distribution of the number of comorbidities in female HCC patients of different age groups. \[3\] -## Reference +### 13. Double-Y-Axis Scatter with Two Correlations (FigureYa62twoAxis) + +FigureYa62 \[9\] plots two response variables with different scales against one x (miRNA and methylation beta vs mRNA expression) using `sec_axis()`. The critical rule: **the secondary variable must be scaled onto the primary axis before plotting** (`Y2 * scaleFactor`), and the `coord_fixed()` ratio is derived from the two ranges so the lm lines are visually comparable. Pearson correlations for both fits are annotated in their own colours: + +```{r} +#| label: fig-13.1TwoAxis +#| fig-cap: "Double-Y-axis scatter (simulated): miRNA expression (left axis, blue) and cg10586317 methylation beta (right axis, orange) vs mRNA expression; both with lm fits; the secondary variable is pre-scaled onto the primary axis; Pearson R annotated per series." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(6211) +n_ta <- 60 +inputData <- data.frame(X = sort(rnorm(n_ta, 6, 1.6))) +inputData$Y1 <- 2.2 * inputData$X + rnorm(n_ta, 0, 1.1) + 14 # miRNA (left) +inputData$Y2 <- 0.55 * inputData$X + rnorm(n_ta, 0, 0.35) + 0.2 # methylation (right) +scaleFactor <- max(inputData$Y1) / max(inputData$Y2) +AspectRatio <- 5 / 2 +ratioValues <- ((max(inputData$X) - min(inputData$X)) / + (max(inputData$Y1) - min(inputData$Y1))) / AspectRatio +R1 <- cor.test(inputData$X, inputData$Y1, method = "pearson") +R2 <- cor.test(inputData$X, inputData$Y2, method = "pearson") +R1cor <- sprintf('italic(R)~"="~%.2f', R1$estimate) +R2cor <- sprintf('italic(R)~"="~%.2f', R2$estimate) +s1Colour <- "#6B9EC2"; s2Colour <- "#EE861A" + +ggplot(inputData, aes(x = X)) + + geom_point(aes(y = Y1), col = s1Colour, size = 1.8) + + geom_smooth(aes(x = X, y = Y1), method = "lm", se = FALSE, col = s1Colour) + + geom_point(aes(y = Y2 * scaleFactor), col = s2Colour, size = 1.8) + + geom_smooth(aes(x = X, y = Y2 * scaleFactor), method = "lm", se = FALSE, + colour = s2Colour) + + scale_y_continuous(name = "miRNA expression (simulated)", + sec.axis = sec_axis(trans = ~ . / scaleFactor, + name = "cg10586317 methylation (beta)")) + + coord_fixed(ratio = ratioValues) + + annotate("text", x = max(inputData$X) * 0.97, y = max(inputData$Y1) * 0.97, + label = R1cor, size = 4.5, parse = TRUE, colour = s1Colour) + + annotate("text", x = max(inputData$X) * 0.97, y = max(inputData$Y1) * 0.88, + label = R2cor, size = 4.5, parse = TRUE, colour = s2Colour) + + labs(x = "mRNA expression (simulated)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + axis.title.y.left = element_text(colour = s1Colour), + axis.text.y.left = element_text(colour = s1Colour), + axis.title.y.right = element_text(colour = s2Colour), + axis.text.y.right = element_text(colour = s2Colour)) +``` + +::: callout-tip +**Practice tips** + +- Never draw the secondary variable raw: scale it by `max(Y1)/max(Y2)` (or a mean-based ratio) and invert on `sec_axis(trans = ~ . / scaleFactor)` — the ticks then read true Y2 units while the geometry stays on the primary scale. +- `coord_fixed(ratio = ratioValues)` ties the panel aspect to the two ranges; without it the two lm slopes are not visually comparable. +- Two lm fits on one x is a "correlation display", not a causal claim — annotate both Pearson R values and let the colours map each annotation to its series. +::: + +## Reference## Reference \[1\] FU C, XU W, ZHENG W, et al. Epidemiological characteristics and interrupted time series analysis of mumps in Quzhou City, 2005-2023[J]. Hum Vaccin Immunother, 2024,20(1): 2411828. @@ -594,4 +653,4 @@ The figure shows: (A) Distribution of the number of comorbidities in HCC patient \[3\] MU X M, WANG W, JIANG Y Y, et al. Patterns of Comorbidity in Hepatocellular Carcinoma: A Network Perspective[J]. Int J Environ Res Public Health, 2020,17(9). - +\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/DataOverTime/LineChart.zh.qmd b/DataOverTime/LineChart.zh.qmd index daa5cec77..8d81a7d93 100644 --- a/DataOverTime/LineChart.zh.qmd +++ b/DataOverTime/LineChart.zh.qmd @@ -588,7 +588,66 @@ p 图中(A) HCC患者合并症数量的分布。(B) 不同年龄和性别的HCC患者的平均合并症数量。(C)各年龄组男性HCC患者合并症数量的分布。(D) 各年龄组女性HCC患者合并症数量的分布。\[3\] -## 参考文献 +### 13. 双 Y 轴散点与两组相关(FigureYa62twoAxis) + +FigureYa62 \[9\] 用 `sec_axis()` 把两个不同量纲的响应变量对同一 x 作图(miRNA 与甲基化 beta 对 mRNA 表达)。关键规则:**次轴变量必须先按主轴缩放再画**(`Y2 * scaleFactor`),`coord_fixed()` 的比例由两个值域推得,使两条 lm 拟合线视觉可比。两次拟合的 Pearson 相关系数以各自颜色标注: + +```{r} +#| label: fig-13.1TwoAxis +#| fig-cap: "双 Y 轴散点(模拟):miRNA 表达(左轴、蓝)与 cg10586317 甲基化 beta(右轴、橙)对 mRNA 表达;均带 lm 拟合线;次轴变量已预缩放到主轴;两系列分别标注 Pearson R。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(6211) +n_ta <- 60 +inputData <- data.frame(X = sort(rnorm(n_ta, 6, 1.6))) +inputData$Y1 <- 2.2 * inputData$X + rnorm(n_ta, 0, 1.1) + 14 # miRNA(左) +inputData$Y2 <- 0.55 * inputData$X + rnorm(n_ta, 0, 0.35) + 0.2 # 甲基化(右) +scaleFactor <- max(inputData$Y1) / max(inputData$Y2) +AspectRatio <- 5 / 2 +ratioValues <- ((max(inputData$X) - min(inputData$X)) / + (max(inputData$Y1) - min(inputData$Y1))) / AspectRatio +R1 <- cor.test(inputData$X, inputData$Y1, method = "pearson") +R2 <- cor.test(inputData$X, inputData$Y2, method = "pearson") +R1cor <- sprintf('italic(R)~"="~%.2f', R1$estimate) +R2cor <- sprintf('italic(R)~"="~%.2f', R2$estimate) +s1Colour <- "#6B9EC2"; s2Colour <- "#EE861A" + +ggplot(inputData, aes(x = X)) + + geom_point(aes(y = Y1), col = s1Colour, size = 1.8) + + geom_smooth(aes(x = X, y = Y1), method = "lm", se = FALSE, col = s1Colour) + + geom_point(aes(y = Y2 * scaleFactor), col = s2Colour, size = 1.8) + + geom_smooth(aes(x = X, y = Y2 * scaleFactor), method = "lm", se = FALSE, + colour = s2Colour) + + scale_y_continuous(name = "miRNA expression (simulated)", + sec.axis = sec_axis(trans = ~ . / scaleFactor, + name = "cg10586317 methylation (beta)")) + + coord_fixed(ratio = ratioValues) + + annotate("text", x = max(inputData$X) * 0.97, y = max(inputData$Y1) * 0.97, + label = R1cor, size = 4.5, parse = TRUE, colour = s1Colour) + + annotate("text", x = max(inputData$X) * 0.97, y = max(inputData$Y1) * 0.88, + label = R2cor, size = 4.5, parse = TRUE, colour = s2Colour) + + labs(x = "mRNA expression (simulated)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + axis.title.y.left = element_text(colour = s1Colour), + axis.text.y.left = element_text(colour = s1Colour), + axis.title.y.right = element_text(colour = s2Colour), + axis.text.y.right = element_text(colour = s2Colour)) +``` + +::: callout-tip +**实践要点** + +- 次轴变量绝不能原样绘制:按 `max(Y1)/max(Y2)`(或基于均值的比值)缩放,并在 `sec_axis(trans = ~ . / scaleFactor)` 上反变换——刻度读的是真实 Y2 单位,而几何留在主轴刻度上。 +- `coord_fixed(ratio = ratioValues)` 把面板长宽比绑定到两个值域;没有它,两条 lm 斜率不具备视觉可比性。 +- 同一 x 上画两条 lm 属"相关性展示",不是因果声明——标注两个 Pearson R 值,用颜色把标注映射到各自系列。 +::: + +## 参考文献## 参考文献 \[1\] FU C, XU W, ZHENG W, et al. Epidemiological characteristics and interrupted time series analysis of mumps in Quzhou City, 2005-2023[J]. Hum Vaccin Immunother, 2024,20(1): 2411828. @@ -596,4 +655,4 @@ p \[3\] MU X M, WANG W, JIANG Y Y, et al. Patterns of Comorbidity in Hepatocellular Carcinoma: A Network Perspective[J]. Int J Environ Res Public Health, 2020,17(9). - +\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Distribution/BoxPlot.qmd b/Distribution/BoxPlot.qmd index c0f1a94a4..c0fa5ad43 100644 --- a/Distribution/BoxPlot.qmd +++ b/Distribution/BoxPlot.qmd @@ -536,7 +536,7 @@ ggplot(long9, aes(x = stage, y = expr, fill = stage)) + ### 10. Signature-Score Boxplots Across Cell Clusters -TME (tumour-microenvironment) studies compare **gene-set scores** — not raw genes — between sample groups \[10\]: each signature's score is the sign-corrected first principal component of its genes, scores are standardised so the panels share a scale, and a Kruskal-Wallis test per signature flags cluster differences with stars. +TME (tumour-microenvironment) studies compare **gene-set scores** — not raw genes — between sample groups \[9\]: each signature's score is the sign-corrected first principal component of its genes, scores are standardised so the panels share a scale, and a Kruskal-Wallis test per signature flags cluster differences with stars. ```{r} #| label: fig-10.1TMEscoreBox @@ -630,7 +630,61 @@ Applications of Grouped Boxplot Figure C: Boxplot of genome size for organisms with H2A that does or does not contain the shown residues.\[2\] -## Reference +### 4. Pan-Cancer Boxplot with Per-Tissue Significance (FigureYa55plus) + +The boxplot companion of the pan-cancer violin (FigureYa55plus_pancancer_boxplot \[14\]): same TOIL TCGA-vs-normal matrix, `ggpubr::ggboxplot()` with jittered points, tumour/normal fills, and a significance star above every tissue from a per-tissue Wilcoxon test. ggpubr's `stat_compare_means(comparisons = ...)` cannot fan out over 10 tissues at once, so the stars are computed and placed manually — the same trick as ggpubr's own multi-panel examples: + +```{r} +#| label: fig-4.1PanCancerBox +#| fig-cap: "Pan-cancer boxplot of the simulated TP53-like matrix: jittered points over tumour/normal boxes per tissue; stars above each tissue are per-tissue Wilcoxon tests." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 5 + +set.seed(5501) +tissues <- c("BRCA", "COAD", "HNSC", "KIRC", "LUAD", "LUSC", "PRAD", "STAD", "THCA", "UCEC") +n_per <- 120 +tp53_base <- c(BRCA = 2.6, COAD = 2.2, HNSC = 2.8, KIRC = 2.4, LUAD = 2.5, + LUSC = 2.9, PRAD = 2.3, STAD = 2.7, THCA = 2.2, UCEC = 2.5) +pan <- do.call(rbind, lapply(tissues, function(t) { + rbind(data.frame(tissue = t, type2 = "tumor", tpm = rnorm(n_per, tp53_base[t] + 0.9, 0.75)), + data.frame(tissue = t, type2 = "normal", tpm = rnorm(n_per, tp53_base[t] - 0.4, 0.6))) +})) +pan$type2 <- factor(pan$type2, levels = c("tumor", "normal")) +pan$tissue <- factor(pan$tissue, levels = tissues) +wt <- do.call(rbind, lapply(tissues, function(t) { + d1 <- pan$tpm[pan$tissue == t & pan$type2 == "tumor"] + d0 <- pan$tpm[pan$tissue == t & pan$type2 == "normal"] + data.frame(tissue = t, p = wilcox.test(d1, d0)$p.value) +})) +star_df <- data.frame(tissue = factor(wt$tissue, levels = tissues), + y = max(pan$tpm) + 0.55, + lab = ifelse(wt$p < 0.001, "***", + ifelse(wt$p < 0.01, "**", + ifelse(wt$p < 0.05, "*", "")))) +ggpubr::ggboxplot(pan, x = "tissue", y = "tpm", fill = "type2", + color = "black", palette = c("#DF2020", "#DDDF21"), + ylab = "TP53 expression (log2 TPM, simulated)", xlab = NULL, + add = "jitter", jitter = 0.18, + add.params = list(size = 0.5, alpha = 0.35, color = "type2"), + outlier.shape = NA) + + geom_text(data = star_df, aes(tissue, y, label = lab), + inherit.aes = FALSE, size = 4.2, colour = "grey10") + + scale_y_continuous(limits = c(min(pan$tpm) - 0.5, max(pan$tpm) + 1.1)) + + theme(legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- `outlier.shape = NA` plus `add = "jitter"` shows every sample exactly once — boxplot outliers and jittered points double-draw the same samples otherwise. +- Place the stars **after** fixing the y range (`limits`), not before: the star row must sit above the tallest whisker without rescaling the boxes. +- Per-tissue tests on one gene are 10 independent tests — if you annotate stars, say which correction (none / BH) the stars reflect. +::: + +## Reference## Reference \[1\] Volkmann C, Brings N, Becker M, Hobeika E, Yang J, Reth M. Molecular requirements of the B-cell antigen receptor for sensing monovalent antigens. EMBO J. 2016 Nov 2;35(21):2371-2381. doi: 10.15252/embj.201694177. Epub 2016 Sep 15. PMID: 27634959; PMCID: PMC5090217. @@ -650,4 +704,4 @@ Figure C: Boxplot of genome size for organisms with H2A that does or does not co \[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 -\[10\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Distribution/BoxPlot.zh.qmd b/Distribution/BoxPlot.zh.qmd index df8c8d78e..7503aec39 100644 --- a/Distribution/BoxPlot.zh.qmd +++ b/Distribution/BoxPlot.zh.qmd @@ -536,7 +536,7 @@ ggplot(long9, aes(x = stage, y = expr, fill = stage)) + ::: ### 10. 跨细胞类群的 signature 评分箱线图 -TME(肿瘤微环境)研究比较的是**基因集评分**而非单个基因 \[10\]:每个 signature 的得分是其基因集合经符号校正的第一主成分,评分标准化后共享一个坐标,再用逐 signature 的 Kruskal-Wallis 检验以星号标记类群差异。 +TME(肿瘤微环境)研究比较的是**基因集评分**而非单个基因 \[9\]:每个 signature 的得分是其基因集合经符号校正的第一主成分,评分标准化后共享一个坐标,再用逐 signature 的 Kruskal-Wallis 检验以星号标记类群差异。 ```{r} #| label: fig-10.1TMEscoreBox @@ -630,7 +630,62 @@ Figure D & Figure F: MDA-MB-453 (D)或 HEK293(F) 中所示 H2A 过表达 Figure C: 具有不含有(左)或含有(右)所示残基的 H2A 的生物体的基因组大小的箱线图。\[2\] -## 参考文献 +### 4. 泛癌箱线图 + 逐组织显著性(FigureYa55plus) + +泛癌小提琴的箱线图伴侣(FigureYa55plus_pancancer_boxplot \[14\]):同一份 TOIL TCGA-vs-normal 矩阵,`ggpubr::ggboxplot()` 加抖动点、肿瘤/正常填色,并逐组织在图上方标注 Wilcoxon 星号。ggpubr 的 `stat_compare_means(comparisons = ...)` 无法一次扇出到 10 个组织,星号需手工计算摆放——与 ggpubr 官方多面板示例同思路: + +```{r} +#| label: fig-4.1PanCancerBox +#| fig-cap: "模拟 TP53 样矩阵的泛癌箱线图:逐组织肿瘤/正常箱体叠加抖动点;各组织上方星号为逐组织 Wilcoxon 检验。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 5 + +set.seed(5501) +tissues <- c("BRCA", "COAD", "HNSC", "KIRC", "LUAD", "LUSC", "PRAD", "STAD", "THCA", "UCEC") +n_per <- 120 +tp53_base <- c(BRCA = 2.6, COAD = 2.2, HNSC = 2.8, KIRC = 2.4, LUAD = 2.5, + LUSC = 2.9, PRAD = 2.3, STAD = 2.7, THCA = 2.2, UCEC = 2.5) +pan <- do.call(rbind, lapply(tissues, function(t) { + rbind(data.frame(tissue = t, type2 = "tumor", tpm = rnorm(n_per, tp53_base[t] + 0.9, 0.75)), + data.frame(tissue = t, type2 = "normal", tpm = rnorm(n_per, tp53_base[t] - 0.4, 0.6))) +})) +pan$type2 <- factor(pan$type2, levels = c("tumor", "normal")) +pan$tissue <- factor(pan$tissue, levels = tissues) +wt <- do.call(rbind, lapply(tissues, function(t) { + d1 <- pan$tpm[pan$tissue == t & pan$type2 == "tumor"] + d0 <- pan$tpm[pan$tissue == t & pan$type2 == "normal"] + data.frame(tissue = t, p = wilcox.test(d1, d0)$p.value) +})) +star_df <- data.frame(tissue = factor(wt$tissue, levels = tissues), + y = max(pan$tpm) + 0.55, + lab = ifelse(wt$p < 0.001, "***", + ifelse(wt$p < 0.01, "**", + ifelse(wt$p < 0.05, "*", "")))) + +ggpubr::ggboxplot(pan, x = "tissue", y = "tpm", fill = "type2", + color = "black", palette = c("#DF2020", "#DDDF21"), + ylab = "TP53 expression (log2 TPM, simulated)", xlab = NULL, + add = "jitter", jitter = 0.18, + add.params = list(size = 0.5, alpha = 0.35, color = "type2"), + outlier.shape = NA) + + geom_text(data = star_df, aes(tissue, y, label = lab), + inherit.aes = FALSE, size = 4.2, colour = "grey10") + + scale_y_continuous(limits = c(min(pan$tpm) - 0.5, max(pan$tpm) + 1.1)) + + theme(legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- `outlier.shape = NA` 加 `add = "jitter"` 让每个样本只出现一次——箱线图离群点与抖动点会把同一样本画两遍。 +- 星号要在**定好 y 范围**(`limits`)之后再放:星号行必须高于最高的须线且不引起箱体重缩放。 +- 单基因的 10 个逐组织检验是 10 次独立检验——标注星号时写明星号反映的校正方式(不校正 / BH)。 +::: + +## 参考文献## 参考文献 \[1\] Volkmann C, Brings N, Becker M, Hobeika E, Yang J, Reth M. Molecular requirements of the B-cell antigen receptor for sensing monovalent antigens. EMBO J. 2016 Nov 2;35(21):2371-2381. doi: 10.15252/embj.201694177. Epub 2016 Sep 15. PMID: 27634959; PMCID: PMC5090217. @@ -650,4 +705,4 @@ Figure C: 具有不含有(左)或含有(右)所示残基的 H2A 的生 \[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 -\[10\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Distribution/ECDFPlot.qmd b/Distribution/ECDFPlot.qmd index a82939961..b3314a7a0 100644 --- a/Distribution/ECDFPlot.qmd +++ b/Distribution/ECDFPlot.qmd @@ -7,12 +7,13 @@ author: The empirical cumulative distribution function (ECDF), $F_n(x) = \frac{1}{n}\sum_i \mathbf{1}(x_i \le x)$, plots every observation as a step that climbs from 0 to 1 — a complete, assumption-free portrait of a distribution. Compared with histograms it needs no bin-width tuning, shows *every* data point's position, and makes quantiles directly readable: the group median is simply where its curve crosses 0.5 \[1\]. Two ECDF curves on one axes are also the geometric basis of the two-sample Kolmogorov–Smirnov test — the vertical gap between them is the KS statistic \[2\]. -This tutorial covers four workflows: +This tutorial covers five workflows: 1. Two-group ECDFs with `stat_ecdf()`; 2. Multi-group ECDFs with annotated medians; 3. The two-sample ECDF *difference* plot — visualizing the KS statistic; -4. The p-value ECDF, a standard omics quality-control view. +4. The p-value ECDF, a standard omics quality-control view; +5. Multi-group ECDFs annotated with Wilcoxon rank-sum p-values. ## Example @@ -24,12 +25,13 @@ This tutorial covers four workflows: - Programming language: R -- Dependent packages: `ggplot2`; `dplyr` +- Dependent packages: `ggplot2`; `dplyr`; `rstatix` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Load packages library(ggplot2) library(dplyr) +library(rstatix) ``` ```{r} @@ -166,6 +168,54 @@ ggplot(pvdf, aes(p, colour = what)) + theme(legend.position = "top") ``` +### 5. ECDF with Wilcoxon Rank-Sum P-Values + +The publication layout behind FigureYa298ecdfPvalue \[3\] — cumulative log2 fold-change distributions of non-target genes, CLIP targets and CLIP + RIP targets — overlays three ECDFs and states each group's shift against the non-target reference with a two-sided Wilcoxon rank-sum test (the Mann–Whitney U test; both names describe the same procedure). The annotations use each curve's color, so the reader maps p-value to distribution without hunting through the legend: + +```{r} +#| label: fig-5.1EcdfWilcox +#| fig-cap: "Three simulated log2 fold-change distributions (n = 100 each): ECDFs annotated with two-sided Wilcoxon rank-sum p-values against the Non-targets reference (P = 0.027 for CLIP targets, P < 0.001 for CLIP + RIP targets)." +#| out.width: "65%" +#| fig-width: 6 +#| fig-height: 5.4 +#| warning: false +#| message: false + +set.seed(2981) +n_ec <- 100 +df_e <- data.frame( + x = c(rnorm(n_ec, 0, 1), rnorm(n_ec, 0.35, 1), rnorm(n_ec, 0.75, 1)), + g = rep(c("Non-targets", "CLIP targets", "CLIP + RIP targets"), each = n_ec)) +df_e$g <- factor(df_e$g, levels = c("Non-targets", "CLIP targets", "CLIP + RIP targets")) + +wt <- df_e |> rstatix::wilcox_test(x ~ g) # all pairwise; keep the vs-reference rows +p_clip <- wt$p[wt$group1 == "Non-targets" & wt$group2 == "CLIP targets"] +p_crip <- wt$p[wt$group1 == "Non-targets" & wt$group2 == "CLIP + RIP targets"] +fmt_p <- function(p) ifelse(p < 0.001, "P < 0.001", sprintf("P = %.3f", p)) + +cols_e <- c("Non-targets" = "red", "CLIP targets" = "forestgreen", + "CLIP + RIP targets" = "darkblue") +labs_e <- c("Non-targets (n = 100)", "CLIP targets (n = 100)", + "CLIP + RIP targets (n = 100)") + +ggplot(df_e, aes(x, colour = g)) + + stat_ecdf(geom = "step", linewidth = 1) + + annotate("text", x = -2.9, y = 0.72, hjust = 0, size = 4.2, + colour = cols_e["CLIP targets"], label = paste0(fmt_p(p_clip), " (vs Non-targets)")) + + annotate("text", x = -2.9, y = 0.62, hjust = 0, size = 4.2, + colour = cols_e["CLIP + RIP targets"], label = paste0(fmt_p(p_crip), " (vs Non-targets)")) + + scale_color_manual(values = cols_e, labels = labs_e, name = NULL) + + labs(x = "log2 fold change (simulated)", y = "Cumulative fraction", + title = "ECDF with two-sided Wilcoxon rank-sum P values") + + theme_bw(base_size = 12) + + theme(legend.position = "top", + panel.grid = element_blank(), + legend.text = element_text(size = 9.5), + plot.title = element_text(size = 12)) +``` + +Two remarks on the statistics. First, the p-value annotations must be formatted defensively: `sprintf("%.3f", 7.8e-5)` renders `0.000`, so values below the resolution switch to the explicit `P < 0.001` form. Second, for exactly two groups the Wilcoxon rank-sum test and the Kruskal–Wallis test are the same procedure — `rstatix::kruskal_test()` on the two-group subset returns an identical p-value — which is a handy cross-check when porting code between the two idioms. + ::: callout-tip ## Practice tips @@ -186,3 +236,5 @@ ECDF plots serve distribution comparison wherever medians and tails matter more \[1\] Chambers JM, Cleveland WS, Kleiner B, Tukey PA. Graphical Methods for Data Analysis. Belmont: Wadsworth; 1983. \[2\] Hodges JL. The significance probability of the Smirnov two-sample test. Ark Mat. 1957;3(5):469-486. doi:10.1007/BF02589501 + +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Distribution/ECDFPlot.zh.qmd b/Distribution/ECDFPlot.zh.qmd index cb1e395c2..71f72e3fa 100644 --- a/Distribution/ECDFPlot.zh.qmd +++ b/Distribution/ECDFPlot.zh.qmd @@ -7,12 +7,13 @@ author: 经验累积分布函数(ECDF),$F_n(x) = \frac{1}{n}\sum_i \mathbf{1}(x_i \le x)$,把每个观测画成一段从 0 爬升到 1 的阶梯——一个完整、无假设的分布画像。与直方图相比,它不需要调分箱宽度、显示*每个*数据点的位置,且分位数可直接读图:组中位数就是曲线穿过 0.5 的位置 \[1\]。把两条 ECDF 画在同一坐标系里,也是两样本 Kolmogorov–Smirnov 检验的几何基础——两条曲线间的垂直间距就是 KS 统计量 \[2\]。 -本教程涵盖四种工作流: +本教程涵盖五种工作流: 1. `stat_ecdf()` 的两组 ECDF; 2. 多组 ECDF 与中位数标注; 3. 两样本 ECDF*差值*图——KS 统计量的可视化; -4. p 值 ECDF——组学质控的标准视图。 +4. p 值 ECDF——组学质控的标准视图; +5. 带 Wilcoxon 秩和检验 p 值标注的多组 ECDF。 ## Example @@ -24,12 +25,13 @@ author: - 编程语言:R -- 依赖包:`ggplot2`;`dplyr` +- 依赖包:`ggplot2`;`dplyr`;`rstatix` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # 加载包 library(ggplot2) library(dplyr) +library(rstatix) ``` ```{r} @@ -166,6 +168,54 @@ ggplot(pvdf, aes(p, colour = what)) + theme(legend.position = "top") ``` +### 5. 带 Wilcoxon 秩和检验 p 值的 ECDF + +FigureYa298ecdfPvalue 对应的论文版式 \[3\]——非靶基因、CLIP 靶基因与 CLIP+RIP 靶基因的 log2 倍数变化累积分布——把三条 ECDF 叠在同一坐标系,并用双侧 Wilcoxon 秩和检验(即 Mann–Whitney U 检验,两个名字是同一方法)给出各组相对非靶参照的偏移。p 值标注使用对应曲线的颜色,读者无需在图例中来回查找即可把 p 值对应到分布: + +```{r} +#| label: fig-5.1EcdfWilcox +#| fig-cap: "三组模拟 log2 倍数变化分布(各 n = 100):ECDF 标注相对 Non-targets 参照的双侧 Wilcoxon 秩和检验 p 值(CLIP targets P = 0.027,CLIP + RIP targets P < 0.001)。" +#| out.width: "65%" +#| fig-width: 6 +#| fig-height: 5.4 +#| warning: false +#| message: false + +set.seed(2981) +n_ec <- 100 +df_e <- data.frame( + x = c(rnorm(n_ec, 0, 1), rnorm(n_ec, 0.35, 1), rnorm(n_ec, 0.75, 1)), + g = rep(c("Non-targets", "CLIP targets", "CLIP + RIP targets"), each = n_ec)) +df_e$g <- factor(df_e$g, levels = c("Non-targets", "CLIP targets", "CLIP + RIP targets")) + +wt <- df_e |> rstatix::wilcox_test(x ~ g) # 全部两两比较;保留 vs 参照的行 +p_clip <- wt$p[wt$group1 == "Non-targets" & wt$group2 == "CLIP targets"] +p_crip <- wt$p[wt$group1 == "Non-targets" & wt$group2 == "CLIP + RIP targets"] +fmt_p <- function(p) ifelse(p < 0.001, "P < 0.001", sprintf("P = %.3f", p)) + +cols_e <- c("Non-targets" = "red", "CLIP targets" = "forestgreen", + "CLIP + RIP targets" = "darkblue") +labs_e <- c("Non-targets (n = 100)", "CLIP targets (n = 100)", + "CLIP + RIP targets (n = 100)") + +ggplot(df_e, aes(x, colour = g)) + + stat_ecdf(geom = "step", linewidth = 1) + + annotate("text", x = -2.9, y = 0.72, hjust = 0, size = 4.2, + colour = cols_e["CLIP targets"], label = paste0(fmt_p(p_clip), " (vs Non-targets)")) + + annotate("text", x = -2.9, y = 0.62, hjust = 0, size = 4.2, + colour = cols_e["CLIP + RIP targets"], label = paste0(fmt_p(p_crip), " (vs Non-targets)")) + + scale_color_manual(values = cols_e, labels = labs_e, name = NULL) + + labs(x = "log2 fold change (simulated)", y = "Cumulative fraction", + title = "ECDF with two-sided Wilcoxon rank-sum P values") + + theme_bw(base_size = 12) + + theme(legend.position = "top", + panel.grid = element_blank(), + legend.text = element_text(size = 9.5), + plot.title = element_text(size = 12)) +``` + +两点统计说明。其一,p 值标注必须做防御性格式化:`sprintf("%.3f", 7.8e-5)` 会渲染成 `0.000`,低于分辨率的值应切换为显式的 `P < 0.001` 形式。其二,对恰好两组的数据,Wilcoxon 秩和检验与 Kruskal–Wallis 检验是同一方法——对两组子集调用 `rstatix::kruskal_test()` 会返回完全相同的 p 值,在两种写法之间移植代码时可以此交叉验证。 + ::: callout-tip ## 实践要点 @@ -186,3 +236,5 @@ ECDF 图适用于中位数与尾部比均数更重要的分布比较场景:药 \[1\] Chambers JM, Cleveland WS, Kleiner B, Tukey PA. Graphical Methods for Data Analysis. Belmont: Wadsworth; 1983. \[2\] Hodges JL. The significance probability of the Smirnov two-sample test. Ark Mat. 1957;3(5):469-486. doi:10.1007/BF02589501 + +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Distribution/RaincloudPlot.qmd b/Distribution/RaincloudPlot.qmd index 8fca7b69e..33cc6e2f1 100644 --- a/Distribution/RaincloudPlot.qmd +++ b/Distribution/RaincloudPlot.qmd @@ -180,7 +180,7 @@ ggplot(penguins_clean) + ### 4. Box-and-Density Stacked Pair -A distribution and its summary say different things; stacked, they say it together: the density panel exposes bimodality or long tails the boxes average away, the box panel hands over medians, spreads and the group-comparison test \[3\]. One palette shared by both panels plus matched category axes makes the seam disappear. `aplot::annotation_boxplot()` packages the same composition with statistical brackets when needed. +A distribution and its summary say different things; stacked, they say it together: the density panel exposes bimodality or long tails the boxes average away, the box panel hands over medians, spreads and the group-comparison test \[3\]. One palette shared by both panels plus matched category axes makes the seam disappear. For statistical brackets on top, `ggsignif::geom_signif()` adds the comparison bars. ```{r} #| label: fig-4.1BoxDensityPair diff --git a/Distribution/RaincloudPlot.zh.qmd b/Distribution/RaincloudPlot.zh.qmd index b6c3e9f19..4f9f74603 100644 --- a/Distribution/RaincloudPlot.zh.qmd +++ b/Distribution/RaincloudPlot.zh.qmd @@ -180,7 +180,7 @@ ggplot(penguins_clean) + ### 4. 箱线-密度上下叠放组合图 -分布与其摘要各说一事,上下相叠则合而说之:密度面板暴露被箱线图平均掉的双峰与长尾,箱线面板交出中位数、离散度与组间检验 \[3\]。两面板共用一套色盘并匹配类别坐标,接缝即隐。需要统计括线时,`aplot::annotation_boxplot()` 可打包同一组合。 +分布与其摘要各说一事,上下相叠则合而说之:密度面板暴露被箱线图平均掉的双峰与长尾,箱线面板交出中位数、离散度与组间检验 \[3\]。两面板共用一套色盘并匹配类别坐标,接缝即隐。需要统计括线时,可用 `ggsignif::geom_signif()` 添加组间比较括线。 ```{r} #| label: fig-4.1BoxDensityPair diff --git a/Distribution/ViolinPlot.qmd b/Distribution/ViolinPlot.qmd index af787cde0..b48e14bce 100755 --- a/Distribution/ViolinPlot.qmd +++ b/Distribution/ViolinPlot.qmd @@ -334,7 +334,7 @@ ggplot(data_penguins, aes(fill=sex, y=flipper_length_mm, x=species)) + # Use X a ### 5. Half-Violin Plot -A half-violin plot is useful for visualizing a large amount of data in a compact form. We can use the `geom_half_violin` function to display two groups separately. +A half-violin plot is useful for visualizing a large amount of data in a compact form. We can use `ggdist::stat_halfeye()` (with `ggbeeswarm::geom_beeswarm()`) to display two groups separately — the gghalves package used here originally was archived from CRAN. In the following example, we visualize the flipper lengths of penguins for both species and genders, by plotting female and male penguins on opposite sides of the plot. @@ -562,7 +562,81 @@ Applications of Violin Plot with Boxplot @fig-ViolinPlotApplications4 D shows the expected median MSD and distribution of droplets attached to the substrate (noise) and in water (stimulation), as well as the nanoscale RMS displacement \[4\]. -## Reference +### 5. Pan-Cancer Split Violin with Quartile Marks (FigureYa55panCancer_violinV2) + +The TOIL-harmonised TCGA + GTEx comparison (FigureYa55panCancer_violinV2 \[15\]) puts every cancer type on the x axis and **splits each violin in half**: tumour (right, red) against matched normal (left, yellow, GTEx or TCGA solid-normal), with quartile lines inside each half and per-tissue significance stars. `ggdist::stat_halfeye(side = ...)` gives the split halves without the archived `GeomSplitViolin` helper; quartile dashes and Wilcoxon stars are drawn from the data: + +```{r} +#| label: fig-5.1PanCancerSplit +#| fig-cap: "Pan-cancer split violin of a simulated TP53-like TPM matrix across 10 tissues: tumour (right, red) vs matched normal (left, yellow); dashes = quartiles per half; stars = per-tissue Wilcoxon tests (***: p < 0.001)." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 5 + +set.seed(5501) +tissues <- c("BRCA", "COAD", "HNSC", "KIRC", "LUAD", "LUSC", "PRAD", "STAD", "THCA", "UCEC") +n_per <- 120 +tp53_base <- c(BRCA = 2.6, COAD = 2.2, HNSC = 2.8, KIRC = 2.4, LUAD = 2.5, + LUSC = 2.9, PRAD = 2.3, STAD = 2.7, THCA = 2.2, UCEC = 2.5) +pan <- do.call(rbind, lapply(tissues, function(t) { + tumor <- rnorm(n_per, tp53_base[t] + 0.9, 0.75) + normal <- rnorm(n_per, tp53_base[t] - 0.4, 0.6) + rbind(data.frame(tissue = t, type2 = "tumor", tpm = tumor), + data.frame(tissue = t, type2 = "normal", tpm = normal)) +})) +pan$type2 <- factor(pan$type2, levels = c("tumor", "normal")) +pan$tissue <- factor(pan$tissue, levels = tissues) +pan$side <- ifelse(pan$type2 == "tumor", "right", "left") +wt <- do.call(rbind, lapply(tissues, function(t) { + d1 <- pan$tpm[pan$tissue == t & pan$type2 == "tumor"] + d0 <- pan$tpm[pan$tissue == t & pan$type2 == "normal"] + data.frame(tissue = t, p = wilcox.test(d1, d0)$p.value) +})) +star_df <- data.frame(tissue = factor(wt$tissue, levels = tissues), + y = max(pan$tpm) + 0.55, + lab = ifelse(wt$p < 0.001, "***", + ifelse(wt$p < 0.01, "**", + ifelse(wt$p < 0.05, "*", "")))) +## quartile marks: tiny horizontal dashes offset into each half +qd106 <- do.call(rbind, lapply(tissues, function(t) do.call(rbind, lapply(c("tumor", "normal"), function(g) { + x <- pan$tpm[pan$tissue == t & pan$type2 == g] + data.frame(tissue = t, type2 = g, q = quantile(x, c(0.25, 0.5, 0.75))) +})))) +qd106$tissue <- factor(qd106$tissue, levels = tissues) +qd106$type2 <- factor(qd106$type2, levels = c("tumor", "normal")) +qd106$xc <- as.numeric(qd106$tissue) + ifelse(qd106$type2 == "tumor", 0.13, -0.13) + +ggplot(pan, aes(tissue, tpm, fill = type2)) + + ggdist::stat_halfeye(aes(side = side), density = "bounded", + point_interval = NULL, + linewidth = 0.3, colour = "black", alpha = 0.95) + + geom_segment(data = qd106, + aes(x = xc - 0.025, xend = xc + 0.025, y = q, yend = q, + colour = type2), + inherit.aes = FALSE, linewidth = 0.55) + + geom_text(data = star_df, aes(tissue, y, label = lab), + inherit.aes = FALSE, size = 4.2, colour = "grey10") + + scale_fill_manual(values = c(tumor = "#DF2020", normal = "#DDDF21"), name = NULL) + + scale_colour_manual(values = c(tumor = "#7a1010", normal = "#8a8a20"), guide = "none") + + scale_y_continuous(limits = c(-2, max(pan$tpm) + 1.1)) + + labs(x = NULL, y = "TP53 expression (log2 TPM, simulated)", + title = "Pan-cancer split violin: tumour vs matched normal (GTEx-like)") + + theme_classic(base_size = 12) + + theme(axis.text.x = element_text(angle = 45, hjust = 0.5, vjust = 0.5), + legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- `stat_halfeye(side = ...)` needs one row per observation with the side computed from the group — never two overlapping full violins, which double-count the density. +- `point_interval = NULL` removes the median-CI whisker ggdist draws by default (and its cryptic `-.width` legend); the quartile dashes above replace it with the reference figure's marks. +- Real analysis: fetch TOIL TPM from UCSC Xena (`tcga_RSEM_gene_tpm.gz` + `gtex_RSEM_gene_tpm.gz`), map tissues with the GEPIA TCGA-GTEx pair table — the reference documents the whole pipeline. +::: + +## Reference## Reference \[1\] Zheng Q, Bao C, Guo W, Li S, Chen J, Chen B, Luo Y, Lyu D, Li Y, Shi G, Liang L, Gu J, He X, Huang S. Circular RNA profiling reveals an abundant circHIPK3 that regulates cell growth by sponging multiple miRNAs. Nat Commun. 2016 Apr 6;7:11215. doi: 10.1038/ncomms11215. PMID: 27050392; PMCID: PMC4823868. @@ -591,3 +665,5 @@ Applications of Violin Plot with Boxplot \[13\] Horst AM, Hill AP, Gorman KB (2020). palmerpenguins: Palmer Archipelago (Antarctica) penguin data. R package version 0.1.0. https://allisonhorst.github.io/palmerpenguins/. doi: 10.5281/zenodo.3960218. \[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[15\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Distribution/ViolinPlot.zh.qmd b/Distribution/ViolinPlot.zh.qmd index 5e0d0d4ca..588bbfc69 100644 --- a/Distribution/ViolinPlot.zh.qmd +++ b/Distribution/ViolinPlot.zh.qmd @@ -562,7 +562,81 @@ print(p_c) @fig-ViolinPlotApplications4 D 图展示附着在基质上 (noise) 和水中 (stimulation ) 的液滴的预期中值 MSD 和分布,以及纳米级的 RMS 位移 \[4\]. -## 参考文献 +### 5. 泛癌分半小提琴 + 四分位标记(FigureYa55panCancer_violinV2) + +TOIL 统一处理的 TCGA + GTEx 对比(FigureYa55panCancer_violinV2 \[15\])把每个癌种放到 x 轴上、**每把小提琴从中剖开**:肿瘤(右半、红色)对匹配正常(左半、黄色,GTEx 或 TCGA 实体正常组织),半区内画四分位线,各组织上方标注显著性星号。`ggdist::stat_halfeye(side = ...)` 无需已归档的 `GeomSplitViolin` 辅助文件即可得到分半效果;四分位杠与 Wilcoxon 星号由数据直接计算绘制: + +```{r} +#| label: fig-5.1PanCancerSplit +#| fig-cap: "模拟 TP53 样 TPM 矩阵在 10 个组织上的泛癌分半小提琴:肿瘤(右、红)vs 匹配正常(左、黄);横杠 = 各半区四分位数;星号 = 逐组织 Wilcoxon 检验(***: p < 0.001)。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 5 + +set.seed(5501) +tissues <- c("BRCA", "COAD", "HNSC", "KIRC", "LUAD", "LUSC", "PRAD", "STAD", "THCA", "UCEC") +n_per <- 120 +tp53_base <- c(BRCA = 2.6, COAD = 2.2, HNSC = 2.8, KIRC = 2.4, LUAD = 2.5, + LUSC = 2.9, PRAD = 2.3, STAD = 2.7, THCA = 2.2, UCEC = 2.5) +pan <- do.call(rbind, lapply(tissues, function(t) { + tumor <- rnorm(n_per, tp53_base[t] + 0.9, 0.75) + normal <- rnorm(n_per, tp53_base[t] - 0.4, 0.6) + rbind(data.frame(tissue = t, type2 = "tumor", tpm = tumor), + data.frame(tissue = t, type2 = "normal", tpm = normal)) +})) +pan$type2 <- factor(pan$type2, levels = c("tumor", "normal")) +pan$tissue <- factor(pan$tissue, levels = tissues) +pan$side <- ifelse(pan$type2 == "tumor", "right", "left") +wt <- do.call(rbind, lapply(tissues, function(t) { + d1 <- pan$tpm[pan$tissue == t & pan$type2 == "tumor"] + d0 <- pan$tpm[pan$tissue == t & pan$type2 == "normal"] + data.frame(tissue = t, p = wilcox.test(d1, d0)$p.value) +})) +star_df <- data.frame(tissue = factor(wt$tissue, levels = tissues), + y = max(pan$tpm) + 0.55, + lab = ifelse(wt$p < 0.001, "***", + ifelse(wt$p < 0.01, "**", + ifelse(wt$p < 0.05, "*", "")))) +## 四分位标记:偏入各半区的小横杠 +qd106 <- do.call(rbind, lapply(tissues, function(t) do.call(rbind, lapply(c("tumor", "normal"), function(g) { + x <- pan$tpm[pan$tissue == t & pan$type2 == g] + data.frame(tissue = t, type2 = g, q = quantile(x, c(0.25, 0.5, 0.75))) +})))) +qd106$tissue <- factor(qd106$tissue, levels = tissues) +qd106$type2 <- factor(qd106$type2, levels = c("tumor", "normal")) +qd106$xc <- as.numeric(qd106$tissue) + ifelse(qd106$type2 == "tumor", 0.13, -0.13) + +ggplot(pan, aes(tissue, tpm, fill = type2)) + + ggdist::stat_halfeye(aes(side = side), density = "bounded", + point_interval = NULL, + linewidth = 0.3, colour = "black", alpha = 0.95) + + geom_segment(data = qd106, + aes(x = xc - 0.025, xend = xc + 0.025, y = q, yend = q, + colour = type2), + inherit.aes = FALSE, linewidth = 0.55) + + geom_text(data = star_df, aes(tissue, y, label = lab), + inherit.aes = FALSE, size = 4.2, colour = "grey10") + + scale_fill_manual(values = c(tumor = "#DF2020", normal = "#DDDF21"), name = NULL) + + scale_colour_manual(values = c(tumor = "#7a1010", normal = "#8a8a20"), guide = "none") + + scale_y_continuous(limits = c(-2, max(pan$tpm) + 1.1)) + + labs(x = NULL, y = "TP53 expression (log2 TPM, simulated)", + title = "Pan-cancer split violin: tumour vs matched normal (GTEx-like)") + + theme_classic(base_size = 12) + + theme(axis.text.x = element_text(angle = 45, hjust = 0.5, vjust = 0.5), + legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- `stat_halfeye(side = ...)` 需要逐观测数据并按组算出 side——绝不要叠两个完整小提琴,那会重复计算密度。 +- `point_interval = NULL` 去掉 ggdist 默认的中位数-CI 须(及其神秘的 `-.width` 图例);上面的四分位杠取代之,与参考图一致。 +- 真实分析:从 UCSC Xena 取 TOIL TPM(`tcga_RSEM_gene_tpm.gz` + `gtex_RSEM_gene_tpm.gz`),用 GEPIA 的 TCGA-GTEx 配对表映射组织——参考文档记录了完整流程。 +::: + +## 参考文献## 参考文献 \[1\] Zheng Q, Bao C, Guo W, Li S, Chen J, Chen B, Luo Y, Lyu D, Li Y, Shi G, Liang L, Gu J, He X, Huang S. Circular RNA profiling reveals an abundant circHIPK3 that regulates cell growth by sponging multiple miRNAs. Nat Commun. 2016 Apr 6;7:11215. doi: 10.1038/ncomms11215. PMID: 27050392; PMCID: PMC4823868. @@ -591,3 +665,5 @@ print(p_c) \[13\] Horst AM, Hill AP, Gorman KB (2020). palmerpenguins: Palmer Archipelago (Antarctica) penguin data. R package version 0.1.0. https://allisonhorst.github.io/palmerpenguins/. doi: 10.5281/zenodo.3960218. \[14\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[15\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Omics/AtacSeqPlot.qmd b/Omics/AtacSeqPlot.qmd index 292f74211..5fb0ed565 100644 --- a/Omics/AtacSeqPlot.qmd +++ b/Omics/AtacSeqPlot.qmd @@ -124,7 +124,7 @@ The WT + GW3965 curve separates from KO + GW3965 in the induced set but not in t ```{r} #| label: fig-1.2DifferenceHeatmap -#| fig-cap: "Log2 accessibility heatmap (rows = peaks sorted within each group, columns = 30 bins x 4 conditions), split by region group." +#| fig-cap: "Accessibility heatmap (rows = peaks sorted within each group, columns = 30 bins x 4 conditions), split by region group." #| out.width: "95%" #| warning: false #| message: false diff --git a/Omics/CellChatCirclePlot.qmd b/Omics/CellChatCirclePlot.qmd index 1d96877fe..9560c8aa3 100644 --- a/Omics/CellChatCirclePlot.qmd +++ b/Omics/CellChatCirclePlot.qmd @@ -31,6 +31,9 @@ if (!requireNamespace("BiocManager", quietly = TRUE)) { if (!requireNamespace("ggplot2", quietly = TRUE)) install.packages("ggplot2") if (!requireNamespace("circlize", quietly = TRUE)) install.packages("circlize") if (!requireNamespace("igraph", quietly = TRUE)) install.packages("igraph") +if (!requireNamespace("ggraph", quietly = TRUE)) install.packages("ggraph") +if (!requireNamespace("tidygraph", quietly = TRUE)) install.packages("tidygraph") +if (!requireNamespace("ggrepel", quietly = TRUE)) install.packages("ggrepel") # Install CellChat from GitHub (jinworks/CellChat is the current maintained fork) if (!requireNamespace("CellChat", quietly = TRUE)) { @@ -42,6 +45,9 @@ if (!requireNamespace("CellChat", quietly = TRUE)) { library(CellChat) library(ggplot2) library(circlize) +library(ggraph) +library(tidygraph) +library(ggrepel) ``` ```{r session info} @@ -387,7 +393,7 @@ for (s in cts) for (r in cts) if (s != r) { col = col, lwd = 0.6 + abs(d) / 12) } } -text(rep(0, length(cts)), pos[, 2] * 1.22, cts, cex = 0.8, col = "#24364A") +text(pos[, 1] * 1.22, pos[, 2] * 1.22, cts, cex = 0.8, col = "#24364A") title("STIM vs CTRL differential circle", line = 0.2, cex.main = 1, font.main = 2) legend("bottomleft", legend = c("up in STIM", "up in CTRL"), col = c("#C0272D", "#1F5FA6"), lwd = 3, bty = "n", cex = 0.75) @@ -402,7 +408,93 @@ legend("bottomleft", legend = c("up in STIM", "up in CTRL"), ::: -## References +### 7. Two-Group Differential Communication as an Edge-Bundled Chord + +The FigureYa310 layout \[6\] reads like a chord diagram but is a **hierarchical edge bundle**: radial tree arms root → cell type → gene, and the ligand–receptor interactions are drawn as bundles connecting a source-cell ligand leaf to a target-cell receptor leaf. Colour carries the ligand's log2 fold change between the two conditions (red = up in STIM), node size the expressing fraction, and the open-vs-filled shape separates ligands from receptors. The input is the same differential table as the §5 dot plot (CellPhoneDB `means`/`pvalues` files plus per-cell-type DE, or the simulated stand-in below); the bundle view adds the *hierarchy* — you see at a glance which cell-type pair a gene belongs to. + +```{r} +#| label: fig-7.1CPDBBundle +#| fig-cap: "Differential ligand-receptor communication as an edge-bundled chord (ggraph): radial tree arms per cell type, bundles coloured by ligand log2 fold change (red = up in STIM), leaf size = expressing fraction, open = ligand, filled = receptor." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 9 + +set.seed(3101) +cells <- c("Cancer", "T CD4", "T CD8", "Macro", "Fibro") +lrs <- expand.grid(ligand = c("EGFR", "ERBB2", "MET", "TGFB1", "CXCL12", "CCL5", + "VEGFA", "FGF2", "WNT5A", "DLL4"), + receptor = c("EGFR", "ERBB3", "MET", "TGFBR1", "CXCR4", "CCR5", + "KDR", "FGFR1", "FZD4", "NOTCH1"), stringsAsFactors = FALSE) +lrs <- lrs[sample(nrow(lrs), 22), ] +lrs$source <- sample(cells, 22, replace = TRUE, prob = c(0.4, 0.15, 0.15, 0.15, 0.15)) +lrs$target <- sample(cells, 22, replace = TRUE, prob = c(0.1, 0.2, 0.2, 0.3, 0.2)) +lrs$logFC <- rnorm(22, 0, 1) +lrs$logFC[lrs$source == "Cancer"] <- lrs$logFC[lrs$source == "Cancer"] + 0.8 +lrs$logFC <- pmin(pmax(lrs$logFC, -2), 2) +lrs$frac <- runif(22, 0.1, 0.9) +lrs$from <- paste0(lrs$ligand, "_", lrs$source, "_ligand") +lrs$to <- paste0(lrs$receptor, "_", lrs$target, "_receptor") +celltypes <- unique(c(lrs$source, lrs$target)) + +vert <- rbind( + data.frame(name = unique(lrs$from), celltype = gsub(".*_(.+)_ligand", "\\1", unique(lrs$from)), + type = "ligand", frac = lrs$frac[match(unique(lrs$from), lrs$from)], + label = gsub("_.*", "", unique(lrs$from))), + data.frame(name = unique(lrs$to), celltype = gsub(".*_(.+)_receptor", "\\1", unique(lrs$to)), + type = "receptor", frac = NA, + label = gsub("_.*", "", unique(lrs$to)))) +vert <- vert[!duplicated(vert$name), ] +vert$frac[is.na(vert$frac)] <- runif(sum(is.na(vert$frac)), 0.1, 0.9) +head_df <- data.frame( + name = c("root", paste0(celltypes, "_ligand"), paste0(celltypes, "_receptor")), + celltype = c("root", celltypes, celltypes), + type = c("root", rep("ligand", length(celltypes)), rep("receptor", length(celltypes))), + frac = 0.5, label = c("root", celltypes, celltypes)) +vert_all <- rbind(head_df, vert) + +## tree edges only (root -> cell-type arms -> gene nodes); the ligand-receptor +## interactions are NOT tree edges, they go into get_con() as node index pairs +## (parallel edges would break the dendrogram layout) +edges <- unique(rbind( + data.frame(from = "root", to = paste0(celltypes, "_ligand")), + data.frame(from = "root", to = paste0(celltypes, "_receptor")), + data.frame(from = paste0(lrs$source, "_ligand"), to = lrs$from), + data.frame(from = paste0(lrs$target, "_receptor"), to = lrs$to))) +g <- graph_from_data_frame(edges, directed = TRUE, vertices = vert_all) +from_m <- match(lrs$from, vert_all$name) +to_m <- match(lrs$to, vert_all$name) + +## precompute the bundle data on the CIRCULAR layout (matching the ggraph call) +## and attach per-connection logFC via con.id - ggraph does not propagate edge +## attributes into geom_conn_bundle +bundle <- get_con(from = from_m, to = to_m)( + create_layout(g, layout = "dendrogram", circular = TRUE)) +bundle$logFC <- lrs$logFC[bundle$con.id] + +cell.col <- setNames(c("#8DD3C7", "#BEBADA", "#FB8072", "#80B1D3", "#FDB462")[1:length(celltypes)], celltypes) +ggraph(g, layout = "dendrogram", circular = TRUE) + + geom_conn_bundle(data = bundle, aes(colour = logFC), + width = 1.1, tension = 0.6, alpha = 0.85) + + geom_node_point(aes(size = frac, filter = leaf, colour = celltype, shape = type)) + + geom_node_text(aes(x = x * 1.08, y = y * 1.08, label = label, filter = leaf), + size = 2.6, repel = TRUE, segment.size = 0.2, max.overlaps = 20) + + scale_edge_colour_gradientn(colours = c("#3E52C5", "#FFFFFF", "#B91129"), + limits = c(-2, 2), name = "ligand log2FC") + + scale_shape_manual(values = c("ligand" = 1, "receptor" = 19), name = NULL) + + scale_colour_manual(values = cell.col, name = NULL) + + theme_void() +``` + +::: callout-tip +**Practice tips** + +- The graph must stay a **tree**: only root → cell-type arm → gene edges belong in it, and `unique()` them — a gene that appears in several interactions has one parent per arm, and parallel edges make the dendrogram layout collapse into a line. +- Compute the bundle with `get_con(from, to)(create_layout(g, layout = "dendrogram", circular = TRUE))` — the layout must carry the same `circular` flag as the `ggraph()` call, or the two layers silently land in different coordinate systems. +- Colour bundles by the ligand's condition effect (the sender's biology); colouring by the receptor side mixes two stories in one plot. +::: + ## References \[1\] Jin S, Guerrero-Juarez CF, Zhang L, et al. Inference and analysis of cell-cell communication using CellChat. *Nature Communications*. 2021;12(1):1088. @@ -414,3 +506,5 @@ legend("bottomleft", legend = c("up in STIM", "up in CTRL"), \[4\] Efremova M, Gong C. CellPhoneDB: inferring intercellular communication network from single-cell transcriptomics data. *Nat Methods*. 2018;15(6):431-432. \[5\] Xiaofan Lu, et al. FigureYa267scCellChat reference figure: differential interaction comparison between conditions. FigureYapy/FigureYa documentation. + +\[6\] Xiaofan Lu, et al. FigureYa310CPDBChordGramV2 reference figure: CellPhoneDB differential communication as a circular edge-bundled chord. FigureYa documentation. diff --git a/Omics/CellChatCirclePlot.zh.qmd b/Omics/CellChatCirclePlot.zh.qmd index 707499486..4091d9b16 100644 --- a/Omics/CellChatCirclePlot.zh.qmd +++ b/Omics/CellChatCirclePlot.zh.qmd @@ -31,6 +31,9 @@ if (!requireNamespace("BiocManager", quietly = TRUE)) { if (!requireNamespace("ggplot2", quietly = TRUE)) install.packages("ggplot2") if (!requireNamespace("circlize", quietly = TRUE)) install.packages("circlize") if (!requireNamespace("igraph", quietly = TRUE)) install.packages("igraph") +if (!requireNamespace("ggraph", quietly = TRUE)) install.packages("ggraph") +if (!requireNamespace("tidygraph", quietly = TRUE)) install.packages("tidygraph") +if (!requireNamespace("ggrepel", quietly = TRUE)) install.packages("ggrepel") # 从 GitHub 安装 CellChat(jinworks/CellChat 为当前维护版本) if (!requireNamespace("CellChat", quietly = TRUE)) { @@ -42,6 +45,9 @@ if (!requireNamespace("CellChat", quietly = TRUE)) { library(CellChat) library(ggplot2) library(circlize) +library(ggraph) +library(tidygraph) +library(ggrepel) ``` ```{r session info} @@ -292,8 +298,6 @@ ggplot(lr_df, aes(cell_pair, pair, size = pval, colour = mean)) + - `expand.grid()` 创建所有配对组合;绘图前筛除不显著互作(如 P ≥ 0.05)以获得更干净的图。 ::: -## References - ### 6. 两条件间差异通讯 @@ -390,7 +394,7 @@ for (s in cts) for (r in cts) if (s != r) { col = col, lwd = 0.6 + abs(d) / 12) } } -text(rep(0, length(cts)), pos[, 2] * 1.22, cts, cex = 0.8, col = "#24364A") +text(pos[, 1] * 1.22, pos[, 2] * 1.22, cts, cex = 0.8, col = "#24364A") title("STIM vs CTRL differential circle", line = 0.2, cex.main = 1, font.main = 2) legend("bottomleft", legend = c("up in STIM", "up in CTRL"), col = c("#C0272D", "#1F5FA6"), lwd = 3, bty = "n", cex = 0.75) @@ -405,6 +409,91 @@ legend("bottomleft", legend = c("up in STIM", "up in CTRL"), ::: +### 7. 两组差异通讯的边捆弦图 + +FigureYa310 版式 \[6\] 看起来像弦图,本质却是**层级边捆图**:径向树根 → 细胞类型 → 基因,配体-受体互作以"源细胞配体叶节点 — 靶细胞受体叶节点"的捆束连线呈现。颜色编码配体在两条件间的 log2 倍数变化(红 = STIM 中上调),节点大小为表达该基因的细胞比例,空心/实心区分配体与受体。输入与 §5 点图相同(CellPhoneDB `means`/`pvalues` 文件加各细胞类型差异分析,或下面的模拟替身);捆束视图额外提供了*层级*——每个基因属于哪对细胞类型一目了然。 + +```{r} +#| label: fig-7.1CPDBBundle +#| fig-cap: "差异配体-受体通讯的边捆弦图(ggraph):每细胞类型一条径向树臂,捆束按配体 log2 倍数变化着色(红 = STIM 上调),叶节点大小 = 表达比例,空心 = 配体,实心 = 受体。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 9 + +set.seed(3101) +cells <- c("Cancer", "T CD4", "T CD8", "Macro", "Fibro") +lrs <- expand.grid(ligand = c("EGFR", "ERBB2", "MET", "TGFB1", "CXCL12", "CCL5", + "VEGFA", "FGF2", "WNT5A", "DLL4"), + receptor = c("EGFR", "ERBB3", "MET", "TGFBR1", "CXCR4", "CCR5", + "KDR", "FGFR1", "FZD4", "NOTCH1"), stringsAsFactors = FALSE) +lrs <- lrs[sample(nrow(lrs), 22), ] +lrs$source <- sample(cells, 22, replace = TRUE, prob = c(0.4, 0.15, 0.15, 0.15, 0.15)) +lrs$target <- sample(cells, 22, replace = TRUE, prob = c(0.1, 0.2, 0.2, 0.3, 0.2)) +lrs$logFC <- rnorm(22, 0, 1) +lrs$logFC[lrs$source == "Cancer"] <- lrs$logFC[lrs$source == "Cancer"] + 0.8 +lrs$logFC <- pmin(pmax(lrs$logFC, -2), 2) +lrs$frac <- runif(22, 0.1, 0.9) +lrs$from <- paste0(lrs$ligand, "_", lrs$source, "_ligand") +lrs$to <- paste0(lrs$receptor, "_", lrs$target, "_receptor") +celltypes <- unique(c(lrs$source, lrs$target)) + +vert <- rbind( + data.frame(name = unique(lrs$from), celltype = gsub(".*_(.+)_ligand", "\\1", unique(lrs$from)), + type = "ligand", frac = lrs$frac[match(unique(lrs$from), lrs$from)], + label = gsub("_.*", "", unique(lrs$from))), + data.frame(name = unique(lrs$to), celltype = gsub(".*_(.+)_receptor", "\\1", unique(lrs$to)), + type = "receptor", frac = NA, + label = gsub("_.*", "", unique(lrs$to)))) +vert <- vert[!duplicated(vert$name), ] +vert$frac[is.na(vert$frac)] <- runif(sum(is.na(vert$frac)), 0.1, 0.9) +head_df <- data.frame( + name = c("root", paste0(celltypes, "_ligand"), paste0(celltypes, "_receptor")), + celltype = c("root", celltypes, celltypes), + type = c("root", rep("ligand", length(celltypes)), rep("receptor", length(celltypes))), + frac = 0.5, label = c("root", celltypes, celltypes)) +vert_all <- rbind(head_df, vert) + +## 图中只放树边(根 -> 细胞类型臂 -> 基因节点)并去重:配体-受体互作不是树的边, +## 而是以节点索引对进入 get_con()(平行边会让树状布局坍塌成一条线) +edges <- unique(rbind( + data.frame(from = "root", to = paste0(celltypes, "_ligand")), + data.frame(from = "root", to = paste0(celltypes, "_receptor")), + data.frame(from = paste0(lrs$source, "_ligand"), to = lrs$from), + data.frame(from = paste0(lrs$target, "_receptor"), to = lrs$to))) +g <- graph_from_data_frame(edges, directed = TRUE, vertices = vert_all) +from_m <- match(lrs$from, vert_all$name) +to_m <- match(lrs$to, vert_all$name) + +## 在"环形" layout 上预计算捆束数据(与 ggraph 调用一致),并经 con.id 回连 +## 每条连线的 logFC——ggraph 不会把边属性传播进 geom_conn_bundle +bundle <- get_con(from = from_m, to = to_m)( + create_layout(g, layout = "dendrogram", circular = TRUE)) +bundle$logFC <- lrs$logFC[bundle$con.id] + +cell.col <- setNames(c("#8DD3C7", "#BEBADA", "#FB8072", "#80B1D3", "#FDB462")[1:length(celltypes)], celltypes) +ggraph(g, layout = "dendrogram", circular = TRUE) + + geom_conn_bundle(data = bundle, aes(colour = logFC), + width = 1.1, tension = 0.6, alpha = 0.85) + + geom_node_point(aes(size = frac, filter = leaf, colour = celltype, shape = type)) + + geom_node_text(aes(x = x * 1.08, y = y * 1.08, label = label, filter = leaf), + size = 2.6, repel = TRUE, segment.size = 0.2, max.overlaps = 20) + + scale_edge_colour_gradientn(colours = c("#3E52C5", "#FFFFFF", "#B91129"), + limits = c(-2, 2), name = "ligand log2FC") + + scale_shape_manual(values = c("ligand" = 1, "receptor" = 19), name = NULL) + + scale_colour_manual(values = cell.col, name = NULL) + + theme_void() +``` + +::: callout-tip +**实践要点** + +- 图必须保持为**树**:只有 根 → 细胞类型臂 → 基因 的边属于它,且要 `unique()`——一个基因出现在多条互作中时,每臂只有一个父节点;平行边会让树状布局坍塌成一条线。 +- 用 `get_con(from, to)(create_layout(g, layout = "dendrogram", circular = TRUE))` 计算捆束——layout 的 `circular` 标志必须与 `ggraph()` 调用一致,否则两层会静默落在不同坐标系里。 +- 捆束按配体侧(发送方生物学)的条件效应着色;按受体侧着色会把两个故事混在一张图里。 +::: + ## 参考文献 \[1\] Jin S, Guerrero-Juarez CF, Zhang L 等. 使用 CellChat 推断和分析细胞-细胞通讯. *Nature Communications*. 2021;12(1):1088. @@ -416,3 +505,5 @@ legend("bottomleft", legend = c("up in STIM", "up in CTRL"), \[4\] Efremova M, Gong C. CellPhoneDB: inferring intercellular communication network from single-cell transcriptomics data. *Nat Methods*. 2018;15(6):431-432. \[5\] Xiaofan Lu, et al. FigureYa267scCellChat 参考图:两条件间差异互作比较。FigureYa 文档。 + +\[6\] Xiaofan Lu, et al. FigureYa310CPDBChordGramV2 参考图:CellPhoneDB 差异通讯的环形边捆弦图。FigureYa 文档。 diff --git a/Omics/ChipPvaluePlot.qmd b/Omics/ChipPvaluePlot.qmd index 7179d4132..80a394d94 100644 --- a/Omics/ChipPvaluePlot.qmd +++ b/Omics/ChipPvaluePlot.qmd @@ -135,15 +135,23 @@ ggplot() + #| fig-height: 4.5 p_tr <- t.test(TR ~ Condition, data = tr_df, var.equal = FALSE)$p.value -star <- cut(p_tr, c(0, 1e-9, 1e-6, 1e-3, 1), - labels = c("****", "***", "**", "*")) +star_lab <- as.character(cut(p_tr, c(0, 1e-9, 1e-6, 1e-3, 1), + labels = c("****", "***", "**", "*"), + include.lowest = TRUE)) # an underflowed p = 0 must map to "****" ggplot(tr_df, aes(Condition, TR, fill = Condition)) + geom_boxplot(outlier.shape = NA, width = 0.55) + geom_jitter(width = 0.08, size = 0.4, alpha = 0.25, show.legend = FALSE) + scale_fill_manual(values = c(Control = "#BDD7E7", `MYCN off` = "#FCAE91")) + + geom_text(data = data.frame(Condition = factor("MYCN off", + levels = levels(tr_df$Condition)), + y = max(tr_df$TR) + 0.08 * diff(range(tr_df$TR)), + lab = star_lab), + aes(Condition, y, label = lab), inherit.aes = FALSE, + size = 5.5, colour = "grey10") + labs(y = "RNA Pol II travelling ratio", title = sprintf("Welch p %s", ifelse(p_tr < 0.001, "< 0.001", sprintf("= %.3f", p_tr)))) + + scale_y_continuous(expand = expansion(mult = c(0.05, 0.17))) + theme_classic(base_size = 11) + theme(legend.position = "none") ``` diff --git a/Omics/ChipPvaluePlot.zh.qmd b/Omics/ChipPvaluePlot.zh.qmd index 31d5bdbed..98df14c0f 100644 --- a/Omics/ChipPvaluePlot.zh.qmd +++ b/Omics/ChipPvaluePlot.zh.qmd @@ -135,15 +135,23 @@ ggplot() + #| fig-height: 4.5 p_tr <- t.test(TR ~ Condition, data = tr_df, var.equal = FALSE)$p.value -star <- cut(p_tr, c(0, 1e-9, 1e-6, 1e-3, 1), - labels = c("****", "***", "**", "*")) +star_lab <- as.character(cut(p_tr, c(0, 1e-9, 1e-6, 1e-3, 1), + labels = c("****", "***", "**", "*"), + include.lowest = TRUE)) # an underflowed p = 0 must map to "****" ggplot(tr_df, aes(Condition, TR, fill = Condition)) + geom_boxplot(outlier.shape = NA, width = 0.55) + geom_jitter(width = 0.08, size = 0.4, alpha = 0.25, show.legend = FALSE) + scale_fill_manual(values = c(Control = "#BDD7E7", `MYCN off` = "#FCAE91")) + + geom_text(data = data.frame(Condition = factor("MYCN off", + levels = levels(tr_df$Condition)), + y = max(tr_df$TR) + 0.08 * diff(range(tr_df$TR)), + lab = star_lab), + aes(Condition, y, label = lab), inherit.aes = FALSE, + size = 5.5, colour = "grey10") + labs(y = "RNA Pol II travelling ratio", title = sprintf("Welch p %s", ifelse(p_tr < 0.001, "< 0.001", sprintf("= %.3f", p_tr)))) + + scale_y_continuous(expand = expansion(mult = c(0.05, 0.17))) + theme_classic(base_size = 11) + theme(legend.position = "none") ``` diff --git a/Omics/ChromosomePlot.qmd b/Omics/ChromosomePlot.qmd index 98dd8301e..82d539c95 100644 --- a/Omics/ChromosomePlot.qmd +++ b/Omics/ChromosomePlot.qmd @@ -21,7 +21,7 @@ The image shows a chromosome ideogram with dual-line labels, plotted using the b - Programming language: R -- Dependent packages: `RIdeogram` +- Dependent packages: `RIdeogram`; `ggplot2` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Install packages @@ -31,6 +31,7 @@ if (!requireNamespace("RIdeogram", quietly = TRUE)) { # Load packages library(RIdeogram) +library(ggplot2) ``` ```{r} @@ -499,6 +500,74 @@ write.csv(karyotype, "karyotype.csv", row.names = FALSE) **Coordinate systems:** GTF/GFF files are 1-based; BED files are 0-based (half-open). `RIdeogram` input should be kept internally consistent — if your feature tables (heatmap, marker tracks) come from BED-derived data, convert them to the same convention as the karyotype before plotting. ::: +### 12. Signal Tracks Around a Gene Without Gviz (ggplot2 Recreation) + +The FigureYa3genomeView layout \[4\] stacks per-base signals (ChIP-seq, ATAC, RNA-seq) over a gene locus with the gene model underneath — but `Gviz` pulls in TxDb annotation packages and bigWig reading via rtracklayer, neither of which is in this repository's lockfile. The same figure is reproducible with plain ggplot2: per-kilobase coverage as `geom_area()` facets, the gene model as its own facet track (exon rectangles on an intron line), and a kb-scaled axis. Swap the simulated bins for real data read from a bigWig with rtracklayer, or from a coverage tsv: + +```{r} +#| label: fig-12.1GenomeTracks +#| fig-cap: "IGV-style signal tracks around a target gene (simulated bigWig bins): four coverage facets plus a dedicated gene-model track with exon rectangles on the intron line; x axis in kilobases." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 6.2 + +set.seed(3001) +region_start <- 0; region_end <- 120000 # a TAL1-like 120 kb locus +bins <- seq(region_start, region_end, by = 1000) +peak_at <- 45000 +sig_fun <- function(amp, width) { + exp(-((bins - peak_at)^2) / (2 * width^2)) * amp + + pmax(0, rnorm(length(bins), 0, 0.02)) +} +tracks <- data.frame( + bin = rep(bins, 4), + signal = c(sig_fun(0.95, 9000), sig_fun(0.75, 5000), + sig_fun(0.6, 14000), sig_fun(0.5, 18000)), + track = factor(rep(c("H3K27ac", "H3K4me3", "DNase", "RNA-seq"), each = length(bins)))) +exons <- data.frame(start = c(43000, 47000, 52000, 58000, 64000), + end = c(44500, 48500, 53500, 59500, 66000)) +## the gene model lives in its own facet track +gene_df <- data.frame(bin = rep(bins, 2), signal = 0, track = "Gene (TAL1, +)") +exon_df <- data.frame(track = "Gene (TAL1, +)", start = exons$start, end = exons$end) + +ggplot(tracks, aes(bin, signal)) + + geom_area(aes(fill = track), colour = NA, alpha = 0.85, linewidth = 0) + + geom_blank(data = gene_df, aes(bin, signal), inherit.aes = FALSE) + + geom_rect(data = exon_df, aes(xmin = start, xmax = end, ymin = 0.15, ymax = 0.85), + inherit.aes = FALSE, fill = "#2166AC", colour = "#2166AC") + + geom_segment(data = data.frame(track = "Gene (TAL1, +)", x = min(exons$start), + xend = max(exons$end)), + aes(x = x, xend = xend, y = 0.5, yend = 0.5), + inherit.aes = FALSE, linewidth = 0.5, colour = "#2166AC") + + facet_grid(track ~ ., switch = "y") + + scale_fill_manual(values = c("H3K27ac" = "#E31A1C", "H3K4me3" = "#FF7F00", + "DNase" = "#33A02C", "RNA-seq" = "#1F78B4"), + name = NULL, + breaks = c("RNA-seq", "DNase", "H3K4me3", "H3K27ac")) + + scale_x_continuous(labels = function(x) paste0(x / 1000, " kb"), + expand = expansion(mult = c(0.01, 0.01))) + + labs(x = "chr1 position", y = NULL, + title = "Signal tracks around the promoter of a target gene (simulated bigWig)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + strip.placement = "outside", + strip.background = element_blank(), + strip.text.y.left = element_text(angle = 0, hjust = 1, size = 8.5), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + legend.position = "top") + + coord_cartesian(ylim = c(0, 1)) +``` + +::: callout-tip +**Practice tips** + +- The gene model must occupy its **own facet track** — layering it onto every signal panel is the classic mistake (each layer without a facet column repeats in all panels). +- Per-base bigWig data can be heavy: aggregate to fixed-width bins (1 kb here) before plotting; at locus scale the eye cannot tell the difference. +- `switch = "y"` with `strip.text.y.left` puts track names where IGV puts them, keeping the genomic axis at the bottom only. +::: + ## Application ::: {#fig-ChromosomePlotApplications1} diff --git a/Omics/ChromosomePlot.zh.qmd b/Omics/ChromosomePlot.zh.qmd index 726076cab..65457b969 100644 --- a/Omics/ChromosomePlot.zh.qmd +++ b/Omics/ChromosomePlot.zh.qmd @@ -33,6 +33,7 @@ if (!requireNamespace("RIdeogram", quietly = TRUE)) { # 加载包 library(RIdeogram) +library(ggplot2) ``` ```{r} @@ -501,6 +502,74 @@ write.csv(karyotype, "karyotype.csv", row.names = FALSE) **坐标体系**:GTF/GFF 是 1-based,BED 是 0-based(半开区间)。`RIdeogram` 的输入要保持内部一致——如果热图、形状标记等特征表来自 BED 衍生数据,请先转换到与 karyotype 相同的坐标约定再绘图。 ::: +### 12. 无 Gviz 的基因周边信号轨道(ggplot2 复现) + +FigureYa3genomeView 版式 \[4\] 在基因座位上堆叠逐碱基信号(ChIP-seq、ATAC、RNA-seq)并在下方给出基因模型——但 `Gviz` 会拉进 TxDb 注释包与基于 rtracklayer 的 bigWig 读取,两者都不在本仓库 lockfile 中。同一张图用朴素 ggplot2 即可复现:每 kb 覆盖度画 `geom_area()` 分面、基因模型独占一个分面轨道(内含子线上摆外显子矩形)、x 轴以 kb 计。真实数据用 rtracklayer 读 bigWig,或直接读覆盖度 tsv 替换模拟分箱: + +```{r} +#| label: fig-12.1GenomeTracks +#| fig-cap: "目标基因周边的 IGV 风格信号轨道(模拟 bigWig 分箱):四个覆盖度分面加一个专属基因模型轨道(内含子线上的外显子矩形);x 轴以 kb 计。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10 +#| fig-height: 6.2 + +set.seed(3001) +region_start <- 0; region_end <- 120000 # TAL1 样的 120 kb 座位 +bins <- seq(region_start, region_end, by = 1000) +peak_at <- 45000 +sig_fun <- function(amp, width) { + exp(-((bins - peak_at)^2) / (2 * width^2)) * amp + + pmax(0, rnorm(length(bins), 0, 0.02)) +} +tracks <- data.frame( + bin = rep(bins, 4), + signal = c(sig_fun(0.95, 9000), sig_fun(0.75, 5000), + sig_fun(0.6, 14000), sig_fun(0.5, 18000)), + track = factor(rep(c("H3K27ac", "H3K4me3", "DNase", "RNA-seq"), each = length(bins)))) +exons <- data.frame(start = c(43000, 47000, 52000, 58000, 64000), + end = c(44500, 48500, 53500, 59500, 66000)) +## 基因模型独占一个分面轨道 +gene_df <- data.frame(bin = rep(bins, 2), signal = 0, track = "Gene (TAL1, +)") +exon_df <- data.frame(track = "Gene (TAL1, +)", start = exons$start, end = exons$end) + +ggplot(tracks, aes(bin, signal)) + + geom_area(aes(fill = track), colour = NA, alpha = 0.85, linewidth = 0) + + geom_blank(data = gene_df, aes(bin, signal), inherit.aes = FALSE) + + geom_rect(data = exon_df, aes(xmin = start, xmax = end, ymin = 0.15, ymax = 0.85), + inherit.aes = FALSE, fill = "#2166AC", colour = "#2166AC") + + geom_segment(data = data.frame(track = "Gene (TAL1, +)", x = min(exons$start), + xend = max(exons$end)), + aes(x = x, xend = xend, y = 0.5, yend = 0.5), + inherit.aes = FALSE, linewidth = 0.5, colour = "#2166AC") + + facet_grid(track ~ ., switch = "y") + + scale_fill_manual(values = c("H3K27ac" = "#E31A1C", "H3K4me3" = "#FF7F00", + "DNase" = "#33A02C", "RNA-seq" = "#1F78B4"), + name = NULL, + breaks = c("RNA-seq", "DNase", "H3K4me3", "H3K27ac")) + + scale_x_continuous(labels = function(x) paste0(x / 1000, " kb"), + expand = expansion(mult = c(0.01, 0.01))) + + labs(x = "chr1 position", y = NULL, + title = "Signal tracks around the promoter of a target gene (simulated bigWig)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + strip.placement = "outside", + strip.background = element_blank(), + strip.text.y.left = element_text(angle = 0, hjust = 1, size = 8.5), + axis.text.y = element_blank(), axis.ticks.y = element_blank(), + legend.position = "top") + + coord_cartesian(ylim = c(0, 1)) +``` + +::: callout-tip +**实践要点** + +- 基因模型必须放在**专属分面轨道**——把它叠到每个信号面板上是经典错误(没有分面列的图层会在所有面板重复出现)。 +- 逐碱基 bigWig 数据可能很大:作图前先聚合成固定宽度分箱(此处 1 kb);座位尺度下肉眼无差别。 +- `switch = "y"` 配 `strip.text.y.left` 把轨道名放到 IGV 的位置,基因组轴只在底部出现一次。 +::: + ## 应用 ::: {#fig-ChromosomePlotApplications1} diff --git a/Omics/GeneStructurePlot.qmd b/Omics/GeneStructurePlot.qmd index 6cdc730c0..c39f0cdf9 100644 --- a/Omics/GeneStructurePlot.qmd +++ b/Omics/GeneStructurePlot.qmd @@ -361,11 +361,11 @@ ggplot(example_genes, aes(xmin = start, xmax = end, y = molecule, fill = gene, f ### 3. ChIP/ATAC Signal Tracks + Gene Structure (ggplot2) -Transcription-regulation figures overlay **sequencing signal tracks** (ChIP-seq, ATAC-seq, DNA methylation) on a gene-body schematic \[4\]. The ggplot2 + cowplot recipe: one `geom_area()`/`geom_line()` layer per track, one `geom_rect()` layer for exons, stacked with `plot_grid()`. +Transcription-regulation figures overlay **sequencing signal tracks** (ChIP-seq, ATAC-seq, DNA methylation) on a gene-body schematic \[2\]. The ggplot2 + cowplot recipe: one `geom_area()`/`geom_line()` layer per track, one `geom_rect()` layer for exons, stacked with `plot_grid()`. ```{r} #| label: fig-3.1SignalTracks -#| fig-cap: "Simulated ATAC-seq and ChIP-seq signal tracks around a gene body; the bottom panel shows the exon structure." +#| fig-cap: "Simulated ATAC-seq and ChIP-seq signal tracks around a gene body; the right-hand panel shows the exon structure." #| out.width: "95%" #| warning: false #| message: false @@ -433,4 +433,4 @@ The figure shows the loss and differentiation model of NLR genes in plants durin \[1\] Guo BC, Zhang YR, Liu ZG, Li XC, Yu Z, Ping BY, Sun YQ, van den Burg H, Ma FW, Zhao T. Deciphering Plant NLR Genomic Evolution: Synteny-Informed Classification Unveils Insights into TNL Gene Loss. Mol Biol Evol. 2025 Feb 3;42(2):msaf015. doi: 10.1093/molbev/msaf015. PMID: 39835721; PMCID: PMC11789945. -\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[2\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/GeneStructurePlot.zh.qmd b/Omics/GeneStructurePlot.zh.qmd index 6f71634f4..901398d0a 100644 --- a/Omics/GeneStructurePlot.zh.qmd +++ b/Omics/GeneStructurePlot.zh.qmd @@ -361,11 +361,11 @@ ggplot(example_genes, aes(xmin = start, xmax = end, y = molecule, fill = gene, f ### 3. ChIP/ATAC 信号轨道 + 基因结构(ggplot2) -转录调控文章常将**测序信号轨道**(ChIP-seq、ATAC-seq、DNA 甲基化)叠在基因结构示意图上 \[4\]。ggplot2 + cowplot 配方:每个轨道一层 `geom_area()`/`geom_line()`,基因外显子一层 `geom_rect()`,用 `plot_grid()` 堆叠。 +转录调控文章常将**测序信号轨道**(ChIP-seq、ATAC-seq、DNA 甲基化)叠在基因结构示意图上 \[2\]。ggplot2 + cowplot 配方:每个轨道一层 `geom_area()`/`geom_line()`,基因外显子一层 `geom_rect()`,用 `plot_grid()` 堆叠。 ```{r} #| label: fig-3.1SignalTracks -#| fig-cap: "模拟 ATAC-seq 和 ChIP-seq 信号轨道与基因结构;下方面板展示外显子结构。" +#| fig-cap: "模拟 ATAC-seq 和 ChIP-seq 信号轨道与基因结构;右侧面板展示外显子结构。" #| out.width: "95%" #| warning: false #| message: false @@ -434,4 +434,4 @@ cowplot::plot_grid(p_tracks, p_gene, ncol = 2, align = "h", axis = "tb", -\[4\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[2\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/GseaPlot.qmd b/Omics/GseaPlot.qmd index 996f81030..d29b0d759 100644 --- a/Omics/GseaPlot.qmd +++ b/Omics/GseaPlot.qmd @@ -331,11 +331,11 @@ as.data.frame(fgseaRes)[, c("pathway", "size", "NES", "pval", "padj")] ### 6. Redrawing Java-GSEA Output as Dot + Barcode Panels -Java-GSEA's per-pathway Excel only stores the running ES **at the genes inside the pathway** — that is why a line redraw never matches the official plot \[6\]. Dots at member positions are the faithful redraw; pairing them with a rank barcode beneath, and aligning the two panels' widths with `gridExtra`'s `unit.pmax()`, reproduces the paper look. +Java-GSEA's per-pathway Excel only stores the running ES **at the genes inside the pathway** — that is why a line redraw never matches the official plot \[6\]. Dots at member positions are the faithful redraw; pairing them with a rank barcode beneath reproduces the paper look; the two panels' widths are aligned by stacking them with `patchwork`. ```{r} #| label: fig-6.1JavaRedraw -#| fig-cap: "Java-GSEA output redrawn: running-ES dots at member positions (top) over a rank barcode (bottom), widths aligned with gridExtra." +#| fig-cap: "Java-GSEA output redrawn: running-ES dots at member positions (top) over a rank barcode (bottom), widths aligned by patchwork stacking." #| out.width: "95%" #| warning: false #| message: false @@ -478,7 +478,7 @@ ggraph(graph, layout = "dendrogram", circular = TRUE) + ### 8. Pan-Cancer NES Bubble Grid Across Tumour Types -The pan-cancer companion of the running-score figure lays many tumour types side by side: for every tumour x pathway cell one bubble, colour carrying the normalized enrichment score (NES) and size its significance \[4\] - one glance answers which pathways move in which cancers. The simulated NES matrix below has a coherent pattern built in (proliferative cohorts move cell-cycle/p53, metabolic cohorts move hypoxia/glycolysis) so the reading order of the panel is verifiable; in a real pipeline the matrix comes from `fgsea::fGSEA()` on per-cohort limma contrasts. +The pan-cancer companion of the running-score figure lays many tumour types side by side: for every tumour x pathway cell one bubble, colour carrying the normalized enrichment score (NES) and size its significance \[4\] - one glance answers which pathways move in which cancers. The simulated NES matrix below has a coherent pattern built in (proliferative cohorts move cell-cycle/p53, metabolic cohorts move hypoxia/glycolysis) so the reading order of the panel is verifiable; in a real pipeline the matrix comes from `fgsea::fgseaMultilevel()` on per-cohort limma contrasts. ```{r} #| label: fig-8.1PanCancerNesGrid @@ -543,7 +543,7 @@ The transpose of the NES grid above: one **pathway**, many genes. For a signatur ```{r gene-nes-ref, eval=FALSE} # Reference workflow (real data): for every tumour x gene, rank by limma -# high-vs-low log2FC and run one fgsea::fGSEA() against the single GMT term; +# high-vs-low log2FC and run one fgsea::fgseaMultilevel() against the single GMT term; # keep term/NES/pvalue/p.adj per cell -> the tab data frame below. ``` @@ -562,7 +562,7 @@ tumors <- c("BLCA", "BRCA", "CESC", "CHOL", "COAD", genes <- c("GPX4", "SLC7A11", "NFE2L2", "NCOA4", "ACSL4", "ALOX15", "FANCD2", "CISD1", "TP53", "HMOX1", "ATF4", "CHAC1", "SLC3A2", "GCLM") -## simulated single-pathway NES per gene x tumour (real pipeline: fgsea::fGSEA() +## simulated single-pathway NES per gene x tumour (real pipeline: fgsea::fgseaMultilevel() ## on the per-cohort high-vs-low contrast of each gene's expression) nes <- matrix(rnorm(10 * 14, 0, 1.1), 10, 14, dimnames = list(tumors, genes)) upg <- 1:7 # first-half panel moves EMT up @@ -607,7 +607,59 @@ Running-score GSEA plots are the standard figure for pathway-level interpretatio ![](../images/Omics/GseaPlot_app1.png){fig-alt="GseaPlot Application" fig-align="center" width="60%"} -## Reference +### 9. clusterProfiler GSEA with the Ranked-List Curve (FigureYa60GSEA_clusterProfilerV2) + +FigureYa60 \[8\] runs `clusterProfiler::GSEA()` on a full ranked gene list and shows the classic **three-panel output**: running enrichment-score lines for the top terms, the gene-rank barcode, and the ranked list metric. In clusterProfiler ≥ 4.x `GSEA()` takes a `TERM2GENE` data frame (not `OrgDb`) — build it from the orgDb GO mapping, plant the signal in a real GO member set, and render with `enrichplot::gseaplot2()`: + +```{r} +#| label: fig-9.1ClusterGSEA +#| fig-cap: "GSEA of 1,500 simulated ranked genes against GO TERM2GENE: running ES lines for the top 3 terms (immune-response term leads), gene-rank barcode and ranked-list metric below." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 6.5 + +set.seed(6011) +id.fc <- data.frame( + ENTREZID = as.character(sample(1:20000, 1500)), + log2fc = c(rnorm(1500, 0, 0.8))) +## build TERM2GENE from the orgDb (GSEA() in clusterProfiler >= 4.x takes +## TERM2GENE, not OrgDb); do the mapping up front so the planted signal +## targets real GO member genes +suppressPackageStartupMessages(library(org.Hs.eg.db)) +go_map <- suppressMessages( + AnnotationDbi::select(org.Hs.eg.db, keys(org.Hs.eg.db, "ENTREZID"), + c("GO"), "ENTREZID")) +t2g <- na.omit(unique(go_map[, c("GO", "ENTREZID")])) +geneList52b <- id.fc$log2fc +names(geneList52b) <- id.fc$ENTREZID +geneList52b <- sort(geneList52b, decreasing = TRUE) +## plant a real GO signal: boost every gene annotated to "immune response" (GO:0006955) +go_immune <- go_map$ENTREZID[go_map$GO == "GO:0006955"] +geneList52b[names(geneList52b) %in% go_immune] <- + geneList52b[names(geneList52b) %in% go_immune] + 1.8 +geneList52b <- sort(geneList52b, decreasing = TRUE) +gsea52b <- GSEA(geneList52b, TERM2GENE = t2g, minGSSize = 20, maxGSSize = 800, + pvalueCutoff = 1, eps = 0) # keep top terms even if FDR > 0.05 for display +top_ids <- head(as.data.frame(gsea52b)$ID, 3) +cat("top terms:", top_ids, "\n") +## NOTE: gseaplot2 returns a patchwork/gglist — adding a theme() layer on top +## breaks the render (black canvas). Keep the plot unmodified. +p112 <- enrichplot::gseaplot2(gsea52b, geneSetID = top_ids, pvalue_table = FALSE, + ES_geom = "line") +p112 +``` + +::: callout-tip +**Practice tips** + +- clusterProfiler ≥ 4.x moved `GSEA()` to `TERM2GENE` — building it from `AnnotationDbi::select(orgDb, keys, "GO")` keeps everything in the lockfile without downloading GMTs. +- Plant the signal **after** sorting the ranked list but **in real GO member genes** — boosting random genes yields zero passing terms and an empty gseaplot2. +- `gseaplot2()` output is a patchwork/gglist: adding a `theme()` layer on top renders a black canvas in some devices — print it unmodified. +::: + +## Reference## Reference \[1\] Subramanian A, Tamayo P, Mootha VK, et al. Gene set enrichment analysis: a knowledge-based approach for interpreting genome-wide expression profiles. Proc Natl Acad Sci USA. 2005;102(43):15545-15550. doi:10.1073/pnas.0506580102 @@ -624,3 +676,5 @@ Running-score GSEA plots are the standard figure for pathway-level interpretatio \[7\] Pedersen TL. ggraph: An Implementation of Grammar of Graphics for Graphs and Networks. https://ggraph.data-imaginist.com/ \[8\] Xiaofan Lu, et al. FigureYa279panGeneGSEA reference figure: pan-cancer single-pathway NES grid with genes on the y-axis. FigureYapy/FigureYa documentation. + +\[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Omics/GseaPlot.zh.qmd b/Omics/GseaPlot.zh.qmd index d63c08e5d..7e86bead4 100644 --- a/Omics/GseaPlot.zh.qmd +++ b/Omics/GseaPlot.zh.qmd @@ -476,7 +476,7 @@ ggraph(graph, layout = "dendrogram", circular = TRUE) + ### 8. 泛癌 NES 泡点矩阵 -running-score 主图的泛癌姊妹篇把多个癌种并排:每个癌种 × 通路一格一泡,颜色携带标准化富集分(NES),大小携带显著性 \[4\]——一眼即可回答哪些通路在哪些癌中变动。下面模拟的 NES 矩阵内建了连贯模式(增殖型队列拉动细胞周期/p53,代谢型队列拉动缺氧/糖酵解),使面板的判读顺序可验证;真实流程中该矩阵来自对各队列 limma 对比结果运行 `fgsea::fGSEA()`。 +running-score 主图的泛癌姊妹篇把多个癌种并排:每个癌种 × 通路一格一泡,颜色携带标准化富集分(NES),大小携带显著性 \[4\]——一眼即可回答哪些通路在哪些癌中变动。下面模拟的 NES 矩阵内建了连贯模式(增殖型队列拉动细胞周期/p53,代谢型队列拉动缺氧/糖酵解),使面板的判读顺序可验证;真实流程中该矩阵来自对各队列 limma 对比结果运行 `fgsea::fgseaMultilevel()`。 ```{r} #| label: fig-8.1PanCancerNesGrid @@ -541,7 +541,7 @@ print(p_b) ```{r gene-nes-ref, eval=FALSE} # 参考工作流(真实数据):对每个癌种 x 基因,以 limma 高-低 log2FC 排序, -# 对该单一 GMT 条目跑一次 fgsea::fGSEA();逐格取 term/NES/pvalue/p.adj -> 下方 tab 数据框。 +# 对该单一 GMT 条目跑一次 fgsea::fgseaMultilevel();逐格取 term/NES/pvalue/p.adj -> 下方 tab 数据框。 ``` ```{r} @@ -559,7 +559,7 @@ tumors <- c("BLCA", "BRCA", "CESC", "CHOL", "COAD", genes <- c("GPX4", "SLC7A11", "NFE2L2", "NCOA4", "ACSL4", "ALOX15", "FANCD2", "CISD1", "TP53", "HMOX1", "ATF4", "CHAC1", "SLC3A2", "GCLM") -## simulated single-pathway NES per gene x tumour (real pipeline: fgsea::fGSEA() +## simulated single-pathway NES per gene x tumour (real pipeline: fgsea::fgseaMultilevel() ## on the per-cohort high-vs-low contrast of each gene's expression) nes <- matrix(rnorm(10 * 14, 0, 1.1), 10, 14, dimnames = list(tumors, genes)) upg <- 1:7 # first-half panel moves EMT up @@ -604,7 +604,59 @@ ggplot(tab, aes(tumor, gene)) + ![](../images/Omics/GseaPlot_app1.png){fig-alt="GseaPlot Application" fig-align="center" width="60%"} -## Reference +### 9. clusterProfiler GSEA 与排序列表曲线(FigureYa60GSEA_clusterProfilerV2) + +FigureYa60 \[8\] 对完整排序基因列表运行 `clusterProfiler::GSEA()`,并展示经典**三面板输出**:top 通路的运行富集分数线、基因排序条码、排序列表度量。clusterProfiler ≥ 4.x 中 `GSEA()` 接收 `TERM2GENE` 数据框(而非 `OrgDb`)——先由 orgDb 的 GO 映射构建,把信号植入真实 GO 成员集,再用 `enrichplot::gseaplot2()` 渲染: + +```{r} +#| label: fig-9.1ClusterGSEA +#| fig-cap: "1,500 个模拟排序基因对 GO TERM2GENE 的 GSEA:top 3 通路的运行 ES 线(免疫应答通路领先),下方为基因排序条码与排序列表度量。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 6.5 + +set.seed(6011) +id.fc <- data.frame( + ENTREZID = as.character(sample(1:20000, 1500)), + log2fc = c(rnorm(1500, 0, 0.8))) +## build TERM2GENE from the orgDb (GSEA() in clusterProfiler >= 4.x takes +## TERM2GENE, not OrgDb); do the mapping up front so the planted signal +## targets real GO member genes +suppressPackageStartupMessages(library(org.Hs.eg.db)) +go_map <- suppressMessages( + AnnotationDbi::select(org.Hs.eg.db, keys(org.Hs.eg.db, "ENTREZID"), + c("GO"), "ENTREZID")) +t2g <- na.omit(unique(go_map[, c("GO", "ENTREZID")])) +geneList52b <- id.fc$log2fc +names(geneList52b) <- id.fc$ENTREZID +geneList52b <- sort(geneList52b, decreasing = TRUE) +## plant a real GO signal: boost every gene annotated to "immune response" (GO:0006955) +go_immune <- go_map$ENTREZID[go_map$GO == "GO:0006955"] +geneList52b[names(geneList52b) %in% go_immune] <- + geneList52b[names(geneList52b) %in% go_immune] + 1.8 +geneList52b <- sort(geneList52b, decreasing = TRUE) +gsea52b <- GSEA(geneList52b, TERM2GENE = t2g, minGSSize = 20, maxGSSize = 800, + pvalueCutoff = 1, eps = 0) # keep top terms even if FDR > 0.05 for display +top_ids <- head(as.data.frame(gsea52b)$ID, 3) +cat("top terms:", top_ids, "\n") +## NOTE: gseaplot2 returns a patchwork/gglist — adding a theme() layer on top +## breaks the render (black canvas). Keep the plot unmodified. +p112 <- enrichplot::gseaplot2(gsea52b, geneSetID = top_ids, pvalue_table = FALSE, + ES_geom = "line") +p112 +``` + +::: callout-tip +**实践要点** + +- clusterProfiler ≥ 4.x 把 `GSEA()` 迁移到了 `TERM2GENE`——用 `AnnotationDbi::select(orgDb, keys, "GO")` 构建即可全程使用 lockfile 内的包,无需下载 GMT。 +- 信号要在**排序之后**植入**真实 GO 成员基因**——给随机基因加效应会得到零个达标通路和一张空的 gseaplot2。 +- `gseaplot2()` 的输出是 patchwork/gglist:在顶层加 `theme()` 会在部分设备渲染成黑色画布——请原样打印。 +::: + +## Reference## Reference \[1\] Subramanian A, Tamayo P, Mootha VK, et al. Gene set enrichment analysis: a knowledge-based approach for interpreting genome-wide expression profiles. Proc Natl Acad Sci USA. 2005;102(43):15545-15550. doi:10.1073/pnas.0506580102 @@ -621,3 +673,5 @@ ggplot(tab, aes(tumor, gene)) + \[7\] Pedersen TL. ggraph: An Implementation of Grammar of Graphics for Graphs and Networks. https://ggraph.data-imaginist.com/ \[8\] Xiaofan Lu, et al. FigureYa279panGeneGSEA 参考图:基因在 Y 轴的泛癌单通路 NES 矩阵。FigureYa 文档。 + +\[8\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Omics/ImmuneLncrnaPlot.qmd b/Omics/ImmuneLncrnaPlot.qmd index 78ccfb9dc..34da68238 100644 --- a/Omics/ImmuneLncrnaPlot.qmd +++ b/Omics/ImmuneLncrnaPlot.qmd @@ -4,7 +4,7 @@ author: - "**[Editor]** ZCode (GLM) — AI-generated, independently AI-reviewed;" --- -Identifying immune-related lncRNAs uses partial correlation between lncRNA expression and immune gene sets, followed by GSEA \[1\]. The canonical figure is a **dual-axis bar + line chart**: bars show the number of immune-related lncRNAs per cancer type (top y-axis) while a line shows the proportion (bottom y-axis). +Identifying immune-related lncRNAs uses partial correlation between lncRNA expression and immune gene sets, followed by GSEA \[1\]. The canonical figure is a **dual-axis bar + line chart**: bars show the number of immune-related lncRNAs per cancer type (left y-axis) while a line shows the proportion (right y-axis). ## Example diff --git a/Omics/ImmuneSubtypePlot.qmd b/Omics/ImmuneSubtypePlot.qmd index ba68d9e73..50f47a65d 100644 --- a/Omics/ImmuneSubtypePlot.qmd +++ b/Omics/ImmuneSubtypePlot.qmd @@ -50,7 +50,7 @@ sessioninfo::session_info("attached") ## Data Preparation -We simulate signature scores for 90 samples across 8 immune signatures, planted with three correlated modules (leucocyte/IFN-γ/T-cell co-high; EMT/WNT co-high opposite the first; mitosis independent) — the structure that produces well-separated immune subtypes. +We simulate signature scores for 90 samples across 8 immune signatures, planted with three independent latent modules (leucocyte/IFN-γ/T-cell co-high on one factor; EMT/WNT co-high on a second; mitosis on a third) — block structure across signatures that consensus clustering resolves into well-separated immune subtypes. ```{r load data, message=FALSE, warning=FALSE} set.seed(601) diff --git a/Omics/ImmuneSubtypePlot.zh.qmd b/Omics/ImmuneSubtypePlot.zh.qmd index 61516699e..a0150babf 100644 --- a/Omics/ImmuneSubtypePlot.zh.qmd +++ b/Omics/ImmuneSubtypePlot.zh.qmd @@ -50,7 +50,7 @@ sessioninfo::session_info("attached") ## Data Preparation -模拟 90 个样本 × 8 个免疫 signature 的评分,植入三个相关模块(白细胞/IFN-γ/T 细胞同高;EMT/WNT 同高且与前者相反;有丝分裂独立)——这正是产生清晰免疫亚型的结构。 +模拟 90 个样本 × 8 个免疫 signature 的评分,植入三个相互独立的潜在模块(白细胞/IFN-γ/T 细胞在同一因子上同高;EMT/WNT 在第二个因子上同高;有丝分裂在第三个因子上)——signature 间的这种分块结构经共识聚类即可得到清晰的免疫亚型。 ```{r load data, message=FALSE, warning=FALSE} set.seed(601) diff --git a/Omics/KeggPathwayPlot.qmd b/Omics/KeggPathwayPlot.qmd index 2dc0713db..1470b3ed5 100644 --- a/Omics/KeggPathwayPlot.qmd +++ b/Omics/KeggPathwayPlot.qmd @@ -623,12 +623,12 @@ kegg_df <- data.frame( level1 = c("Cellular Processes", "Cellular Processes", "Environmental Info Processing", "Environmental Info Processing", "Genetic Info Processing", "Genetic Info Processing", "Genetic Info Processing", - "Organic Systems", "Human Diseases"), + "Organismal Systems", "Human Diseases"), level2 = c("Cell growth and death", "Cell growth and death", "Signal transduction", "Signal transduction", "Translation", "Translation", "Replication and repair", "Digestive system", "Infectious disease"), - level3 = c("Cell cycle", "Cell cycle", "MAPK signaling", "ErbB signaling", + level3 = c("Cell cycle", "p53 signaling", "MAPK signaling", "ErbB signaling", "Ribosome", "Proteasome", "Mismatch repair", "Glycosaminoglycan degradation", "Bacterial infection"), Detected = c(120L, 98L, 310L, 260L, 75L, 61L, 40L, 22L, 130L), @@ -639,13 +639,17 @@ kegg_df <- data.frame( kegg_df$level3 <- factor(kegg_df$level3, levels = rev(unique(kegg_df$level3))) dir_cols <- c(GSH = "#4D9342", GSL = "#B2182B") -p_lab <- ggplot(kegg_df, aes(level3, 0)) + - geom_text(aes(label = paste0(level2, " | ", level1), colour = Direction), - size = 2.8, hjust = 1.02) + +p_lab <- ggplot(kegg_df, aes(level3, -0.45)) + + # wrap to <= 3 short lines; anchored at the panel's left edge growing rightward, + # so even the longest label stays on-canvas + geom_text(aes(label = stringr::str_wrap(paste0(level2, " | ", level1), 26), + colour = Direction), + size = 2.8, hjust = 0, lineheight = 0.9) + scale_colour_manual(values = dir_cols) + scale_y_continuous(limits = c(-0.5, 1)) + coord_flip() + theme_void(base_size = 10) + labs(x = NULL, y = NULL) + - theme(axis.text = element_blank(), axis.ticks = element_blank()) + theme(axis.text = element_blank(), axis.ticks = element_blank(), + plot.margin = margin(4, 0, 4, 2, unit = "mm")) p_det <- ggplot(kegg_df, aes(level3, Detected)) + geom_col(fill = "grey75", colour = "black", width = 0.7) + @@ -676,7 +680,7 @@ stopifnot(all(kegg_df$Enriched <= kegg_df$Detected)) **Practice tips** - On real data, extract the three levels from the KEGG REST JSON (`get_htext?br08901.keg`) once and cache it as a table — the browser API is rate-limited. -- The left label column draws `geom_text` at x = 0 on the same factor, which is what keeps all three panels row-aligned; keep `coord_flip()` in every panel. +- The left label column draws `geom_text` at a fixed position on the same factor, which is what keeps all three panels row-aligned; keep `coord_flip()` in every panel. - Log scales on the count axes keep small pathways visible when detected and enriched counts differ by orders of magnitude. ::: diff --git a/Omics/KeggPathwayPlot.zh.qmd b/Omics/KeggPathwayPlot.zh.qmd index bd256afcf..5107855f4 100644 --- a/Omics/KeggPathwayPlot.zh.qmd +++ b/Omics/KeggPathwayPlot.zh.qmd @@ -623,12 +623,12 @@ kegg_df <- data.frame( level1 = c("Cellular Processes", "Cellular Processes", "Environmental Info Processing", "Environmental Info Processing", "Genetic Info Processing", "Genetic Info Processing", "Genetic Info Processing", - "Organic Systems", "Human Diseases"), + "Organismal Systems", "Human Diseases"), level2 = c("Cell growth and death", "Cell growth and death", "Signal transduction", "Signal transduction", "Translation", "Translation", "Replication and repair", "Digestive system", "Infectious disease"), - level3 = c("Cell cycle", "Cell cycle", "MAPK signaling", "ErbB signaling", + level3 = c("Cell cycle", "p53 signaling", "MAPK signaling", "ErbB signaling", "Ribosome", "Proteasome", "Mismatch repair", "Glycosaminoglycan degradation", "Bacterial infection"), Detected = c(120L, 98L, 310L, 260L, 75L, 61L, 40L, 22L, 130L), @@ -639,13 +639,17 @@ kegg_df <- data.frame( kegg_df$level3 <- factor(kegg_df$level3, levels = rev(unique(kegg_df$level3))) dir_cols <- c(GSH = "#4D9342", GSL = "#B2182B") -p_lab <- ggplot(kegg_df, aes(level3, 0)) + - geom_text(aes(label = paste0(level2, " | ", level1), colour = Direction), - size = 2.8, hjust = 1.02) + +p_lab <- ggplot(kegg_df, aes(level3, -0.45)) + + # wrap to <= 3 short lines; anchored at the panel's left edge growing rightward, + # so even the longest label stays on-canvas + geom_text(aes(label = stringr::str_wrap(paste0(level2, " | ", level1), 26), + colour = Direction), + size = 2.8, hjust = 0, lineheight = 0.9) + scale_colour_manual(values = dir_cols) + scale_y_continuous(limits = c(-0.5, 1)) + coord_flip() + theme_void(base_size = 10) + labs(x = NULL, y = NULL) + - theme(axis.text = element_blank(), axis.ticks = element_blank()) + theme(axis.text = element_blank(), axis.ticks = element_blank(), + plot.margin = margin(4, 0, 4, 2, unit = "mm")) p_det <- ggplot(kegg_df, aes(level3, Detected)) + geom_col(fill = "grey75", colour = "black", width = 0.7) + diff --git a/Omics/ManhattanPlot.qmd b/Omics/ManhattanPlot.qmd index cae9ab645..ee17bc6fc 100644 --- a/Omics/ManhattanPlot.qmd +++ b/Omics/ManhattanPlot.qmd @@ -21,7 +21,7 @@ The horizontal axis of the Manhattan plot is the chromosome position, and the ve - Programming language: R -- Dependent packages: `qqman`; `tidyverse`; `aplot` +- Dependent packages: `qqman`; `tidyverse`; `aplot`; `ggrepel` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Installing necessary packages @@ -39,6 +39,7 @@ if (!requireNamespace("aplot", quietly = TRUE)) { library(qqman) library(tidyverse) library(aplot) +library(ggrepel) ``` ```{r} @@ -282,6 +283,75 @@ p2 <- p1/p2 ``` +### 3. Repelled Labels and Per-Chromosome Colour (ggplot2) + +The qqman route labels nothing. The FigureYa43 layout \[2\] rebuilds the Manhattan plot in ggplot2 to gain three things: alternating chromosome colours chosen by hand, a **red threshold line** with points above it enlarged (`size = pcut`), and `geom_label_repel()` labels carrying gene + rs-ID **with arrows**, constrained to the region above the threshold. The cumulative-offset x axis (`chrx` join) is what places chromosomes side by side: + +```{r} +#| label: fig-3.1ManhattanRepel +#| fig-cap: "Manhattan plot of 8 simulated chromosomes (2,500 SNPs each): red threshold at -log10(P) = 5, points above it enlarged and labeled with gene + rs-ID via ggrepel; alternating chromosome colours." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 5.2 + +set.seed(4301) +n_chr <- 8 +snp_per <- 2500 +gwas <- do.call(rbind, lapply(1:n_chr, function(cc) { + data.frame(CHR = cc, SNP = paste0("rs", cc, sample(1e5:9e5, snp_per)), + POS = sort(sample(1:7e7, snp_per)), + P_value = rexp(snp_per, 0.35), + gene = NA) +})) +gwas$P_value <- pmin(1, gwas$P_value) +hits <- sample(nrow(gwas), 14) +gwas$P_value[hits] <- 10^(-runif(14, 5.2, 9)) +gwas$gene[hits] <- paste0("GENE", 1:14) +gwas$chr <- factor(gwas$CHR, levels = 1:n_chr) + +chrx <- gwas %>% group_by(chr) %>% summarise(chr_len = max(POS)) %>% + mutate(chrx = cumsum(chr_len) - chr_len) %>% select(-chr_len) %>% data.frame() +gwas <- left_join(gwas, chrx, by = c("chr" = "chr")) %>% + mutate(SNPx = POS + chrx, SNPy = -log10(P_value)) +axisdf <- gwas %>% group_by(chr) %>% summarize(center = (max(SNPx) + min(SNPx)) / 2) +logPcutoff <- 5 +gwas$pcut <- ifelse(gwas$SNPy > logPcutoff, "1", "0") +gwas$label <- paste0(gwas$gene, "\n", gwas$SNP) +gwas$label[is.na(gwas$gene)] <- NA +mycol <- rep(c("#223D6C", "#D20A13"), length.out = n_chr) + +ggplot(gwas, aes(SNPx, SNPy)) + + geom_point(aes(colour = chr, size = pcut), alpha = 0.85) + + scale_colour_manual(values = mycol, guide = "none") + + scale_size_discrete(range = c(0.6, 2.2), guide = "none") + + geom_hline(yintercept = logPcutoff, colour = "red", linewidth = 0.4) + + geom_label_repel(data = subset(gwas, !is.na(label)), + aes(label = label), size = 2.4, + segment.colour = "black", segment.size = 0.35, + arrow = arrow(angle = 20, length = unit(0.04, "inches")), + min.segment.length = 0, na.rm = TRUE, + box.padding = 0.35, max.overlaps = 30, show.legend = FALSE) + + scale_x_continuous(breaks = axisdf$center, labels = axisdf$chr, + expand = expansion(mult = c(0, 0.02))) + + scale_y_continuous(expand = expansion(mult = c(0, 0.06))) + + labs(x = "Chromosome", y = expression(-log[10](P)), + title = "GWAS Manhattan plot with repelled labels (simulated)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), panel.border = element_blank(), + axis.line = element_line(colour = "black"), + axis.text = element_text(size = rel(0.85))) +``` + +::: callout-tip +**Practice tips** + +- Label only what passes the threshold, and put **gene + rs-ID on two lines** — one-line labels collide immediately at GWAS density. +- `max.overlaps = 30` keeps ggrepel from silently dropping labels in crowded top regions; check the dropped-label warning rather than trusting the plot. +- The chromosome offsets must come from a grouped `max(POS)` join, not from row order — an unsorted `POS` column scrambles the alternating colours. +::: + ## Application ::: {#fig-HistApplications} @@ -295,3 +365,5 @@ This figure shows the association between SNP loci in poplar trees and temperatu ## Reference \[1\] Sang Y, Long Z, Dan X, Feng J, Shi T, Jia C, Zhang X, Lai Q, Yang G, Zhang H, Xu X, Liu H, Jiang Y, Ingvarsson PK, Liu J, Mao K, Wang J. Genomic insights into local adaptation and future climate-induced vulnerability of a keystone forest tree in East Asia. Nat Commun. 2022 Nov 1;13(1):6541. doi: 10.1038/s41467-022-34206-8. PMID: 36319648; PMCID: PMC9626627. + +\[2\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/ManhattanPlot.zh.qmd b/Omics/ManhattanPlot.zh.qmd index 460b635bc..398c79699 100644 --- a/Omics/ManhattanPlot.zh.qmd +++ b/Omics/ManhattanPlot.zh.qmd @@ -34,11 +34,15 @@ if (!requireNamespace("tidyverse", quietly = TRUE)) { if (!requireNamespace("aplot", quietly = TRUE)) { install.packages("aplot") } +if (!requireNamespace("ggrepel", quietly = TRUE)) { + install.packages("ggrepel") +} # 加载包 library(qqman) library(tidyverse) library(aplot) +library(ggrepel) ``` ```{r} @@ -282,6 +286,75 @@ p2 <- p1/p2 ``` +### 3. 避让标签与逐染色体配色(ggplot2) + +qqman 路线不打任何标签。FigureYa43 版式 \[2\] 用 ggplot2 重造曼哈顿图换取三件事:手工指定的交替染色体配色、**红色阈值线**(线上点用 `size = pcut` 放大),以及带箭头、携带"基因 + rs 号"双行标签的 `geom_label_repel()`,标签区域约束在阈值之上。累计偏移 x 轴(`chrx` join)是把染色体并排放置的关键: + +```{r} +#| label: fig-3.1ManhattanRepel +#| fig-cap: "8 条模拟染色体(每条 2,500 个 SNP)的曼哈顿图:-log10(P) = 5 处红色阈值线,线上点放大并用 ggrepel 标注基因 + rs 号;染色体交替配色。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 5.2 + +set.seed(4301) +n_chr <- 8 +snp_per <- 2500 +gwas <- do.call(rbind, lapply(1:n_chr, function(cc) { + data.frame(CHR = cc, SNP = paste0("rs", cc, sample(1e5:9e5, snp_per)), + POS = sort(sample(1:7e7, snp_per)), + P_value = rexp(snp_per, 0.35), + gene = NA) +})) +gwas$P_value <- pmin(1, gwas$P_value) +hits <- sample(nrow(gwas), 14) +gwas$P_value[hits] <- 10^(-runif(14, 5.2, 9)) +gwas$gene[hits] <- paste0("GENE", 1:14) +gwas$chr <- factor(gwas$CHR, levels = 1:n_chr) + +chrx <- gwas %>% group_by(chr) %>% summarise(chr_len = max(POS)) %>% + mutate(chrx = cumsum(chr_len) - chr_len) %>% select(-chr_len) %>% data.frame() +gwas <- left_join(gwas, chrx, by = c("chr" = "chr")) %>% + mutate(SNPx = POS + chrx, SNPy = -log10(P_value)) +axisdf <- gwas %>% group_by(chr) %>% summarize(center = (max(SNPx) + min(SNPx)) / 2) +logPcutoff <- 5 +gwas$pcut <- ifelse(gwas$SNPy > logPcutoff, "1", "0") +gwas$label <- paste0(gwas$gene, "\n", gwas$SNP) +gwas$label[is.na(gwas$gene)] <- NA +mycol <- rep(c("#223D6C", "#D20A13"), length.out = n_chr) + +ggplot(gwas, aes(SNPx, SNPy)) + + geom_point(aes(colour = chr, size = pcut), alpha = 0.85) + + scale_colour_manual(values = mycol, guide = "none") + + scale_size_discrete(range = c(0.6, 2.2), guide = "none") + + geom_hline(yintercept = logPcutoff, colour = "red", linewidth = 0.4) + + geom_label_repel(data = subset(gwas, !is.na(label)), + aes(label = label), size = 2.4, + segment.colour = "black", segment.size = 0.35, + arrow = arrow(angle = 20, length = unit(0.04, "inches")), + min.segment.length = 0, na.rm = TRUE, + box.padding = 0.35, max.overlaps = 30, show.legend = FALSE) + + scale_x_continuous(breaks = axisdf$center, labels = axisdf$chr, + expand = expansion(mult = c(0, 0.02))) + + scale_y_continuous(expand = expansion(mult = c(0, 0.06))) + + labs(x = "Chromosome", y = expression(-log[10](P)), + title = "GWAS Manhattan plot with repelled labels (simulated)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), panel.border = element_blank(), + axis.line = element_line(colour = "black"), + axis.text = element_text(size = rel(0.85))) +``` + +::: callout-tip +**实践要点** + +- 只给过阈值的点打标签,且**基因 + rs 号分两行**——GWAS 密度下单行标签立刻相撞。 +- `max.overlaps = 30` 防止 ggrepel 在拥挤的顶部区域静默丢标签——请检查 dropped-label 警告而不是相信图本身。 +- 染色体偏移必须来自按 `max(POS)` 分组的 join,而不是行顺序——`POS` 列未排序会打乱交替配色。 +::: + ## 应用场景 ::: {#fig-HistApplications} @@ -295,3 +368,5 @@ p1/p2 ## 参考文献 \[1\] Sang Y, Long Z, Dan X, Feng J, Shi T, Jia C, Zhang X, Lai Q, Yang G, Zhang H, Xu X, Liu H, Jiang Y, Ingvarsson PK, Liu J, Mao K, Wang J. Genomic insights into local adaptation and future climate-induced vulnerability of a keystone forest tree in East Asia. Nat Commun. 2022 Nov 1;13(1):6541. doi: 10.1038/s41467-022-34206-8. PMID: 36319648; PMCID: PMC9626627. + +\[2\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/MultiSeqsAlignment.qmd b/Omics/MultiSeqsAlignment.qmd index 79a7dc7fe..83b2255ce 100644 --- a/Omics/MultiSeqsAlignment.qmd +++ b/Omics/MultiSeqsAlignment.qmd @@ -16,16 +16,29 @@ Multiple Sequence Alignment (MSA) is a fundamental and crucial technique in bioi - Programming language: R -- Dependent packages: `ggmsa` +- Dependent packages: `ggmsa`, `pheatmap`, `ape`, `ggtree` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # Install packages if (!requireNamespace("ggmsa", quietly = TRUE)) { install.packages("ggmsa") } +if (!requireNamespace("pheatmap", quietly = TRUE)) { + install.packages("pheatmap") +} +if (!requireNamespace("ape", quietly = TRUE)) { + install.packages("ape") +} +if (!requireNamespace("ggtree", quietly = TRUE)) { + if (!requireNamespace("BiocManager", quietly = TRUE)) install.packages("BiocManager") + BiocManager::install("ggtree") +} # Library packages library(ggmsa) +library(pheatmap) +library(ape) +library(ggtree) ``` ```{r} @@ -123,3 +136,116 @@ p <- ggmsa( p ``` + +### 4. From an Expression Cluster to a Gene Family: Heatmap + Tree + Alignment + +The FigureYa2 workflow answers a common discovery question \[1\]: an expression heatmap clusters some genes of unknown function together with a known gene family — are the unknowns really family members? The check runs the other direction: align the family's protein sequences, build a tree from the alignment distances, and see whether expression clusters and sequence clades agree. The three panels below reproduce that loop on a simulated 12-member family with two subfamilies (evolved from one ancestor by substitutions only, so the "alignment" is exact and needs no aligner — with real sequences run `msa::msa()` and `seqinr::dist.alignment()` as in the reference, or any standard MSA tool). + +Expression first: the two subfamilies are co-expressed, so a clustered heatmap with a group annotation separates them into two row blocks — the observation that starts the investigation. + +```{r} +#| label: fig-4.1FamilyHeatmap +#| fig-cap: "Expression heatmap of the 12-member simulated family (rows z-scored, complete linkage): the two co-expression blocks correspond to the two subfamilies." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(2186) +aas <- strsplit("ARNDCQEGHILKMFPSTWYV", "")[[1]] +anc <- paste(sample(aas, 140, replace = TRUE), collapse = "") + +evolve <- function(seq, n_sub) { + s <- strsplit(seq, "")[[1]] + pos <- sample(length(s), n_sub) + s[pos] <- sample(aas, length(pos), replace = TRUE) + paste(s, collapse = "") +} +## two subfamilies: 22 substitutions shared within each lineage, 6 private per member +fam_a <- anc; fam_b <- anc +for (j in 1:22) { fam_a <- evolve(fam_a, 1); fam_b <- evolve(fam_b, 1) } +seqs <- c( + setNames(vapply(1:6, function(j) evolve(fam_a, 6), ""), paste0("FAM1_M", 1:6)), + setNames(vapply(1:6, function(j) evolve(fam_b, 6), ""), paste0("FAM2_U", 1:6))) +aln <- do.call(rbind, lapply(seqs, function(s) strsplit(s, "")[[1]])) +rownames(aln) <- names(seqs) + +n_samp <- 18 +grp <- factor(rep(c("Group1", "Group2"), c(6, 12))) +expr <- matrix(rnorm(12 * n_samp, sd = 0.7), 12, n_samp, + dimnames = list(rownames(aln), paste0("S", 1:n_samp))) +expr[grep("FAM1", rownames(expr)), grp == "Group1"] <- + expr[grep("FAM1", rownames(expr)), grp == "Group1"] + 1.4 +expr[grep("FAM2", rownames(expr)), grp == "Group2"] <- + expr[grep("FAM2", rownames(expr)), grp == "Group2"] + 1.4 + +ann_col <- data.frame(group = grp); rownames(ann_col) <- colnames(expr) +pheatmap(expr, scale = "row", clustering_method = "complete", + annotation_col = ann_col, + annotation_colors = list(group = c(Group1 = "#F4A582", Group2 = "#92C5DE")), + color = colorRampPalette(c("navy", "white", "firebrick3"))(20), + show_colnames = FALSE, fontsize = 9) +``` + +Second, the alignment view: with no insertions or deletions in the simulation every member keeps the ancestor's 140 positions, so the alignment matrix is the sequences themselves; `ggmsa()` renders the first 60 positions. Subfamily 1's signature at positions 1–3 (`CSR…` vs `MSA…`) and the scattered private substitutions are exactly what a real family alignment shows. + +```{r} +#| label: fig-4.2FamilyAlignment +#| fig-cap: "First 60 alignment positions of the 12 family members (ggmsa, Chemistry_AA colouring): each subfamily carries shared diagnostic substitutions plus private ones." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 4.6 + +## write the member sequences as FASTA (the real workflow aligns member FASTAs) +fa <- file.path(tempdir(), "family_msa.fasta") +con <- file(fa, "w") +for (nm in names(seqs)) writeLines(c(paste0(">", nm), seqs[[nm]]), con) +close(con) +ggmsa(fa, start = 1, end = 60, font = "DroidSansMono", + color = "Chemistry_AA", char_width = 0.5, seq_name = TRUE) +``` + +Third, the tree: a pairwise-identity distance (base R here; `seqinr::dist.alignment()` on a real MSA) feeds neighbour-joining (`ape::nj`), and `ggtree` \[2\] draws it with tips coloured by subfamily — the two expression clusters and the two sequence clades agree, which is the evidence the workflow exists to produce. + +```{r} +#| label: fig-4.3FamilyTree +#| fig-cap: "Neighbour-joining tree from pairwise sequence identity (ggtree): the two clades match the two expression blocks of the heatmap." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 6 + +n <- nrow(aln) +d <- matrix(0, n, n, dimnames = list(rownames(aln), rownames(aln))) +for (i in 2:n) for (j in 1:(i - 1)) { + d[i, j] <- d[j, i] <- 1 - mean(aln[i, ] == aln[j, ]) +} +tree <- nj(as.dist(d)) +sub <- ifelse(grepl("FAM1", tree$tip.label), "subfamily 1", "subfamily 2") +xr <- max(ape::node.depth.edgelength(tree)) +ggtree(tree, size = 0.8) %<+% data.frame(label = tree$tip.label, sub = sub) + + geom_tippoint(aes(color = sub), size = 2.6) + + geom_tiplab(aes(color = sub), size = 3.2, offset = 0.02, + align = TRUE, linesize = 0.2, show.legend = FALSE) + + scale_color_manual(values = c("subfamily 1" = "#B2182B", + "subfamily 2" = "#2166AC"), name = NULL) + + xlim(0, xr * 1.5) + theme(legend.position = "bottom") +``` + +::: callout-tip +**Practice tips** + +- Read the three panels together, always in this order: expression block → alignment signature → tree clade. A cluster that splits into two tree clades is evidence of a subfamily; a cluster that mixes clades usually means the expression pattern is condition-specific, not family-wide. +- The simulation evolves by substitutions only so the alignment is trivially correct; real proteins need a real aligner (`msa::msa()` with ClustalW, or MAFFT externally) — then convert with `msa::msaConvert(type = "seqinr::alignment")` for `dist.alignment()`. +- `ggtree` needs tip-label data attached with `%<+%`; colour the tips AND the labels the same way so the clade membership survives greyscale printing. +::: + +## Reference + +\[1\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[2\] Yu G, Lam TT. ggtree: an R package for visualization and annotation of phylogenetic trees. Methods in Ecology and Evolution. 2018. diff --git a/Omics/MultiSeqsAlignment.zh.qmd b/Omics/MultiSeqsAlignment.zh.qmd index 11b15c677..2034e5abb 100644 --- a/Omics/MultiSeqsAlignment.zh.qmd +++ b/Omics/MultiSeqsAlignment.zh.qmd @@ -16,16 +16,29 @@ author: - 编程语言:R -- 依赖包:`ggmsa` +- 依赖包:`ggmsa`、`pheatmap`、`ape`、`ggtree` ```{r packages setup, message=FALSE, warning=FALSE, output=FALSE} # 安装包 if (!requireNamespace("ggmsa", quietly = TRUE)) { install.packages("ggmsa") } +if (!requireNamespace("pheatmap", quietly = TRUE)) { + install.packages("pheatmap") +} +if (!requireNamespace("ape", quietly = TRUE)) { + install.packages("ape") +} +if (!requireNamespace("ggtree", quietly = TRUE)) { + if (!requireNamespace("BiocManager", quietly = TRUE)) install.packages("BiocManager") + BiocManager::install("ggtree") +} # 加载包 library(ggmsa) +library(pheatmap) +library(ape) +library(ggtree) ``` ```{r} @@ -123,3 +136,116 @@ p <- ggmsa( p ``` + +### 4. 从表达聚类到基因家族:热图 + 进化树 + 多序列比对 + +FigureYa2 工作流回答一个常见的发现型问题 \[1\]:表达热图中一些功能未知的基因与已知基因家族聚在同一簇——它们真的是家族成员吗?验证从序列方向展开:对家族蛋白序列做多序列比对、用比对距离建树,看表达簇与序列进化枝是否一致。下面三张图在一个模拟的 12 成员家族(两个亚家族,由同一祖先仅经替换演化而来,因此"比对"是精确的、无需比对软件)上复现该闭环;真实序列请按参考文档用 `msa::msa()` + `seqinr::dist.alignment()` 或任何标准 MSA 工具。 + +先看表达:两个亚家族分别共表达,带分组注释的聚类热图把它们分成两个行块——这正是启动验证的观察。 + +```{r} +#| label: fig-4.1FamilyHeatmap +#| fig-cap: "模拟 12 成员家族的表达热图(行 z-score,完全连锁):两个共表达块对应两个亚家族。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(2186) +aas <- strsplit("ARNDCQEGHILKMFPSTWYV", "")[[1]] +anc <- paste(sample(aas, 140, replace = TRUE), collapse = "") + +evolve <- function(seq, n_sub) { + s <- strsplit(seq, "")[[1]] + pos <- sample(length(s), n_sub) + s[pos] <- sample(aas, length(pos), replace = TRUE) + paste(s, collapse = "") +} +## 两个亚家族:各自 22 个共享替换 + 每成员 6 个私有替换 +fam_a <- anc; fam_b <- anc +for (j in 1:22) { fam_a <- evolve(fam_a, 1); fam_b <- evolve(fam_b, 1) } +seqs <- c( + setNames(vapply(1:6, function(j) evolve(fam_a, 6), ""), paste0("FAM1_M", 1:6)), + setNames(vapply(1:6, function(j) evolve(fam_b, 6), ""), paste0("FAM2_U", 1:6))) +aln <- do.call(rbind, lapply(seqs, function(s) strsplit(s, "")[[1]])) +rownames(aln) <- names(seqs) + +n_samp <- 18 +grp <- factor(rep(c("Group1", "Group2"), c(6, 12))) +expr <- matrix(rnorm(12 * n_samp, sd = 0.7), 12, n_samp, + dimnames = list(rownames(aln), paste0("S", 1:n_samp))) +expr[grep("FAM1", rownames(expr)), grp == "Group1"] <- + expr[grep("FAM1", rownames(expr)), grp == "Group1"] + 1.4 +expr[grep("FAM2", rownames(expr)), grp == "Group2"] <- + expr[grep("FAM2", rownames(expr)), grp == "Group2"] + 1.4 + +ann_col <- data.frame(group = grp); rownames(ann_col) <- colnames(expr) +pheatmap(expr, scale = "row", clustering_method = "complete", + annotation_col = ann_col, + annotation_colors = list(group = c(Group1 = "#F4A582", Group2 = "#92C5DE")), + color = colorRampPalette(c("navy", "white", "firebrick3"))(20), + show_colnames = FALSE, fontsize = 9) +``` + +第二,比对视图:模拟只发生替换、无插入缺失,每个成员都保持祖先的 140 个位置,比对矩阵即序列本身;`ggmsa()` 渲染前 60 个位置。亚家族 1 在 1–3 位有特征(`CSR…` vs `MSA…`),加上散布的私有替换——这正是真实家族比对呈现的结构。 + +```{r} +#| label: fig-4.2FamilyAlignment +#| fig-cap: "12 个家族成员的前 60 个比对位置(ggmsa,Chemistry_AA 配色):每个亚家族携带共享的诊断性替换与各自的私有替换。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 4.6 + +## 把成员序列写成 FASTA(真实流程对成员 FASTA 做比对) +fa <- file.path(tempdir(), "family_msa.fasta") +con <- file(fa, "w") +for (nm in names(seqs)) writeLines(c(paste0(">", nm), seqs[[nm]]), con) +close(con) +ggmsa(fa, start = 1, end = 60, font = "DroidSansMono", + color = "Chemistry_AA", char_width = 0.5, seq_name = TRUE) +``` + +第三,进化树:配对一致率距离(此处用 base R;真实 MSA 上用 `seqinr::dist.alignment()`)输入邻接法(`ape::nj`),`ggtree` \[2\] 绘制并以亚家族着色枝端——两个表达簇与两个序列进化枝完全对应,这正是该工作流要产出的证据。 + +```{r} +#| label: fig-4.3FamilyTree +#| fig-cap: "由配对序列一致率距离构建的邻接树(ggtree):两个进化枝与热图的两个表达块对应。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 8 +#| fig-height: 6 + +n <- nrow(aln) +d <- matrix(0, n, n, dimnames = list(rownames(aln), rownames(aln))) +for (i in 2:n) for (j in 1:(i - 1)) { + d[i, j] <- d[j, i] <- 1 - mean(aln[i, ] == aln[j, ]) +} +tree <- nj(as.dist(d)) +sub <- ifelse(grepl("FAM1", tree$tip.label), "subfamily 1", "subfamily 2") +xr <- max(ape::node.depth.edgelength(tree)) +ggtree(tree, size = 0.8) %<+% data.frame(label = tree$tip.label, sub = sub) + + geom_tippoint(aes(color = sub), size = 2.6) + + geom_tiplab(aes(color = sub), size = 3.2, offset = 0.02, + align = TRUE, linesize = 0.2, show.legend = FALSE) + + scale_color_manual(values = c("subfamily 1" = "#B2182B", + "subfamily 2" = "#2166AC"), name = NULL) + + xlim(0, xr * 1.5) + theme(legend.position = "bottom") +``` + +::: callout-tip +**实践要点** + +- 三张图务必按此顺序连读:表达块 → 比对特征 → 进化枝。一个表达簇分裂为两个进化枝是亚家族的证据;一个簇内混杂多个进化枝,通常说明表达模式是条件特异的而非家族性的。 +- 模拟只含替换所以比对天然正确;真实蛋白需要真正的比对器(`msa::msa()` 的 ClustalW,或外部 MAFFT),再用 `msa::msaConvert(type = "seqinr::alignment")` 转换后计算 `dist.alignment()`。 +- `ggtree` 的枝端数据要用 `%<+%` 挂接;枝端点与标签用同一套颜色映射,保证灰度打印下进化枝归属仍可读。 +::: + +## Reference + +\[1\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[2\] Yu G, Lam TT. ggtree: an R package for visualization and annotation of phylogenetic trees. Methods in Ecology and Evolution. 2018. diff --git a/Omics/MutationOncoplot.qmd b/Omics/MutationOncoplot.qmd index 96b4e56e1..60cb94808 100644 --- a/Omics/MutationOncoplot.qmd +++ b/Omics/MutationOncoplot.qmd @@ -432,11 +432,11 @@ ggdraw(combined) + ### 8. De Novo Mutation-Signature Decomposition -Somatic mutation catalogues decompose into **signatures** — 96-channel trinucleotide-context profiles characteristic of mutational processes (APOBEC, tobacco, UV, aging) \[4\]. The maftools/MutationalPatterns route needs a reference genome; the layout itself can be reproduced from a simulated channel matrix decomposed with NMF: +Somatic mutation catalogues decompose into **signatures** — trinucleotide-context profiles (96 channels in the full SBS convention) characteristic of mutational processes (APOBEC, tobacco, UV, aging) \[4\]. The maftools/MutationalPatterns route needs a reference genome; the layout itself can be reproduced from a simulated **48-channel** matrix (6 classes x 8 simplified contexts) decomposed with NMF: ```{r} #| label: fig-8.1SignatureNMF -#| fig-cap: "De novo signature decomposition of a simulated 96-channel catalogue: NMF-extracted signature profiles (top) and per-sample exposures (bottom)." +#| fig-cap: "De novo signature decomposition of a simulated 48-channel catalogue: NMF-extracted signature profiles (top) and per-sample exposures (bottom)." #| out.width: "95%" #| warning: false #| message: false @@ -450,7 +450,7 @@ channels <- paste0(rep(bases, each = 8), "_", rep(1:8, times = 6)) n_ch <- length(channels); n_samp <- 40 sig_apobec <- c(2, 6, 8, 6, 2, 1, 1, 1) # TCW motif enrichment, simplified shape -sig_aging <- c(5, 4, 6, 5, 4, 3, 2, 2) # flat, C>T tilt +sig_aging <- c(5, 4, 6, 5, 4, 3, 2, 2) # flat shape (shared by all classes here) W_true <- cbind(rep(sig_apobec, 6), rep(sig_aging, 6)) W_true <- W_true / colSums(W_true) expo <- t(cbind(c(rep(0.7, 15), rep(0.05, 25)), rep(0.5, n_samp))) # 2 signatures x 40 samples @@ -520,7 +520,8 @@ names(type_cols) <- mut_types contexts <- c("A_C", "C_C", "G_C", "T_C", "A_G", "C_G", "G_G", "T_G", "A_T", "C_T", "G_T", "T_T", "A_A", "C_A", "G_A", "T_A") -## simulate a 96-channel count vector with a C>T (aging-like) tilt +## simulate a 96-channel count vector; identical context profile within each +## class (schematic catalogue - real SBS1/aging signatures skew C>T) counts <- rmultinom(1, 6000, prob = rep(c(4, 2, 3, 1, 2, 2, 3, 1, 6, 3, 4, 2, 1, 1, 1, 1), times = 6)) @@ -647,7 +648,70 @@ draw(op1 %v% op2) - Both blocks must consume the SAME `ord` permutation of samples - one reordered vector is the whole trick behind a legible stacked landscape. - `heatmap_legend_param = list(space = "none")` silences the per-block legend; give legends once, in the caption or a dedicated block. -- Real data: take per-sample signature exposures from `maftools::get.mutationMatrix()`/SigProfiler rather than simulated shares, and let the sort key (`sig_key`) be a genuine SBS exposure. +- Real data: take per-sample signature exposures from `maftools::trinucleotideMatrix()` + NMF or SigProfiler rather than simulated shares, and let the sort key (`sig_key`) be a genuine SBS exposure. +::: + +### 11. 01-Matrix Oncoprint Split by Pathway with Clinical Annotation + +Panel-sequencing reports often deliver a **01 matrix** — mutated yes/no per gene per sample, no variant types — with the genes annotated to pathways and a clinical table beside them. The FigureYa42oncoprintV2 layout \[4\] feeds that straight into `ComplexHeatmap::oncoPrint()`: `row_split = pathway` stacks the pathway groups, `show_pct = FALSE` replaces the percentage axis with gene names, and `bottom_annotation` carries the clinical covariates so mutation pattern and phenotype read against each other: + +```{r} +#| label: fig-11.1PathwayOncoprint +#| fig-cap: "01-matrix oncoprint of 12 genes in 40 simulated samples: rows split by pathway (RTK/RAS, PI3K, p53/cell cycle), green = mutated, bottom annotation rows carry smoking, stage and treatment; the top barplot counts mutations per sample." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10.5 +#| fig-height: 6.5 + +set.seed(4201) +genes_path <- data.frame( + gene = c("EGFR", "ERBB2", "KRAS", "NRAS", "BRAF", "PIK3CA", "PTEN", "AKT1", + "TP53", "MDM2", "CDKN2A", "RB1"), + pathway = c("RTK/RAS", "RTK/RAS", "RTK/RAS", "RTK/RAS", "RTK/RAS", + "PI3K", "PI3K", "PI3K", "p53/cell cycle", "p53/cell cycle", + "p53/cell cycle", "p53/cell cycle")) +n_sm <- 40 +freq <- c(0.35, 0.2, 0.3, 0.12, 0.25, 0.4, 0.15, 0.1, 0.55, 0.18, 0.22, 0.12) +mat01 <- sapply(freq, function(f) sample(c("mut", ""), n_sm, TRUE, prob = c(f, 1 - f))) +mat01 <- t(mat01) +rownames(mat01) <- genes_path$gene +colnames(mat01) <- paste0("P", sprintf("%02d", 1:n_sm)) +mygene <- as.data.frame(mat01) +mygene$pathway <- genes_path$pathway +clin <- data.frame( + row.names = colnames(mat01), + Smoking = factor(sample(c("ever", "never"), n_sm, TRUE)), + Stage = factor(sample(c("I-II", "III-IV"), n_sm, TRUE)), + Treatment = factor(sample(c("chemo", "ICI", "TKI"), n_sm, TRUE, prob = c(0.4, 0.4, 0.2)))) +alter_fun <- list( + background = function(x, y, w, h) grid.rect(x, y, w - unit(0.5, "mm"), h - unit(0.5, "mm"), + gp = gpar(fill = NA, col = NA)), + mut = function(x, y, w, h) grid.rect(x, y, w - unit(0.5, "mm"), h - unit(0.5, "mm"), + gp = gpar(fill = "#008000", col = NA))) +col_g <- c("mut" = "#008000") +my_annotation <- HeatmapAnnotation(df = clin, + col = list(Smoking = c(ever = "#7A142C", never = "#D8D155"), + Stage = c("I-II" = "#58CDD9", "III-IV" = "#223D6C"), + Treatment = c(chemo = "#088247", ICI = "#D20A13", TKI = "#FFD121")), + annotation_name_side = "left", + annotation_name_gp = gpar(fontsize = 8)) +draw(oncoPrint(mygene[, colnames(mat01)], get_type = function(x) x, + alter_fun = alter_fun, col = col_g, + show_pct = FALSE, + bottom_annotation = my_annotation, + row_split = mygene$pathway, + show_heatmap_legend = FALSE, + column_title = "01-matrix oncoprint split by pathway, clinical data below", + column_title_gp = gpar(fontsize = 11))) +``` + +::: callout-tip +**Practice tips** + +- `oncoPrint()` needs the matrix values to be strings matching the `alter_fun`/`col` names — convert the 01 matrix with `mat01[mat01 == 1] <- "mut"; mat01[mat01 == 0] <- ""` before plotting. +- `get_type = function(x) x` tells oncoPrint each cell already carries its alteration labels verbatim (single-type 01 input); with multi-type MAF data keep the default parser instead. +- Keep clinical annotation rows to 2-4 factors; the bottom strip is for reading mutation-phenotype alignment, not a second heatmap. ::: ## Applications diff --git a/Omics/MutationOncoplot.zh.qmd b/Omics/MutationOncoplot.zh.qmd index 9d85a7323..c88acf98a 100644 --- a/Omics/MutationOncoplot.zh.qmd +++ b/Omics/MutationOncoplot.zh.qmd @@ -431,11 +431,11 @@ ggdraw(combined) + ### 8. 从头突变 signature 分解 -体细胞突变目录可分解为 **signature**——特征性的 96 通道三核苷酸上下文谱(APOBEC、烟草、UV、衰老等突变过程)\[4\]。maftools/MutationalPatterns 路线需要参考基因组;其版式本身可由模拟的通道矩阵经 NMF 分解复现: +体细胞突变目录可分解为 **signature**——特征性的三核苷酸上下文谱(完整 SBS 约定为 96 通道;APOBEC、烟草、UV、衰老等突变过程)\[4\]。maftools/MutationalPatterns 路线需要参考基因组;其版式本身可由模拟的 **48 通道**(6 类 × 8 简化上下文)矩阵经 NMF 分解复现: ```{r} #| label: fig-8.1SignatureNMF -#| fig-cap: "模拟 96 通道突变目录的从头分解:NMF 提取的 signature 谱(上)与各样本的 signature 暴露(下)。" +#| fig-cap: "模拟 48 通道突变目录的从头分解:NMF 提取的 signature 谱(上)与各样本的 signature 暴露(下)。" #| out.width: "95%" #| warning: false #| message: false @@ -448,7 +448,7 @@ channels <- paste0(rep(bases, each = 8), "_", rep(1:8, times = 6)) n_ch <- length(channels); n_samp <- 40 sig_apobec <- c(2, 6, 8, 6, 2, 1, 1, 1) # TCW motif 富集(简化形状) -sig_aging <- c(5, 4, 6, 5, 4, 3, 2, 2) # 平坦、C>T 倾斜 +sig_aging <- c(5, 4, 6, 5, 4, 3, 2, 2) # 平坦形状(此处各类共享) W_true <- cbind(rep(sig_apobec, 6), rep(sig_aging, 6)) W_true <- W_true / colSums(W_true) expo <- t(cbind(c(rep(0.7, 15), rep(0.05, 25)), rep(0.5, n_samp))) # 2 signatures x 40 samples @@ -518,7 +518,7 @@ names(type_cols) <- mut_types contexts <- c("A_C", "C_C", "G_C", "T_C", "A_G", "C_G", "G_G", "T_G", "A_T", "C_T", "G_T", "T_T", "A_A", "C_A", "G_A", "T_A") -## 模拟带 C>T(类衰老)倾斜的 96 通道计数向量 +## 模拟 96 通道计数向量;每类内上下文分布相同(示意目录——真实 SBS1/衰老 signature 偏向 C>T) counts <- rmultinom(1, 6000, prob = rep(c(4, 2, 3, 1, 2, 2, 3, 1, 6, 3, 4, 2, 1, 1, 1, 1), times = 6)) @@ -646,7 +646,70 @@ draw(op1 %v% op2) - 两区块必须消费同一个 `ord` 样本置换——一个重排向量便是叠放景观可读的全部机关。 - `heatmap_legend_param = list(space = "none")` 屏蔽逐块图例;图例只给一次,交图注或专门区块。 -- 真实数据以 `maftools::get.mutationMatrix()`/SigProfiler 取各样本签名暴露量替代模拟占比,排序键(`sig_key`)须为真实 SBS 暴露。 +- 真实数据以 `maftools::trinucleotideMatrix()` + NMF 或 SigProfiler 取各样本签名暴露量替代模拟占比,排序键(`sig_key`)须为真实 SBS 暴露。 +::: + +### 11. 01 矩阵 oncoprint:按通路拆分 + 临床注释 + +panel 测序报告常常给出 **01 矩阵**——每基因每样本突变与否、无变异类型——基因带通路注释、旁边附临床表。FigureYa42oncoprintV2 版式 \[4\] 把它直接喂给 `ComplexHeatmap::oncoPrint()`:`row_split = pathway` 堆叠通路分组,`show_pct = FALSE` 用基因名替换百分比轴,`bottom_annotation` 携带临床协变量,让突变模式与表型对照阅读: + +```{r} +#| label: fig-11.1PathwayOncoprint +#| fig-cap: "40 个模拟样本中 12 个基因的 01 矩阵 oncoprint:行按通路拆分(RTK/RAS、PI3K、p53/cell cycle),绿色 = 突变,底部注释行携带吸烟、分期与治疗;顶栏统计每样本突变数。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 10.5 +#| fig-height: 6.5 + +set.seed(4201) +genes_path <- data.frame( + gene = c("EGFR", "ERBB2", "KRAS", "NRAS", "BRAF", "PIK3CA", "PTEN", "AKT1", + "TP53", "MDM2", "CDKN2A", "RB1"), + pathway = c("RTK/RAS", "RTK/RAS", "RTK/RAS", "RTK/RAS", "RTK/RAS", + "PI3K", "PI3K", "PI3K", "p53/cell cycle", "p53/cell cycle", + "p53/cell cycle", "p53/cell cycle")) +n_sm <- 40 +freq <- c(0.35, 0.2, 0.3, 0.12, 0.25, 0.4, 0.15, 0.1, 0.55, 0.18, 0.22, 0.12) +mat01 <- sapply(freq, function(f) sample(c("mut", ""), n_sm, TRUE, prob = c(f, 1 - f))) +mat01 <- t(mat01) +rownames(mat01) <- genes_path$gene +colnames(mat01) <- paste0("P", sprintf("%02d", 1:n_sm)) +mygene <- as.data.frame(mat01) +mygene$pathway <- genes_path$pathway +clin <- data.frame( + row.names = colnames(mat01), + Smoking = factor(sample(c("ever", "never"), n_sm, TRUE)), + Stage = factor(sample(c("I-II", "III-IV"), n_sm, TRUE)), + Treatment = factor(sample(c("chemo", "ICI", "TKI"), n_sm, TRUE, prob = c(0.4, 0.4, 0.2)))) +alter_fun <- list( + background = function(x, y, w, h) grid.rect(x, y, w - unit(0.5, "mm"), h - unit(0.5, "mm"), + gp = gpar(fill = NA, col = NA)), + mut = function(x, y, w, h) grid.rect(x, y, w - unit(0.5, "mm"), h - unit(0.5, "mm"), + gp = gpar(fill = "#008000", col = NA))) +col_g <- c("mut" = "#008000") +my_annotation <- HeatmapAnnotation(df = clin, + col = list(Smoking = c(ever = "#7A142C", never = "#D8D155"), + Stage = c("I-II" = "#58CDD9", "III-IV" = "#223D6C"), + Treatment = c(chemo = "#088247", ICI = "#D20A13", TKI = "#FFD121")), + annotation_name_side = "left", + annotation_name_gp = gpar(fontsize = 8)) +draw(oncoPrint(mygene[, colnames(mat01)], get_type = function(x) x, + alter_fun = alter_fun, col = col_g, + show_pct = FALSE, + bottom_annotation = my_annotation, + row_split = mygene$pathway, + show_heatmap_legend = FALSE, + column_title = "01-matrix oncoprint split by pathway, clinical data below", + column_title_gp = gpar(fontsize = 11))) +``` + +::: callout-tip +**实践要点** + +- `oncoPrint()` 要求矩阵值是与 `alter_fun`/`col` 名字匹配的字符串——先用 `mat01[mat01 == 1] <- "mut"; mat01[mat01 == 0] <- ""` 转换 01 矩阵再作图。 +- `get_type = function(x) x` 告诉 oncoPrint 每个格子已经原样携带变异标签(单类型 01 输入);多类型 MAF 数据请保留默认解析器。 +- 临床注释行控制在 2-4 个因子:底部色条是用来读突变-表型对齐的,不是第二张热图。 ::: ## 应用场景 diff --git a/Omics/NetworkPlot.qmd b/Omics/NetworkPlot.qmd index fb1154d44..58f864ae4 100644 --- a/Omics/NetworkPlot.qmd +++ b/Omics/NetworkPlot.qmd @@ -209,7 +209,7 @@ The MetaNet package provides a comprehensive set of tools for microbial network ### 5. Hub-Spoke Interaction Network -Interaction databases (STRING chat, ComPPI) answer one protein per query; the resulting table reads best as a **hub-spoke drawing**: the bait sits large in the centre, interactors radiate around it, each edge is coloured by its evidence class (cellular location, motif, peak overlap...) and the number of edges per spoke encodes how many evidence lines support the interaction \[9\]. +Interaction databases (STRING chat, ComPPI) answer one protein per query; the resulting table reads best as a **hub-spoke drawing**: the bait sits large in the centre, interactors radiate around it, each edge is coloured by its evidence class (cellular location, motif, peak overlap...) and the number of edges per spoke encodes how many evidence lines support the interaction \[5\]. ```{r} #| label: fig-5.1HubSpoke @@ -278,3 +278,5 @@ legend("bottomleft", bty = "n", cex = 0.7, lty = 1, lwd = 2, \[4\] Chen Peng (2025). MetaNet: Network Analysis for Omics Data. R package +\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + diff --git a/Omics/NetworkPlot.zh.qmd b/Omics/NetworkPlot.zh.qmd index 2c694b0da..dfe7169a5 100644 --- a/Omics/NetworkPlot.zh.qmd +++ b/Omics/NetworkPlot.zh.qmd @@ -209,7 +209,7 @@ plot(co_net_union) MetaNet 包为微生物网络分析提供了全面的工具集,从基础的网络构建到高级的注释与可视化。通过灵活使用这些功能,我们能够从复杂的微生物组数据中提取有意义的生物学模式,为理解微生物群落结构与功能提供新视角。 ### 5. 中心-放射互作网络 -互作数据库(STRING chat、ComPPI)一次回答一个蛋白;结果表最适合画成**中心-放射图**:诱饵蛋白居中放大,互作蛋白向外辐射,每条边按证据类别着色(亚细胞定位、motif、peak 重叠……),每根辐条上的边数编码支持该互作的证据条数 \[10\]。 +互作数据库(STRING chat、ComPPI)一次回答一个蛋白;结果表最适合画成**中心-放射图**:诱饵蛋白居中放大,互作蛋白向外辐射,每条边按证据类别着色(亚细胞定位、motif、peak 重叠……),每根辐条上的边数编码支持该互作的证据条数 \[5\]。 ```{r} #| label: fig-5.1HubSpoke @@ -278,3 +278,7 @@ legend("bottomleft", bty = "n", cex = 0.7, lty = 1, lwd = 2, \[4\] Chen Peng (2025). MetaNet: Network Analysis for Omics Data. R package +\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[5\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + diff --git a/Omics/RnaVelocityPlot.qmd b/Omics/RnaVelocityPlot.qmd index c682a03d9..5d1337b9d 100644 --- a/Omics/RnaVelocityPlot.qmd +++ b/Omics/RnaVelocityPlot.qmd @@ -114,7 +114,7 @@ ggplot(vel_df, aes(cluster, speed, fill = cluster)) + ## Application -RNA velocity arrows are the standard figure for demonstrating differentiation direction in developmental and cancer scRNA-seq studies. +RNA velocity arrows are the standard figure for demonstrating differentiation direction in developmental and cancer scRNA-seq studies; the simulated-data workflow on this page adapts FigureYa177RNAvelocity \[2\]. ## Reference diff --git a/Omics/RnaVelocityPlot.zh.qmd b/Omics/RnaVelocityPlot.zh.qmd index db3725b20..8db9eec9e 100644 --- a/Omics/RnaVelocityPlot.zh.qmd +++ b/Omics/RnaVelocityPlot.zh.qmd @@ -114,7 +114,7 @@ ggplot(vel_df, aes(cluster, speed, fill = cluster)) + ## Application -RNA 速率箭头是发育和肿瘤 scRNA-seq 研究中展示分化方向的标准配图。 +RNA 速率箭头是发育和肿瘤 scRNA-seq 研究中展示分化方向的标准配图;本页的模拟数据工作流改编自 FigureYa177RNAvelocity \[2\]。 ## Reference diff --git a/Omics/ScCnvPlot.qmd b/Omics/ScCnvPlot.qmd index 54041a05c..ce410d533 100644 --- a/Omics/ScCnvPlot.qmd +++ b/Omics/ScCnvPlot.qmd @@ -4,7 +4,7 @@ author: - "**[Editor]** ZCode (GLM) — AI-generated, independently AI-reviewed;" --- -Large-scale copy-number aberrations can be **inferred from single-cell RNA-seq**: order genes by genomic position, smooth expression over 100-gene windows, median-centre every cell, and the residual waves are the CNV landscape \[1\]. Plotting cells (rows) against chromosomal positions (columns) separates malignant from non-malignant cells, with a per-cell CNV score as the ordering statistic. +Large-scale copy-number aberrations can be **inferred from single-cell RNA-seq**: order genes by genomic position, smooth expression over 50-gene windows, median-centre every cell, and the residual waves are the CNV landscape \[1\]. Plotting cells (rows) against chromosomal positions (columns) separates malignant from non-malignant cells, with a per-cell CNV score as the ordering statistic. ## Example @@ -89,7 +89,7 @@ rela <- pmin(pmax(rela, -3), 3) ```{r} #| label: fig-1.1SmoothedCNV -#| fig-cap: "CNV heatmap: cells (rows, malignant on top) x chromosomal positions (columns, chromosome boundaries ticked); smoothed over 100-gene windows." +#| fig-cap: "CNV heatmap: cells (rows, malignant on top) x chromosomal positions (columns); smoothed over 50-gene windows." #| out.width: "95%" #| warning: false #| message: false @@ -114,8 +114,6 @@ row_ha <- HeatmapAnnotation( col = list(Type = c(Malignant = "#B2182B", `Non-malignant` = "#4D4D4D")), annotation_name_side = "left") -chr_breaks <- cumsum(table(gene_pos$chr[gene_order]))[-n_chr] - Heatmap(smoothed[, col_order], name = "CNV", top_annotation = row_ha, col = col_fun, @@ -157,7 +155,7 @@ ggplot(score_df, aes(type, score, fill = type)) + **Practice tips** - Filter out lowly expressed genes **before** inferring CNV — near-zero expression distorts the running mean and mutes the waves. -- Centre per **cell** (median of all genes), not per gene: the waves are relative to each cell's baseline. +- The pipeline centres twice: per **gene** first (all genes share a baseline), then per **cell** (median across genes after smoothing) — the per-cell median makes the waves relative to each cell's own baseline. - The CNV score doubles as a malignancy classifier — the reference workflow uses it to flag malignant cells that marker genes miss. ::: diff --git a/Omics/ScCnvPlot.zh.qmd b/Omics/ScCnvPlot.zh.qmd index 0dd9c5a93..11347aef2 100644 --- a/Omics/ScCnvPlot.zh.qmd +++ b/Omics/ScCnvPlot.zh.qmd @@ -4,7 +4,7 @@ author: - "**[编辑]** ZCode (GLM) — AI 生成,独立 AI 复核" --- -大尺度拷贝数 aberration 可以**从单细胞 RNA-seq 推断**:按基因组位置排序基因、在 100 基因窗口上平滑表达、对每个细胞做中位数中心化,剩余的波动就是 CNV 图景 \[1\]。把细胞(行)对染色体位置(列)铺开即可区分恶性与非恶性细胞,每细胞 CNV 评分用作排序统计量。 +大尺度拷贝数 aberration 可以**从单细胞 RNA-seq 推断**:按基因组位置排序基因、在 50 基因窗口上平滑表达、对每个细胞做中位数中心化,剩余的波动就是 CNV 图景 \[1\]。把细胞(行)对染色体位置(列)铺开即可区分恶性与非恶性细胞,每细胞 CNV 评分用作排序统计量。 ## Example @@ -85,11 +85,11 @@ rela <- pmin(pmax(rela, -3), 3) ## Visualization -### 1. 滑动均值平滑(100 基因窗口) +### 1. 滑动均值平滑(50 基因窗口) ```{r} #| label: fig-1.1SmoothedCNV -#| fig-cap: "CNV 热图:细胞(行,恶性在上)× 染色体位置(列,标注染色体边界);100 基因窗口平滑。" +#| fig-cap: "CNV 热图:细胞(行,恶性在上)× 染色体位置(列);50 基因窗口平滑。" #| out.width: "95%" #| warning: false #| message: false @@ -114,8 +114,6 @@ row_ha <- HeatmapAnnotation( col = list(Type = c(Malignant = "#B2182B", `Non-malignant` = "#4D4D4D")), annotation_name_side = "left") -chr_breaks <- cumsum(table(gene_pos$chr[gene_order]))[-n_chr] - Heatmap(smoothed[, col_order], name = "CNV", top_annotation = row_ha, col = col_fun, @@ -157,7 +155,7 @@ ggplot(score_df, aes(type, score, fill = type)) + **Practice tips** - 推断 CNV 前先**过滤低表达基因**——近零表达会扭曲滑动均值、削弱波动。 -- 按**细胞**(全部基因的中位数)中心化,而非按基因:波形是相对每个细胞基线的。 +- 流程做了两次中心化:先按**基因**(所有基因共享基线),平滑后再按**细胞**(跨基因取中位数)——按细胞中位数使波形相对每个细胞自身的基线。 - CNV 评分兼作恶性判定——参考工作流用它标记 marker 基因漏掉的恶性细胞。 ::: diff --git a/Omics/TextEnrichmentBarPlot.qmd b/Omics/TextEnrichmentBarPlot.qmd index f2bb409da..2f3f9147c 100644 --- a/Omics/TextEnrichmentBarPlot.qmd +++ b/Omics/TextEnrichmentBarPlot.qmd @@ -73,7 +73,7 @@ ekegg <- enrichKEGG( organism = 'hsa' ) # KEGG results default to Entrez ID; manually convert to Symbol to match plotting data format -ekegg <- setReadable(ekegg, OrgDb = org.Hs.eg.db, keyType = "ENTREZID") +ekegg <- setReadable(ekegg, OrgDb = "org.Hs.eg.db", keyType = "ENTREZID") # 3. Data Cleaning and Merging # Extract GO results (Rename ONTOLOGY to Category) @@ -369,9 +369,161 @@ stopifnot(sum(up$FDR < 0.05) + sum(dn$FDR < 0.05) >= 10) - The negative-`Count` trick keeps both arms on one scale so the eye compares arm lengths directly. - `facet_grid(..., scales = "free_y", space = "free_y")` lets each arm sort its own terms without empty padding rows. -- With real results, build the two arms with `clusterProfiler::compare_eGO()` / `compareEGO()` and feed the merged frame to the same ggplot2 layers — no enrichplot dependency needed. +- With real results, build the two arms with `clusterProfiler::compareCluster()` and feed the merged frame to the same ggplot2 layers — no enrichplot dependency needed. ::: +### 4. Pathway-Activity DE Dot Plot Across Cell Types + +The FigureYa318 layout \[2\] asks the two-group question **per cell type and per pathway at once**: rows = cell types, columns = pathways (grouped by a classification colour strip), dot size = FDR bins, dot colour = log2 fold change of the pathway activity score. The reference computes AUCell scores per cell and limma contrasts per cell type; here the same geometry is reproduced from simulated per-cell activity scores tested with Wilcoxon rank-sum and Bonferroni correction — swap in your own AUCell/GSVA score matrix for real data. + +```{r} +#| label: fig-4.1PathwayDEDot +#| fig-cap: "Pathway-activity differential dot plot (12 pathways x 4 cell types): dot size = Bonferroni-FDR bins, colour = log2 fold change of the activity score; the bottom strip groups pathways into Immune / Metabolism / Signaling / Proliferation." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 6 + +set.seed(3181) +paths <- c("HALLMARK_INTERFERON_GAMMA", "HALLMARK_TNFA_SIGNALING", "HALLMARK_COMPLEMENT", + "HALLMARK_GLYCOLYSIS", "HALLMARK_OXIDATIVE_PHOSPH", "HALLMARK_FATTY_ACID", + "HALLMARK_MAPK", "HALLMARK_PI3K", "HALLMARK_NOTCH", + "HALLMARK_E2F", "HALLMARK_G2M", "HALLMARK_APOPTOSIS") +class.df <- data.frame( + geneset = paths, + Classification = c("Immune", "Immune", "Immune", + "Metabolism", "Metabolism", "Metabolism", + "Signaling", "Signaling", "Signaling", + "Proliferation", "Proliferation", "Proliferation")) +cts <- c("CD8 T", "Macro", "Fibro", "Cancer") +n_pc <- 40 +path_mean <- setNames(c(0.55, 0.5, 0.45, 0.35, 0.4, 0.3, 0.25, 0.3, 0.2, 0.2, 0.25, 0.3), paths) +scores_ctl <- do.call(rbind, lapply(cts, function(ct) { + m <- sapply(paths, function(pw) rnorm(n_pc, path_mean[pw], 0.12)) + data.frame(cell = ct, m, check.names = FALSE) +})) +scores_tr <- scores_ctl +immune_hit <- scores_tr$cell %in% c("CD8 T", "Macro") +scores_tr$HALLMARK_INTERFERON_GAMMA[immune_hit] <- + scores_tr$HALLMARK_INTERFERON_GAMMA[immune_hit] + 0.28 +scores_tr$HALLMARK_TNFA_SIGNALING[immune_hit] <- + scores_tr$HALLMARK_TNFA_SIGNALING[immune_hit] + 0.32 +scores_tr$HALLMARK_E2F[] <- scores_tr$HALLMARK_E2F[] - 0.22 +## null pathways get small cell-type-specific offsets in the treated arm so +## their near-zero log2FC scatter stays visible on the white midpoint +set.seed(3182) +null_paths <- setdiff(paths, c("HALLMARK_INTERFERON_GAMMA", "HALLMARK_TNFA_SIGNALING", "HALLMARK_E2F")) +for (pw in null_paths) { + off <- rnorm(length(cts), 0, 0.07); names(off) <- cts + sel <- scores_tr$cell %in% cts + scores_tr[sel, pw] <- scores_tr[sel, pw] + off[scores_tr$cell[sel]] +} + +DP.list <- lapply(cts, function(ct) { + do.call(rbind, lapply(paths, function(pw) { + a <- scores_ctl$cell == ct; b <- scores_tr$cell == ct + data.frame(Celltypes = ct, Pathway = pw, + logFC = mean(scores_tr[[pw]][b]) - mean(scores_ctl[[pw]][a]), + p.val = wilcox.test(scores_tr[[pw]][b], scores_ctl[[pw]][a])$p.value) + })) +}) +DPs <- do.call(rbind, DP.list) +DPs$adj.P.Val <- p.adjust(DPs$p.val, method = "bonferroni") + +plot.data <- DPs +plot.data$FDR <- cut(plot.data$adj.P.Val, breaks = c(0, 1e-10, 1e-6, 1e-3, 1), + include.lowest = TRUE, + labels = c("<1e-10", "1e-10~1e-6", "1e-6~1e-3", ">1e-3")) +plot.data$FDR <- factor(as.character(plot.data$FDR), + levels = c("<1e-10", "1e-10~1e-6", "1e-6~1e-3", ">1e-3")) +plot.data$Pathway <- factor(sub("HALLMARK_", "", plot.data$Pathway), + levels = sub("HALLMARK_", "", class.df$geneset)) +plot.data$Celltypes <- factor(plot.data$Celltypes, levels = rev(cts)) + +color <- c("#4682B4", "#FFFFFF", "#CD2626") +class.color <- c("Immune" = "#D58986", "Metabolism" = "#80554C", + "Signaling" = "#71AC7A", "Proliferation" = "#E8D4B4") +p1 <- ggplot(plot.data, aes(Pathway, Celltypes, color = logFC, size = FDR)) + + geom_point() + + scale_color_gradient2(low = color[1], mid = color[2], high = color[3], + limits = c(-0.35, 0.35), name = "log2FC (score)") + + scale_size_manual(values = c("<1e-10" = 4.4, "1e-10~1e-6" = 3.6, + "1e-6~1e-3" = 2.8, ">1e-3" = 1.6), + name = "Bonferroni FDR", drop = FALSE) + + geom_hline(yintercept = seq(0.5, length(cts) - 0.5, 1), colour = "grey80") + + geom_vline(xintercept = seq(0.5, length(paths) - 0.5, 1), colour = "grey80") + + theme_classic(base_size = 10) + + theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5), + axis.line = element_blank()) +## the classification strip must share p1's column order: keep geneset as a +## factor with the same level order, never a bare character vector +class.df$geneset <- factor(sub("HALLMARK_", "", class.df$geneset), + levels = sub("HALLMARK_", "", paths)) +p2 <- ggplot(class.df, aes(geneset, 1, fill = Classification)) + + geom_tile() + + scale_fill_manual(values = class.color, name = NULL) + + theme_void(base_size = 10) + + theme(legend.position = "bottom", legend.direction = "horizontal", + legend.title = element_text(size = 8), + legend.text = element_text(size = 7.5), + legend.key.size = unit(3, "mm"), + legend.margin = margin(0, 0, 0, 0)) +cowplot::plot_grid(p1, p2, ncol = 1, align = "v", axis = "lr", + rel_heights = c(10, 1.9)) +``` + +::: callout-tip +**Practice tips** + +- Keep the strip and the dot plot on the **same factor levels** — the strip's x axis is a plain character vector in most drafts, which silently re-sorts alphabetically and desynchronises the two panels. +- Bonferroni over pathways x cell types is what the reference uses; with `rstatix` the same workflow is `group_by(Celltypes, Pathway) |> wilcox_test() |> adjust_pvalue(method = "bonferroni")`. +- Dots at the white midpoint are invisible on a white panel: either plant real per-cell-type variability (as done here) or outline non-significant dots. +::: + +### 5. Gene-Concept Circular Network (GOplot-Style) + +The GOplot package behind FigureYa52 \[2\] is no longer on CRAN, but its signature figure — genes linked to the top enriched terms, gene nodes coloured by log2 fold change — is exactly `enrichplot::cnetplot()` on a `clusterProfiler::enrichGO()` result with `foldChange` attached. Two steps matter: `simplify()` first (BP terms are massively redundant and the network becomes unreadable), and pass the named log2FC vector so gene nodes carry the direction: + +```{r} +#| label: fig-5.1GeneConceptNet +#| fig-cap: "Gene-concept network of 3 top enriched BP terms (clusterProfiler + enrichplot): term hubs sized by member count, gene nodes coloured by log2 fold change (blue = up, red = down); simulated IFN-gamma response gene set." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 7 + +set.seed(5201) +de_genes <- data.frame( + SYMBOL = c("IFNG", "TNF", "IL2", "STAT1", "CXCL9", "CXCL10", "IRF1", "GBP1", + "CD8A", "GZMB", "PRF1", "LAG3", "PDCD1", "CTLA4", "ISG15", "MX1"), + log2fc = c(1.6, 1.4, 1.2, 1.1, 1.5, 1.3, 1.0, 0.9, 1.2, 1.5, 1.1, -1.0, -0.9, -0.8, 1.0, 0.8)) +## simplify() first: BP terms are massively redundant and the gene-concept +## network is unreadable without it; cnetplot's `layout`/`circular` args moved +## in clusterProfiler >= 4.x, so the default layout is used here +ego52 <- clusterProfiler::enrichGO(gene = de_genes$SYMBOL, OrgDb = "org.Hs.eg.db", + keyType = "SYMBOL", ont = "BP", + pvalueCutoff = 0.01, qvalueCutoff = 0.05, + readable = TRUE) +ego52 <- clusterProfiler::simplify(ego52, cutoff = 0.6, by = "p.adjust") +geneList52 <- de_genes$log2fc; names(geneList52) <- de_genes$SYMBOL +enrichplot::cnetplot(ego52, showCategory = 3, foldChange = geneList52, + color_edge = "grey") + + theme_minimal(base_size = 11) + + theme(legend.position = "bottom", + panel.background = element_rect(fill = "white", colour = NA)) +``` + +::: callout-tip +**Practice tips** + +- `simplify()` (semantic redundancy removal) before any gene-concept network: without it a 16-gene input yields hundreds of near-identical BP terms and the three you display are arbitrary. +- `readable = TRUE` in `enrichGO()` maps ENTREZ IDs back to symbols — the network is only useful when gene nodes carry names a reader knows. +- In clusterProfiler >= 4.x the old `circular = TRUE` / `colorEdge` arguments are gone (`layout`/`color_edge`); the `...` errors are silent-looking signature changes worth checking with `args(clusterProfiler::cnetplot)`. +::: + +## Reference \[1\] 生信医道. 超好看的单细胞GO,KEGG富集分析图!确定不来看看吗? \[Internet\]. 微信公众号: 生信医道. 2025 \[cited 2025 Dec 30\]. Available from: diff --git a/Omics/TextEnrichmentBarPlot.zh.qmd b/Omics/TextEnrichmentBarPlot.zh.qmd index 6836192b1..dddc5370a 100644 --- a/Omics/TextEnrichmentBarPlot.zh.qmd +++ b/Omics/TextEnrichmentBarPlot.zh.qmd @@ -370,9 +370,161 @@ stopifnot(sum(up$FDR < 0.05) + sum(dn$FDR < 0.05) >= 10) - 负 `Count` 手法使两臂同处一尺度,两臂长度可直读对比。 - `facet_grid(..., scales = "free_y", space = "free_y")` 允许两臂各自排 term 而不产生空行。 -- 真实结果用 `clusterProfiler::compare_eGO()`/`compareEGO()` 构建两臂后,直接喂给同一组 ggplot2 图层即可——无需依赖 enrichplot。 +- 真实结果用 `clusterProfiler::compareCluster()` 构建两臂后,直接喂给同一组 ggplot2 图层即可——无需依赖 enrichplot。 ::: +### 4. 跨细胞类型的通路活性差异点图 + +FigureYa318 版式 \[2\] 同时问"每个细胞类型 × 每条通路"的两组问题:行 = 细胞类型,列 = 通路(按分类色条分组),点大小 = FDR 分档,点颜色 = 通路活性得分的 log2 倍数变化。参考流程对每个细胞逐条计算 AUCell 得分、按细胞类型做 limma 对比;此处用模拟的逐细胞活性得分 + Wilcoxon 秩和检验 + Bonferroni 校正复现同一几何结构——真实数据请替换为你自己的 AUCell/GSVA 得分矩阵。 + +```{r} +#| label: fig-4.1PathwayDEDot +#| fig-cap: "通路活性差异点图(12 通路 × 4 细胞类型):点大小 = Bonferroni-FDR 分档,颜色 = 活性得分 log2 倍数变化;底部色条把通路分为 Immune / Metabolism / Signaling / Proliferation。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 11 +#| fig-height: 6 + +set.seed(3181) +paths <- c("HALLMARK_INTERFERON_GAMMA", "HALLMARK_TNFA_SIGNALING", "HALLMARK_COMPLEMENT", + "HALLMARK_GLYCOLYSIS", "HALLMARK_OXIDATIVE_PHOSPH", "HALLMARK_FATTY_ACID", + "HALLMARK_MAPK", "HALLMARK_PI3K", "HALLMARK_NOTCH", + "HALLMARK_E2F", "HALLMARK_G2M", "HALLMARK_APOPTOSIS") +class.df <- data.frame( + geneset = paths, + Classification = c("Immune", "Immune", "Immune", + "Metabolism", "Metabolism", "Metabolism", + "Signaling", "Signaling", "Signaling", + "Proliferation", "Proliferation", "Proliferation")) +cts <- c("CD8 T", "Macro", "Fibro", "Cancer") +n_pc <- 40 +path_mean <- setNames(c(0.55, 0.5, 0.45, 0.35, 0.4, 0.3, 0.25, 0.3, 0.2, 0.2, 0.25, 0.3), paths) +scores_ctl <- do.call(rbind, lapply(cts, function(ct) { + m <- sapply(paths, function(pw) rnorm(n_pc, path_mean[pw], 0.12)) + data.frame(cell = ct, m, check.names = FALSE) +})) +scores_tr <- scores_ctl +immune_hit <- scores_tr$cell %in% c("CD8 T", "Macro") +scores_tr$HALLMARK_INTERFERON_GAMMA[immune_hit] <- + scores_tr$HALLMARK_INTERFERON_GAMMA[immune_hit] + 0.28 +scores_tr$HALLMARK_TNFA_SIGNALING[immune_hit] <- + scores_tr$HALLMARK_TNFA_SIGNALING[immune_hit] + 0.32 +scores_tr$HALLMARK_E2F[] <- scores_tr$HALLMARK_E2F[] - 0.22 +## 零效应通路在处理臂上加入小的细胞类型特异偏移, +## 使其接近 0 的 log2FC 散布在白色中点上仍然可见 +set.seed(3182) +null_paths <- setdiff(paths, c("HALLMARK_INTERFERON_GAMMA", "HALLMARK_TNFA_SIGNALING", "HALLMARK_E2F")) +for (pw in null_paths) { + off <- rnorm(length(cts), 0, 0.07); names(off) <- cts + sel <- scores_tr$cell %in% cts + scores_tr[sel, pw] <- scores_tr[sel, pw] + off[scores_tr$cell[sel]] +} + +DP.list <- lapply(cts, function(ct) { + do.call(rbind, lapply(paths, function(pw) { + a <- scores_ctl$cell == ct; b <- scores_tr$cell == ct + data.frame(Celltypes = ct, Pathway = pw, + logFC = mean(scores_tr[[pw]][b]) - mean(scores_ctl[[pw]][a]), + p.val = wilcox.test(scores_tr[[pw]][b], scores_ctl[[pw]][a])$p.value) + })) +}) +DPs <- do.call(rbind, DP.list) +DPs$adj.P.Val <- p.adjust(DPs$p.val, method = "bonferroni") + +plot.data <- DPs +plot.data$FDR <- cut(plot.data$adj.P.Val, breaks = c(0, 1e-10, 1e-6, 1e-3, 1), + include.lowest = TRUE, + labels = c("<1e-10", "1e-10~1e-6", "1e-6~1e-3", ">1e-3")) +plot.data$FDR <- factor(as.character(plot.data$FDR), + levels = c("<1e-10", "1e-10~1e-6", "1e-6~1e-3", ">1e-3")) +plot.data$Pathway <- factor(sub("HALLMARK_", "", plot.data$Pathway), + levels = sub("HALLMARK_", "", class.df$geneset)) +plot.data$Celltypes <- factor(plot.data$Celltypes, levels = rev(cts)) + +color <- c("#4682B4", "#FFFFFF", "#CD2626") +class.color <- c("Immune" = "#D58986", "Metabolism" = "#80554C", + "Signaling" = "#71AC7A", "Proliferation" = "#E8D4B4") +p1 <- ggplot(plot.data, aes(Pathway, Celltypes, color = logFC, size = FDR)) + + geom_point() + + scale_color_gradient2(low = color[1], mid = color[2], high = color[3], + limits = c(-0.35, 0.35), name = "log2FC (score)") + + scale_size_manual(values = c("<1e-10" = 4.4, "1e-10~1e-6" = 3.6, + "1e-6~1e-3" = 2.8, ">1e-3" = 1.6), + name = "Bonferroni FDR", drop = FALSE) + + geom_hline(yintercept = seq(0.5, length(cts) - 0.5, 1), colour = "grey80") + + geom_vline(xintercept = seq(0.5, length(paths) - 0.5, 1), colour = "grey80") + + theme_classic(base_size = 10) + + theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5), + axis.line = element_blank()) +## 分类色条必须与点图共享同一套因子水平——草稿里它常是裸字符向量, +## 会被字母序静默重排,导致两面板列错位 +class.df$geneset <- factor(sub("HALLMARK_", "", class.df$geneset), + levels = sub("HALLMARK_", "", paths)) +p2 <- ggplot(class.df, aes(geneset, 1, fill = Classification)) + + geom_tile() + + scale_fill_manual(values = class.color, name = NULL) + + theme_void(base_size = 10) + + theme(legend.position = "bottom", legend.direction = "horizontal", + legend.title = element_text(size = 8), + legend.text = element_text(size = 7.5), + legend.key.size = unit(3, "mm"), + legend.margin = margin(0, 0, 0, 0)) +cowplot::plot_grid(p1, p2, ncol = 1, align = "v", axis = "lr", + rel_heights = c(10, 1.9)) +``` + +::: callout-tip +**实践要点** + +- 色条与点图必须使用**同一套因子水平**——多数草稿里色条的 x 轴是裸字符向量,会被字母序静默重排,两面板列错位。 +- 参考流程用通路 × 细胞类型上的 Bonferroni 校正;用 `rstatix` 可写成 `group_by(Celltypes, Pathway) |> wilcox_test() |> adjust_pvalue(method = "bonferroni")`。 +- 白色中点上的点在白底面板里不可见:要么像本例这样植入真实的细胞类型间变异,要么给非显著的点加描边。 +::: + +### 5. 基因-概念环形网络(GOplot 风格) + +FigureYa52 背后的 GOplot 包已从 CRAN 下架 \[2\],但其招牌图——基因连到 top 富集通路、基因节点按 log2 倍数变化着色——正是 `enrichplot::cnetplot()` 在 `clusterProfiler::enrichGO()` 结果上带 `foldChange` 的输出。两步关键:先 `simplify()`(BP 通路冗余极重,不去重网络不可读),并传入带名字的 log2FC 向量让基因节点携带方向: + +```{r} +#| label: fig-5.1GeneConceptNet +#| fig-cap: "3 个 top 富集 BP 通路的基因-概念网络(clusterProfiler + enrichplot):通路枢纽节点大小 = 成员数,基因节点按 log2 倍数变化着色(蓝 = 上调、红 = 下调);模拟的 IFN-γ 响应基因集。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 7 + +set.seed(5201) +de_genes <- data.frame( + SYMBOL = c("IFNG", "TNF", "IL2", "STAT1", "CXCL9", "CXCL10", "IRF1", "GBP1", + "CD8A", "GZMB", "PRF1", "LAG3", "PDCD1", "CTLA4", "ISG15", "MX1"), + log2fc = c(1.6, 1.4, 1.2, 1.1, 1.5, 1.3, 1.0, 0.9, 1.2, 1.5, 1.1, -1.0, -0.9, -0.8, 1.0, 0.8)) +## 先 simplify():BP 通路冗余极重,不去重基因-概念网络不可读; +## clusterProfiler >= 4.x 中 cnetplot 的 `layout`/`circular` 参数已迁移, +## 这里使用默认布局 +ego52 <- clusterProfiler::enrichGO(gene = de_genes$SYMBOL, OrgDb = "org.Hs.eg.db", + keyType = "SYMBOL", ont = "BP", + pvalueCutoff = 0.01, qvalueCutoff = 0.05, + readable = TRUE) +ego52 <- clusterProfiler::simplify(ego52, cutoff = 0.6, by = "p.adjust") +geneList52 <- de_genes$log2fc; names(geneList52) = de_genes$SYMBOL +enrichplot::cnetplot(ego52, showCategory = 3, foldChange = geneList52, + color_edge = "grey") + + theme_minimal(base_size = 11) + + theme(legend.position = "bottom", + panel.background = element_rect(fill = "white", colour = NA)) +``` + +::: callout-tip +**实践要点** + +- 任何基因-概念网络前先 `simplify()`(语义冗余去除):不做时 16 个基因输入会产生数百个近乎相同的 BP 通路,展示的 3 条通路纯属任意。 +- `enrichGO()` 的 `readable = TRUE` 把 ENTREZ ID 映射回基因符号——网络只有在基因节点携带读者认识的符号时才有用。 +- clusterProfiler >= 4.x 中旧的 `circular = TRUE` / `colorEdge` 参数已移除(改为 `layout`/`color_edge`)——这类"签名静默变更"值得用 `args(clusterProfiler::cnetplot)` 核对。 +::: + +## 参考文献 \[1\] 生信医道. 超好看的单细胞GO,KEGG富集分析图!确定不来看看吗? \[Internet\]. 微信公众号: 生信医道. 2025 \[cited 2025 Dec 30\]. Available from: diff --git a/Omics/VolcanoPlot.qmd b/Omics/VolcanoPlot.qmd index 28c70938b..92a4a18b2 100644 --- a/Omics/VolcanoPlot.qmd +++ b/Omics/VolcanoPlot.qmd @@ -274,6 +274,147 @@ ggdraw(combined) - `insert_xaxis_grob()` / `insert_yaxis_grob()` come from cowplot and keep the main panel's size; the alternative is `patchwork::plot_layout` with `design` — both need aligned limits. ::: -## Reference +### 4. Size-Encoded Volcano for Small-Effect Screens (PDUI Style) + +Alternative-polyadenylation screens (the TC3A PDUI analysis behind FigureYa321 \[1\]) produce **small effect sizes** — a meaningful 3'UTR-usage shift is ΔPDUI ≈ 0.1, not 1 — so the usual |log2FC| ≥ 1 gates do nothing. The reference's encoding: y = −log10 adjusted P, x = ΔPDUI with relaxed ±0.05 gates, and **dot size = |ΔPDUI × −log10 P|** so effect-and-significance jointly drive prominence. The block below runs the same `limma` pipeline the reference uses on a simulated PDUI matrix: + +```{r} +#| label: fig-4.1PduiVolcano +#| fig-cap: "Size-encoded volcano of simulated 3'UTR-usage (PDUI) events between vital-status groups: colour = direction gate (|delta PDUI| > 0.05 and adjusted P < 0.1), dot size = |delta PDUI x -log10 P|; the strongest shift on each side is labeled." +#| out.width: "75%" +#| warning: false +#| message: false +#| fig-width: 6.8 +#| fig-height: 5.6 + +set.seed(3211) +n_ev <- 400; n_s <- 60 +PDUI <- matrix(runif(n_ev * n_s, 0.2, 0.8), n_ev, n_s) +rownames(PDUI) <- paste0("chr", sample(1:22, n_ev, replace = TRUE), "_", + sample(1:9, n_ev, replace = TRUE), "|EV", 1:n_ev, "|") +grp <- factor(rep(c("LIVING", "DEAD"), each = n_s / 2), levels = c("LIVING", "DEAD")) +hit <- sample(n_ev, 18) +PDUI[hit[1:9], grp == "DEAD"] <- pmin(1, PDUI[hit[1:9], grp == "DEAD"] + 0.2) # 3'UTR shortening +PDUI[hit[10:18], grp == "DEAD"] <- pmax(0, PDUI[hit[10:18], grp == "DEAD"] - 0.2) + +design <- model.matrix(~0 + grp); colnames(design) <- levels(grp) +fit <- limma::lmFit(PDUI, design) +fit2 <- limma::contrasts.fit(fit, limma::makeContrasts(DEAD - LIVING, levels = design)) +fit2 <- limma::eBayes(fit2) +DEGs <- limma::topTable(fit2, coef = 1, n = Inf) +DEGs$SYMBOL <- gsub(".+\\|(EV[0-9]+)\\|.*", "\\1", rownames(DEGs)) + +plot.data <- DEGs +plot.data$logPadj <- -log(plot.data$adj.P.Val) +plotgene <- rownames(plot.data)[c(which.max(plot.data$logFC), which.min(plot.data$logFC))] +plot.data$label <- ifelse(rownames(plot.data) %in% plotgene, plot.data$SYMBOL, NA) +plot.data$status <- "NoSig" +plot.data$status[plot.data$logFC < -0.05 & plot.data$logPadj > 1] <- "Down" +plot.data$status[plot.data$logFC > 0.05 & plot.data$logPadj > 1] <- "Up" +plot.data$status <- factor(plot.data$status, levels = c("Up", "Down", "NoSig")) +plot.data$size_v <- abs(plot.data$logFC * plot.data$logPadj) +palette_volcano <- c(Up = "#D93F3C", Down = "#184A8C", NoSig = "#B3B3B3") + +ggplot(plot.data, aes(logFC, logPadj, color = status)) + + geom_point(alpha = 0.9, aes(size = size_v)) + + scale_size_continuous(range = c(1, 7), guide = "none") + + scale_color_manual(values = palette_volcano, drop = FALSE, name = NULL) + + geom_label_repel(data = subset(plot.data, !is.na(label)), + aes(label = label), size = 3.4, fontface = "bold", + box.padding = 0.5, show.legend = FALSE) + + geom_point(data = subset(plot.data, !is.na(label)), shape = 1, + stroke = 0.6, color = "black", size = 2.6) + + geom_vline(xintercept = c(-0.05, 0.05), colour = "grey40", linetype = "longdash", lwd = 0.25) + + geom_hline(yintercept = 1, colour = "grey40", linetype = "longdash", lwd = 0.25) + + labs(x = "delta PDUI (DEAD - LIVING)", y = "-log10 adjusted P", + title = "3'UTR usage shift by vital status (simulated TC3A-style PDUI)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- When effects are small, the size channel carries the headline: `|effect x -log10(P)|` grows quadratically in evidence, which pulls the doubly-strong events out of a crowded centre — say so in the caption, because readers assume size is a third variable. +- Thresholds must match the assay's scale: ΔPDUI gates live at ±0.05 (usage fractions live in [0, 1]); recycling a transcriptomics volcano's ±1 gate empties the plot. +- Keep the two labeled events as the reading anchors — one per direction — and let colour do the rest. +::: + +### 5. The Tiered "Cool" Volcano (FigureYa59volcanoV2) + +When a screen feeds downstream validation, the reference's advanced volcano \[2\] encodes **three significance tiers at once**: point colour darkens through nested gates (|logFC| > 1.5 & P < 0.05, then > 2.5 & P < 1e-4, then > 5 & P < 1e-5), point size grows with the tier, and the handful of genes chosen for functional validation are recoloured by pathway, circled black and labeled. The gates are data-driven, so the plot survives huge dynamic ranges without axis clipping: + +```{r} +#| label: fig-5.1TieredVolcano +#| fig-cap: "Tiered volcano of 900 simulated events: nested gates at |logFC| = 1.5/2.5/5 and adjusted P = 0.05/1e-4/1e-5 drive colour darkness and point size; pathway-coloured, black-circled and labeled points are the validation picks." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 6.2 + +set.seed(5901) +n_v2 <- 900 +v2 <- data.frame( + gsym = paste0("G", 1:n_v2), + logFC = rnorm(n_v2, 0, 1.4), + adjP = 10^(-rexp(n_v2, 0.9))) +v2$adjP <- pmin(1, v2$adjP) +sel <- sample(n_v2, 10) +v2$adjP[sel[1:6]] <- 10^(-runif(6, 5, 12)); v2$logFC[sel[1:4]] <- rnorm(4, 4.5, 0.7) +v2$adjP[sel[7:10]] <- 10^(-runif(4, 5, 10)); v2$logFC[sel[7:10]] <- rnorm(4, -4.5, 0.7) +v2$pathway <- sample(c("Pathway A", "Pathway B", "Pathway C"), n_v2, TRUE, + prob = c(0.05, 0.05, 0.9)) +v2$pathway[sel] <- rep(c("Pathway A", "Pathway B"), c(6, 4)) +selected <- v2[sel, ] +selected$pathway <- factor(selected$pathway, levels = c("Pathway A", "Pathway B")) + +logFCcut <- 1.5; pvalCut <- 0.05 +logFCcut2 <- 2.5; pvalCut2 <- 1e-4 +logFCcut3 <- 5; pvalCut3 <- 1e-5 +pathcol <- c("Pathway A" = "darkgreen", "Pathway B" = "chocolate4", "Pathway C" = "blueviolet") + +v2$y <- -log10(v2$adjP) +v2$tier <- 1 +v2$tier[abs(v2$logFC) > logFCcut & v2$adjP < pvalCut] <- 2 +v2$tier[abs(v2$logFC) > logFCcut2 & v2$adjP < pvalCut2] <- 3 +v2$tier[abs(v2$logFC) > logFCcut3 & v2$adjP < pvalCut3] <- 4 +v2$col <- "grey75" +v2$col[v2$tier == 2] <- "grey45" +v2$col[v2$tier == 3 & v2$logFC > 0] <- "#F49A9A" +v2$col[v2$tier == 3 & v2$logFC < 0] <- "#8FB2E0" +v2$col[v2$tier == 4 & v2$logFC > 0] <- "#D93F3C" +v2$col[v2$tier == 4 & v2$logFC < 0] <- "#184A8C" +v2$col[sel] <- pathcol[v2$pathway[sel]] +v2$size <- c(1, 1.6, 2.2, 3)[v2$tier] +lab_df <- selected +lab_df$y <- -log10(lab_df$adjP) + +ggplot(v2, aes(logFC, y)) + + geom_point(colour = v2$col, size = v2$size, alpha = 0.9) + + geom_vline(xintercept = c(-logFCcut, logFCcut), linetype = "dashed", colour = "grey40") + + geom_hline(yintercept = -log10(pvalCut), linetype = "dashed", colour = "grey40") + + geom_point(data = lab_df, aes(logFC, y), shape = 21, colour = "black", + size = 3.4, fill = NA, stroke = 0.8, inherit.aes = FALSE) + + geom_label_repel(data = lab_df, aes(label = gsym, colour = pathway), + size = 3.2, fontface = "bold", box.padding = 0.5, + show.legend = FALSE, max.overlaps = 20) + + scale_colour_manual(values = pathcol, name = "Selected pathway") + + labs(x = "log2 fold change", y = "-log10 adjusted P", + title = "Tiered volcano: thresholds at 1.5/2.5/5 and 0.05/1e-4/1e-5") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**Practice tips** + +- Write the tier assignment as an **explicit ordered table** (`tier <- 1; tier[gate2] <- 2; ...`) — one gate per line is auditable; a chain of `ifelse()` over four thresholds is not. +- Validation picks get *three* encodings (pathway colour, black circle, label) — the circle is what survives when the label is repelled away, so keep both. +- Say the gates in the caption exactly as coded; "more significant" invites readers to invent thresholds you did not use. +::: + +## Reference## Reference \[1\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + +\[3\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/VolcanoPlot.zh.qmd b/Omics/VolcanoPlot.zh.qmd index 92f7b4240..f053ce86c 100644 --- a/Omics/VolcanoPlot.zh.qmd +++ b/Omics/VolcanoPlot.zh.qmd @@ -273,6 +273,145 @@ ggdraw(combined) - `insert_xaxis_grob()` / `insert_yaxis_grob()` 来自 cowplot,且保持主面板尺寸;等价做法是 `patchwork::plot_layout` 配合 `design`——两者都需要对齐坐标范围。 ::: -## 参考文献 +### 4. 小效应量筛选的尺寸编码火山图(PDUI 风格) + +可变多聚腺苷化筛选(FigureYa321 背后的 TC3A PDUI 分析 \[1\])产生的**效应量很小**——有意义的 3'UTR 使用偏移是 ΔPDUI ≈ 0.1 而不是 1——常规的 |log2FC| ≥ 1 阈值完全不起作用。参考编码方式:y = −log10 校正 P,x = ΔPDUI(放宽到 ±0.05 阈值),**点大小 = |ΔPDUI × −log10 P|**,让效应与显著性共同决定视觉权重。下块在与参考一致的 `limma` 流程上运行模拟 PDUI 矩阵: + +```{r} +#| label: fig-4.1PduiVolcano +#| fig-cap: "模拟 3'UTR 使用(PDUI)事件的尺寸编码火山图:颜色 = 方向阈值(|ΔPDUI| > 0.05 且校正 P < 0.1),点大小 = |ΔPDUI × -log10 P|;两侧最强的偏移事件带标签。" +#| out.width: "75%" +#| warning: false +#| message: false +#| fig-width: 6.8 +#| fig-height: 5.6 + +set.seed(3211) +n_ev <- 400; n_s <- 60 +PDUI <- matrix(runif(n_ev * n_s, 0.2, 0.8), n_ev, n_s) +rownames(PDUI) <- paste0("chr", sample(1:22, n_ev, replace = TRUE), "_", + sample(1:9, n_ev, replace = TRUE), "|EV", 1:n_ev, "|") +grp <- factor(rep(c("LIVING", "DEAD"), each = n_s / 2), levels = c("LIVING", "DEAD")) +hit <- sample(n_ev, 18) +PDUI[hit[1:9], grp == "DEAD"] <- pmin(1, PDUI[hit[1:9], grp == "DEAD"] + 0.2) # 3'UTR 缩短 +PDUI[hit[10:18], grp == "DEAD"] <- pmax(0, PDUI[hit[10:18], grp == "DEAD"] - 0.2) + +design <- model.matrix(~0 + grp); colnames(design) <- levels(grp) +fit <- limma::lmFit(PDUI, design) +fit2 <- limma::contrasts.fit(fit, limma::makeContrasts(DEAD - LIVING, levels = design)) +fit2 <- limma::eBayes(fit2) +DEGs <- limma::topTable(fit2, coef = 1, n = Inf) +DEGs$SYMBOL <- gsub(".+\\|(EV[0-9]+)\\|.*", "\\1", rownames(DEGs)) + +plot.data <- DEGs +plot.data$logPadj <- -log(plot.data$adj.P.Val) +plotgene <- rownames(plot.data)[c(which.max(plot.data$logFC), which.min(plot.data$logFC))] +plot.data$label <- ifelse(rownames(plot.data) %in% plotgene, plot.data$SYMBOL, NA) +plot.data$status <- "NoSig" +plot.data$status[plot.data$logFC < -0.05 & plot.data$logPadj > 1] <- "Down" +plot.data$status[plot.data$logFC > 0.05 & plot.data$logPadj > 1] <- "Up" +plot.data$status <- factor(plot.data$status, levels = c("Up", "Down", "NoSig")) +plot.data$size_v <- abs(plot.data$logFC * plot.data$logPadj) +palette_volcano <- c(Up = "#D93F3C", Down = "#184A8C", NoSig = "#B3B3B3") + +ggplot(plot.data, aes(logFC, logPadj, color = status)) + + geom_point(alpha = 0.9, aes(size = size_v)) + + scale_size_continuous(range = c(1, 7), guide = "none") + + scale_color_manual(values = palette_volcano, drop = FALSE, name = NULL) + + geom_label_repel(data = subset(plot.data, !is.na(label)), + aes(label = label), size = 3.4, fontface = "bold", + box.padding = 0.5, show.legend = FALSE) + + geom_point(data = subset(plot.data, !is.na(label)), shape = 1, + stroke = 0.6, color = "black", size = 2.6) + + geom_vline(xintercept = c(-0.05, 0.05), colour = "grey40", linetype = "longdash", lwd = 0.25) + + geom_hline(yintercept = 1, colour = "grey40", linetype = "longdash", lwd = 0.25) + + labs(x = "delta PDUI (DEAD - LIVING)", y = "-log10 adjusted P", + title = "3'UTR usage shift by vital status (simulated TC3A-style PDUI)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- 效应量小时,尺寸通道承担主要信息:`|效应 × -log10(P)|` 随证据二次增长,能把双重强的事件从拥挤的中心拉出来——请在图注中说明,否则读者会以为 size 是第三个变量。 +- 阈值必须匹配量表尺度:ΔPDUI 的阈值在 ±0.05(使用比例取值 [0, 1]);照抄转录组火山图的 ±1 阈值会把图清空。 +- 两个带标签的事件作为阅读锚点——每个方向一个——其余交给颜色。 +::: + +### 5. 分层"酷炫"火山图(FigureYa59volcanoV2) + +当筛选结果要交给下游功能验证时,参考文档的高级火山图 \[1\] 一次编码**三个显著性层级**:点色随嵌套门槛加深(|logFC| > 1.5 且 P < 0.05 → > 2.5 且 P < 1e-4 → > 5 且 P < 1e-5),点大小随层级增大,选去做功能验证的基因按通路重新着色、加黑圈并打标签。门槛由数据驱动,图在大动态范围下无需轴截断: + +```{r} +#| label: fig-5.1TieredVolcano +#| fig-cap: "900 个模拟事件的分层火山图:|logFC| = 1.5/2.5/5 与校正 P = 0.05/1e-4/1e-5 的嵌套门槛决定颜色深浅与点大小;按通路着色、黑圈、带标签的点为验证候选。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 6.2 + +set.seed(5901) +n_v2 <- 900 +v2 <- data.frame( + gsym = paste0("G", 1:n_v2), + logFC = rnorm(n_v2, 0, 1.4), + adjP = 10^(-rexp(n_v2, 0.9))) +v2$adjP <- pmin(1, v2$adjP) +sel <- sample(n_v2, 10) +v2$adjP[sel[1:6]] <- 10^(-runif(6, 5, 12)); v2$logFC[sel[1:4]] <- rnorm(4, 4.5, 0.7) +v2$adjP[sel[7:10]] <- 10^(-runif(4, 5, 10)); v2$logFC[sel[7:10]] <- rnorm(4, -4.5, 0.7) +v2$pathway <- sample(c("Pathway A", "Pathway B", "Pathway C"), n_v2, TRUE, + prob = c(0.05, 0.05, 0.9)) +v2$pathway[sel] <- rep(c("Pathway A", "Pathway B"), c(6, 4)) +selected <- v2[sel, ] +selected$pathway <- factor(selected$pathway, levels = c("Pathway A", "Pathway B")) + +logFCcut <- 1.5; pvalCut <- 0.05 +logFCcut2 <- 2.5; pvalCut2 <- 1e-4 +logFCcut3 <- 5; pvalCut3 <- 1e-5 +pathcol <- c("Pathway A" = "darkgreen", "Pathway B" = "chocolate4", "Pathway C" = "blueviolet") + +v2$y <- -log10(v2$adjP) +v2$tier <- 1 +v2$tier[abs(v2$logFC) > logFCcut & v2$adjP < pvalCut] <- 2 +v2$tier[abs(v2$logFC) > logFCcut2 & v2$adjP < pvalCut2] <- 3 +v2$tier[abs(v2$logFC) > logFCcut3 & v2$adjP < pvalCut3] <- 4 +v2$col <- "grey75" +v2$col[v2$tier == 2] <- "grey45" +v2$col[v2$tier == 3 & v2$logFC > 0] <- "#F49A9A" +v2$col[v2$tier == 3 & v2$logFC < 0] <- "#8FB2E0" +v2$col[v2$tier == 4 & v2$logFC > 0] <- "#D93F3C" +v2$col[v2$tier == 4 & v2$logFC < 0] <- "#184A8C" +v2$col[sel] <- pathcol[v2$pathway[sel]] +v2$size <- c(1, 1.6, 2.2, 3)[v2$tier] +lab_df <- selected +lab_df$y <- -log10(lab_df$adjP) + +ggplot(v2, aes(logFC, y)) + + geom_point(colour = v2$col, size = v2$size, alpha = 0.9) + + geom_vline(xintercept = c(-logFCcut, logFCcut), linetype = "dashed", colour = "grey40") + + geom_hline(yintercept = -log10(pvalCut), linetype = "dashed", colour = "grey40") + + geom_point(data = lab_df, aes(logFC, y), shape = 21, colour = "black", + size = 3.4, fill = NA, stroke = 0.8, inherit.aes = FALSE) + + geom_label_repel(data = lab_df, aes(label = gsym, colour = pathway), + size = 3.2, fontface = "bold", box.padding = 0.5, + show.legend = FALSE, max.overlaps = 20) + + scale_colour_manual(values = pathcol, name = "Selected pathway") + + labs(x = "log2 fold change", y = "-log10 adjusted P", + title = "Tiered volcano: thresholds at 1.5/2.5/5 and 0.05/1e-4/1e-5") + + theme_bw(base_size = 11) + theme(panel.grid = element_blank()) +``` + +::: callout-tip +**实践要点** + +- 分层赋值写成**显式有序表**(`tier <- 1; tier[gate2] <- 2; ...`)——每行一个门槛可审计;四重阈值的 `ifelse()` 链不可审计。 +- 验证候选带*三重*编码(通路色、黑圈、标签)——标签被 repel 推走时黑圈仍会存活,两者都要保留。 +- 在图注中逐字写出门槛;"更显著"会诱导读者发明你没有用过的阈值。 +::: + +## 参考文献## 参考文献 \[1\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Omics/iVolcanoPlot.qmd b/Omics/iVolcanoPlot.qmd index cef46b1ad..eecd1dfda 100644 --- a/Omics/iVolcanoPlot.qmd +++ b/Omics/iVolcanoPlot.qmd @@ -328,7 +328,15 @@ Figure 8 demonstrates the linkage effect between the pathway dot plot and the vo - `pathway_volcano`: Combines the two plots; the `widths` parameter adjusts the relative widths of the left and right plots. ::: -## Application Scenarios +### 4. The FigureYa59Plus Shiny Volcano App + +FigureYa59Plus ships the same volcano as a **standalone Shiny application** (`app.R` in ): upload a limma/DESeq2 result table, tune the logFC and P gates interactively, colour pathway-selected genes, hover for gene cards and export the figure — a `DT` table underneath mirrors every highlighted gene. It is meant for exploration and teaching; for a *publication* figure, run the static pipeline of §5 above, whose tiered gates match the app's defaults: + +::: callout-note +**Run it locally.** `shiny::runGitHub("ying-ge/FigureYa", subdir = "FigureYa59Plus_volcano_shiny")` — or clone the folder and `shiny::runApp()`. Inputs: `easy_input_limma.csv` (gene, logFC, P / adj.P) and `easy_input_selected.csv` (gene + optional pathway); both columns follow §5's tiered-volcano conventions, so results transfer 1:1 between the app and the static plot. +::: + +## Application Scenarios## Application Scenarios ::: {#fig-iVolcanoApplications} ![](../images/Omics/iVolcanoPlot_fig8.png){fig-alt="Pathway and volcano plot linkage application" fig-align="center" width="60%"} @@ -342,3 +350,7 @@ Figure 9 demonstrates the application of the `pathway_volcano` linkage function 1. Guangchuang Yu, et al. (2024). ivolcano: Interactive Volcano Plots. R package version 0.99.0. 2. [ivolcano FigureYa wechat post](https://mp.weixin.qq.com/s/x24vW4cCLLDWulgkZ2F8Sw) + +3. Xiaofan Lu, et al. FigureYa59Plus_volcano_shiny: interactive volcano Shiny application. FigureYa documentation. 2025. + +4. Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Omics/iVolcanoPlot.zh.qmd b/Omics/iVolcanoPlot.zh.qmd index 7856c2856..8291b12a9 100644 --- a/Omics/iVolcanoPlot.zh.qmd +++ b/Omics/iVolcanoPlot.zh.qmd @@ -326,7 +326,15 @@ Figure 8 展示了通路点图与火山图的联动效果。点击左侧通路 - `pathway_volcano`:将两幅图组合,`widths` 参数可调整左右两图的相对宽度。 ::: -## 应用场景 +### 4. FigureYa59Plus 交互式火山图 Shiny 应用 + +FigureYa59Plus 把同一张火山图做成了**独立 Shiny 应用**( 中的 `app.R`):上传 limma/DESeq2 结果表,交互调节 logFC 与 P 阈值、按通路给选中基因着色、悬停查看基因卡片并导出图片——下方的 `DT` 表格镜像每个高亮基因。它面向探索与教学;*发表*图请用上文 §5 的静态流程,其分层阈值与应用默认一致: + +::: callout-note +**本地运行。** `shiny::runGitHub("ying-ge/FigureYa", subdir = "FigureYa59Plus_volcano_shiny")`——或克隆该目录后 `shiny::runApp()`。输入:`easy_input_limma.csv`(gene、logFC、P / adj.P)与 `easy_input_selected.csv`(基因 + 可选通路);两列约定与 §5 分层火山一致,结果可在应用与静态图之间 1:1 迁移。 +::: + +## 应用场景## 应用场景 ::: {#fig-iVolcanoApplications} ![](../images/Omics/iVolcanoPlot_fig8.png){fig-alt="通路与火山图联动应用" fig-align="center" width="60%"} @@ -340,3 +348,7 @@ Figure 9 展示了 `pathway_volcano` 联动功能在多组学整合分析中的 1. Guangchuang Yu, et al. (2024). ivolcano: Interactive Volcano Plots. R package version 0.99.0. 2. [ivolcano的FigureYa主题](https://mp.weixin.qq.com/s/x24vW4cCLLDWulgkZ2F8Sw) + +3. Xiaofan Lu, et al. FigureYa59Plus_volcano_shiny: interactive volcano Shiny application. FigureYa documentation. 2025. + +4. Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 \ No newline at end of file diff --git a/Proportion/ChordDiagram.qmd b/Proportion/ChordDiagram.qmd index e4b649ca2..bd69c49a5 100644 --- a/Proportion/ChordDiagram.qmd +++ b/Proportion/ChordDiagram.qmd @@ -694,7 +694,7 @@ stopifnot(nrow(links) >= 250 && all(links$source_type %in% c("src_up", "src_dn") # geometry: sources share one vertical rail at x = 0; each pathway becomes a circle src_df <- data.frame(src = sources, src_type = src_type, x = 0, y = seq_along(sources) * 1.2, stringsAsFactors = FALSE) -cen_y <- c(9, 6, 3, 6.5, 1.5) # stagger circle rows on the right +cen_y <- c(10.5, 8.2, 5.9, 3.6, 1.3) # staggered rows, centre gaps > 2r so circles never overlap path_df <- data.frame(path = paths, cx = 4.2, cy = cen_y, r = 1.05, stringsAsFactors = FALSE) tgt_xy <- lapply(seq_along(targets), function(i) { @@ -718,7 +718,7 @@ circle <- function(x0, y0, r, col) { for (k in seq_along(paths)) { circle(path_df$cx[k], path_df$cy[k], path_df$r[k], "grey25") cnt <- sum(tgt_df$path == paths[k]) - text(path_df$cx[k], path_df$cy[k] + path_df$r[k] + 0.34, paths[k], cex = 0.82, col = "grey25") + text(path_df$cx[k] + path_df$r[k] + 0.28, path_df$cy[k], paths[k], cex = 0.82, col = "grey25") text(path_df$cx[k], path_df$cy[k], cnt, cex = 0.9, col = "grey45") } # links coloured by source class, half transparent so the web stays readable @@ -740,7 +740,86 @@ points(tgt_df$x, tgt_df$y, pch = 16, cex = 1.0, col = colmap[tgt_df$type]) - Draw order is part of the design: rings first, links half transparent, nodes last - each layer stays readable because it occludes only what sits beneath it. - Printing the member count at each ring centre turns the figure into a density map of the target set, not just a tangle of lines. -- With real data the coordinates would come from layout algorithms (`igraph::layout.on.circle`, `qgraph`); the drawing code stays byte-identical. +- With real data the coordinates would come from layout algorithms (`igraph::layout_in_circle`, `qgraph`); the drawing code stays byte-identical. +::: + +### 5. Circular Score Comparison with a Highlighted Case (circlize) + +The TIP-server figure behind FigureYa313 compares one patient's immunophenotype scores with a whole cohort **as two concentric rings**: each sample is a point whose angle encodes the score and whose ring encodes the group, a radial line marks each group's median, and a red pointer highlights the case of interest \[7\]. `circlize` draws it with a spare sector trick — the sector spans the value range plus 5% padding so the axis closes just short of a full circle: + +```{r} +#| label: fig-5.1CircularScores +#| fig-cap: "Two-ring score comparison (circlize): outer ring = 800 simulated tumour samples, inner ring = 120 normal samples, grey radial lines = group medians, red pointer = the index patient's score of 20." +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 7.8 + +set.seed(3131) +n_tumor <- 800; n_normal <- 120 +scores <- data.frame( + Group = c(rep("Tumor", n_tumor), rep("Normal", n_normal)), + Value = c(rnorm(n_tumor, 38, 11), rnorm(n_normal, 30, 10))) +scores$Value <- pmin(pmax(scores$Value, 0), 70) +patient_score <- 20 + +prop <- 0.05; mark <- patient_score +plot.region <- c(min(scores$Value), max(scores$Value)) +plot.region <- rbind(plot.region, (plot.region - min(plot.region)) * prop) +plot.data <- split(scores[, c("Group", "Value"), drop = FALSE], scores$Group) +deg.adjust <- 360 * 0.5 * prop +circos.par("start.degree" = 360 - deg.adjust, track.margin = c(0.01, 0.01)) +circos.initialize(sectors = c("main", "spare"), xlim = plot.region) + +## outer ring: tumour samples +draw.sector(deg.adjust, 360 - deg.adjust, rou1 = 0.99, rou2 = 0.79, + clock.wise = FALSE, col = "#FF000080", border = NA) +tumor <- plot.data[["Tumor"]] +circos.track(sectors = rep("main", nrow(tumor)), x = tumor$Value, + y = runif(nrow(tumor)), panel.fun = function(x, y) { + circos.points(x, y, col = "deepskyblue3", bg = "deepskyblue", + pch = 21, cex = 0.7) + }, ylim = c(0, 1), bg.border = NA) +circos.lines(rep(median(tumor$Value), 2), c(0, 1), + sector.index = "main", track.index = 1, col = "#618895", lwd = 2) + +## inner ring: normal samples +draw.sector(deg.adjust, 360 - deg.adjust, rou1 = 0.77, rou2 = 0.57, + clock.wise = FALSE, col = "#B1CFC3", border = NA) +normal <- plot.data[["Normal"]] +circos.track(sectors = rep("main", nrow(normal)), x = normal$Value, + y = runif(nrow(normal)), panel.fun = function(x, y) { + circos.points(x, y, col = "firebrick3", bg = "firebrick1", + pch = 21, cex = 0.9) + }, ylim = c(0, 1), bg.border = NA) +circos.lines(rep(median(normal$Value), 2), c(0, 1), + sector.index = "main", track.index = 2, col = "#618895", lwd = 2) + +circos.xaxis(sector.index = "main", track.index = 1, h = "top", + labels.facing = "clockwise") + +## the index patient's pointer line +deg.mark.cx <- get.cell.meta.data(name = "cell.xlim", sector.index = "main") +deg.range <- get.cell.meta.data(name = "xplot", sector.index = "main") +deg.mark <- deg.range[1] + (mark - deg.mark.cx[1]) * diff(deg.range) / diff(deg.mark.cx) +draw.sector(deg.mark, deg.mark, rou1 = 1, rou2 = 0, border = "#FF000080", lwd = 2) +text(x = 0, y = 0, sprintf("Patient: %.0f", mark), cex = 0.9) +legend("topright", inset = c(0.005, 0.02), bty = "n", cex = 0.82, xpd = NA, + legend = c("Tumour (n = 800)", "Normal (n = 120)", + "Group median", "This patient"), + pch = c(21, 21, NA, NA), lty = c(NA, NA, 1, 1), lwd = c(NA, NA, 2, 2), + col = c("deepskyblue3", "firebrick3", "#618895", "#FF000080"), + pt.bg = c("deepskyblue", "firebrick1", NA, NA)) +circos.clear() +``` + +::: callout-tip +**Practice tips** + +- The `y` aesthetic inside `circos.track()` only jitters points within the ring band — use it to avoid overplotting, never to encode a second variable (the radial position would look meaningful). +- `circos.clear()` is mandatory before any later base-graphics call on the page; a stale circos layout silently consumes the next plot's margins. +- The pointer is the whole point of the figure: pick the value in data units and convert to degrees through `get.cell.meta.data("cell.xlim")` / `"xplot"`, exactly as above. ::: ## Applications @@ -799,6 +878,8 @@ Modular structure of the potential hippocampal connectome. A, Chord diagram of p \[6\] Wickham, H. (2021). readxl: Read Excel Files. https://cran.r-project.org/package=readxl +\[7\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 + \[7\] Wickham, H. (2021). dplyr: A Grammar of Data Manipulation. https://cran.r-project.org/package=dplyr \[8\] Csardi, G., & Nepusz, T. (2006). igraph: Complex network analysis. https://cran.r-project.org/package=igraph diff --git a/Proportion/ChordDiagram.zh.qmd b/Proportion/ChordDiagram.zh.qmd index ce85b9fb5..3254abcb4 100644 --- a/Proportion/ChordDiagram.zh.qmd +++ b/Proportion/ChordDiagram.zh.qmd @@ -695,7 +695,7 @@ stopifnot(nrow(links) >= 250 && all(links$source_type %in% c("src_up", "src_dn") # geometry: sources share one vertical rail at x = 0; each pathway becomes a circle src_df <- data.frame(src = sources, src_type = src_type, x = 0, y = seq_along(sources) * 1.2, stringsAsFactors = FALSE) -cen_y <- c(9, 6, 3, 6.5, 1.5) # stagger circle rows on the right +cen_y <- c(10.5, 8.2, 5.9, 3.6, 1.3) # staggered rows, centre gaps > 2r so circles never overlap path_df <- data.frame(path = paths, cx = 4.2, cy = cen_y, r = 1.05, stringsAsFactors = FALSE) tgt_xy <- lapply(seq_along(targets), function(i) { @@ -719,7 +719,7 @@ circle <- function(x0, y0, r, col) { for (k in seq_along(paths)) { circle(path_df$cx[k], path_df$cy[k], path_df$r[k], "grey25") cnt <- sum(tgt_df$path == paths[k]) - text(path_df$cx[k], path_df$cy[k] + path_df$r[k] + 0.34, paths[k], cex = 0.82, col = "grey25") + text(path_df$cx[k] + path_df$r[k] + 0.28, path_df$cy[k], paths[k], cex = 0.82, col = "grey25") text(path_df$cx[k], path_df$cy[k], cnt, cex = 0.9, col = "grey45") } # links coloured by source class, half transparent so the web stays readable @@ -741,7 +741,86 @@ points(tgt_df$x, tgt_df$y, pch = 16, cex = 1.0, col = colmap[tgt_df$type]) - 绘制顺序即设计的一部分:先圆环,再半透明连线,最后节点——每层可读,因为它只遮挡自己之下的内容。 - 环心打印成员数,把图从一团线升级成靶集合的密度地图。 -- 真实数据下坐标可交给布局算法(`igraph::layout.on.circle`、`qgraph`);绘图代码可逐字节不动。 +- 真实数据下坐标可交给布局算法(`igraph::layout_in_circle`、`qgraph`);绘图代码可逐字节不动。 +::: + +### 5. 圆环评分对比 + 突出病例(circlize) + +FigureYa313 背后的 TIP 服务器图把一位患者的免疫表型评分与整个队列放在**两个同心环**上比较:每个样本是一个点,角度编码评分、所在环编码分组,径向线标记各组中位数,红色指针突出目标病例 \[11\]。`circlize` 用"备胎扇区"技巧实现——扇区跨度 = 值域 + 5% padding,坐标轴在差一点满圆处收口: + +```{r} +#| label: fig-5.1CircularScores +#| fig-cap: "双环评分对比(circlize):外环 800 个模拟肿瘤样本、内环 120 个正常样本,灰色径向线 = 组中位数,红色指针 = 目标患者评分 20。" +#| out.width: "80%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 7.8 + +set.seed(3131) +n_tumor <- 800; n_normal <- 120 +scores <- data.frame( + Group = c(rep("Tumor", n_tumor), rep("Normal", n_normal)), + Value = c(rnorm(n_tumor, 38, 11), rnorm(n_normal, 30, 10))) +scores$Value <- pmin(pmax(scores$Value, 0), 70) +patient_score <- 20 + +prop <- 0.05; mark <- patient_score +plot.region <- c(min(scores$Value), max(scores$Value)) +plot.region <- rbind(plot.region, (plot.region - min(plot.region)) * prop) +plot.data <- split(scores[, c("Group", "Value"), drop = FALSE], scores$Group) +deg.adjust <- 360 * 0.5 * prop +circos.par("start.degree" = 360 - deg.adjust, track.margin = c(0.01, 0.01)) +circos.initialize(sectors = c("main", "spare"), xlim = plot.region) + +## 外环:肿瘤样本 +draw.sector(deg.adjust, 360 - deg.adjust, rou1 = 0.99, rou2 = 0.79, + clock.wise = FALSE, col = "#FF000080", border = NA) +tumor <- plot.data[["Tumor"]] +circos.track(sectors = rep("main", nrow(tumor)), x = tumor$Value, + y = runif(nrow(tumor)), panel.fun = function(x, y) { + circos.points(x, y, col = "deepskyblue3", bg = "deepskyblue", + pch = 21, cex = 0.7) + }, ylim = c(0, 1), bg.border = NA) +circos.lines(rep(median(tumor$Value), 2), c(0, 1), + sector.index = "main", track.index = 1, col = "#618895", lwd = 2) + +## 内环:正常样本 +draw.sector(deg.adjust, 360 - deg.adjust, rou1 = 0.77, rou2 = 0.57, + clock.wise = FALSE, col = "#B1CFC3", border = NA) +normal <- plot.data[["Normal"]] +circos.track(sectors = rep("main", nrow(normal)), x = normal$Value, + y = runif(nrow(normal)), panel.fun = function(x, y) { + circos.points(x, y, col = "firebrick3", bg = "firebrick1", + pch = 21, cex = 0.9) + }, ylim = c(0, 1), bg.border = NA) +circos.lines(rep(median(normal$Value), 2), c(0, 1), + sector.index = "main", track.index = 2, col = "#618895", lwd = 2) + +circos.xaxis(sector.index = "main", track.index = 1, h = "top", + labels.facing = "clockwise") + +## 目标患者指针线 +deg.mark.cx <- get.cell.meta.data(name = "cell.xlim", sector.index = "main") +deg.range <- get.cell.meta.data(name = "xplot", sector.index = "main") +deg.mark <- deg.range[1] + (mark - deg.mark.cx[1]) * diff(deg.range) / diff(deg.mark.cx) +draw.sector(deg.mark, deg.mark, rou1 = 1, rou2 = 0, border = "#FF000080", lwd = 2) +text(x = 0, y = 0, sprintf("Patient: %.0f", mark), cex = 0.9) +legend("topright", inset = c(0.005, 0.02), bty = "n", cex = 0.82, xpd = NA, + legend = c("Tumour (n = 800)", "Normal (n = 120)", + "Group median", "This patient"), + pch = c(21, 21, NA, NA), lty = c(NA, NA, 1, 1), lwd = c(NA, NA, 2, 2), + col = c("deepskyblue3", "firebrick3", "#618895", "#FF000080"), + pt.bg = c("deepskyblue", "firebrick1", NA, NA)) +circos.clear() +``` + +::: callout-tip +**实践要点** + +- `circos.track()` 内部的 `y` 只用于在环带内抖动点位防重叠——不要用它编码第二个变量(径向位置会被读者当成有含义)。 +- 本页后续若有 base 图形,`circos.clear()` 必须调用;残留的 circos 布局会静默吃掉下一张图的边距。 +- 指针线是整张图的点睛之笔:在数据单位下取值,再经 `get.cell.meta.data("cell.xlim")` / `"xplot"` 换算成角度,如上所示。 ::: ## 应用场景 @@ -800,6 +879,7 @@ CK1tau和 CK1 过表达时磷酸化位点差异之间的重叠。弦图显示了 \[6\] Wickham, H. (2021). readxl: Read Excel Files. https://cran.r-project.org/package=readxl + \[7\] Wickham, H. (2021). dplyr: A Grammar of Data Manipulation. https://cran.r-project.org/package=dplyr \[8\] Csardi, G., & Nepusz, T. (2006). igraph: Complex network analysis. https://cran.r-project.org/package=igraph diff --git a/Ranking/BarPlot.qmd b/Ranking/BarPlot.qmd index f821b2f2b..ca10dd3d7 100644 --- a/Ranking/BarPlot.qmd +++ b/Ranking/BarPlot.qmd @@ -553,11 +553,11 @@ p ### 8. Multi-Group Bar Chart with Subgroup Gradient -The reference figure encodes **three levels of grouping**: major groups (colours), subgroups within each group (gradient shades), and error bars (mean ± SE) \[7\]. The gradient effect is achieved by assigning lighter shades to subgroup levels within each major-group colour. +The reference figure encodes **three levels of grouping**: major groups (colours), subgroups within each group (gradient shades), and error bars (mean ± SE) \[13\]. The gradient effect is achieved by assigning lighter shades to subgroup levels within each major-group colour. ```{r} #| label: fig-8.1SubgroupGradient -#| fig-cap: "Multi-group bar chart with subgroup gradient fills, error bars (mean ± SE) and intra-group comparison brackets." +#| fig-cap: "Multi-group bar chart with subgroup gradient fills and error bars (mean ± SE)." #| out.width: "85%" #| warning: false #| message: false @@ -604,11 +604,301 @@ ggplot(summ_b, aes(subgroup, mean, fill = subgroup)) + ::: callout-tip **Practice tips** -- The gradient shading uses `col2rgb()` + `rgb()` to lighten the base colour per subgroup index — this ties each subgroup visually to its major-group colour. +- The gradient shades are derived per subgroup index from the major-group base colour (here hardcoded as explicit hex values; derive your own with `colorRampPalette(c(light, base))(n)` when subgroups are many) — this ties each subgroup visually to its major-group colour. - The `se = sd / sqrt(n)` error bar is the standard for mean comparison; some journals require `sd` instead — check the author guidelines. - For intra-group comparison brackets, add `ggsignif::geom_signif(comparisons = list(c("A1", "A2")))` on top of the bars. ::: +### 9. Cell-Type Proportion Bars with a Cluster-wise Fisher Post-hoc Test + +Single-cell studies routinely summarize composition as the fraction of cells per cluster in each condition. The reference workflow \[13\] draws the stacked proportion bars, tests the whole cluster × condition table with Fisher's exact test, and then asks *which* cluster drives the difference with a one-vs-rest post-hoc: `rstatix::row_wise_fisher_test()` runs one Fisher test per cluster (that cluster vs all others) and BH-adjusts the family of eight p-values. + +```{r} +#| label: fig-9.1CellPropSig +#| fig-cap: "Cell-type composition per cluster (WT vs KO, simulated). Stars are BH-adjusted one-vs-rest Fisher tests per cluster; the overall Fisher exact test on the full table gives p < 0.0001 (Monte-Carlo, B = 10^5)." +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 5.5 + +set.seed(2900) +clusters <- paste0("C", 1:8) +p0 <- c(0.18, 0.16, 0.14, 0.12, 0.11, 0.10, 0.10, 0.09) +# KO proportions: unaffected clusters keep p0 exactly; only C2/C6/C8 are reallocated +p_ko <- p0 +p_ko[2] <- 0.05; p_ko[6] <- 0.22; p_ko[8] <- 0.08 +stopifnot(abs(sum(p_ko) - 1) < 1e-12) +n_wt <- 900; n_ko <- 900 +mk_cells <- function(n, p, grp) { + data.frame(cluster = sample(clusters, n, replace = TRUE, prob = p), + group = grp, + run = sample(c("R1", "R2"), n, replace = TRUE)) +} +cellinfo <- rbind(mk_cells(n_wt, p0, "WT"), mk_cells(n_ko, p_ko, "KO")) +cellinfo$cluster <- factor(cellinfo$cluster, levels = clusters) + +tbl <- table(cellinfo$cluster, cellinfo$group) +ft <- fisher.test(tbl, simulate.p.value = TRUE, B = 1e5) +post <- rstatix::row_wise_fisher_test(tbl) + +cell.col <- c(WT = "#1A63A8", KO = "#FC6910") +prop_df <- as.data.frame(tbl, stringsAsFactors = FALSE) +colnames(prop_df) <- c("cluster", "group", "n") +prop_df$cluster <- factor(prop_df$cluster, levels = clusters) +prop_df$group <- factor(prop_df$group, levels = c("WT", "KO")) +sig_df <- as.data.frame(post) +sig_df$cluster <- factor(sig_df$group, levels = clusters) +sig_df$lab <- ifelse(sig_df$p.adj.signif == "ns", "", sig_df$p.adj.signif) + +ggplot(prop_df, aes(cluster, n, fill = group)) + + geom_col(stat = "identity", position = "fill", width = 0.72, + colour = "grey25", linewidth = 0.2) + + geom_text(data = sig_df, aes(x = cluster, y = 1.05, label = lab), + inherit.aes = FALSE, size = 4.4, colour = "grey10") + + scale_fill_manual(values = cell.col, name = NULL) + + scale_y_continuous(breaks = seq(0, 1, 0.25), labels = scales::percent, + expand = expansion(mult = c(0, 0.1))) + + labs(x = "Cluster", y = "Fraction of cells", + title = "Cell-type composition per cluster (KO vs WT)") + + theme_classic(base_size = 12) + + theme(legend.position = "top", plot.title = element_text(size = 11)) +``` + +Faceting by sequencing run (replicate) shows whether the compositional shift is reproducible or an artifact of one library — the layout of the reference figure's first panel \[13\]: + +```{r} +#| label: fig-9.2CellPropRep +#| fig-cap: "The same composition faceted by sequencing replicate: the depletion (C2) and enrichment (C6) are consistent across runs." +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 12 +#| fig-height: 3.8 + +# same cells as the chunk above, now split by sequencing run +ggplot(cellinfo, aes(run, fill = group)) + + geom_bar(position = "fill", width = 0.85, colour = "grey25", linewidth = 0.2) + + facet_wrap(~cluster, nrow = 1) + + scale_fill_manual(values = cell.col, name = NULL) + + scale_y_continuous(breaks = seq(0, 1, 0.5), labels = scales::percent) + + labs(x = "Replicate", y = "Fraction of cells") + + theme_classic(base_size = 11) + + theme(strip.background = element_rect(fill = "grey88", colour = NA), + strip.text = element_text(face = "bold"), + legend.position = "top", + axis.text.x = element_text(angle = 45, hjust = 1)) +``` + +::: callout-tip +**Practice tips** + +- `row_wise_fisher_test()` expects the contingency table with categories as rows and groups as columns; its `group` column holds the row names, and `p.adj`/`p.adj.signif` carry the BH-adjusted result — plot the stars from `p.adj.signif`, not raw p-values. +- With large N, `fisher.test(..., simulate.p.value = TRUE)` cannot return a p-value smaller than its Monte-Carlo floor `1/(B + 1)`; report such results as `p < 1/(B+1)` (here `p < 0.0001` for B = 10^5) instead of quoting the floor itself. +- Keep the two condition sizes balanced: with unequal group totals, every unaffected cluster picks up a small systematic shift that the per-cluster tests can flag as significant. +::: + +### 10. Gradient-Filled Bars (ggpattern) + +Presentation-grade bars sometimes carry an "office" gradient fill instead of a flat colour — the reference figure \[13\] uses a two-tone gradient per segment. `ggpattern::geom_col_pattern()` draws it with `pattern = "gradient"` and the two endpoint colours `pattern_fill` / `pattern_fill2`; `pattern_orientation = "radial"` radiates from the segment centre: + +```{r} +#| label: fig-10.1RadialGradient +#| fig-cap: "Radial-gradient bars: the dark metastatic fraction carries white percentage labels; values are simulated prevalence data." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(2970) +df_d <- data.frame( + Country = c("Japan", "USA", "England", "S. Korea", "China", "France", "Germany", "Australia"), + Metastatic = c(19, 24, 28, 33, 36, 31, 22, 27), + Localized = c(81, 76, 72, 67, 64, 69, 78, 73)) +df_d$ID <- seq_len(nrow(df_d)) +maxID <- nrow(df_d) + +plot.df.all <- reshape2::melt(df_d, id.var = c("Country", "ID"), + value.name = "Percentage", variable.name = "Type") +plot.df <- subset(plot.df.all, Type %in% c("Metastatic", "Localized")) +plot.df1 <- subset(plot.df, Type == "Metastatic") +type.color.1 <- c('#dbeffc', '#7bb8e5') # light segment (Localized) +type.color.2 <- c('#a7d7f3', '#0079bb') # dark segment (Metastatic) +barwidth <- 0.44 + +ggplot() + + geom_col_pattern(data = plot.df, mapping = aes(ID, Percentage), + width = barwidth, position = "stack", + pattern = 'gradient', pattern_orientation = "radial", + pattern_fill = type.color.1[1], pattern_fill2 = type.color.1[2], + fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID, Percentage), + width = barwidth, + pattern = 'gradient', pattern_orientation = "radial", + pattern_fill = type.color.2[1], pattern_fill2 = type.color.2[2], + fill = NA) + + geom_text(data = plot.df1, mapping = aes(x = ID, y = Percentage * 0.22, + label = paste0(Percentage, " %")), + size = 2.6, color = "white") + + scale_x_continuous(breaks = seq(1, maxID, 1), + labels = stringr::str_wrap(plot.df1$Country, 9)) + + scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10), expand = c(0, 0)) + + labs(x = NULL, y = "Prevalence (%)") + + theme_bw(base_size = 11) + + theme(panel.grid.major.x = element_blank(), panel.grid.minor = element_blank(), + panel.border = element_blank(), axis.line = element_line(colour = 'black'), + axis.text = element_text(colour = 'black', size = 9)) +``` + +A horizontal gradient needs a trick: ggpattern can only interpolate between two colours along one direction, so the reference draws each bar as left and right halves with mirrored gradients, producing a symmetric light-centre stripe, and adds black borders with `geom_rect()`: + +```{r} +#| label: fig-10.2HorizontalGradient +#| fig-cap: "Horizontal-gradient bars assembled from mirrored left/right halves with black segment borders (ggpattern)." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +barwidth2 <- 0.22 +ggplot() + + geom_col_pattern(data = plot.df, mapping = aes(ID - barwidth2 / 2 + 0.002, Percentage), + width = barwidth2, position = "stack", + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.1[2], pattern_fill2 = type.color.1[1], fill = NA) + + geom_col_pattern(data = plot.df, mapping = aes(ID + barwidth2 / 2 - 0.002, Percentage), + width = barwidth2, position = "stack", + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.1[1], pattern_fill2 = type.color.1[2], fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID - barwidth2 / 2 + 0.002, Percentage), + width = barwidth2, + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.2[2], pattern_fill2 = type.color.2[1], fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID + barwidth2 / 2 - 0.002, Percentage), + width = barwidth2, + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.2[1], pattern_fill2 = type.color.2[2], fill = NA) + + geom_rect(data = plot.df1, + mapping = aes(xmin = ID - barwidth2, xmax = ID + barwidth2, + ymin = 0, ymax = Percentage), + linewidth = 0.3, fill = NA, color = "black") + + geom_rect(data = df_d, + mapping = aes(xmin = ID - barwidth2, xmax = ID + barwidth2, + ymin = Metastatic, ymax = 100), + linewidth = 0.3, fill = NA, color = "black") + + geom_text(data = plot.df1, mapping = aes(x = ID, y = Percentage * 0.22, + label = paste0(Percentage, " %")), + size = 2.6, color = "white") + + scale_x_continuous(breaks = seq(1, maxID, 1), + labels = stringr::str_wrap(plot.df1$Country, 9)) + + scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10), expand = c(0, 0)) + + labs(x = NULL, y = "Prevalence (%)") + + theme_bw(base_size = 11) + + theme(panel.grid.major.x = element_blank(), panel.grid.minor = element_blank(), + panel.border = element_blank(), axis.line = element_line(colour = 'black'), + axis.text = element_text(colour = 'black', size = 9)) +``` + +::: callout-tip +**Practice tips** + +- `pattern_fill`/`pattern_fill2` are the two gradient endpoints only — a three-colour ramp is out of scope; chain `colorRampPalette()` manually for more stops. +- The gradient is pure decoration: it encodes nothing the bar height does not. Prefer flat fills for reviewer-facing figures and keep gradients for slides and covers. +- White labels stay legible on the dark endpoint, not on `pattern_fill2`'s light centre — anchor labels to the darker part or outline the text. +::: + +### 11. Reference-Line Bars and Diverging Gray/Colored Bars + +Two publication layouts from FigureYa39bar \[13\]. The first (NEJM waterfall style) gives **every tumour type its own colour**, draws dashed reference lines at the clinically meaningful values (RECIST boundaries at −30 and +20, plus zero), and — when one bar towers over the rest — clips the y axis with `coord_cartesian()` and prints the true value on the bar: + +```{r} +#| label: fig-11.1ResponseBars +#| fig-cap: "Waterfall of simulated best tumour-response by type: one colour per type, dashed RECIST reference lines at -30/0/+20; the y axis is clipped at 50 and the towering bar carries its true value." +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 5.5 + +set.seed(3901) +df1 <- data.frame(ID = c("NSCLC", "CRC", "Melanoma", "RCC", "HNSCC", "Breast", + "Ovarian", "Prostate", "Pancreas", "HCC", "Cervix", "Sarcoma"), + score = c(-58, -46, -39, -33, -28, -22, -18, -12, 8, 14, 19, 62)) +df1 <- df1[order(df1$score, decreasing = TRUE), ] +df1$index <- seq_len(nrow(df1)) + +ggplot(df1, aes(index, score, fill = ID)) + + geom_col(width = 0.8) + + scale_fill_brewer(type = "Qualitative", palette = "Paired") + + scale_y_continuous(breaks = seq(-100, 100, 10), expand = c(0, 0)) + + scale_x_continuous(expand = expansion(mult = c(0.01, 0))) + + geom_hline(yintercept = c(-30, 0, 20), linetype = 5, linewidth = 0.3) + + coord_cartesian(ylim = c(-90, 50)) + + geom_text(data = subset(df1, score > 50), + aes(index, 48, label = round(score)), size = 3.2) + + labs(x = NULL, y = "Maximum change in tumour size (%)", + title = "Response by tumour type (one colour per type)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), panel.border = element_blank(), + axis.line = element_line(colour = "black"), + axis.line.x = element_blank(), axis.ticks.x = element_blank(), + axis.text.x = element_blank(), + legend.position = "bottom") + + guides(fill = guide_legend(ncol = 4, title = NULL, override.aes = list(size = 3))) +``` + +The second (Nature Medicine enrichment style) shows signed GSVA-style t-values as a **horizontal diverging bar** with names beside each bar, gray for |t| below the significance threshold and colour only for the significant ones: + +```{r} +#| label: fig-11.2DivergingBars +#| fig-cap: "Diverging GSVA-style t-value bars (endothelial cells, tumour vs non-malignant, simulated): bars beyond |t| = 4 are coloured by direction, the rest gray; names sit beside each bar." +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 5.5 +#| fig-height: 7.5 + +df2 <- data.frame(ID = c("VEGFA", "ANGPT2", "CXCL8", "PDGFB", "MMP9", "TNFSF15", + "ANGPT1", "TEK", "NID2", "COL4A1", "LAMA4", "SPARCL1", + "KDR", "PECAM1", "VWF", "CDH5"), + score = c(7.2, 5.8, 4.9, 4.1, 3.4, -2.6, -3.3, -4.2, -5.1, + -6.3, 2.4, 1.8, 3.1, 2.8, -1.6, 1.2)) +df2$group <- cut(df2$score, breaks = c(-Inf, -4, 4, Inf), labels = c(1, 2, 3)) +df2 <- df2[order(df2$score, decreasing = FALSE), ] +df2$index <- seq_len(nrow(df2)) + +ggplot(df2, aes(index, score, fill = group)) + + geom_col(width = 0.8) + + scale_fill_manual(values = c("palegreen3", "snow3", "dodgerblue4")) + + scale_x_continuous(expand = expansion(add = 0.6)) + + scale_y_continuous(breaks = seq(-30, 20, 5)) + + coord_flip() + + geom_hline(yintercept = c(-4, 4), colour = "white", linetype = 2, linewidth = 0.3) + + geom_text(data = subset(df2, score > 0), + aes(index, -0.3, label = ID, colour = group), size = 3, hjust = "inward") + + geom_text(data = subset(df2, score < 0), + aes(index, 0.3, label = ID, colour = group), size = 3, hjust = "outward") + + scale_colour_manual(values = c("snow3", "black", "black")) + + labs(x = NULL, y = "t value of GSVA score, tumour vs non-malignant", + title = "Endothelial cells, tumour vs non-malignant") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + panel.border = element_rect(linewidth = 0.6, fill = NA), + axis.line.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.y = element_blank()) + + guides(fill = "none", colour = "none") +``` + +::: callout-tip +**Practice tips** + +- `coord_cartesian(ylim = ...)` clips the *drawing*, not the data — the towering bar keeps its full `geom_col` height and only the label reveals its value; `scale_y_continuous(limits = ...)` would instead drop the bar entirely. +- In the diverging layout the names live **inside** the bars' empty half (hjust "inward"/"outward" by sign), so no separate axis labelling is needed; gray for non-significant keeps the colour budget for the findings. +- Reference lines at community-accepted boundaries (RECIST ±30/+20) carry meaning a gridline cannot — quote them in the caption. +::: + ## Applications ### 1. Basic bar plot @@ -667,5 +957,4 @@ Figure B shows the average LV myocardial signal-to-noise ratio (SNR) of all mice \[12\] Kassambara A (2023). rstatix: Pipe-Friendly Framework for Basic Statistical Tests. R package version 0.7.2, https://CRAN.R-project.org/package=rstatix. - -\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[13\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Ranking/BarPlot.zh.qmd b/Ranking/BarPlot.zh.qmd index b57593bc6..973bef461 100644 --- a/Ranking/BarPlot.zh.qmd +++ b/Ranking/BarPlot.zh.qmd @@ -553,7 +553,7 @@ p ### 8. 多组柱形图 + 亚组渐变色 -参考图编码了**三级分组**:大组(颜色)、组内亚组(同色渐变浅色)、误差条(mean ± SE)\[9\]。渐变效果通过在每大组基色内按亚组序号赋予浅色调实现。 +参考图编码了**三级分组**:大组(颜色)、组内亚组(同色渐变浅色)、误差条(mean ± SE)\[13\]。渐变效果通过在每大组基色内按亚组序号赋予浅色调实现。 ```{r} #| label: fig-8.1SubgroupGradient @@ -603,11 +603,301 @@ ggplot(summ_b, aes(subgroup, mean, fill = subgroup)) + ::: callout-tip **实践要点** -- 渐变色用 `col2rgb()` + `rgb()` 在基色内按亚组序号调亮——将每个亚组视觉上关联到大组颜色。 +- 渐变浅色按亚组序号取自大组基色(此处为硬编码的显式 hex;亚组多时可用 `colorRampPalette(c(浅色, 基色))(n)` 自行派生)——将每个亚组视觉上关联到大组颜色。 - `se = sd / sqrt(n)` 误差条是均值比较的标准;部分期刊要求用 `sd` 而非 `se`——查阅作者指南。 - 组内比较括号可用 `ggsignif::geom_signif(comparisons = list(c("A1", "A2")))` 叠加在柱上。 ::: +### 9. 细胞类型比例柱形图 + 分簇 Fisher 事后检验 + +单细胞研究常用"每个簇在各条件中的细胞占比"概括组成变化。参考工作流 \[13\] 绘制堆积比例柱形图,对整个 簇 × 条件 列联表做 Fisher 精确检验,再用 one-vs-rest 事后检验回答*哪个*簇驱动了差异:`rstatix::row_wise_fisher_test()` 对每个簇做一次"该簇 vs 其余"的 Fisher 检验,并对 8 个 p 值做 BH 校正。 + +```{r} +#| label: fig-9.1CellPropSig +#| fig-cap: "各簇细胞组成(WT 与 KO,模拟数据)。星号为各簇 BH 校正后的 one-vs-rest Fisher 检验;对完整表的整体 Fisher 精确检验 p < 0.0001(Monte-Carlo,B = 10^5)。" +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9.5 +#| fig-height: 5.5 + +set.seed(2900) +clusters <- paste0("C", 1:8) +p0 <- c(0.18, 0.16, 0.14, 0.12, 0.11, 0.10, 0.10, 0.09) +# KO 比例:无效应簇严格保持 p0,仅在 C2/C6/C8 之间重新分配 +p_ko <- p0 +p_ko[2] <- 0.05; p_ko[6] <- 0.22; p_ko[8] <- 0.08 +stopifnot(abs(sum(p_ko) - 1) < 1e-12) +n_wt <- 900; n_ko <- 900 +mk_cells <- function(n, p, grp) { + data.frame(cluster = sample(clusters, n, replace = TRUE, prob = p), + group = grp, + run = sample(c("R1", "R2"), n, replace = TRUE)) +} +cellinfo <- rbind(mk_cells(n_wt, p0, "WT"), mk_cells(n_ko, p_ko, "KO")) +cellinfo$cluster <- factor(cellinfo$cluster, levels = clusters) + +tbl <- table(cellinfo$cluster, cellinfo$group) +ft <- fisher.test(tbl, simulate.p.value = TRUE, B = 1e5) +post <- rstatix::row_wise_fisher_test(tbl) + +cell.col <- c(WT = "#1A63A8", KO = "#FC6910") +prop_df <- as.data.frame(tbl, stringsAsFactors = FALSE) +colnames(prop_df) <- c("cluster", "group", "n") +prop_df$cluster <- factor(prop_df$cluster, levels = clusters) +prop_df$group <- factor(prop_df$group, levels = c("WT", "KO")) +sig_df <- as.data.frame(post) +sig_df$cluster <- factor(sig_df$group, levels = clusters) +sig_df$lab <- ifelse(sig_df$p.adj.signif == "ns", "", sig_df$p.adj.signif) + +ggplot(prop_df, aes(cluster, n, fill = group)) + + geom_col(stat = "identity", position = "fill", width = 0.72, + colour = "grey25", linewidth = 0.2) + + geom_text(data = sig_df, aes(x = cluster, y = 1.05, label = lab), + inherit.aes = FALSE, size = 4.4, colour = "grey10") + + scale_fill_manual(values = cell.col, name = NULL) + + scale_y_continuous(breaks = seq(0, 1, 0.25), labels = scales::percent, + expand = expansion(mult = c(0, 0.1))) + + labs(x = "Cluster", y = "Fraction of cells", + title = "Cell-type composition per cluster (KO vs WT)") + + theme_classic(base_size = 12) + + theme(legend.position = "top", plot.title = element_text(size = 11)) +``` + +按测序批次(重复)分面可以观察组成变化是可复现的还是单批次假象——参考图第一面板的版式 \[13\]: + +```{r} +#| label: fig-9.2CellPropRep +#| fig-cap: "按测序重复分面的同一组成图:耗竭(C2)与富集(C6)在两批间保持一致。" +#| out.width: "100%" +#| warning: false +#| message: false +#| fig-width: 12 +#| fig-height: 3.8 + +# same cells as the chunk above, now split by sequencing run +ggplot(cellinfo, aes(run, fill = group)) + + geom_bar(position = "fill", width = 0.85, colour = "grey25", linewidth = 0.2) + + facet_wrap(~cluster, nrow = 1) + + scale_fill_manual(values = cell.col, name = NULL) + + scale_y_continuous(breaks = seq(0, 1, 0.5), labels = scales::percent) + + labs(x = "Replicate", y = "Fraction of cells") + + theme_classic(base_size = 11) + + theme(strip.background = element_rect(fill = "grey88", colour = NA), + strip.text = element_text(face = "bold"), + legend.position = "top", + axis.text.x = element_text(angle = 45, hjust = 1)) +``` + +::: callout-tip +**实践要点** + +- `row_wise_fisher_test()` 要求列联表以类别为行、组为列;其 `group` 列是行名,`p.adj`/`p.adj.signif` 是 BH 校正结果——绘图请用 `p.adj.signif` 的星号,不要用原始 p 值。 +- 大 N 时 `fisher.test(..., simulate.p.value = TRUE)` 不可能返回小于 Monte-Carlo 地板 `1/(B + 1)` 的 p 值;此类结果应报告为 `p < 1/(B+1)`(此处 B = 10^5 即 `p < 0.0001`),不要照抄地板数值本身。 +- 保持两组样本量均衡:组总量不等时,每个无效应簇都会带上微小的系统性偏移,可能被分簇检验判为显著。 +::: + +### 10. 渐变填充柱形图(ggpattern) + +演示级图表有时用"办公软件式"渐变填充替代纯色——参考图 \[13\] 对每个区段使用双色调渐变。`ggpattern::geom_col_pattern()` 用 `pattern = "gradient"` 与两个端点色 `pattern_fill` / `pattern_fill2` 实现;`pattern_orientation = "radial"` 从区段中心向外辐射: + +```{r} +#| label: fig-10.1RadialGradient +#| fig-cap: "径向渐变柱:深色的转移癌区段承载白色百分比标签;数值为模拟的患病率数据。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +set.seed(2970) +df_d <- data.frame( + Country = c("Japan", "USA", "England", "S. Korea", "China", "France", "Germany", "Australia"), + Metastatic = c(19, 24, 28, 33, 36, 31, 22, 27), + Localized = c(81, 76, 72, 67, 64, 69, 78, 73)) +df_d$ID <- seq_len(nrow(df_d)) +maxID <- nrow(df_d) + +plot.df.all <- reshape2::melt(df_d, id.var = c("Country", "ID"), + value.name = "Percentage", variable.name = "Type") +plot.df <- subset(plot.df.all, Type %in% c("Metastatic", "Localized")) +plot.df1 <- subset(plot.df, Type == "Metastatic") +type.color.1 <- c('#dbeffc', '#7bb8e5') # 浅色区段(Localized) +type.color.2 <- c('#a7d7f3', '#0079bb') # 深色区段(Metastatic) +barwidth <- 0.44 + +ggplot() + + geom_col_pattern(data = plot.df, mapping = aes(ID, Percentage), + width = barwidth, position = "stack", + pattern = 'gradient', pattern_orientation = "radial", + pattern_fill = type.color.1[1], pattern_fill2 = type.color.1[2], + fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID, Percentage), + width = barwidth, + pattern = 'gradient', pattern_orientation = "radial", + pattern_fill = type.color.2[1], pattern_fill2 = type.color.2[2], + fill = NA) + + geom_text(data = plot.df1, mapping = aes(x = ID, y = Percentage * 0.22, + label = paste0(Percentage, " %")), + size = 2.6, color = "white") + + scale_x_continuous(breaks = seq(1, maxID, 1), + labels = stringr::str_wrap(plot.df1$Country, 9)) + + scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10), expand = c(0, 0)) + + labs(x = NULL, y = "Prevalence (%)") + + theme_bw(base_size = 11) + + theme(panel.grid.major.x = element_blank(), panel.grid.minor = element_blank(), + panel.border = element_blank(), axis.line = element_line(colour = 'black'), + axis.text = element_text(colour = 'black', size = 9)) +``` + +水平渐变需要一个技巧:ggpattern 只能沿一个方向在两色间插值,因此参考图把每根柱拆成左右两半并镜像渐变,形成中心对称的浅色条纹,再用 `geom_rect()` 补黑色描边: + +```{r} +#| label: fig-10.2HorizontalGradient +#| fig-cap: "水平渐变柱:由镜像的左右两半拼装,区段带黑色描边(ggpattern)。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 7.5 +#| fig-height: 5.2 + +barwidth2 <- 0.22 +ggplot() + + geom_col_pattern(data = plot.df, mapping = aes(ID - barwidth2 / 2 + 0.002, Percentage), + width = barwidth2, position = "stack", + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.1[2], pattern_fill2 = type.color.1[1], fill = NA) + + geom_col_pattern(data = plot.df, mapping = aes(ID + barwidth2 / 2 - 0.002, Percentage), + width = barwidth2, position = "stack", + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.1[1], pattern_fill2 = type.color.1[2], fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID - barwidth2 / 2 + 0.002, Percentage), + width = barwidth2, + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.2[2], pattern_fill2 = type.color.2[1], fill = NA) + + geom_col_pattern(data = plot.df1, mapping = aes(ID + barwidth2 / 2 - 0.002, Percentage), + width = barwidth2, + pattern = 'gradient', pattern_orientation = "horizontal", + pattern_fill = type.color.2[1], pattern_fill2 = type.color.2[2], fill = NA) + + geom_rect(data = plot.df1, + mapping = aes(xmin = ID - barwidth2, xmax = ID + barwidth2, + ymin = 0, ymax = Percentage), + linewidth = 0.3, fill = NA, color = "black") + + geom_rect(data = df_d, + mapping = aes(xmin = ID - barwidth2, xmax = ID + barwidth2, + ymin = Metastatic, ymax = 100), + linewidth = 0.3, fill = NA, color = "black") + + geom_text(data = plot.df1, mapping = aes(x = ID, y = Percentage * 0.22, + label = paste0(Percentage, " %")), + size = 2.6, color = "white") + + scale_x_continuous(breaks = seq(1, maxID, 1), + labels = stringr::str_wrap(plot.df1$Country, 9)) + + scale_y_continuous(limits = c(0, 100), breaks = seq(0, 100, 10), expand = c(0, 0)) + + labs(x = NULL, y = "Prevalence (%)") + + theme_bw(base_size = 11) + + theme(panel.grid.major.x = element_blank(), panel.grid.minor = element_blank(), + panel.border = element_blank(), axis.line = element_line(colour = 'black'), + axis.text = element_text(colour = 'black', size = 9)) +``` + +::: callout-tip +**实践要点** + +- `pattern_fill`/`pattern_fill2` 只是渐变的两个端点——三色渐变超出其能力范围;更多色阶需手动用 `colorRampPalette()` 构造。 +- 渐变是纯装饰:它不编码柱高之外的任何信息。面向审稿人的图请用纯色填充,渐变留给幻灯片和封面。 +- 白色标签在深色端点上清晰,在 `pattern_fill2` 的浅色中心上不行——把标签锚定在较深的部分,或给文字加描边。 +::: + +### 11. 参考线柱形图与发散式灰/彩柱形图 + +FigureYa39bar 的两种论文版式 \[13\]。第一种(NEJM 瀑布风格)给**每个癌种一种颜色**、在临床有意义的值处画虚线参考线(RECIST 边界 −30 与 +20,加零线),当一根柱远高于其余时——用 `coord_cartesian()` 裁剪 y 轴并在柱上标出真实值: + +```{r} +#| label: fig-11.1ResponseBars +#| fig-cap: "模拟的各癌种最佳肿瘤响应瀑布图:每癌种一色,-30/0/+20 处的 RECIST 虚线参考线;y 轴截断于 50,超出的柱标注真实值。" +#| out.width: "85%" +#| warning: false +#| message: false +#| fig-width: 8.5 +#| fig-height: 5.5 + +set.seed(3901) +df1 <- data.frame(ID = c("NSCLC", "CRC", "Melanoma", "RCC", "HNSCC", "Breast", + "Ovarian", "Prostate", "Pancreas", "HCC", "Cervix", "Sarcoma"), + score = c(-58, -46, -39, -33, -28, -22, -18, -12, 8, 14, 19, 62)) +df1 <- df1[order(df1$score, decreasing = TRUE), ] +df1$index <- seq_len(nrow(df1)) + +ggplot(df1, aes(index, score, fill = ID)) + + geom_col(width = 0.8) + + scale_fill_brewer(type = "Qualitative", palette = "Paired") + + scale_y_continuous(breaks = seq(-100, 100, 10), expand = c(0, 0)) + + scale_x_continuous(expand = expansion(mult = c(0.01, 0))) + + geom_hline(yintercept = c(-30, 0, 20), linetype = 5, linewidth = 0.3) + + coord_cartesian(ylim = c(-90, 50)) + + geom_text(data = subset(df1, score > 50), + aes(index, 48, label = round(score)), size = 3.2) + + labs(x = NULL, y = "Maximum change in tumour size (%)", + title = "Response by tumour type (one colour per type)") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), panel.border = element_blank(), + axis.line = element_line(colour = "black"), + axis.line.x = element_blank(), axis.ticks.x = element_blank(), + axis.text.x = element_blank(), + legend.position = "bottom") + + guides(fill = guide_legend(ncol = 4, title = NULL, override.aes = list(size = 3))) +``` + +第二种(Nature Medicine 富集风格)把带符号的 GSVA 风格 t 值画成**水平发散柱**,名字贴在每根柱旁,|t| 低于显著性阈值显示灰色,只有显著的才有颜色: + +```{r} +#| label: fig-11.2DivergingBars +#| fig-cap: "发散式 GSVA 风格 t 值柱(内皮细胞,肿瘤 vs 非肿瘤,模拟):超过 |t| = 4 的柱按方向着色,其余灰色;名字贴在柱旁。" +#| out.width: "65%" +#| warning: false +#| message: false +#| fig-width: 5.5 +#| fig-height: 7.5 + +df2 <- data.frame(ID = c("VEGFA", "ANGPT2", "CXCL8", "PDGFB", "MMP9", "TNFSF15", + "ANGPT1", "TEK", "NID2", "COL4A1", "LAMA4", "SPARCL1", + "KDR", "PECAM1", "VWF", "CDH5"), + score = c(7.2, 5.8, 4.9, 4.1, 3.4, -2.6, -3.3, -4.2, -5.1, + -6.3, 2.4, 1.8, 3.1, 2.8, -1.6, 1.2)) +df2$group <- cut(df2$score, breaks = c(-Inf, -4, 4, Inf), labels = c(1, 2, 3)) +df2 <- df2[order(df2$score, decreasing = FALSE), ] +df2$index <- seq_len(nrow(df2)) + +ggplot(df2, aes(index, score, fill = group)) + + geom_col(width = 0.8) + + scale_fill_manual(values = c("palegreen3", "snow3", "dodgerblue4")) + + scale_x_continuous(expand = expansion(add = 0.6)) + + scale_y_continuous(breaks = seq(-30, 20, 5)) + + coord_flip() + + geom_hline(yintercept = c(-4, 4), colour = "white", linetype = 2, linewidth = 0.3) + + geom_text(data = subset(df2, score > 0), + aes(index, -0.3, label = ID, colour = group), size = 3, hjust = "inward") + + geom_text(data = subset(df2, score < 0), + aes(index, 0.3, label = ID, colour = group), size = 3, hjust = "outward") + + scale_colour_manual(values = c("snow3", "black", "black")) + + labs(x = NULL, y = "t value of GSVA score, tumour vs non-malignant", + title = "Endothelial cells, tumour vs non-malignant") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), + panel.border = element_rect(linewidth = 0.6, fill = NA), + axis.line.y = element_blank(), axis.ticks.y = element_blank(), + axis.text.y = element_blank()) + + guides(fill = "none", colour = "none") +``` + +::: callout-tip +**实践要点** + +- `coord_cartesian(ylim = ...)` 裁的是*绘图*而非数据——高柱保持完整的 `geom_col` 高度,只有标签揭示真实值;`scale_y_continuous(limits = ...)` 则会把柱整根丢弃。 +- 发散版式里名字住在柱的**空白半区**(按符号取 hjust "inward"/"outward"),无需单独的轴标签;非显著用灰色把颜色预算留给发现。 +- 社区公认边界(RECIST ±30/+20)处的参考线带有网格线没有的含义——请在图注中引用其出处。 +::: + ## 应用场景 ### 1. 基础条形图 @@ -666,5 +956,4 @@ ggplot(summ_b, aes(subgroup, mean, fill = subgroup)) + \[12\] Kassambara A (2023). rstatix: Pipe-Friendly Framework for Basic Statistical Tests. R package version 0.7.2, https://CRAN.R-project.org/package=rstatix. - -\[9\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[13\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Ranking/Lollipop.qmd b/Ranking/Lollipop.qmd index 3d3252f10..31dac6bf5 100644 --- a/Ranking/Lollipop.qmd +++ b/Ranking/Lollipop.qmd @@ -496,7 +496,7 @@ mut <- data.frame( position = c(175, 175, 175, 220, 220, 245, 248, 248, 273, 273, 273, 158, 179, 196, 213, 234, 245, 280, 306, 338, 34, 72, 115, 133, 141)) -# Protein domains (e.g. from maftools::read-protein-domains or UniProt) +# Protein domains (e.g. from maftools::pfamDomains or UniProt) dom <- data.frame( name = c("Proline-rich", "DNA-binding", "Tetramerization"), start = c(60, 100, 320), end = c(80, 290, 360), @@ -534,7 +534,7 @@ ggplot() + - On real data, `trackViewer::lolliplot()` with a `GRanges` object (points carry a `score` for height) is the drop-in path; the `ggplot2` version above gives full theme control and vector SVG output. - Splitting stalks into two layers (`layer = c("top", "bottom")`) is the standard cure for crowding hot-spots; split by a clinical variable instead of randomly for a two-group contrast. -- Take domain coordinates from `maftools::read-protein-domains()` filtered by RefSeq ID, or from the UniProt REST API. +- Take domain coordinates from `maftools::pfamDomains()` (returns the `PFAM` domain table), or from the UniProt REST API. ::: ## Applications diff --git a/Ranking/Lollipop.zh.qmd b/Ranking/Lollipop.zh.qmd index 38777675a..ff6b24c58 100644 --- a/Ranking/Lollipop.zh.qmd +++ b/Ranking/Lollipop.zh.qmd @@ -496,7 +496,7 @@ mut <- data.frame( position = c(175, 175, 175, 220, 220, 245, 248, 248, 273, 273, 273, 158, 179, 196, 213, 234, 245, 280, 306, 338, 34, 72, 115, 133, 141)) -# 蛋白结构域(可来自 maftools::read.protein.domains 或 UniProt) +# 蛋白结构域(可来自 maftools::pfamDomains 或 UniProt) dom <- data.frame( name = c("Proline-rich", "DNA-binding", "Tetramerization"), start = c(60, 100, 320), end = c(80, 290, 360), @@ -534,7 +534,7 @@ ggplot() + - 真实数据上,用 `trackViewer::lolliplot()` 配 `GRanges` 对象(点带 `score` 控制高度)是即插即用的路径;上面的 `ggplot2` 版本可完全定制主题并输出矢量 SVG。 - 支棍分上下两层(`layer = c("top", "bottom")`)是热点拥挤的常用解法;按临床变量而非随机分层即可得到两组对比。 -- 结构域坐标可取 `maftools::read.protein.domains()` 按 RefSeq ID 过滤,或来自 UniProt REST API。 +- 结构域坐标可取 `maftools::pfamDomains()`(返回 `PFAM` 结构域表),或来自 UniProt REST API。 ::: ## 应用场景 diff --git a/Ranking/Parallel.qmd b/Ranking/Parallel.qmd index 2e3c6dd20..4dc33c105 100644 --- a/Ranking/Parallel.qmd +++ b/Ranking/Parallel.qmd @@ -420,7 +420,130 @@ p This figure shows the methylation variation of different composites (cg236, cg292, and cg658) across different samples. The lines represent the numerical trend of each composite across samples, the dots represent the specific values, and the labels indicate the composite's name. The colors distinguish the different composites, and the fluctuations in their values across samples can be seen through the lines. -## Applications +### 3. The Metagene Profile: One Line per Sample Across Ordered Windows + +The FigureYa44 layout \[12\] is a profile plot in this page's line language with the axes replaced by **ordered genomic windows**: every gene is compressed to a fixed number of bins (3 kb upstream | gene body | 3 kb downstream), the per-window tag counts are averaged over thousands of genes, and each ChIP-seq sample is one line. IP-versus-input contrast is the classic reading. rtracklayer/bigWig extraction is outside this repository's lockfile, so the block below simulates the averaged window matrix — swap in your real per-window means and everything downstream is unchanged: + +```{r} +#| label: fig-3.1Metagene +#| fig-cap: "Metagene profile over 3,000 simulated genes: mean tag density across 100-bp upstream windows, the compressed gene body and 3-kb downstream windows, one line per sample (IP vs Input); dashed lines mark TSS and TTS." +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(4401) +n_gene <- 3000 +resol <- 100 +span <- 3000 +gb_win <- 20 +up_win <- span / resol +w_up <- seq_len(up_win) +w_gb <- seq_len(gb_win) +w_dn <- seq_len(up_win) +pos_lab <- c(paste0("-", seq(span, resol, -resol)), + rep("gene body", gb_win), + paste0("+", seq(resol, span, resol))) +axis_at <- c(1, up_win, up_win + gb_win, length(pos_lab)) +axis_lab <- c("-3 kb", "TSS", "TTS", "+3 kb") +mk_profile <- function(amp_tss, amp_gb, noise) { + up <- exp(-(w_up - max(w_up))^2 / (2 * (up_win / 2.2)^2)) * amp_tss + gb <- (0.25 + 0.5 * seq(0, 1, length.out = gb_win)) * amp_gb + dn <- exp(-(w_dn - 1)^2 / (2 * (up_win / 2.5)^2)) * (amp_tss * 0.35) + pmax(0, c(up, gb, dn) + rnorm(length(up) + length(gb) + length(dn), 0, noise)) +} +prof <- data.frame( + window = seq_along(pos_lab), + Cxxc1 = mk_profile(1.0, 0.55, 0.012), + Input = mk_profile(0.30, 0.18, 0.010)) +prof_long <- tidyr::pivot_longer(prof, cols = c(Cxxc1, Input), + names_to = "sample", values_to = "signal") +ggplot(prof_long, aes(window, signal, colour = sample)) + + geom_line(linewidth = 1) + + geom_vline(xintercept = c(up_win + 0.5, up_win + gb_win + 0.5), + linetype = 2, colour = "grey55") + + annotate("rect", xmin = up_win + 0.5, xmax = up_win + gb_win + 0.5, + ymin = -Inf, ymax = Inf, alpha = 0.06, fill = "#2166AC") + + annotate("text", x = up_win / 2, y = max(prof_long$signal) * 1.02, + label = "3 kb upstream", size = 2.8, colour = "grey30") + + annotate("text", x = up_win + gb_win / 2, y = max(prof_long$signal) * 1.02, + label = "gene body (compressed)", size = 2.8, colour = "grey30") + + annotate("text", x = up_win + gb_win + up_win / 2, y = max(prof_long$signal) * 1.02, + label = "3 kb downstream", size = 2.8, colour = "grey30") + + scale_x_continuous(breaks = axis_at, labels = axis_lab, + expand = expansion(mult = c(0.01, 0.01))) + + labs(x = NULL, y = "Mean tag density (simulated, 3,000 genes)", + title = "Metagene profile: IP vs Input over extended gene bodies", + colour = NULL) + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- Plot the mean over genes, never the per-gene lines — a metagene's message *is* the average shape; per-gene spaghetti destroys it. +- Keep the gene-body compression honest: equal-length bodies resampled to the same bin count (here 20) is the standard; note it in the caption. +- Shade the gene-body region and mark TSS/TTS with dashed lines — the two boundaries are the only positions a reader can interpret without the caption. +::: + +### 4. One Sample, Many Region Classes: the Single-bigWig Profile + +The sibling layout of §3 (FigureYa57profile_1bw \[13\]): **one bigWig sample**, several *region classes* — e.g. promoters grouped by CpG content (HCP / ICP / LCP) — each class averaged over its own BED file, one coloured line per class. The contrast is between genomic contexts instead of between samples; H3K4me3 at high-CpG promoters versus low-CpG promoters is the reference's textbook example. As in §3, the averaged window matrix is simulated here in place of the bigWig extraction: + +```{r} +#| label: fig-4.1RegionProfile +#| fig-cap: "Single-sample metagene profile by promoter class (simulated): mean H3K4me3 density over TSS +-2 kb for high- (HCP), intermediate- (ICP) and low-CpG (LCP) promoters; dashed lines mark TSS and the gene-body end." +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(5701) +resol <- 10 +span <- 2000 +up_win <- span / resol +body_win <- 40 +amp <- c(HCP = 1.0, ICP = 0.45, LCP = 0.15) +prof108 <- do.call(rbind, lapply(names(amp), function(cl) { + a <- amp[[cl]] + up <- exp(-(seq_len(up_win) - max(seq_len(up_win)))^2 / (2 * (up_win / 2.0)^2)) * a + body <- rep(0.15 * a + 0.1, body_win) + dn <- rep(0.08 * a, up_win) + data.frame(window = seq_len(up_win + body_win + up_win), + signal = pmax(0, c(up, body, dn) + + rnorm(length(up) + body_win + up_win, 0, 0.015)), + region = cl) +})) +prof108$region <- factor(prof108$region, levels = c("HCP", "ICP", "LCP")) +ggplot(prof108, aes(window, signal, colour = region)) + + geom_line(linewidth = 1.1) + + geom_vline(xintercept = c(up_win + 0.5, up_win + body_win + 0.5), + linetype = 2, colour = "grey55") + + annotate("text", x = up_win / 2, y = 1.05, label = "-2 kb", size = 2.9, colour = "grey30") + + annotate("text", x = up_win + body_win / 2, y = 1.05, label = "TSS + gene body", size = 2.9, colour = "grey30") + + annotate("text", x = up_win + body_win + up_win / 2, y = 1.05, label = "+2 kb", size = 2.9, colour = "grey30") + + scale_x_continuous(breaks = c(1, up_win, up_win + body_win, length(unique(prof108$window))), + labels = c("-2 kb", "TSS", "TTS", "+2 kb"), + expand = expansion(mult = c(0.01, 0.01))) + + scale_colour_manual(values = c(HCP = "darkorange", ICP = "navy", LCP = "darkgreen"), name = NULL) + + labs(x = NULL, y = "H3K4me3 tag density (simulated)", + title = "One sample, three CpG classes: promoter signal by region type") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**Practice tips** + +- Class the regions **before** extraction and keep one BED per class (the reference's `mm9_HCP_tss.bed` / ICP / LCP naming); averaging across classes destroys exactly the contrast the figure exists to show. +- With several classes, draw each line thinner and rely on the top legend — the three curves never touch, so colour alone carries identity here; check grey-scale separation before print. +- `span` and the gene-body bins must stay multiples of `resolution`, or the compressed body resampling misaligns TSS/TTS. +::: + +## Applications## Applications ### 1. Basic Parallel Graph @@ -474,4 +597,6 @@ Parallel plots illustrate cluster analysis of genes exhibiting Depot*[Dex] inter \[11\] Neuwirth, E. (2023). RColorBrewer: ColorBrewer Palettes. https://cran.r-project.org/package=RColorBrewer +\[12\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[13\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Ranking/Parallel.zh.qmd b/Ranking/Parallel.zh.qmd index 9116af1eb..93e347904 100644 --- a/Ranking/Parallel.zh.qmd +++ b/Ranking/Parallel.zh.qmd @@ -420,7 +420,130 @@ p 这个图展示了不同“Composite”(cg236、cg292、cg658)在不同“sample”中的甲基化值变化。线条表示每个“Composite”在不同样本中的数值趋势,点表示具体数值,标签标出“Composite”的名字。颜色区分不同的“Composite”,通过样本间的线条起伏可以看出它们的数值变化。 -## 应用场景 +### 3. 元基因剖面:有序窗口上每样本一条线 + +FigureYa44 版式 \[12\] 是本页线条语言里的剖面图,只是轴换成了**有序基因组窗口**:每个基因压缩到固定窗口数(3 kb 上游 | 基因体 | 3 kb 下游),逐窗口 tag 计数在数千基因上取均值,每个 ChIP-seq 样本一条线。IP 与 input 的对照是经典读法。rtracklayer/bigWig 提取不在本仓库 lockfile 内,下块模拟均值窗口矩阵——换成你真实的逐窗口均值,下游一切不变: + +```{r} +#| label: fig-3.1Metagene +#| fig-cap: "3,000 个模拟基因的元基因剖面:100-bp 上游窗口、压缩基因体与 3-kb 下游窗口的平均 tag 密度,每样本一条线(IP vs Input);虚线标记 TSS 与 TTS。" +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(4401) +n_gene <- 3000 +resol <- 100 +span <- 3000 +gb_win <- 20 +up_win <- span / resol +w_up <- seq_len(up_win) +w_gb <- seq_len(gb_win) +w_dn <- seq_len(up_win) +pos_lab <- c(paste0("-", seq(span, resol, -resol)), + rep("gene body", gb_win), + paste0("+", seq(resol, span, resol))) +axis_at <- c(1, up_win, up_win + gb_win, length(pos_lab)) +axis_lab <- c("-3 kb", "TSS", "TTS", "+3 kb") +mk_profile <- function(amp_tss, amp_gb, noise) { + up <- exp(-(w_up - max(w_up))^2 / (2 * (up_win / 2.2)^2)) * amp_tss + gb <- (0.25 + 0.5 * seq(0, 1, length.out = gb_win)) * amp_gb + dn <- exp(-(w_dn - 1)^2 / (2 * (up_win / 2.5)^2)) * (amp_tss * 0.35) + pmax(0, c(up, gb, dn) + rnorm(length(up) + length(gb) + length(dn), 0, noise)) +} +prof <- data.frame( + window = seq_along(pos_lab), + Cxxc1 = mk_profile(1.0, 0.55, 0.012), + Input = mk_profile(0.30, 0.18, 0.010)) +prof_long <- tidyr::pivot_longer(prof, cols = c(Cxxc1, Input), + names_to = "sample", values_to = "signal") +ggplot(prof_long, aes(window, signal, colour = sample)) + + geom_line(linewidth = 1) + + geom_vline(xintercept = c(up_win + 0.5, up_win + gb_win + 0.5), + linetype = 2, colour = "grey55") + + annotate("rect", xmin = up_win + 0.5, xmax = up_win + gb_win + 0.5, + ymin = -Inf, ymax = Inf, alpha = 0.06, fill = "#2166AC") + + annotate("text", x = up_win / 2, y = max(prof_long$signal) * 1.02, + label = "3 kb upstream", size = 2.8, colour = "grey30") + + annotate("text", x = up_win + gb_win / 2, y = max(prof_long$signal) * 1.02, + label = "gene body (compressed)", size = 2.8, colour = "grey30") + + annotate("text", x = up_win + gb_win + up_win / 2, y = max(prof_long$signal) * 1.02, + label = "3 kb downstream", size = 2.8, colour = "grey30") + + scale_x_continuous(breaks = axis_at, labels = axis_lab, + expand = expansion(mult = c(0.01, 0.01))) + + labs(x = NULL, y = "Mean tag density (simulated, 3,000 genes)", + title = "Metagene profile: IP vs Input over extended gene bodies", + colour = NULL) + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- 画的是基因间均值,绝不是逐基因线——元基因的信息就是*平均形状*;逐基因"意大利面"会毁掉它。 +- 基因体压缩要保持诚实:等长 body 重采样到同一窗口数(此处 20)是标准做法,图注里写明。 +- 给基因体区域上底色并用虚线标 TSS/TTS——不读图注时读者唯一能解读的两个位置就是它们。 +::: + +### 4. 单样本、多区域类别:单 bigWig 剖面图 + +§3 的姊妹版式(FigureYa57profile_1bw \[13\]):**一份 bigWig 样本**、若干*区域类别*——例如按 CpG 含量分组的启动子(HCP / ICP / LCP)——每类用自己的 BED 平均,每类一条彩色线。对比的是基因组背景之间而非样本之间;高 CpG 启动子与低 CpG 启动子的 H3K4me3 差异是参考文档的经典示例。与 §3 一样,均值窗口矩阵在此模拟,替代 bigWig 提取: + +```{r} +#| label: fig-4.1RegionProfile +#| fig-cap: "按启动子类别的单样本元基因剖面(模拟):高(HCP)、中(ICP)、低 CpG(LCP)启动子在 TSS ±2 kb 的平均 H3K4me3 密度;虚线标记 TSS 与基因体末端。" +#| out.width: "95%" +#| warning: false +#| message: false +#| fig-width: 9 +#| fig-height: 5 + +set.seed(5701) +resol <- 10 +span <- 2000 +up_win <- span / resol +body_win <- 40 +amp <- c(HCP = 1.0, ICP = 0.45, LCP = 0.15) +prof108 <- do.call(rbind, lapply(names(amp), function(cl) { + a <- amp[[cl]] + up <- exp(-(seq_len(up_win) - max(seq_len(up_win)))^2 / (2 * (up_win / 2.0)^2)) * a + body <- rep(0.15 * a + 0.1, body_win) + dn <- rep(0.08 * a, up_win) + data.frame(window = seq_len(up_win + body_win + up_win), + signal = pmax(0, c(up, body, dn) + + rnorm(length(up) + body_win + up_win, 0, 0.015)), + region = cl) +})) +prof108$region <- factor(prof108$region, levels = c("HCP", "ICP", "LCP")) +ggplot(prof108, aes(window, signal, colour = region)) + + geom_line(linewidth = 1.1) + + geom_vline(xintercept = c(up_win + 0.5, up_win + body_win + 0.5), + linetype = 2, colour = "grey55") + + annotate("text", x = up_win / 2, y = 1.05, label = "-2 kb", size = 2.9, colour = "grey30") + + annotate("text", x = up_win + body_win / 2, y = 1.05, label = "TSS + gene body", size = 2.9, colour = "grey30") + + annotate("text", x = up_win + body_win + up_win / 2, y = 1.05, label = "+2 kb", size = 2.9, colour = "grey30") + + scale_x_continuous(breaks = c(1, up_win, up_win + body_win, length(unique(prof108$window))), + labels = c("-2 kb", "TSS", "TTS", "+2 kb"), + expand = expansion(mult = c(0.01, 0.01))) + + scale_colour_manual(values = c(HCP = "darkorange", ICP = "navy", LCP = "darkgreen"), name = NULL) + + labs(x = NULL, y = "H3K4me3 tag density (simulated)", + title = "One sample, three CpG classes: promoter signal by region type") + + theme_bw(base_size = 11) + + theme(panel.grid = element_blank(), legend.position = "top") +``` + +::: callout-tip +**实践要点** + +- 先按类别划分区域再提取信号,每类一个 BED(参考文档的 `mm9_HCP_tss.bed` / ICP / LCP 命名);跨类平均会抹掉这张图要展示的对比本身。 +- 多类别时线条更细、靠顶部图例承载身份——三条曲线互不相交,颜色即身份;打印前检查灰度可分性。 +- `span` 与基因体窗口数必须是 `resolution` 的整数倍,否则压缩 body 重采样会错位 TSS/TTS。 +::: + +## 应用场景## 应用场景 ### 1. 基础平行图 @@ -474,4 +597,6 @@ p \[11\] Neuwirth, E. (2023). RColorBrewer: ColorBrewer Palettes. https://cran.r-project.org/package=RColorBrewer +\[12\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 +\[13\] Xiaofan Lu, et al. FigureYa: A Standardized Visualization Framework for Enhancing Biomedical Data Interpretation and Research Efficiency. iMetaMed. 2025. doi:10.1002/imm3.70005 diff --git a/Ranking/VennPlot.qmd b/Ranking/VennPlot.qmd index 70a93966b..8d9e47465 100644 --- a/Ranking/VennPlot.qmd +++ b/Ranking/VennPlot.qmd @@ -220,7 +220,7 @@ The core function of the VennDiagram package is `venn.diagram`. This function ca #| warning: false #| message: false -p <- venn.diagram(x,filename = NULL);grid::grid.draw(p) +p <- venn.diagram(x, filename = NULL, disable.logging = TRUE);grid::grid.draw(p) ``` The biggest difference between VennDiagram set color settings and ggVennDiagram is that the colors are set as discrete colors according to different sets. The setting method is as follows: @@ -234,7 +234,7 @@ The biggest difference between VennDiagram set color settings and ggVennDiagram # When only one color is entered, all sets display the same color. When the number of entered colors matches the number of sets, each set has its own color. You can also use a specific naming method to accurately set the color of the set. p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, fill = c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), alpha= 0.3);grid::grid.draw(p) ``` @@ -249,7 +249,7 @@ Line settings: #| message: false p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, col = c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), lwd = 0.3, lty = 2);grid::grid.draw(p) ``` @@ -264,7 +264,7 @@ Font settings. If you need to adjust the position, please use the `cat.dist`, `c #| message: false p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, cat.col =c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), label.col = "red");grid::grid.draw(p) ``` @@ -280,7 +280,7 @@ Display the size of the collection in proportion. This mode is only applicable t p <- venn.diagram( x[c("A","B")], filename = NULL, fill= c("A"="#2E75A2","B"="#FBD75F"), - scaled = T + scaled = T, disable.logging = TRUE );grid::grid.draw(p) ``` @@ -372,14 +372,14 @@ ggVennDiagram(sets4, label = "percent", label_alpha = 0, ::: -### 6. Venn Diagram With an Exact Multiset-Intersection p Value +### 6. Venn Diagram With a Multiset-Intersection p Value -When a Venn diagram carries an argument (which pathways are *shared* across three PDX models?), the triple overlap needs a statistic: a P value under the null of independent sets, printed under the diagram \[4\]. The MSET test of Wang et al. generalises it to many sets; for the common three-set case the exact upper-tail binomial test below is self-contained and dependency-free. +When a Venn diagram carries an argument (which pathways are *shared* across three PDX models?), the triple overlap needs a statistic: a P value under the null of independent sets, printed under the diagram \[4\]. The exact MSET test of Wang et al. (SuperExactTest) handles arbitrary numbers of sets with fixed set sizes; SuperExactTest is not in this repository's lockfile, so the section ships a self-contained **binomial approximation**: treat each background member as independently included in set i with probability |S_i|/N, and upper-tail-test the triple-overlap count against Binomial(N, p1·p2·p3). Fixed set sizes make triple-inclusion events mildly negatively correlated, so the binomial tail is slightly **conservative** — it will not exaggerate significance. ```{r} #| label: fig-6.1MultisetP -#| fig-cap: "Three PDX-model pathway sets with the exact multiset-intersection test below: the 52-member planted core makes the triple overlap astronomically richer than independent sampling allows (P < 1e-30)." +#| fig-cap: "Three PDX-model pathway sets with a binomial-approximation test of the triple intersection below: the 52-member planted core makes the overlap far richer than independent sampling allows (P < 1e-30)." #| out.width: "85%" #| warning: false #| message: false @@ -396,18 +396,20 @@ S2 <- unique(c(core, sample(setdiff(bg, core), sz[2] - length(core)))) S3 <- unique(c(core, sample(setdiff(bg, core), sz[3] - length(core)))) dat <- list(PDX_95 = S1, PDX_112 = S2, PDX_207 = S3) -## exact upper-tail test of the triple intersection under independent sets: -## the observed triple-overlap count vs Binomial(n, p1*p2*p3) +## binomial approximation of the triple-intersection test (independent-inclusion +## null): observed triple-overlap count vs Binomial(n, p1*p2*p3); slightly +## conservative under the true fixed-size null t3 <- length(intersect(intersect(S1, S2), S3)) pval <- binom.test(t3, n = n_bg, p = prod(sz / n_bg), alternative = "greater")$p.value venn <- venn.diagram(x = dat, filename = NULL, - fill = c("red", "steelblue", "yellow")) + fill = c("red", "steelblue", "yellow"), + disable.logging = TRUE) # keep VennDiagram from dropping .log files in the working dir grid::grid.newpage() grid::grid.draw(venn) -grid::grid.text(sprintf("Exact test of multiset intersections: P = %.2e", pval), - x = unit(0.5, "npc"), y = unit(0.05, "npc"), +grid::grid.text(sprintf("Binomial tail test of the triple intersection: P = %.2e", pval), + x = unit(0.5, "npc"), y = unit(0.105, "npc"), gp = gpar(fontsize = 11, col = "#B2182B")) cat(sprintf("Triple overlap: %d pathways (sizes %s), P = %.2e\n", t3, paste(sz, collapse = "/"), pval)) @@ -418,7 +420,7 @@ cat(sprintf("Triple overlap: %d pathways (sizes %s), P = %.2e\n", - The p-value must come from the **same null** the reader assumes: background size = the pathway/gene universe you sampled *from*, not the union of the drawn sets; a wrong n inflates significance silently. - Check the test against a Monte-Carlo null once per new design: draw independent sets with the same sizes and confirm the observed overlap never occurs by chance - if it does, your p-value is lying. -- Packages such as SuperExactTest implement the full multiset exact test (Wang et al. 2015); the binomial tail here is its independent-sets special case - sufficient for the usual "is this overlap more than expected?" question. +- The binomial tail assumes independent set membership; with fixed set sizes the exact null is the multiset hypergeometric cascade implemented by SuperExactTest's `MSET()` (Wang et al. 2015) — use it for publication-grade claims (install separately; it is not in this repository's lockfile). ::: ## Application diff --git a/Ranking/VennPlot.zh.qmd b/Ranking/VennPlot.zh.qmd index 2ef9a8f85..428758dc4 100644 --- a/Ranking/VennPlot.zh.qmd +++ b/Ranking/VennPlot.zh.qmd @@ -220,7 +220,7 @@ VennDiagram包的核心函数为`venn.diagram`,该函数不能直接将图像 #| warning: false #| message: false -p <- venn.diagram(x,filename = NULL);grid::grid.draw(p) +p <- venn.diagram(x, filename = NULL, disable.logging = TRUE);grid::grid.draw(p) ``` VennDiagram集合颜色设置于ggVennDiagram最大的区别在于颜色是根据不同集合设置的离散型颜色,设置方法如下: @@ -234,7 +234,7 @@ VennDiagram集合颜色设置于ggVennDiagram最大的区别在于颜色是根 # 仅输入一个颜色时,所有集合显示同一个颜色,当输入颜色数量与集合数量一致时每个集合各自一个颜色,也可以使用指定命名的方式精确设置集合的颜色 p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, fill = c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), alpha= 0.3);grid::grid.draw(p) ``` @@ -249,7 +249,7 @@ p <- venn.diagram( #| message: false p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, col = c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), lwd = 0.3, lty = 2);grid::grid.draw(p) ``` @@ -264,7 +264,7 @@ p <- venn.diagram( #| message: false p <- venn.diagram( - x, filename = NULL, + x, filename = NULL, disable.logging = TRUE, cat.col =c("A"="#2E75A2","B"="#FBD75F","C"="#379337","D"="#C13A3C"), label.col = "red");grid::grid.draw(p) ``` @@ -280,7 +280,7 @@ p <- venn.diagram( p <- venn.diagram( x[c("A","B")], filename = NULL, fill= c("A"="#2E75A2","B"="#FBD75F"), - scaled = T + scaled = T, disable.logging = TRUE );grid::grid.draw(p) ``` @@ -372,14 +372,14 @@ ggVennDiagram(sets4, label = "percent", label_alpha = 0, ::: -### 6. 带多重集交集精确检验 p 值的韦恩图 +### 6. 带多重集交集检验 p 值的韦恩图 -当韦恩图承载论点(三个 PDX 模型*共有*哪些通路?)时,三重重叠需要一个统计量:在集合相互独立的零模型下给出 P 值并印在图下方 \[4\]。Wang et al. 的 MSET 检验将其推广到多集合;常见的三集合情形,下面这个自足、零依赖的精确上侧二项检验即可胜任。 +当韦恩图承载论点(三个 PDX 模型*共有*哪些通路?)时,三重重叠需要一个统计量:在集合相互独立的零模型下给出 P 值并印在图下方 \[4\]。Wang et al. 的精确 MSET 检验(SuperExactTest)可处理任意数量集合、固定集合大小的情形;SuperExactTest 不在本仓库 lockfile 中,因此本节给出一个自足的**二项近似**:把背景每个成员视为以概率 |S_i|/N 独立落入集合 i,将三重交集计数对 Binomial(N, p1·p2·p3) 做上侧检验。固定集合大小会使"三重入选"事件呈轻度负相关,因此二项尾略**保守**——不会夸大显著性。 ```{r} #| label: fig-6.1MultisetP -#| fig-cap: "Three PDX-model pathway sets with the exact multiset-intersection test below: the 52-member planted core makes the triple overlap astronomically richer than independent sampling allows (P < 1e-30)." +#| fig-cap: "Three PDX-model pathway sets with a binomial-approximation test of the triple intersection below: the 52-member planted core makes the overlap far richer than independent sampling allows (P < 1e-30)." #| out.width: "85%" #| warning: false #| message: false @@ -396,18 +396,19 @@ S2 <- unique(c(core, sample(setdiff(bg, core), sz[2] - length(core)))) S3 <- unique(c(core, sample(setdiff(bg, core), sz[3] - length(core)))) dat <- list(PDX_95 = S1, PDX_112 = S2, PDX_207 = S3) -## exact upper-tail test of the triple intersection under independent sets: -## the observed triple-overlap count vs Binomial(n, p1*p2*p3) +## 三重交集检验的二项近似(独立入选零模型):观测三重交集计数 vs +## Binomial(n, p1*p2*p3);在真实固定大小零模型下略保守 t3 <- length(intersect(intersect(S1, S2), S3)) pval <- binom.test(t3, n = n_bg, p = prod(sz / n_bg), alternative = "greater")$p.value venn <- venn.diagram(x = dat, filename = NULL, - fill = c("red", "steelblue", "yellow")) + fill = c("red", "steelblue", "yellow"), + disable.logging = TRUE) # keep VennDiagram from dropping .log files in the working dir grid::grid.newpage() grid::grid.draw(venn) -grid::grid.text(sprintf("Exact test of multiset intersections: P = %.2e", pval), - x = unit(0.5, "npc"), y = unit(0.05, "npc"), +grid::grid.text(sprintf("Binomial tail test of the triple intersection: P = %.2e", pval), + x = unit(0.5, "npc"), y = unit(0.105, "npc"), gp = gpar(fontsize = 11, col = "#B2182B")) cat(sprintf("Triple overlap: %d pathways (sizes %s), P = %.2e\n", t3, paste(sz, collapse = "/"), pval)) @@ -418,7 +419,7 @@ cat(sprintf("Triple overlap: %d pathways (sizes %s), P = %.2e\n", - p 值必须来自读者默认的那个**零模型**:背景大小是你抽样自的通路/基因宇宙,而非所画集合的并集;n 取错会在无声中夸大显著性。 - 每换新设计就用 Monte-Carlo 零模型对拍一次:以相同集合大小抽独立集合,确认观测重叠从不随机出现——一旦出现,你的 p 值就在撒谎。 -- SuperExactTest 等包实现了完整的多重集精确检验(Wang et al. 2015);此处的二项尾是其在独立集合下的特例——足以回答常见的"这重叠超出预期吗"。 +- 二项尾假设集合成员相互独立;固定集合大小下的精确零模型是 SuperExactTest `MSET()` 的多重集超几何级联(Wang et al. 2015)——发表级结论请用它(需另行安装,不在本仓库 lockfile 中)。 ::: ## 应用场景 diff --git a/VennDiagram.2026-11-07_14-11-24.172093.log b/VennDiagram.2026-11-07_14-11-24.172093.log deleted file mode 100644 index 96f4d4b8a..000000000 --- a/VennDiagram.2026-11-07_14-11-24.172093.log +++ /dev/null @@ -1,6 +0,0 @@ -INFO [2026-11-07 14:11:24] [[1]] -INFO [2026-11-07 14:11:24] x -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-24.248981.log b/VennDiagram.2026-11-07_14-11-24.248981.log deleted file mode 100644 index 29f677d94..000000000 --- a/VennDiagram.2026-11-07_14-11-24.248981.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:24] [[1]] -INFO [2026-11-07 14:11:24] x -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $fill -INFO [2026-11-07 14:11:24] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $alpha -INFO [2026-11-07 14:11:24] [1] 0.3 -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-24.368769.log b/VennDiagram.2026-11-07_14-11-24.368769.log deleted file mode 100644 index d1d970c37..000000000 --- a/VennDiagram.2026-11-07_14-11-24.368769.log +++ /dev/null @@ -1,15 +0,0 @@ -INFO [2026-11-07 14:11:24] [[1]] -INFO [2026-11-07 14:11:24] x -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $col -INFO [2026-11-07 14:11:24] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $lwd -INFO [2026-11-07 14:11:24] [1] 0.3 -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $lty -INFO [2026-11-07 14:11:24] [1] 2 -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-24.437038.log b/VennDiagram.2026-11-07_14-11-24.437038.log deleted file mode 100644 index 722efec8c..000000000 --- a/VennDiagram.2026-11-07_14-11-24.437038.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:24] [[1]] -INFO [2026-11-07 14:11:24] x -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $cat.col -INFO [2026-11-07 14:11:24] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $label.col -INFO [2026-11-07 14:11:24] [1] "red" -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-24.507391.log b/VennDiagram.2026-11-07_14-11-24.507391.log deleted file mode 100644 index 821bc15ea..000000000 --- a/VennDiagram.2026-11-07_14-11-24.507391.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:24] [[1]] -INFO [2026-11-07 14:11:24] x[c("A", "B")] -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $fill -INFO [2026-11-07 14:11:24] c(A = "#2E75A2", B = "#FBD75F") -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $scaled -INFO [2026-11-07 14:11:24] T -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-24.887789.log b/VennDiagram.2026-11-07_14-11-24.887789.log deleted file mode 100644 index 07f4d5dba..000000000 --- a/VennDiagram.2026-11-07_14-11-24.887789.log +++ /dev/null @@ -1,9 +0,0 @@ -INFO [2026-11-07 14:11:24] $x -INFO [2026-11-07 14:11:24] dat -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $filename -INFO [2026-11-07 14:11:24] NULL -INFO [2026-11-07 14:11:24] -INFO [2026-11-07 14:11:24] $fill -INFO [2026-11-07 14:11:24] c("red", "steelblue", "yellow") -INFO [2026-11-07 14:11:24] diff --git a/VennDiagram.2026-11-07_14-11-30.919896.log b/VennDiagram.2026-11-07_14-11-30.919896.log deleted file mode 100644 index 4538267e1..000000000 --- a/VennDiagram.2026-11-07_14-11-30.919896.log +++ /dev/null @@ -1,6 +0,0 @@ -INFO [2026-11-07 14:11:30] [[1]] -INFO [2026-11-07 14:11:30] x -INFO [2026-11-07 14:11:30] -INFO [2026-11-07 14:11:30] $filename -INFO [2026-11-07 14:11:30] NULL -INFO [2026-11-07 14:11:30] diff --git a/VennDiagram.2026-11-07_14-11-30.994599.log b/VennDiagram.2026-11-07_14-11-30.994599.log deleted file mode 100644 index 1c66cc1cd..000000000 --- a/VennDiagram.2026-11-07_14-11-30.994599.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:30] [[1]] -INFO [2026-11-07 14:11:30] x -INFO [2026-11-07 14:11:30] -INFO [2026-11-07 14:11:30] $filename -INFO [2026-11-07 14:11:30] NULL -INFO [2026-11-07 14:11:30] -INFO [2026-11-07 14:11:30] $fill -INFO [2026-11-07 14:11:30] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:30] -INFO [2026-11-07 14:11:30] $alpha -INFO [2026-11-07 14:11:30] [1] 0.3 -INFO [2026-11-07 14:11:30] diff --git a/VennDiagram.2026-11-07_14-11-31.06614.log b/VennDiagram.2026-11-07_14-11-31.06614.log deleted file mode 100644 index e765f97a2..000000000 --- a/VennDiagram.2026-11-07_14-11-31.06614.log +++ /dev/null @@ -1,15 +0,0 @@ -INFO [2026-11-07 14:11:31] [[1]] -INFO [2026-11-07 14:11:31] x -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $filename -INFO [2026-11-07 14:11:31] NULL -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $col -INFO [2026-11-07 14:11:31] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $lwd -INFO [2026-11-07 14:11:31] [1] 0.3 -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $lty -INFO [2026-11-07 14:11:31] [1] 2 -INFO [2026-11-07 14:11:31] diff --git a/VennDiagram.2026-11-07_14-11-31.155293.log b/VennDiagram.2026-11-07_14-11-31.155293.log deleted file mode 100644 index 9e4a470eb..000000000 --- a/VennDiagram.2026-11-07_14-11-31.155293.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:31] [[1]] -INFO [2026-11-07 14:11:31] x -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $filename -INFO [2026-11-07 14:11:31] NULL -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $cat.col -INFO [2026-11-07 14:11:31] c(A = "#2E75A2", B = "#FBD75F", C = "#379337", D = "#C13A3C") -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $label.col -INFO [2026-11-07 14:11:31] [1] "red" -INFO [2026-11-07 14:11:31] diff --git a/VennDiagram.2026-11-07_14-11-31.227704.log b/VennDiagram.2026-11-07_14-11-31.227704.log deleted file mode 100644 index fab78dca8..000000000 --- a/VennDiagram.2026-11-07_14-11-31.227704.log +++ /dev/null @@ -1,12 +0,0 @@ -INFO [2026-11-07 14:11:31] [[1]] -INFO [2026-11-07 14:11:31] x[c("A", "B")] -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $filename -INFO [2026-11-07 14:11:31] NULL -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $fill -INFO [2026-11-07 14:11:31] c(A = "#2E75A2", B = "#FBD75F") -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $scaled -INFO [2026-11-07 14:11:31] T -INFO [2026-11-07 14:11:31] diff --git a/VennDiagram.2026-11-07_14-11-31.548459.log b/VennDiagram.2026-11-07_14-11-31.548459.log deleted file mode 100644 index c5736af01..000000000 --- a/VennDiagram.2026-11-07_14-11-31.548459.log +++ /dev/null @@ -1,9 +0,0 @@ -INFO [2026-11-07 14:11:31] $x -INFO [2026-11-07 14:11:31] dat -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $filename -INFO [2026-11-07 14:11:31] NULL -INFO [2026-11-07 14:11:31] -INFO [2026-11-07 14:11:31] $fill -INFO [2026-11-07 14:11:31] c("red", "steelblue", "yellow") -INFO [2026-11-07 14:11:31] diff --git a/files/gallery_data.csv b/files/gallery_data.csv index b0ba2c66d..d03fbb9dd 100644 --- a/files/gallery_data.csv +++ b/files/gallery_data.csv @@ -1157,3 +1157,41 @@ Id,Name,Image_url,Tutorial_url,Description,Type,Level1,Level2 1157,Mutation-Report t-SNE: Highlight and Feature Strip,https://openbiox.github.io/Bizard/Correlation/TSNEplot_files/figure-html/fig-5.1MutantReport-1.png,https://openbiox.github.io/Bizard/Correlation/TSNEplot.html#fig-5.1MutantReport,"Publication-style t-SNE panel: the 100 mutated cells pop out yellow on a greyed population, while the mutation's report gene and two lineage markers are painted as feature panels on the shared embedding.",t-SNE Plot,BASICS,TSNEplot 1158,Venn Diagram With Multiset-Intersection p Value,https://openbiox.github.io/Bizard/Ranking/VennPlot_files/figure-html/fig-6.1MultisetP-1.png,https://openbiox.github.io/Bizard/Ranking/VennPlot.html#fig-6.1MultisetP,Three PDX-model pathway sets with the exact multiset-intersection test printed beneath: the planted 52-member core makes the triple overlap astronomically richer than independent sampling allows (P < 1e-30).,Veen Plot,BASICS,Ranking 1159,Differential Communication Circle Network,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot_files/figure-html/fig-6.2DiffCircle-1.png,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot.html#fig-6.2DiffCircle,"The same STIM-minus-CTRL diff matrix as a circular network: node ring width scales with total communication, curved links show only the changed pairs (red up in STIM, blue up in CTRL).",Cell-Cell Communication Circle Plot,OMICS,CellChatCirclePlot +1160,ECDF with Wilcoxon Rank-Sum P-Values,https://openbiox.github.io/Bizard/Distribution/ECDFPlot_files/figure-html/fig-5.1EcdfWilcox-1.png,https://openbiox.github.io/Bizard/Distribution/ECDFPlot.html#fig-5.1EcdfWilcox,"Three simulated log2 fold-change distributions (n = 100 each): ECDFs annotated with two-sided Wilcoxon rank-sum p-values against the Non-targets reference (P = 0.027 for CLIP targets, P < 0.001 for CLIP + RIP targets).",ECDF Plot,BASICS,Distribution +1161,Cell-Type Proportion Bars with a Cluster-wise Fisher Post-hoc Test,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-9.1CellPropSig-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-9.1CellPropSig,"Cell-type composition per cluster (WT vs KO, simulated). Stars are BH-adjusted one-vs-rest Fisher tests per cluster; the overall Fisher exact test on the full table gives p < 0.0001 (Monte-Carlo, B = 10^5).",Bar Plot,BASICS,Ranking +1162,Cell-Type Proportion Bars with a Cluster-wise Fisher Post-hoc Test,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-9.2CellPropRep-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-9.2CellPropRep,The same composition faceted by sequencing replicate: the depletion (C2) and enrichment (C6) are consistent across runs.,Bar Plot,BASICS,Ranking +1163,Gradient-Filled Bars (ggpattern),https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-10.1RadialGradient-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-10.1RadialGradient,Radial-gradient bars: the dark metastatic fraction carries white percentage labels; values are simulated prevalence data.,Bar Plot,BASICS,Ranking +1164,Gradient-Filled Bars (ggpattern),https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-10.2HorizontalGradient-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-10.2HorizontalGradient,Horizontal-gradient bars assembled from mirrored left/right halves with black segment borders (ggpattern).,Bar Plot,BASICS,Ranking +1165,Pairwise Log-rank Comparisons Across Many Groups,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-2.3pairwise-1.png,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot.html#fig-2.3pairwise,"Five-stratum KM curves with risk table; the lower-left table gives Holm-adjusted pairwise log-rank p-values (columns vs rows), and the overall log-rank test gives p < 0.001.",Kaplan Meier Plot,CLINICS,KaplanMeierPlot +1166,10 Subtype-Centroid Heatmap with Signature-Score Annotations (PAM50-Style),https://openbiox.github.io/Bizard/Correlation/Heatmap_files/figure-html/fig-4.10SubtypeCentroid-1.png,https://openbiox.github.io/Bizard/Correlation/Heatmap.html#fig-4.10SubtypeCentroid,"Subtype-centroid heatmap (50 simulated PAM50-style genes, 60 samples): samples ordered and split by nearest-centroid prediction; top annotations show the subtype call, two signature-score lines (AR-like: Basal-high; proliferation: LumB-high) and the AR phenotype.",Heatmap,BASICS,Correlation +1167,Two-Group Differential Communication as an Edge-Bundled Chord,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot_files/figure-html/fig-7.1CPDBBundle-1.png,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot.html#fig-7.1CPDBBundle,"Differential ligand-receptor communication as an edge-bundled chord (ggraph): radial tree arms per cell type, bundles coloured by ligand log2 fold change (red = up in STIM), leaf size = expressing fraction, open = ligand, filled = receptor.",Cell-Cell Communication Circle Plot,OMICS,CellChatCirclePlot +1168,From an Expression Cluster to a Gene Family: Heatmap + Tree + Alignment,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.1FamilyHeatmap-1.png,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment.html#fig-4.1FamilyHeatmap,"Expression heatmap of the 12-member simulated family (rows z-scored, complete linkage): the two co-expression blocks correspond to the two subfamilies.",Multiple Sequences Alignment,OMICS,MultiSeqsAlignment +1169,From an Expression Cluster to a Gene Family: Heatmap + Tree + Alignment,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.2FamilyAlignment-1.png,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment.html#fig-4.2FamilyAlignment,"First 60 alignment positions of the 12 family members (ggmsa, Chemistry_AA colouring): each subfamily carries shared diagnostic substitutions plus private ones.",Multiple Sequences Alignment,OMICS,MultiSeqsAlignment +1170,From an Expression Cluster to a Gene Family: Heatmap + Tree + Alignment,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.3FamilyTree-1.png,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment.html#fig-4.3FamilyTree,Neighbour-joining tree from pairwise sequence identity (ggtree): the two clades match the two expression blocks of the heatmap.,Multiple Sequences Alignment,OMICS,MultiSeqsAlignment +1171,Calibrate the Nomogram,https://openbiox.github.io/Bizard/Clinics/Nomogram_files/figure-html/fig-3.1Calibration3y-1.png,https://openbiox.github.io/Bizard/Clinics/Nomogram.html#fig-3.1Calibration3y,Bootstrap calibration of the Cox nomogram at 3 years (u = 1095 days): apparent (×) vs bias-corrected (•) survival against the ideal 45° line.,Nomogram,CLINICS,Nomogram +1172,Calibrate the Nomogram,https://openbiox.github.io/Bizard/Clinics/Nomogram_files/figure-html/fig-3.2Calibration5y-1.png,https://openbiox.github.io/Bizard/Clinics/Nomogram.html#fig-3.2Calibration5y,Bootstrap calibration of the Cox nomogram at 5 years (u = 1825 days): the model tracks the ideal line within the bootstrap confidence bars.,Nomogram,CLINICS,Nomogram +1173,Circular Score Comparison with a Highlighted Case (circlize),https://openbiox.github.io/Bizard/Proportion/ChordDiagram_files/figure-html/fig-5.1CircularScores-1.png,https://openbiox.github.io/Bizard/Proportion/ChordDiagram.html#fig-5.1CircularScores,"Two-ring score comparison (circlize): outer ring = 800 simulated tumour samples, inner ring = 120 normal samples, grey radial lines = group medians, red pointer = the index patient's score of 20.",Chord Diagram,BASICS,Proportion +1174,Pathway-Activity DE Dot Plot Across Cell Types,https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot_files/figure-html/fig-4.1PathwayDEDot-1.png,https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot.html#fig-4.1PathwayDEDot,"Pathway-activity differential dot plot (12 pathways x 4 cell types): dot size = Bonferroni-FDR bins, colour = log2 fold change of the activity score; the bottom strip groups pathways into Immune / Metabolism / Signaling / Proliferation.",Text-Overlaid Enrichment Barplot,OMICS,TextEnrichmentBarPlot +1175,Size-Encoded Volcano for Small-Effect Screens (PDUI Style),https://openbiox.github.io/Bizard/Omics/VolcanoPlot_files/figure-html/fig-4.1PduiVolcano-1.png,https://openbiox.github.io/Bizard/Omics/VolcanoPlot.html#fig-4.1PduiVolcano,"Size-encoded volcano of simulated 3'UTR-usage (PDUI) events between vital-status groups: colour = direction gate (|delta PDUI| > 0.05 and adjusted P < 0.1), dot size = |delta PDUI x -log10 P|; the strongest shift on each side is labeled.",Volcano Plot,OMICS,VolcanoPlot +1176,Many Models at One Horizon: Value and Over-Intervention,https://openbiox.github.io/Bizard/Clinics/DCAPlot_files/figure-html/fig-5.1FourModelDCA-1.png,https://openbiox.github.io/Bizard/Clinics/DCAPlot.html#fig-5.1FourModelDCA,"Decision curves for four risk models at the 2-year horizon (simulated cohort, n = 500): net benefit against treat-all and treat-none defaults.",Decision Curve Analysis,CLINICS,DCAPlot +1177,Many Models at One Horizon: Value and Over-Intervention,https://openbiox.github.io/Bizard/Clinics/DCAPlot_files/figure-html/fig-5.2FourModelNIA-1.png,https://openbiox.github.io/Bizard/Clinics/DCAPlot.html#fig-5.2FourModelNIA,Net interventions avoided per 100 patients for the same four models: the value of a model is how many treat-all interventions it can spare at equal missed events.,Decision Curve Analysis,CLINICS,DCAPlot +1178,Batch Optimal Cutpoints (Best Separation),https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.4BestSeparation-1.png,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot.html#fig-3.4BestSeparation,"Batch best-separation screen of 8 simulated markers: KM curves for the markers whose maximally-selected log-rank p passes 0.05, with the optimal cutoff, n per group, HR and 95% CI printed in each panel.",Kaplan Meier Plot,CLINICS,KaplanMeierPlot +1179,Correlation Chord Around the Circle (circlize),https://openbiox.github.io/Bizard/Correlation/Correlogram_files/figure-html/fig-6.1CorrChord-1.png,https://openbiox.github.io/Bizard/Correlation/Correlogram.html#fig-6.1CorrChord,"Spearman correlation chord of the top 16 pairs among 10 simulated genes: gene arcs coloured with the d3 palette, link width = |cor|, link colour = signed cor (green = negative, red = positive), gradient bar as the legend.",Correlogram,BASICS,Correlation +1180,Top-N Loading Arrows with Multi-Level Confidence Ellipses,https://openbiox.github.io/Bizard/Correlation/PCAplot_files/figure-html/fig-9.1LoadingArrows-1.png,https://openbiox.github.io/Bizard/Correlation/PCAplot.html#fig-9.1LoadingArrows,PCA of a simulated 3-cancer panel (30 genes): arrows point along the top-3 contributing genes (loading x sqrt(eigenvalue) over PC1-PC2); each group carries nested 90% (dashed) and 95% (solid) confidence ellipses.,PCA Plot,BASICS,Correlation +1181,Reference-Line Bars and Diverging Gray/Colored Bars,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-11.1ResponseBars-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-11.1ResponseBars,"Waterfall of simulated best tumour-response by type: one colour per type, dashed RECIST reference lines at -30/0/+20; the y axis is clipped at 50 and the towering bar carries its true value.",Bar Plot,BASICS,Ranking +1182,Reference-Line Bars and Diverging Gray/Colored Bars,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-11.2DivergingBars-1.png,https://openbiox.github.io/Bizard/Ranking/BarPlot.html#fig-11.2DivergingBars,"Diverging GSVA-style t-value bars (endothelial cells, tumour vs non-malignant, simulated): bars beyond |t| = 4 are coloured by direction, the rest gray; names sit beside each bar.",Bar Plot,BASICS,Ranking +1183,Signal Tracks Around a Gene Without Gviz (ggplot2 Recreation),https://openbiox.github.io/Bizard/Omics/ChromosomePlot_files/figure-html/fig-12.1GenomeTracks-1.png,https://openbiox.github.io/Bizard/Omics/ChromosomePlot.html#fig-12.1GenomeTracks,IGV-style signal tracks around a target gene (simulated bigWig bins): four coverage facets plus a dedicated gene-model track with exon rectangles on the intron line; x axis in kilobases.,Chromosome Plot,OMICS,ChromosomePlot +1184,01-Matrix Oncoprint Split by Pathway with Clinical Annotation,https://openbiox.github.io/Bizard/Omics/MutationOncoplot_files/figure-html/fig-11.1PathwayOncoprint-1.png,https://openbiox.github.io/Bizard/Omics/MutationOncoplot.html#fig-11.1PathwayOncoprint,"01-matrix oncoprint of 12 genes in 40 simulated samples: rows split by pathway (RTK/RAS, PI3K, p53/cell cycle), green = mutated, bottom annotation rows carry smoking, stage and treatment; the top barplot counts mutations per sample.",Mutation Landscape Oncoplot,OMICS,MutationOncoplot +1185,The Metagene Profile: One Line per Sample Across Ordered Windows,https://openbiox.github.io/Bizard/Ranking/Parallel_files/figure-html/fig-3.1Metagene-1.png,https://openbiox.github.io/Bizard/Ranking/Parallel.html#fig-3.1Metagene,"Metagene profile over 3,000 simulated genes: mean tag density across 100-bp upstream windows, the compressed gene body and 3-kb downstream windows, one line per sample (IP vs Input); dashed lines mark TSS and TTS.",Parallel Coordinates Plot,BASICS,Ranking +1186,Repelled Labels and Per-Chromosome Colour (ggplot2),https://openbiox.github.io/Bizard/Omics/ManhattanPlot_files/figure-html/fig-3.1ManhattanRepel-1.png,https://openbiox.github.io/Bizard/Omics/ManhattanPlot.html#fig-3.1ManhattanRepel,"Manhattan plot of 8 simulated chromosomes (2,500 SNPs each): red threshold at -log10(P) = 5, points above it enlarged and labeled with gene + rs-ID via ggrepel; alternating chromosome colours.",Manhattan Plot,OMICS,ManhattanPlot +1187,Gene-Concept Circular Network (GOplot-Style),https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot_files/figure-html/fig-5.1GeneConceptNet-1.png,https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot.html#fig-5.1GeneConceptNet,"Gene-concept network of 3 top enriched BP terms (clusterProfiler + enrichplot): term hubs sized by member count, gene nodes coloured by log2 fold change (blue = up, red = down); simulated IFN-gamma response gene set.",Text-Overlaid Enrichment Barplot,OMICS,TextEnrichmentBarPlot +1188,The Optimal-Split Landscape for One Marker,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.5SplitLandscape-1.png,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot.html#fig-3.5SplitLandscape,The split landscape of one simulated marker (200 samples): log-rank p-value and HR at every possible dichotomisation; dashed lines at p = 0.05 and HR = 2 / 0.5; the minimum-p split is highlighted.,Kaplan Meier Plot,CLINICS,KaplanMeierPlot +1189,The Optimal-Split Landscape for One Marker,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.6SplitKMs-1.png,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot.html#fig-3.6SplitKMs,KM curves of the same marker dichotomised two ways: the min-P split (left) versus the median split (right); the difference in reported p-values is the optimism the landscape warns about.,Kaplan Meier Plot,CLINICS,KaplanMeierPlot +1190,Pan-Cancer Boxplot with Per-Tissue Significance (FigureYa55plus),https://openbiox.github.io/Bizard/Distribution/BoxPlot_files/figure-html/fig-4.1PanCancerBox-1.png,https://openbiox.github.io/Bizard/Distribution/BoxPlot.html#fig-4.1PanCancerBox,Pan-cancer boxplot of the simulated TP53-like matrix: jittered points over tumour/normal boxes per tissue; stars above each tissue are per-tissue Wilcoxon tests.,Box Plot,BASICS,Distribution +1191,Pan-Cancer Split Violin with Quartile Marks (FigureYa55panCancerviolinV2),https://openbiox.github.io/Bizard/Distribution/ViolinPlot_files/figure-html/fig-5.1PanCancerSplit-1.png,https://openbiox.github.io/Bizard/Distribution/ViolinPlot.html#fig-5.1PanCancerSplit,"Pan-cancer split violin of a simulated TP53-like TPM matrix across 10 tissues: tumour (right, red) vs matched normal (left, yellow); dashes = quartiles per half; stars = per-tissue Wilcoxon tests (***: p < 0.001).",Violin Plot,BASICS,Distribution +1192,"One Sample, Many Region Classes: the Single-bigWig Profile",https://openbiox.github.io/Bizard/Ranking/Parallel_files/figure-html/fig-4.1RegionProfile-1.png,https://openbiox.github.io/Bizard/Ranking/Parallel.html#fig-4.1RegionProfile,"Single-sample metagene profile by promoter class (simulated): mean H3K4me3 density over TSS +-2 kb for high- (HCP), intermediate- (ICP) and low-CpG (LCP) promoters; dashed lines mark TSS and the gene-body end.",Parallel Coordinates Plot,BASICS,Ranking +1193,"The Tiered ""Cool"" Volcano (FigureYa59volcanoV2)",https://openbiox.github.io/Bizard/Omics/VolcanoPlot_files/figure-html/fig-5.1TieredVolcano-1.png,https://openbiox.github.io/Bizard/Omics/VolcanoPlot.html#fig-5.1TieredVolcano,"Tiered volcano of 900 simulated events: nested gates at |logFC| = 1.5/2.5/5 and adjusted P = 0.05/1e-4/1e-5 drive colour darkness and point size; pathway-coloured, black-circled and labeled points are the validation picks.",Volcano Plot,OMICS,VolcanoPlot +1194,Bubble Grid: Motif P-Value Size × TF Expression Fill (FigureYa5bubbles),https://openbiox.github.io/Bizard/Correlation/Bubble_files/figure-html/fig-3.1MotifBubbles-1.png,https://openbiox.github.io/Bizard/Correlation/Bubble.html#fig-3.1MotifBubbles,"Bubble grid of 14 simulated motifs across 5 differentiation stages: dot size = -log10(P) of motif enrichment, fill = the TF's simulated FPKM; both clamped to the plotting range as in the reference.",Bubble Plot,BASICS,Correlation +1195,Mutation-Frequency Composition Across Three Subtypes (FigureYa64triangle),https://openbiox.github.io/Bizard/Correlation/TernaryPlot_files/figure-html/fig-4.1TernaryMut-1.png,https://openbiox.github.io/Bizard/Correlation/TernaryPlot.html#fig-4.1TernaryMut,"Ternary plot of 22 simulated mutations across pGBM/LGG/sGBM: axes are the within-mutation subtype frequency shares (sum = 1); dot size uses the reference's segmented scaling (10^f x 3 above 0.1, linear 50f below).",Ternary chart,BASICS,Correlation +1196,Double-Y-Axis Scatter with Two Correlations (FigureYa62twoAxis),https://openbiox.github.io/Bizard/DataOverTime/LineChart_files/figure-html/fig-13.1TwoAxis-1.png,https://openbiox.github.io/Bizard/DataOverTime/LineChart.html#fig-13.1TwoAxis,"Double-Y-axis scatter (simulated): miRNA expression (left axis, blue) and cg10586317 methylation beta (right axis, orange) vs mRNA expression; both with lm fits; the secondary variable is pre-scaled onto the primary axis; Pearson R annotated per series.",Line Chart,BASICS,Evolution +1197,clusterProfiler GSEA with the Ranked-List Curve (FigureYa60GSEAclusterProfilerV2),https://openbiox.github.io/Bizard/Omics/GseaPlot_files/figure-html/fig-9.1ClusterGSEA-1.png,https://openbiox.github.io/Bizard/Omics/GseaPlot.html#fig-9.1ClusterGSEA,"GSEA of 1,500 simulated ranked genes against GO TERM2GENE: running ES lines for the top 3 terms (immune-response term leads), gene-rank barcode and ranked-list metric below.",GSEA Running-Score Plot,OMICS,GseaPlot diff --git a/files/gallery_data_zh.csv b/files/gallery_data_zh.csv index 94fdb2ca3..38adf948c 100644 --- a/files/gallery_data_zh.csv +++ b/files/gallery_data_zh.csv @@ -1157,3 +1157,41 @@ Id,Name,Image_url,Tutorial_url,Description,Type,Level1,Level2 1157,突变报告 t-SNE:高亮图与特征条,https://openbiox.github.io/Bizard/Correlation/TSNEplot_files/figure-html/fig-5.1MutantReport-1.png,https://openbiox.github.io/Bizard/zh/Correlation/TSNEplot.html#fig-5.1MutantReport,论文版式 t-SNE 面板:100 个突变细胞在灰化群体中跳为黄色,该突变的报告基因与两个谱系标记基因以特征面板画于同一嵌入上。,t-SNE 图,BASICS,TSNEplot 1158,带多重集交集 p 值的韦恩图,https://openbiox.github.io/Bizard/Ranking/VennPlot_files/figure-html/fig-6.1MultisetP-1.png,https://openbiox.github.io/Bizard/zh/Ranking/VennPlot.html#fig-6.1MultisetP,三个 PDX 模型通路集合的韦恩图,下方印多重集交集精确检验:内建的 52 员核心使三重重叠远超独立抽样所能允许(P < 1e-30)。,韦恩图,BASICS,Ranking 1159,差异通讯差值圆图,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot_files/figure-html/fig-6.2DiffCircle-1.png,https://openbiox.github.io/Bizard/zh/Omics/CellChatCirclePlot.html#fig-6.2DiffCircle,同一 STIM-CTRL 差值矩阵的圆图视图:节点环宽按总通讯量缩放,弧形连线只画发生变化的配对(红=STIM 上调,蓝=CTRL 上调)。,细胞-细胞通讯网络圈图,OMICS,CellChatCirclePlot +1160,带 Wilcoxon 秩和检验 p 值的 ECDF,https://openbiox.github.io/Bizard/Distribution/ECDFPlot_files/figure-html/fig-5.1EcdfWilcox-1.png,https://openbiox.github.io/Bizard/zh/Distribution/ECDFPlot.html#fig-5.1EcdfWilcox,三组模拟 log2 倍数变化分布(各 n = 100):ECDF 标注相对 Non-targets 参照的双侧 Wilcoxon 秩和检验 p 值(CLIP targets P = 0.027,CLIP + RIP targets P < 0.001)。,ECDF 图,BASICS,Distribution +1161,细胞类型比例柱形图 + 分簇 Fisher 事后检验,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-9.1CellPropSig-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-9.1CellPropSig,各簇细胞组成(WT 与 KO,模拟数据)。星号为各簇 BH 校正后的 one-vs-rest Fisher 检验;对完整表的整体 Fisher 精确检验 p < 0.0001(Monte-Carlo,B = 10^5)。,条形图,BASICS,Ranking +1162,细胞类型比例柱形图 + 分簇 Fisher 事后检验,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-9.2CellPropRep-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-9.2CellPropRep,按测序重复分面的同一组成图:耗竭(C2)与富集(C6)在两批间保持一致。,条形图,BASICS,Ranking +1163,渐变填充柱形图(ggpattern),https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-10.1RadialGradient-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-10.1RadialGradient,径向渐变柱:深色的转移癌区段承载白色百分比标签;数值为模拟的患病率数据。,条形图,BASICS,Ranking +1164,渐变填充柱形图(ggpattern),https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-10.2HorizontalGradient-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-10.2HorizontalGradient,水平渐变柱:由镜像的左右两半拼装,区段带黑色描边(ggpattern)。,条形图,BASICS,Ranking +1165,多组间的两两 log-rank 比较,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-2.3pairwise-1.png,https://openbiox.github.io/Bizard/zh/Clinics/KaplanMeierPlot.html#fig-2.3pairwise,五分层 KM 曲线 + 风险表;左下表格为 Holm 校正的两两 log-rank p 值(列为组、行为组),总体 log-rank 检验 p < 0.001。,KM 曲线,CLINICS,KaplanMeierPlot +1166,10 亚型质心热图 + signature 评分注释(PAM50 风格),https://openbiox.github.io/Bizard/Correlation/Heatmap_files/figure-html/fig-4.10SubtypeCentroid-1.png,https://openbiox.github.io/Bizard/zh/Correlation/Heatmap.html#fig-4.10SubtypeCentroid,亚型质心热图(50 个模拟 PAM50 风格基因,60 个样本):样本按最近质心预测排序分块;顶部注释为亚型判定、两条 signature 评分线(AR 样:Basal 高;增殖:LumB 高)与 AR 表型。,热图,BASICS,Correlation +1167,两组差异通讯的边捆弦图,https://openbiox.github.io/Bizard/Omics/CellChatCirclePlot_files/figure-html/fig-7.1CPDBBundle-1.png,https://openbiox.github.io/Bizard/zh/Omics/CellChatCirclePlot.html#fig-7.1CPDBBundle,差异配体-受体通讯的边捆弦图(ggraph):每细胞类型一条径向树臂,捆束按配体 log2 倍数变化着色(红 = STIM 上调),叶节点大小 = 表达比例,空心 = 配体,实心 = 受体。,细胞-细胞通讯网络圈图,OMICS,CellChatCirclePlot +1168,从表达聚类到基因家族:热图 + 进化树 + 多序列比对,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.1FamilyHeatmap-1.png,https://openbiox.github.io/Bizard/zh/Omics/MultiSeqsAlignment.html#fig-4.1FamilyHeatmap,模拟 12 成员家族的表达热图(行 z-score,完全连锁):两个共表达块对应两个亚家族。,多序列比对可视化,OMICS,MultiSeqsAlignment +1169,从表达聚类到基因家族:热图 + 进化树 + 多序列比对,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.2FamilyAlignment-1.png,https://openbiox.github.io/Bizard/zh/Omics/MultiSeqsAlignment.html#fig-4.2FamilyAlignment,12 个家族成员的前 60 个比对位置(ggmsa,Chemistry_AA 配色):每个亚家族携带共享的诊断性替换与各自的私有替换。,多序列比对可视化,OMICS,MultiSeqsAlignment +1170,从表达聚类到基因家族:热图 + 进化树 + 多序列比对,https://openbiox.github.io/Bizard/Omics/MultiSeqsAlignment_files/figure-html/fig-4.3FamilyTree-1.png,https://openbiox.github.io/Bizard/zh/Omics/MultiSeqsAlignment.html#fig-4.3FamilyTree,由配对序列一致率距离构建的邻接树(ggtree):两个进化枝与热图的两个表达块对应。,多序列比对可视化,OMICS,MultiSeqsAlignment +1171,校准诺莫图,https://openbiox.github.io/Bizard/Clinics/Nomogram_files/figure-html/fig-3.1Calibration3y-1.png,https://openbiox.github.io/Bizard/zh/Clinics/Nomogram.html#fig-3.1Calibration3y,Cox 诺莫图 3 年(u = 1095 天)的 bootstrap 校准:表观(×)与偏差校正(•)生存相对 45° 理想线。,诺莫图,CLINICS,Nomogram +1172,校准诺莫图,https://openbiox.github.io/Bizard/Clinics/Nomogram_files/figure-html/fig-3.2Calibration5y-1.png,https://openbiox.github.io/Bizard/zh/Clinics/Nomogram.html#fig-3.2Calibration5y,Cox 诺莫图 5 年(u = 1825 天)的 bootstrap 校准:模型在 bootstrap 误差条内贴合理想线。,诺莫图,CLINICS,Nomogram +1173,圆环评分对比 + 突出病例(circlize),https://openbiox.github.io/Bizard/Proportion/ChordDiagram_files/figure-html/fig-5.1CircularScores-1.png,https://openbiox.github.io/Bizard/zh/Proportion/ChordDiagram.html#fig-5.1CircularScores,双环评分对比(circlize):外环 800 个模拟肿瘤样本、内环 120 个正常样本,灰色径向线 = 组中位数,红色指针 = 目标患者评分 20。,和弦图,BASICS,Proportion +1174,跨细胞类型的通路活性差异点图,https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot_files/figure-html/fig-4.1PathwayDEDot-1.png,https://openbiox.github.io/Bizard/zh/Omics/TextEnrichmentBarPlot.html#fig-4.1PathwayDEDot,通路活性差异点图(12 通路 × 4 细胞类型):点大小 = Bonferroni-FDR 分档,颜色 = 活性得分 log2 倍数变化;底部色条把通路分为 Immune / Metabolism / Signaling / Proliferation。,文字叠加的富集分析柱状图,OMICS,TextEnrichmentBarPlot +1175,小效应量筛选的尺寸编码火山图(PDUI 风格),https://openbiox.github.io/Bizard/Omics/VolcanoPlot_files/figure-html/fig-4.1PduiVolcano-1.png,https://openbiox.github.io/Bizard/zh/Omics/VolcanoPlot.html#fig-4.1PduiVolcano,模拟 3'UTR 使用(PDUI)事件的尺寸编码火山图:颜色 = 方向阈值(|ΔPDUI| > 0.05 且校正 P < 0.1),点大小 = |ΔPDUI × -log10 P|;两侧最强的偏移事件带标签。,火山图,OMICS,VolcanoPlot +1176,一个 horizon 上的多模型比较:获益与避免过度干预,https://openbiox.github.io/Bizard/Clinics/DCAPlot_files/figure-html/fig-5.1FourModelDCA-1.png,https://openbiox.github.io/Bizard/zh/Clinics/DCAPlot.html#fig-5.1FourModelDCA,四个风险模型在 2 年 horizon 的决策曲线(模拟队列,n = 500):相对 treat-all 与 treat-none 默认策略的净获益。,决策曲线分析,CLINICS,DCAPlot +1177,一个 horizon 上的多模型比较:获益与避免过度干预,https://openbiox.github.io/Bizard/Clinics/DCAPlot_files/figure-html/fig-5.2FourModelNIA-1.png,https://openbiox.github.io/Bizard/zh/Clinics/DCAPlot.html#fig-5.2FourModelNIA,同一四个模型每 100 名患者避免的干预数:模型的价值在于同等漏检下能省下多少 treat-all 干预。,决策曲线分析,CLINICS,DCAPlot +1178,批量最优截断值(最佳分离),https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.4BestSeparation-1.png,https://openbiox.github.io/Bizard/zh/Clinics/KaplanMeierPlot.html#fig-3.4BestSeparation,8 个模拟标志物的批量最佳分离筛选:对最大化 log-rank p 通过 0.05 的标志物绘制 KM 曲线,面板内打印最优截断值、各组 n、HR 与 95% CI。,KM 曲线,CLINICS,KaplanMeierPlot +1179,环形相关弦图(circlize),https://openbiox.github.io/Bizard/Correlation/Correlogram_files/figure-html/fig-6.1CorrChord-1.png,https://openbiox.github.io/Bizard/zh/Correlation/Correlogram.html#fig-6.1CorrChord,10 个模拟基因中最强 16 对的 Spearman 相关弦图:基因弧用 d3 配色,连线宽度 = |cor|,颜色 = 带符号系数(绿 = 负、红 = 正),底部渐变条即图例。,相关图,BASICS,Correlation +1180,Top-N 载荷箭头 + 多层置信椭圆,https://openbiox.github.io/Bizard/Correlation/PCAplot_files/figure-html/fig-9.1LoadingArrows-1.png,https://openbiox.github.io/Bizard/zh/Correlation/PCAplot.html#fig-9.1LoadingArrows,模拟三癌种面板(30 基因)的 PCA:箭头指向贡献前三的基因(PC1-PC2 上的载荷 × sqrt(特征值));每组带嵌套的 90%(虚线)与 95%(实线)置信椭圆。,PCA图,BASICS,Correlation +1181,参考线柱形图与发散式灰/彩柱形图,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-11.1ResponseBars-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-11.1ResponseBars,模拟的各癌种最佳肿瘤响应瀑布图:每癌种一色,-30/0/+20 处的 RECIST 虚线参考线;y 轴截断于 50,超出的柱标注真实值。,条形图,BASICS,Ranking +1182,参考线柱形图与发散式灰/彩柱形图,https://openbiox.github.io/Bizard/Ranking/BarPlot_files/figure-html/fig-11.2DivergingBars-1.png,https://openbiox.github.io/Bizard/zh/Ranking/BarPlot.html#fig-11.2DivergingBars,发散式 GSVA 风格 t 值柱(内皮细胞,肿瘤 vs 非肿瘤,模拟):超过 |t| = 4 的柱按方向着色,其余灰色;名字贴在柱旁。,条形图,BASICS,Ranking +1183,无 Gviz 的基因周边信号轨道(ggplot2 复现),https://openbiox.github.io/Bizard/Omics/ChromosomePlot_files/figure-html/fig-12.1GenomeTracks-1.png,https://openbiox.github.io/Bizard/zh/Omics/ChromosomePlot.html#fig-12.1GenomeTracks,目标基因周边的 IGV 风格信号轨道(模拟 bigWig 分箱):四个覆盖度分面加一个专属基因模型轨道(内含子线上的外显子矩形);x 轴以 kb 计。,染色体图,OMICS,ChromosomePlot +1184,01 矩阵 oncoprint:按通路拆分 + 临床注释,https://openbiox.github.io/Bizard/Omics/MutationOncoplot_files/figure-html/fig-11.1PathwayOncoprint-1.png,https://openbiox.github.io/Bizard/zh/Omics/MutationOncoplot.html#fig-11.1PathwayOncoprint,40 个模拟样本中 12 个基因的 01 矩阵 oncoprint:行按通路拆分(RTK/RAS、PI3K、p53/cell cycle),绿色 = 突变,底部注释行携带吸烟、分期与治疗;顶栏统计每样本突变数。,基因突变全景瀑布图,OMICS,MutationOncoplot +1185,元基因剖面:有序窗口上每样本一条线,https://openbiox.github.io/Bizard/Ranking/Parallel_files/figure-html/fig-3.1Metagene-1.png,https://openbiox.github.io/Bizard/zh/Ranking/Parallel.html#fig-3.1Metagene,"3,000 个模拟基因的元基因剖面:100-bp 上游窗口、压缩基因体与 3-kb 下游窗口的平均 tag 密度,每样本一条线(IP vs Input);虚线标记 TSS 与 TTS。",平行坐标图,BASICS,Ranking +1186,避让标签与逐染色体配色(ggplot2),https://openbiox.github.io/Bizard/Omics/ManhattanPlot_files/figure-html/fig-3.1ManhattanRepel-1.png,https://openbiox.github.io/Bizard/zh/Omics/ManhattanPlot.html#fig-3.1ManhattanRepel,"8 条模拟染色体(每条 2,500 个 SNP)的曼哈顿图:-log10(P) = 5 处红色阈值线,线上点放大并用 ggrepel 标注基因 + rs 号;染色体交替配色。",曼哈顿图,OMICS,ManhattanPlot +1187,基因-概念环形网络(GOplot 风格),https://openbiox.github.io/Bizard/Omics/TextEnrichmentBarPlot_files/figure-html/fig-5.1GeneConceptNet-1.png,https://openbiox.github.io/Bizard/zh/Omics/TextEnrichmentBarPlot.html#fig-5.1GeneConceptNet,3 个 top 富集 BP 通路的基因-概念网络(clusterProfiler + enrichplot):通路枢纽节点大小 = 成员数,基因节点按 log2 倍数变化着色(蓝 = 上调、红 = 下调);模拟的 IFN-γ 响应基因集。,文字叠加的富集分析柱状图,OMICS,TextEnrichmentBarPlot +1188,单标志物的最优分离景观图,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.5SplitLandscape-1.png,https://openbiox.github.io/Bizard/zh/Clinics/KaplanMeierPlot.html#fig-3.5SplitLandscape,单标志物的切分景观图(200 样本):每个可能的二分方式的 log-rank p 值与 HR;虚线在 p = 0.05 与 HR = 2 / 0.5;最小 p 切分已高亮。,KM 曲线,CLINICS,KaplanMeierPlot +1189,单标志物的最优分离景观图,https://openbiox.github.io/Bizard/Clinics/KaplanMeierPlot_files/figure-html/fig-3.6SplitKMs-1.png,https://openbiox.github.io/Bizard/zh/Clinics/KaplanMeierPlot.html#fig-3.6SplitKMs,同一标志物两种二分方式的 KM 曲线:min-P 切分(左)与中位数切分(右);两者 p 值之差就是景观图警示的乐观量。,KM 曲线,CLINICS,KaplanMeierPlot +1190,泛癌箱线图 + 逐组织显著性(FigureYa55plus),https://openbiox.github.io/Bizard/Distribution/BoxPlot_files/figure-html/fig-4.1PanCancerBox-1.png,https://openbiox.github.io/Bizard/zh/Distribution/BoxPlot.html#fig-4.1PanCancerBox,模拟 TP53 样矩阵的泛癌箱线图:逐组织肿瘤/正常箱体叠加抖动点;各组织上方星号为逐组织 Wilcoxon 检验。,箱线图,BASICS,Distribution +1191,泛癌分半小提琴 + 四分位标记(FigureYa55panCancerviolinV2),https://openbiox.github.io/Bizard/Distribution/ViolinPlot_files/figure-html/fig-5.1PanCancerSplit-1.png,https://openbiox.github.io/Bizard/zh/Distribution/ViolinPlot.html#fig-5.1PanCancerSplit,模拟 TP53 样 TPM 矩阵在 10 个组织上的泛癌分半小提琴:肿瘤(右、红)vs 匹配正常(左、黄);横杠 = 各半区四分位数;星号 = 逐组织 Wilcoxon 检验(***: p < 0.001)。,小提琴图,BASICS,Distribution +1192,单样本、多区域类别:单 bigWig 剖面图,https://openbiox.github.io/Bizard/Ranking/Parallel_files/figure-html/fig-4.1RegionProfile-1.png,https://openbiox.github.io/Bizard/zh/Ranking/Parallel.html#fig-4.1RegionProfile,按启动子类别的单样本元基因剖面(模拟):高(HCP)、中(ICP)、低 CpG(LCP)启动子在 TSS ±2 kb 的平均 H3K4me3 密度;虚线标记 TSS 与基因体末端。,平行坐标图,BASICS,Ranking +1193,"分层""酷炫""火山图(FigureYa59volcanoV2)",https://openbiox.github.io/Bizard/Omics/VolcanoPlot_files/figure-html/fig-5.1TieredVolcano-1.png,https://openbiox.github.io/Bizard/zh/Omics/VolcanoPlot.html#fig-5.1TieredVolcano,900 个模拟事件的分层火山图:|logFC| = 1.5/2.5/5 与校正 P = 0.05/1e-4/1e-5 的嵌套门槛决定颜色深浅与点大小;按通路着色、黑圈、带标签的点为验证候选。,火山图,OMICS,VolcanoPlot +1194,气泡网格:motif P 值作大小 × TF 表达作填充(FigureYa5bubbles),https://openbiox.github.io/Bizard/Correlation/Bubble_files/figure-html/fig-3.1MotifBubbles-1.png,https://openbiox.github.io/Bizard/zh/Correlation/Bubble.html#fig-3.1MotifBubbles,14 个模拟 motif 在 5 个分化阶段的气泡网格:点大小 = motif 富集 -log10(P),填充 = TF 的模拟 FPKM;两者均按参考做法截断到作图范围。,气泡图,BASICS,Correlation +1195,三个亚型间的突变频率构成(FigureYa64triangle),https://openbiox.github.io/Bizard/Correlation/TernaryPlot_files/figure-html/fig-4.1TernaryMut-1.png,https://openbiox.github.io/Bizard/zh/Correlation/TernaryPlot.html#fig-4.1TernaryMut,22 个模拟突变在 pGBM/LGG/sGBM 上的三元图:轴为突变内亚型频率占比(和 = 1);点大小采用参考的分段缩放(0.1 以上用 10^f × 3,以下线性 50f)。,三元图,BASICS,Correlation +1196,双 Y 轴散点与两组相关(FigureYa62twoAxis),https://openbiox.github.io/Bizard/DataOverTime/LineChart_files/figure-html/fig-13.1TwoAxis-1.png,https://openbiox.github.io/Bizard/zh/DataOverTime/LineChart.html#fig-13.1TwoAxis,双 Y 轴散点(模拟):miRNA 表达(左轴、蓝)与 cg10586317 甲基化 beta(右轴、橙)对 mRNA 表达;均带 lm 拟合线;次轴变量已预缩放到主轴;两系列分别标注 Pearson R。,线性图,BASICS,Evolution +1197,clusterProfiler GSEA 与排序列表曲线(FigureYa60GSEAclusterProfilerV2),https://openbiox.github.io/Bizard/Omics/GseaPlot_files/figure-html/fig-9.1ClusterGSEA-1.png,https://openbiox.github.io/Bizard/zh/Omics/GseaPlot.html#fig-9.1ClusterGSEA,"1,500 个模拟排序基因对 GO TERM2GENE 的 GSEA:top 3 通路的运行 ES 线(免疫应答通路领先),下方为基因排序条码与排序列表度量。",GSEA 运行得分图,OMICS,GseaPlot