From 39ae9196e9ec479ff31d127cb792683425023f31 Mon Sep 17 00:00:00 2001 From: Bruno Ariano Date: Sat, 16 May 2026 13:28:09 +0200 Subject: [PATCH] Latest modifiactions from Nicole suggestions --- .DS_Store | Bin 0 -> 6148 bytes R/00_text_style.R | 46 +++++++ R/10_plot_ref.R | 11 +- R/11_plot_beta.R | 22 +++- R/12_plot_zscore.R | 2 +- R/13_plot_zoom.R | 10 +- R/14_plot_locuszoom.R | 119 ++++++++++++++----- plot_umap_simplified_multimodules_one_side.R | 82 ++++++++++--- 8 files changed, 236 insertions(+), 56 deletions(-) create mode 100644 .DS_Store create mode 100644 R/00_text_style.R diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..60a4005204d671b56d8540113c80e5bd5d4508e8 GIT binary patch literal 6148 zcmeHKK~BRk5FD2xS~$=n$2_2l#1BH19yo9*4=A(=s3K_!Z6)B8JAdE{ypI#i+E&yg za6<^8U1>e*^^ToPqBsU%M%&~R7y#(e1v`BRcqoe zDj?795HSkOamS}tJ-_p;n9s6e#&LN$&gkKXHAcWOYag*;{WX~zOz}+5*oIi)slk40 zu!pS4xTf&7$T`P~(VA~gZbugOElQCvo3kQgrHmEKNH1mWl)WV*$4eN6nAF!bFO79g ztKz*;(Z>X1-ffHvV#qa<`kbBH24g@CQrz>p7BWN$>HI^Qb!x})SitK@#j zXjF=7yOr#!sRF8iD)1u;aL*R&9XZri6;K6Kfl2}SJ_K~Z$YbfyemdCLBLK0>v^B=^ zyC|H%W8|@P$Pt=xRHCCAf5b43&V1nOB9Em*M~Cr;593!h{)A%e>YP8Ykef9AAf)TuamT=3aA4AN&(Z2FXIt!$?vVLo0GjZpkL9&q^@*WQ5e{*n6 0 - x_min_bp <- min(df$POS); x_max_bp <- max(df$POS) + x_min_bp <- suppressWarnings(min(as.numeric(df$POS), na.rm = TRUE)) + x_max_bp <- suppressWarnings(max(as.numeric(df$POS), na.rm = TRUE)) # context: widen x-axis with focal eGene + all genes in genes_df (GTF). # snp: min/max association POS only (still adds small pad below). if (identical(xlim_mode, "context")) { if (has_focal) { - x_min_bp <- min(x_min_bp, as.numeric(locus_info$gene_start)) - x_max_bp <- max(x_max_bp, as.numeric(locus_info$gene_end)) + gs <- suppressWarnings(as.numeric(locus_info$gene_start)) + ge <- suppressWarnings(as.numeric(locus_info$gene_end)) + if (is.finite(gs)) x_min_bp <- min(x_min_bp, gs) + if (is.finite(ge)) x_max_bp <- max(x_max_bp, ge) } if (has_many) { - x_min_bp <- min(x_min_bp, min(genes_df$start)) - x_max_bp <- max(x_max_bp, max(genes_df$end)) + g_starts <- suppressWarnings(as.numeric(genes_df$start)) + g_ends <- suppressWarnings(as.numeric(genes_df$end)) + g_starts <- g_starts[is.finite(g_starts)] + g_ends <- g_ends[is.finite(g_ends)] + if (length(g_starts) > 0L) x_min_bp <- min(x_min_bp, min(g_starts)) + if (length(g_ends) > 0L) x_max_bp <- max(x_max_bp, max(g_ends)) } } + if (!is.finite(x_min_bp) || !is.finite(x_max_bp) || x_max_bp < x_min_bp) { + cat(sprintf("Warning: cannot derive a numeric x-range for %s; skipping LocusZoom panel.\n", lz_file)) + return(plot_spacer()) + } pad <- max((x_max_bp - x_min_bp) * 0.02, 1) x_lims_mb <- c((x_min_bp - pad) / 1e6, (x_max_bp + pad) / 1e6) y_max <- max(df$logp, na.rm = TRUE) * 1.15 @@ -179,7 +199,7 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", if (!is.null(ld_vec)) { # One point size for every SNP; only fill reflects LD bin. Draw # lower-LD points first so warmer colours sit on top. - PT_LZ <- 2.5 + PT_LZ <- 3.5 df_nonlead <- data.table::copy(df[is_lead == FALSE][order(as.integer(ld_bin), na.last = FALSE)]) # Invisible anchor layer: one off-screen point per bin so every LD @@ -210,17 +230,21 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", } else { p_main <- p_main + geom_point(shape = 21, fill = "#4F8EDC", color = "white", - size = 1.6, alpha = 0.85, stroke = 0.25) + size = 3.0, alpha = 0.85, stroke = 0.25) } p_main <- p_main + geom_point(data = df[is_lead == TRUE][1L], aes(x = POS / 1e6, y = logp), shape = 23, fill = "#8E24AA", color = "black", - size = 3.5, stroke = 0.6, inherit.aes = FALSE) + + size = 5.0, stroke = 0.6, inherit.aes = FALSE) + geom_text_repel(data = df[is_lead == TRUE][1L], aes(x = POS / 1e6, y = logp, label = lead_label), - size = 2.9, fontface = "bold", color = "#4A148C", - nudge_y = y_max * 0.08, segment.color = "#8E24AA", - min.segment.length = 0, box.padding = 0.3, + family = "Helvetica", fontface = "plain", + size = 6.5, color = "#4A148C", + # Push the label well clear of the diamond / SNP cloud so + # it doesn't get buried in the LZ panel. + nudge_y = y_max * 0.18, + segment.color = "#8E24AA", + min.segment.length = 0, box.padding = 0.45, inherit.aes = FALSE) + coord_cartesian(xlim = x_lims_mb, ylim = c(0, y_max)) + labs(title = title, x = NULL, y = expression(-log[10](italic(P)))) + @@ -259,6 +283,13 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", # us draw the top of the lines at the exact Mb position of the zoom # window while the bottom sits at the panel's full width -- where the # zoom panel starts. + # NOTE: build_zoom_connector() is intentionally label-less. We do NOT rely + # on theme_void() / axis.* = element_blank() to suppress text, because the + # outer `& big_helvetica_theme()` cascade later overrides those theme slots + # and would resurrect the default axis labels ("(lead_pos - zoom_window)/1e6" + # for x, "y" for y) plus tick text. Removing breaks at the SCALE level and + # setting labs(x=NULL, y=NULL, title=NULL, ...) survives the cascade because + # there are simply no breaks / labels to render. build_zoom_connector <- function() { ggplot() + geom_segment(aes(x = (lead_pos - zoom_window) / 1e6, @@ -271,9 +302,15 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", y = 1, yend = 0), linewidth = 0.55, color = "#8E24AA", linetype = "dashed", alpha = 0.75) + + scale_x_continuous(breaks = NULL, expand = c(0, 0)) + + scale_y_continuous(breaks = NULL, expand = c(0, 0)) + coord_cartesian(xlim = x_lims_mb, ylim = c(0, 1), expand = FALSE) + + labs(x = NULL, y = NULL, title = NULL, subtitle = NULL, caption = NULL) + theme_void() + - theme(plot.margin = margin(0, 5, 0, 5)) + theme(plot.margin = margin(0, 5, 0, 5), + panel.background = element_blank(), + plot.background = element_blank(), + legend.position = "none") } if (!has_focal && !has_many) { @@ -285,10 +322,13 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", if (is.null(p_zoom)) return(p_main) p_link <- if (include_zoom_connector) build_zoom_connector() else NULL zoom_h <- max(1.2, 0.6 * length(annotation_tracks) + 0.6) + # Bumped the main Manhattan weight (5 -> 9) so it dominates the LZ + # column. The previous ratio left p_main paper-thin once the gene track, + # connector and zoom panel each claimed their own row underneath. if (is.null(p_link)) - return(p_main / p_zoom + plot_layout(heights = c(5, zoom_h))) + return(p_main / p_zoom + plot_layout(heights = c(9, zoom_h))) return(p_main / p_link / p_zoom + - plot_layout(heights = c(5, 0.35, zoom_h))) + plot_layout(heights = c(9, 0.35, zoom_h))) } focal_sym <- if (!is.null(locus_info) && @@ -340,8 +380,9 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", length = unit(0.07, "inches"))) + geom_text_repel(aes(x = mid_mb_clip, y = lane + 0.35, label = gene_name, color = I(col), - fontface = ifelse(is_focal, "bold.italic", "italic")), - size = 2.8, + fontface = ifelse(is_focal, "italic", "italic")), + family = "Helvetica", + size = 3.5, direction = "y", nudge_y = 0.25, box.padding = 0.2, @@ -382,14 +423,15 @@ plot_locuszoom <- function(lz_file, locus_info = NULL, title = "LocusZoom", if (is.null(p_zoom)) { if (is.null(p_link)) { - return(p_main / p_gene + plot_layout(heights = c(5, gene_weight))) + # Manhattan gets weight 9 (was 5) so it dominates the LZ column. + return(p_main / p_gene + plot_layout(heights = c(9, gene_weight))) } return(p_main / p_gene / p_link + - plot_layout(heights = c(5, gene_weight, 0.35))) + plot_layout(heights = c(9, gene_weight, 0.35))) } zoom_h <- max(1.2, 0.6 * length(annotation_tracks) + 0.6) p_main / p_gene / p_link / p_zoom + - plot_layout(heights = c(5, gene_weight, 0.35, zoom_h)) + plot_layout(heights = c(9, gene_weight, 0.35, zoom_h)) } # plot_locuszoom_merged(): one LocusZoom panel with all credible sets overlaid, @@ -407,6 +449,12 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, xlim_mode = c("context", "snp")) { xlim_mode <- match.arg(xlim_mode) data.table::setDT(df) + df[, POS := suppressWarnings(as.numeric(POS))] + df <- df[is.finite(POS)] + if (nrow(df) == 0) { + cat("Warning: merged LocusZoom has no rows with a numeric POS column.\n") + return(patchwork::plot_spacer()) + } data.table::setorderv(df, c("CS", "logp"), c(1, -1)) df[, is_lead := (seq_len(.N) == 1L), by = CS] df[, cs_id := factor(as.character(CS), levels = sort(unique(as.character(CS))))] @@ -420,18 +468,28 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, !is.null(locus_info$gene_start) && !is.na(locus_info$gene_start) && !is.null(locus_info$gene_end) && !is.na(locus_info$gene_end) has_many <- !is.null(genes_df) && nrow(genes_df) > 0 - x_min_bp <- min(df$POS, na.rm = TRUE) - x_max_bp <- max(df$POS, na.rm = TRUE) + x_min_bp <- suppressWarnings(min(as.numeric(df$POS), na.rm = TRUE)) + x_max_bp <- suppressWarnings(max(as.numeric(df$POS), na.rm = TRUE)) if (identical(xlim_mode, "context")) { if (has_focal) { - x_min_bp <- min(x_min_bp, as.numeric(locus_info$gene_start)) - x_max_bp <- max(x_max_bp, as.numeric(locus_info$gene_end)) + gs <- suppressWarnings(as.numeric(locus_info$gene_start)) + ge <- suppressWarnings(as.numeric(locus_info$gene_end)) + if (is.finite(gs)) x_min_bp <- min(x_min_bp, gs) + if (is.finite(ge)) x_max_bp <- max(x_max_bp, ge) } if (has_many) { - x_min_bp <- min(x_min_bp, min(genes_df$start, na.rm = TRUE)) - x_max_bp <- max(x_max_bp, max(genes_df$end, na.rm = TRUE)) + g_starts <- suppressWarnings(as.numeric(genes_df$start)) + g_ends <- suppressWarnings(as.numeric(genes_df$end)) + g_starts <- g_starts[is.finite(g_starts)] + g_ends <- g_ends[is.finite(g_ends)] + if (length(g_starts) > 0L) x_min_bp <- min(x_min_bp, min(g_starts)) + if (length(g_ends) > 0L) x_max_bp <- max(x_max_bp, max(g_ends)) } } + if (!is.finite(x_min_bp) || !is.finite(x_max_bp) || x_max_bp < x_min_bp) { + cat("Warning: cannot derive a numeric x-range for merged LocusZoom; skipping.\n") + return(patchwork::plot_spacer()) + } pad <- max((x_max_bp - x_min_bp) * 0.02, 1) x_lims_mb <- c((x_min_bp - pad) / 1e6, (x_max_bp + pad) / 1e6) y_max <- max(df$logp, na.rm = TRUE) * 1.12 @@ -475,7 +533,7 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, ymin = 0, ymax = 1, fill = cs_f)) + ggplot2::geom_rect(color = "gray35", linewidth = 0.25) + ggplot2::geom_text(ggplot2::aes(x = (xmin_mb + xmax_mb) / 2, y = 0.5, label = lab), - size = 2.35, color = "black") + + family = "Helvetica", size = 4.0, color = "black") + ggplot2::scale_fill_manual(values = pal_named, drop = FALSE, guide = "none") + ggplot2::coord_cartesian(xlim = x_lims_mb, ylim = c(0, 1), expand = FALSE) + ggplot2::labs( @@ -493,7 +551,7 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, plot.margin = ggplot2::margin(0, 5, 4, 5)) if (!has_focal && !has_many) { - return(p_main / p_strip + patchwork::plot_layout(heights = c(5.2, 1.05))) + return(p_main / p_strip + patchwork::plot_layout(heights = c(9.0, 1.05))) } focal_sym <- if (!is.null(locus_info) && !is.null(locus_info$gene_symbol) && @@ -540,8 +598,9 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, length = grid::unit(0.07, "inches"))) + ggrepel::geom_text_repel(ggplot2::aes(x = mid_mb_clip, y = lane + 0.35, label = gene_name, color = I(col), - fontface = ifelse(is_focal, "bold.italic", "italic")), - size = 2.8, direction = "y", nudge_y = 0.25, + fontface = ifelse(is_focal, "italic", "italic")), + family = "Helvetica", + size = 3.5, direction = "y", nudge_y = 0.25, box.padding = 0.2, point.padding = 0.1, segment.size = 0.45, segment.alpha = 0.75, min.segment.length = 0, max.overlaps = Inf, seed = 42, @@ -561,5 +620,5 @@ plot_locuszoom_merged <- function(df, locus_info, title, genes_df, gene_weight <- max(1, min(n_lanes, 5)) p_main / p_gene / p_strip + - patchwork::plot_layout(heights = c(5.2, gene_weight, 1.05)) + patchwork::plot_layout(heights = c(9.0, gene_weight, 1.05)) } diff --git a/plot_umap_simplified_multimodules_one_side.R b/plot_umap_simplified_multimodules_one_side.R index 2713c79..a7b51d0 100644 --- a/plot_umap_simplified_multimodules_one_side.R +++ b/plot_umap_simplified_multimodules_one_side.R @@ -448,7 +448,7 @@ for (i in seq_len(n_items)) { snp_str <- sprintf("\n%s", disp_snp) pval_str <- "" } - lz_title <- paste0("LocusZoom (merged credible sets) | ", opt$name, + lz_title <- paste0("LocusZoom (merged credible sets)\n", opt$name, " | ", this_cell, " | ", this_sym, "\n[", mod_id, "]", snp_str, pval_str) @@ -636,8 +636,11 @@ for (i in seq_len(n_items)) { locus_info$chrom <- sub("^chr","", as.character(lz_peek$CHR[1]), ignore.case = TRUE) } - lz_title <- paste0("LocusZoom | ", opt$name, " | ", this_cell, " | ", - this_sym, "\n[", mod_id, "]") + # Wrap onto 3 short lines so the title fits inside the narrower + # LocusZoom column at the new (bigger) Helvetica font size. The + # pipe-separated form on a single line overflowed past the panel. + lz_title <- paste0("LocusZoom | ", opt$name, "\n", + this_cell, " | ", this_sym, "\n[", mod_id, "]") # Region for the gene track: union of SNP extents (filtered) + eGene body. genes_region <- NULL @@ -762,7 +765,7 @@ for (i in seq_len(n_items)) { module_plots[[length(module_plots) + 1]] <- plot_spacer() } if (has_z) { - z_title <- paste0("Coloc Z-Scores | ", this_cell, " | ", this_sym, + z_title <- paste0("Coloc Z-Scores\n", this_cell, " | ", this_sym, "\n[", mod_id, "]") module_plots[[length(module_plots) + 1]] <- build_zscore_column( z_tbl_mod, z_title, this_cs = this_cs) @@ -774,7 +777,22 @@ for (i in seq_len(n_items)) { n_cs_for_mod <- length(module_plots) %/% cols total_cs_rows <- total_cs_rows + n_cs_for_mod - cs_grid <- wrap_plots(module_plots, ncol = cols) + # Per-CS-row column widths: LocusZoom (when present) is rendered narrower + # than the other side panels (beta UMAP, Z-score) but with enough room for + # its multi-line title and gene track to lay out cleanly. The figure-wide + # plot_width below scales by sum(col_widths) so the other panels actually + # close the gap instead of leaving empty horizontal space (beta + z-score + # use coord_equal()/coord_fixed() and can't grow into the slack). + col_widths <- rep(1, cols) + if (has_lz) col_widths[1] <- 1.2 + cs_grid <- wrap_plots(module_plots, ncol = cols) + + patchwork::plot_layout(widths = col_widths) + # Apply the global Helvetica / large / plain text styling NOW, before + # wrap_elements() makes cs_grid atomic. `& theme()` does NOT propagate + # through wrap_elements(), so the final `final_plot & big_helvetica_theme()` + # at the bottom never reaches the LZ / beta / Z panels -- only the merged + # annotation box and (when shown) the reference UMAP. + cs_grid <- cs_grid & big_helvetica_theme(base_size = 18) # Merged, full-width annotation box for the whole module. if (!is.null(annotations_tbl) && !is.null(annotation_tracks) && @@ -799,12 +817,35 @@ for (i in seq_len(n_items)) { lab <- as.character(mod_master_snp_id) lab }) - # Heights: each CS row ~5 units, merged box ~2 units. Keeps the box - # readable without dominating the figure. Wrapping `cs_grid` with - # `wrap_elements()` keeps it atomic so `/` stacks two blocks rather - # than flattening the inner panels (which breaks when cols == 1). + # The merged annotation box was full-width before, which made it look + # disconnected from the LocusZoom even though they share the same + # genomic axis. Now we put it in a 1-row patchwork beside `plot_spacer()` + # blocks for the beta / Z columns and reuse the SAME col_widths, so the + # box visually anchors directly under the LocusZoom column. + # + # It also uses a slightly smaller base text size than the top panels + # since its column is narrower (text wraps better at ~14 pt). + merged_box <- merged_box + big_helvetica_theme(base_size = 14) + if (cols > 1L) { + merged_row_parts <- c(list(merged_box), + replicate(cols - 1L, patchwork::plot_spacer(), + simplify = FALSE)) + merged_row <- patchwork::wrap_plots(merged_row_parts, ncol = cols) + + patchwork::plot_layout(widths = col_widths) + } else { + merged_row <- merged_box + } + # Heights: each CS row ~5 units, merged box ~1.5 units (lowered from 2 + # so the top row keeps more vertical real-estate, since its panels are + # the larger / more information-dense ones). Wrapping `cs_grid` AND the + # merged row with `wrap_elements()` keeps each block atomic so `/` stacks + # them cleanly without flattening inner panels. + # merged_h bumped slightly (1.5 -> 2) so the y-axis track labels + # (promoter_flanking_region, open_chromatin_region, ...) don't end up + # stacked on top of each other now that the merged box is also + # narrower (LZ-column width only). merged_h <- 2 - composite <- wrap_elements(cs_grid) / merged_box + + composite <- wrap_elements(cs_grid) / wrap_elements(merged_row) + plot_layout(heights = c(n_cs_for_mod * 5, merged_h)) module_composites[[length(module_composites) + 1]] <- composite total_cs_rows <- total_cs_rows + (merged_h / 5) # ~0.4 row-equivalents @@ -822,18 +863,29 @@ grid_plot <- if (length(module_composites) == 1) { } n_rows <- max(1, total_cs_rows) +# Effective per-row width is the sum of col_widths (the LZ slot is 0.5, +# others are 1) -- not `cols` -- so when the LZ is halved the row shrinks +# accordingly instead of leaving empty horizontal space. +row_w <- sum(col_widths) if (show_ref) { p_ref <- plot_ref(merged, paste(opt$name, "Reference"), opt$join_col, opt$pt_size, use_raster) final_plot <- p_ref | grid_plot - final_plot <- final_plot + plot_layout(widths = c(1, cols)) - plot_width <- (cols + 1) * 6 + final_plot <- final_plot + plot_layout(widths = c(1, row_w)) + plot_width <- (row_w + 1) * 6 } else { final_plot <- grid_plot - plot_width <- cols * 6 + plot_width <- row_w * 6 } -base_height <- 4.5 -plot_height <- max(base_height * n_rows, 5) +# Bumped from 4.5 to 6 so the top row's panels (LZ, beta UMAP, Z-score) keep +# enough vertical room after the new bigger Helvetica titles + bigger axis text. +base_height <- 6 +plot_height <- max(base_height * n_rows, 6) + +# Helvetica / large / plain text on the outer patchwork. This reaches the +# merged annotation box and (when present) the reference UMAP. The inner +# LZ / beta / Z grid was already styled above before wrap_elements(). +final_plot <- final_plot & big_helvetica_theme(base_size = 18) # --- Save Logic --- out_base <- sub("\\.png$|\\.pdf$", "", opt$out, ignore.case = TRUE)