diff --git a/R/writer0.R b/R/writer0.R
index b32ce3c..f7c086b 100644
--- a/R/writer0.R
+++ b/R/writer0.R
@@ -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',
@@ -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',
@@ -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',
@@ -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',
@@ -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',
@@ -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',
@@ -855,9 +851,10 @@ 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',
@@ -865,9 +862,10 @@ wrShFunc <- function() {
' 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',
@@ -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',
@@ -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',
@@ -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',
diff --git a/R/writer1.R b/R/writer1.R
index 54f23e2..1a2bff5 100644
--- a/R/writer1.R
+++ b/R/writer1.R
@@ -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(\'\' + \'
\');}} }}" \n',
- ' observe({{ \n',
+ ' optCrt="{{ option_create: function(data,escape) {{return(\'\' + \'
\');}} }}" \n',
+ ' observe({{ \n',
' invalidateLater(30000) # ping every 30 seconds to keep connection alive \n',
' cat(".") \n',
' }}) \n',
@@ -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 \'\' + escape(item.label) + \'
\';",\n',
+ ' "}}")\n',
+ ' optColor = paste0("{{ option: ", optColFn, ", item: ", optColFn,\n',
+ ' ", option_create: function(data,escape) {{return(\'\' + \'
\');}} }}")\n',
' getG{prefix}a2inp1 <- reactive({{ \n',
' req(gsub("^Assay: ", "", input${prefix}a2ass1)) \n',
' if(gsub("^Assay: ", "", input${prefix}a2ass1) == "Cell Information"){{ \n',
@@ -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',
@@ -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',
@@ -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',
@@ -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',
@@ -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',
diff --git a/R/writer2.R b/R/writer2.R
index 9e35630..d6dad0d 100644
--- a/R/writer2.R
+++ b/R/writer2.R
@@ -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',
@@ -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',
+ ' "",\n',
+ ' "Selector colour key: ",\n',
+ ' "■ Categorical ",\n',
+ ' "■ Continuous ",\n',
+ ' "■ Undetermined",\n',
+ ' "
")),\n',
' fluidRow( \n',
' column( \n',
' 3, fluidRow(\n',
@@ -568,6 +580,7 @@ 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',
@@ -575,7 +588,7 @@ wrUImainA2 <- function(prefix, ptsiz) {
' "- 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',
@@ -620,6 +633,7 @@ 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',
@@ -627,7 +641,7 @@ wrUImainA2 <- function(prefix, ptsiz) {
' "- 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',
@@ -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',