Skip to content

Side by side page fixes. #12

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
rroutsong merged 2 commits into from
Jun 29, 2026
Merged

Side by side page fixes. #12

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
a8c8e18
feat: usability and bug fixes for side by side spatial page
rroutsong Jun 24, 2026
6fbc8ed
fix: remove expression filter on side x side page
rroutsong Jun 26, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
62 changes: 33 additions & 29 deletions R/writer0.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -167,8 +167,9 @@ wrShFunc <- function() {
' xlab(paste0(inpdr,"1")) + ylab(paste0(inpdr,"2")) + \n',
' sctheme(base_size = inpfsz, XYval = inptxt) \n',
' if(ggCont){{ \n',
' ggOut = ggOut + scale_color_gradientn(paste0(inp1, " "), colours = inpcol) + \n',
' guides(color = guide_colorbar(barwidth = 15)) \n',
' ggOut = ggOut + scale_color_gradientn(paste0(inp1, " "), colours = inpcol) +\n',
' guides(color = guide_colorbar(barwidth = 15)) +\n',
' theme(legend.text = element_text(angle = 45, hjust = 1)) \n',
' }} else {{ \n',
' legfsz = min(nchar(paste0(levels(ggData$val), collapse = "")), 200) \n',
' legfsz = 0.75 * (inpfsz - (1.5 * floor(legfsz/50))) \n',
Expand Down Expand Up @@ -322,7 +323,7 @@ wrShFunc <- function() {
' if(ggCont1 == TRUE & ggCont2 == TRUE){{ \n',
' # Both cont: Scatter plot \n',
' ggOut <- ggplot(ggData, aes(val1, val2)) + \n',
' geom_point() + sctheme(base_size = inpfsz) + xlab(inp1) + ylab(inp2) \n',
' geom_point() + sctheme(base_size = inpfsz, Xang = 45, XjusH = 1) + xlab(inp1) + ylab(inp2) \n',
' }} else if(ggCont1 == FALSE & ggCont2 == FALSE){{ \n',
' # Both cate: Confusion matrix \n',
' allCombi <- CJ(val1 = unique(ggData$val1), val2 = unique(ggData$val2)) \n',
Expand All @@ -332,8 +333,9 @@ wrShFunc <- function() {
' ggOut <- ggplot(ggData, aes(val1, val2, fill = N, label = N)) + \n',
' geom_tile(color = "white") + geom_text(size = inpfsz/5) + \n',
' scale_fill_gradient(low = "white", high = "steelblue") + \n',
' theme_minimal(base_size = inpfsz) + xlab(inp1) + ylab(inp2) + \n',
' theme(axis.text.x = element_text(angle = 45, hjust = 1)) + \n',
' theme_minimal(base_size = inpfsz) + xlab(inp1) + ylab(inp2) +\n',
' theme(axis.text.x = element_text(angle = 45, hjust = 1),\n',
' legend.text = element_text(angle = 45, hjust = 1)) +\n',
' ggtitle("Confusion matrix") \n',
' }} else {{ \n',
' # Cate-cont: Ask user to use VlnBoxP directly! \n',
Expand All @@ -347,7 +349,7 @@ wrShFunc <- function() {
'# Plot X/Y relationship (either confusion matrix or scatter plot) \n',
'sc2Dcnum <- function(inpConf, inpMeta, inp1, inp2, inpH5, inpGene, \n',
' inpDtyp1, inpDtyp2, inpsub1, inpsub2, \n',
' inpmin1, inpmax1, inpmin2, inpmax2, inpcut = 0){{ \n',
' inpmin1, inpmax1, inpmin2, inpmax2){{ \n',
' # Tidy inputs \n',
' inpDtyp1 = gsub("^Assay: ", "", inpDtyp1) \n',
' inpDtyp2 = gsub("^Assay: ", "", inpDtyp2) \n',
Expand Down Expand Up @@ -416,15 +418,17 @@ wrShFunc <- function() {
' # Both cont: Pearson / Spearman corr \n',
' ggP <- round(cor(ggData$val1, ggData$val2, method = "pearson"), 6) \n',
' ggS <- round(cor(ggData$val1, ggData$val2, method = "spearman"), 6) \n',
' ggK <- round(cor(ggData$val1, ggData$val2, method = "kendall"), 6) \n',
' # Kendall correlation is O(n^2) and extremely slow on large datasets\n',
' # (~150s for ~95k cells); disabled for performance.\n',
' # ggK <- round(cor(ggData$val1, ggData$val2, method = "kendall"), 6) \n',
' ggModel <- lm(val2 ~ val1, data = ggData)\n',
' ggCoeff <- signif(coef(ggModel), 6)\n',
' ggData = data.table(measures = c("Pearson Corr.",\n',
' "Spearman Corr.",\n',
' "Kendall Corr.",\n',
' # "Kendall Corr.",\n',
' "LM (Y/RHS~X/LHS) Gradient",\n',
' "LM (Y/RHS~X/LHS) Intercept"),\n',
' value = c(ggP, ggS, ggK, ggCoeff[2], ggCoeff[1]))\n',
' value = c(ggP, ggS, ggCoeff[2], ggCoeff[1]))\n',
' \n',
' }} else if(ggCont1 == FALSE & ggCont2 == FALSE){{ \n',
' # Both cate: Confusion matrix \n',
Expand All @@ -436,16 +440,8 @@ wrShFunc <- function() {
' if(ggCont1 == TRUE){{\n',
' colnames(ggData) <- c("sub", "val2", "val1")\n',
' }} \n',
' ggData$express = FALSE \n',
' ggData[val2 > inpcut]$express = TRUE \n',
' ggData1 = ggData[express == TRUE, .(nExpress = .N), by = "val1"] \n',
' ggData = ggData[, .(nCells = .N), by = "val1"] \n',
' ggData = ggData1[ggData, on = "val1"] \n',
' ggData = ggData[, c("val1", "nCells", "nExpress"), with = FALSE] \n',
' ggData[is.na(nExpress)]$nExpress = 0 \n',
' ggData$pctExpress = round(100 * ggData$nExpress / ggData$nCells, 2)\n',
' colnames(ggData)[1] = "group"\n',
' colnames(ggData)[3] = paste0(colnames(ggData)[3], "_", inp2) \n',
' ggData = ggData[order(group)] \n',
' }} \n',
' return(ggData) \n',
Expand Down Expand Up @@ -855,19 +851,21 @@ wrShFunc <- function() {
' scale_y_discrete(expand = c(0, 0.5)) + \n',
' scale_size_continuous("proportion", range = c(0, 8), \n',
' limits = c(0, 1), breaks = c(0.00,0.25,0.50,0.75,1.00)) + \n',
' scale_color_gradientn("expression", limits = colRange, colours = inpcols) + \n',
' guides(color = guide_colorbar(barwidth = 15)) + \n',
' theme(axis.title = element_blank(), legend.box = "vertical") \n',
' scale_color_gradientn("expression", limits = colRange, colours = inpcols) +\n',
' guides(color = guide_colorbar(barwidth = 15)) +\n',
' theme(axis.title = element_blank(), legend.box = "vertical",\n',
' legend.text = element_text(angle = 45, hjust = 1)) \n',
' }} else {{ \n',
' # Heatmap \n',
' ggOut = ggplot(ggData, aes(grpBy, geneName, fill = val)) + \n',
' geom_tile() + \n',
' sctheme(base_size = inpfsz, Xang = 45, XjusH = 1) + \n',
' scale_x_discrete(expand = c(0.05, 0)) + \n',
' scale_y_discrete(expand = c(0, 0.5)) + \n',
' scale_fill_gradientn("expression", limits = colRange, colours = inpcols) + \n',
' guides(fill = guide_colorbar(barwidth = 15)) + \n',
' theme(axis.title = element_blank()) \n',
' scale_fill_gradientn("expression", limits = colRange, colours = inpcols) +\n',
' guides(fill = guide_colorbar(barwidth = 15)) +\n',
' theme(axis.title = element_blank(),\n',
' legend.text = element_text(angle = 45, hjust = 1)) \n',
' }} \n',
' \n',
' # Final tidy \n',
Expand Down Expand Up @@ -950,6 +948,12 @@ wrShFunc <- function() {
' ggData$X = ggData$X * coord_scale\n',
' ggData$Y = ggData$Y * coord_scale\n',
' }}\n',
' # Flip Y into ggplot\'s bottom-up axis so the spots line up with the tissue\n',
' # image. We deliberately do NOT use scale_y_reverse() to achieve this:\n',
' # annotation_custom()/rasterGrob ignore reversed continuous scales and the\n',
' # background image collapses to an invisible sliver. Flipping the data and\n',
' # keeping a normal axis lets the raster render correctly.\n',
' ggData$Y = img_h - ggData$Y\n',
' # Extract metadata columns - handle different scenarios for backwards compatibility\n',
' # Check if we need to match spatial cells to metadata\n',
' spatial_cells <- rownames(inpImg$coord)\n',
Expand Down Expand Up @@ -1084,11 +1088,10 @@ wrShFunc <- function() {
' size = (inpfsz/4), seed = 42) \n',
' }} \n',
' }} \n',
' ggOut = ggOut + \n',
' scale_y_reverse() + # Flip Y-axis to match image coordinates\n',
' coord_fixed(ratio = 1, \n',
' xlim = c(0, img_w), \n',
' ylim = c(img_h, 0), # Reversed for scale_y_reverse\n',
' ggOut = ggOut +\n',
' coord_fixed(ratio = 1,\n',
' xlim = c(0, img_w),\n',
' ylim = c(0, img_h), # Normal axis; Y already flipped in ggData\n',
' expand = FALSE) + \n',
' theme_void(base_size = inpfsz) + theme(\n',
' axis.text = element_blank(), axis.line = element_blank(), \n',
Expand Down Expand Up @@ -1148,7 +1151,8 @@ wrShFunc <- function() {
' geom_point(size = input_size, shape = 16) +\n',
' facet_wrap(ggData$split, ncol = ncolumn) +\n',
' scale_color_gradientn(ggData$gene, colours = color_pal, name = gene_exp) +\n',
' guides(color = guide_colorbar(barwidth = 15), fill = guide_legend(title = gene_exp))\n',
' guides(color = guide_colorbar(barwidth = 15), fill = guide_legend(title = gene_exp)) +\n',
' theme(legend.text = element_text(angle = 45, hjust = 1))\n',
' calc_ratio <- (max(ggData$X) - min(ggData$X)) / (max(ggData$Y) - min(ggData$Y))\n',
' if (aspect_ratio == "Square") {{\n',
' ggOut <- ggOut + coord_fixed(ratio = calc_ratio)\n',
Expand Down
49 changes: 36 additions & 13 deletions R/writer1.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,8 +100,8 @@ wrSVpre <- function() {
'shinyServer(function(input, output, session) {{ \n',
' ### For all tags and Server-side selectize \n',
' observe_helpers() \n',
' optCrt="{{ option_create: function(data,escape) {{return(\'<div class=\\"create\\"><strong>\' + \'</strong></div>\');}} }}" \n',
' observe({{ \n',
' optCrt="{{ option_create: function(data,escape) {{return(\'<div class=\\"create\\"><strong>\' + \'</strong></div>\');}} }}" \n',
' observe({{ \n',
' invalidateLater(30000) # ping every 30 seconds to keep connection alive \n',
' cat(".") \n',
' }}) \n',
Expand Down Expand Up @@ -391,6 +391,29 @@ wrSVmainS3 <- function(prefix) {
wrSVmainA2 <- function(prefix) {
glue::glue(
' ### Functions for tab A2 \n',
' # Selectize render that colours each option by the data type used in the table\n',
' # calculations: categorical (green), continuous (blue), or undetermined (orange).\n',
' # - Categorical = Cell Information with a defined factor colour list (fCL).\n',
' # - Continuous = Cell Information without an fCL whose values are numeric, plus\n',
' # all gene/feature expression (always numeric). These take the\n',
' # ggCont == TRUE path in sc2Dcnum / sc2Dcomp.\n',
' # - Undetermined = anything that is neither - no fCL and not numeric (e.g.\n',
' # logical QC flags). Type cannot be exclusively determined.\n',
' # Genes are not listed in either set; they fall through to the continuous\n',
' # default below, which is correct.\n',
' optColCat = jsonlite::toJSON({prefix}conf[!is.na(fCL)]$UI)\n',
' optColUnd = jsonlite::toJSON({prefix}conf[is.na(fCL) &\n',
' !sapply(ID, function(i) i %in% colnames({prefix}meta) &&\n',
' is.numeric({prefix}meta[[i]]))]$UI)\n',
' optColFn = paste0(\n',
' "function(item, escape) {{",\n',
' " var cat = ", optColCat, "; var und = ", optColUnd, ";",\n',
' " var c = cat.indexOf(item.value) > -1 ? \'#1B7837\' :",\n',
' " (und.indexOf(item.value) > -1 ? \'#E66101\' : \'#2166AC\');",\n',
' " return \'<div style=\\"color:\' + c + \';font-weight:bold;text-align:center;\\">\' + escape(item.label) + \'</div>\';",\n',
' "}}")\n',
' optColor = paste0("{{ option: ", optColFn, ", item: ", optColFn,\n',
' ", option_create: function(data,escape) {{return(\'<div class=\\"create\\"><strong>\' + \'</strong></div>\');}} }}")\n',
' getG{prefix}a2inp1 <- reactive({{ \n',
' req(gsub("^Assay: ", "", input${prefix}a2ass1)) \n',
' if(gsub("^Assay: ", "", input${prefix}a2ass1) == "Cell Information"){{ \n',
Expand All @@ -408,7 +431,7 @@ wrSVmainA2 <- function(prefix) {
' updateSelectizeInput(session, "{prefix}a2inp1", choices = getG{prefix}a2inp1()[[1]], \n',
' server = TRUE, selected = getG{prefix}a2inp1()[[2]], options = list( \n',
' maxOptions = getG{prefix}a2inp1()[[3]], create = TRUE, \n',
' persist = TRUE, render = I(optCrt))) \n',
' persist = TRUE, render = I(optColor))) \n',
' }})\n',
' getG{prefix}a2inp2 <- reactive({{ \n',
' req(gsub("^Assay: ", "", input${prefix}a2ass2)) \n',
Expand All @@ -427,7 +450,7 @@ wrSVmainA2 <- function(prefix) {
' updateSelectizeInput(session, "{prefix}a2inp2", choices = getG{prefix}a2inp2()[[1]], \n',
' server = TRUE, selected = getG{prefix}a2inp2()[[2]], options = list( \n',
' maxOptions = getG{prefix}a2inp2()[[3]], create = TRUE, \n',
' persist = TRUE, render = I(optCrt))) \n',
' persist = TRUE, render = I(optColor))) \n',
' }})\n',
' output${prefix}a2sub1.ui <- renderUI({{ \n',
' sub = strsplit({prefix}conf[UI == input${prefix}a2sub1]$fID, "\\\\|")[[1]] \n',
Expand Down Expand Up @@ -510,7 +533,7 @@ wrSVmainA2 <- function(prefix) {
' output${prefix}a2.dt <- renderDataTable({{\n',
' ggData = sc2Dcnum({prefix}conf, {prefix}meta, input${prefix}a2inp1, input${prefix}a2inp2,\n',
' "{prefix}assay_", {prefix}gene, input${prefix}a2ass1, input${prefix}a2ass2, input${prefix}a2sub1, input${prefix}a2sub2,\n',
' input${prefix}a2min1, input${prefix}a2max1, input${prefix}a2min2, input${prefix}a2max2, input${prefix}a2cut)\n',
' input${prefix}a2min1, input${prefix}a2max1, input${prefix}a2min2, input${prefix}a2max2)\n',
' datatable(ggData, rownames = FALSE, extensions = "Buttons",\n',
' options = list(pageLength = -1, dom = "tB", buttons = c("copy", "csv", "excel")))\n',
' }})\n',
Expand Down Expand Up @@ -1119,10 +1142,10 @@ wrSVmainS1 <- function(prefix) {
' zoom_factor_y <- img_h / diff({prefix}s1oup1xy$y)\n',
' zoom_factor <- min(zoom_factor_x, zoom_factor_y)\n',
' adjSiz <- input${prefix}s1siz * zoom_factor\n',
' {prefix}s1oup1() + theme(legend.position = "none") + \n',
' coord_fixed(ratio = 1, \n',
' xlim = {prefix}s1oup1xy$x, \n',
' ylim = rev({prefix}s1oup1xy$y), # Reverse for scale_y_reverse\n',
' {prefix}s1oup1() + theme(legend.position = "none") +\n',
' coord_fixed(ratio = 1,\n',
' xlim = {prefix}s1oup1xy$x,\n',
' ylim = {prefix}s1oup1xy$y, # Normal axis; brush coords already in flipped data space\n',
' expand = FALSE) + \n',
' scale_size_continuous(range = c(0, adjSiz), limits = c(0,1))\n',
' }}\n',
Expand All @@ -1143,10 +1166,10 @@ wrSVmainS1 <- function(prefix) {
' zoom_factor <- min(zoom_factor_x, zoom_factor_y)\n',
' adjSiz <- input${prefix}s1siz * zoom_factor\n',
' ggsav(file, height = input${prefix}s1oup1.h, width = input${prefix}s1oup1.w, \n',
' plot = {prefix}s1oup1() + theme(legend.position = "none") + \n',
' coord_fixed(ratio = 1, \n',
' xlim = {prefix}s1oup1xy$x, \n',
' ylim = rev({prefix}s1oup1xy$y), \n',
' plot = {prefix}s1oup1() + theme(legend.position = "none") +\n',
' coord_fixed(ratio = 1,\n',
' xlim = {prefix}s1oup1xy$x,\n',
' ylim = {prefix}s1oup1xy$y,\n',
' expand = FALSE) + \n',
' scale_size_continuous(range = c(0, adjSiz), limits = c(0,1)))\n',
' }}\n',
Expand Down
19 changes: 16 additions & 3 deletions R/writer2.R
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -76,6 +76,11 @@ wrUIpre <- function(title, ganalytics) {
' {ga} \n',
' tags$head(tags$style(HTML(".shiny-output-error-validation {{color: red; font-weight: bold;}}"))), \n',
' list(tags$style(HTML(".navbar-default .navbar-nav {{ font-weight: bold; font-size: 16px; }}"))), \n',
' ### Center-align the text inside the colour-coded feature selectors (tab A2)\n',
' tags$head(tags$style(HTML(paste0(\n',
' ".centerSelect .selectize-input, ",\n',
' ".centerSelect .selectize-input input, ",\n',
' ".centerSelect .selectize-dropdown .option {{ text-align: center; }}")))),\n',
' \n',
' ### Page title \n',
' titlePanel("{title}"), \n',
Expand Down Expand Up @@ -515,6 +520,13 @@ wrUImainA2 <- function(prefix, ptsiz) {
' "In this tab, users can visualise both cell information and gene ", \n',
' "expression side-by-side on low-dimensional representions.", \n',
' br(),br(), \n',
' HTML(paste0(\n',
' "<div style=\'font-size:13px; margin-bottom:8px;\'>",\n',
' "<b>Selector colour key:</b>&nbsp;&nbsp;",\n',
' "<span style=\'color:#1B7837; font-weight:bold;\'>&#9632; Categorical</span>&nbsp;&nbsp;",\n',
' "<span style=\'color:#2166AC; font-weight:bold;\'>&#9632; Continuous</span>&nbsp;&nbsp;",\n',
' "<span style=\'color:#E66101; font-weight:bold;\'>&#9632; Undetermined</span>",\n',
' "</div>")),\n',
' fluidRow( \n',
' column( \n',
' 3, fluidRow(\n',
Expand Down Expand Up @@ -568,14 +580,15 @@ wrUImainA2 <- function(prefix, ptsiz) {
' 6, selectInput("{prefix}a2ass1", "Data type to colour plot:",\n',
' choices = c("Cell Information", paste0("Assay: ", {prefix}def$assay)), \n',
' selected = "Cell Information"), \n',
' div(class = "centerSelect",\n',
' selectInput("{prefix}a2inp1", "Cell Info / Feature Name:", choices = NULL) %>% \n',
' helper(type = "inline", size = "m", fade = TRUE,\n',
' title = "Cell Info / Gene to colour cells by",\n',
' content = c("Select cell info / feature to colour cells",\n',
' "- Categorical covariates have a fixed colour palette",\n',
' paste0("- Continuous covariates / gene expression are coloured ",\n',
' "in a Blue-Yellow-Red colour scheme, which can be ",\n',
' "changed in the plot controls")))\n',
' "changed in the plot controls"))))\n',
' ),\n',
' column(\n',
' 6, actionButton("{prefix}a2tog1", "Toggle plot controls"),\n',
Expand Down Expand Up @@ -620,14 +633,15 @@ wrUImainA2 <- function(prefix, ptsiz) {
' 6, selectInput("{prefix}a2ass2", "Data type to colour plot:",\n',
' choices = c("Cell Information", paste0("Assay: ", {prefix}def$assay)), \n',
' selected = paste0("Assay: ", {prefix}def$assay[1])), \n',
' div(class = "centerSelect",\n',
' selectInput("{prefix}a2inp2", "Cell Info / Feature Name:", choices = NULL) %>% \n',
' helper(type = "inline", size = "m", fade = TRUE,\n',
' title = "Cell Info / Gene to colour cells by",\n',
' content = c("Select cell info / feature to colour cells",\n',
' "- Categorical covariates have a fixed colour palette",\n',
' paste0("- Continuous covariates / gene expression are coloured ",\n',
' "in a Blue-Yellow-Red colour scheme, which can be ",\n',
' "changed in the plot controls")))\n',
' "changed in the plot controls"))))\n',
' ),\n',
' column(\n',
' 6, actionButton("{prefix}a2tog2", "Toggle plot controls"),\n',
Expand Down Expand Up @@ -682,7 +696,6 @@ wrUImainA2 <- function(prefix, ptsiz) {
' ),\n',
' column(\n',
' 6, h4("Cell numbers / statistics"), \n',
' numericInput("{prefix}a2cut", "Cutoff for Expression:", value = 0), \n',
' dataTableOutput("{prefix}a2.dt") \n',
' ) # End of column (6 space) \n',
' ) # End of fluidRow (4 space) \n',
Expand Down
Loading