diff --git a/.Rbuildignore b/.Rbuildignore
index 755a45ee8e9b8185a3809b28c767a304cd8e4a76..976eb0452c7fa503d647fe80d8347981de346ed0 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -11,3 +11,5 @@
^_pkgdown\.yml$
^UTechSCB-SCHNAPPs.wiki$
^_gh-pages$
+^history
+^CONTRIBUTING.md$
diff --git a/.gitignore b/.gitignore
index a94fd2e2decdfcc0ce29301e34daadd8b326ee7f..68aee2e813ffd4748eea0db42e9967a0a8850bc1 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,6 +1,7 @@
# History files
.Rhistory
.Rapp.history
+history/
# Session Data files
.RData
diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md
new file mode 100644
index 0000000000000000000000000000000000000000..76408784fe6082199d337a041ea533404e857a1b
--- /dev/null
+++ b/CONTRIBUTING.md
@@ -0,0 +1 @@
+see wiki on how to contribute
diff --git a/DESCRIPTION b/DESCRIPTION
index 9591cdff71774203008eaadb7439f544f8a71a3c..393d72631d8177903d254941dcf7557bafd1c7e9 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,7 +1,7 @@
Package: SCHNAPPs
Type: Package
Title: Single Cell Shiny Application for Analysing Single Cell Transcriptomics Data
-Version: 1.1.24
+Version: 1.2.1
Authors@R: c(person("Bernd", "Jagla", role = c("aut", "cre"), email = "bernd.jagla@pasteur.fr", comment = c(ORCID = "0000-0002-7696-0484")))
Maintainer: Bernd Jagla <bernd.jagla@pasteur.fr>
Description: Single Cell sHiny APPlication (SCHNAPPs) is a R/Shiny based application to interact, manipulate, explore, and analyze single cell RNA-seq experiments, including MARS-seq and others.
@@ -34,6 +34,7 @@ Imports:
shinyTree,
shinyWidgets,
SingleCellExperiment,
+ ggpubr,
SummarizedExperiment,
threejs,
tidyverse,
diff --git a/R/schnapps-Main.R b/R/schnapps-Main.R
index ffc0d6200dff6c99b4a0d5a0c84c5ca5ae2c7c06..754b023df2166f66c73924a260b700af039ec314 100644
--- a/R/schnapps-Main.R
+++ b/R/schnapps-Main.R
@@ -31,11 +31,15 @@
#' save(file = "scEx.Rdata", list = "scEx")
#' # use "scEx.Rdata" with load data functionality within the shiny app
schnapps <- function(localContributionDir = "~/Rstudio/shHubgit/Dummy/",
- defaultValueSingleGene = "CD52",
- defaultValueMultiGenes = "CD52, S100A4, S100A9, S100A8",
- defaultValueRegExGene = "", # tip: '^CD7$|^KIT$; genes with min expression
- DEBUG = FALSE,
- DEBUGSAVE = FALSE) {
+ defaultValueSingleGene = "CD52",
+ defaultValueMultiGenes = "CD52, S100A4, S100A9, S100A8",
+ defaultValueRegExGene = "", # tip: '^CD7$|^KIT$; genes with min expression
+ DEBUG = FALSE,
+ DEBUGSAVE = FALSE,
+ historyPath = NULL,
+ historyFile = NULL
+
+ ) {
# on.exit({
# rm(list = c(".SCHNAPPs_locContributionDir",
# ".SCHNAPPs_defaultValueSingleGene",
@@ -53,6 +57,9 @@ schnapps <- function(localContributionDir = "~/Rstudio/shHubgit/Dummy/",
assign(".SCHNAPPs_DEBUGSAVE", DEBUGSAVE, envir = .schnappsEnv)
assign("DEBUG", DEBUG, envir = .schnappsEnv)
assign("DEBUGSAVE", DEBUGSAVE, envir = .schnappsEnv)
+ assign("historyPath", historyPath, envir = .schnappsEnv)
+ assign("historyFile", historyFile, envir = .schnappsEnv)
+
# will be set during sourcing, but we need to define them, otherwise there will be a warning
scShinyUI <- NULL
scShinyServer <- NULL
diff --git a/inst/app/contributions/DE_DataExploration/outputs.R b/inst/app/contributions/DE_DataExploration/outputs.R
index 6db898cdd9b8fe215cc3a3f1098a4ac9ec3b84ef..fad5fc6310b03f36fbdd0d6c441526d82b70ebbe 100644
--- a/inst/app/contributions/DE_DataExploration/outputs.R
+++ b/inst/app/contributions/DE_DataExploration/outputs.R
@@ -28,7 +28,7 @@ observe(label = "ob18", {
.schnappsEnv$DE_Y1 <- input$DE_dim_y
})
-DE_updateInputExpPanel <- reactive({
+observe({
if (DEBUG) cat(file = stderr(), "DE_updateInputExpPanel started.\n")
start.time <- base::Sys.time()
on.exit({
@@ -59,7 +59,7 @@ DE_updateInputExpPanel <- reactive({
choices = colnames(projections),
selected = .schnappsEnv$DE_Y1
)
- return(TRUE)
+ # return(TRUE)
})
@@ -152,15 +152,21 @@ output$DE_panelPlot <- renderPlot({
}
if (DEBUG) cat(file = stderr(), "output$DE_panelPlot\n")
+ clicked <- input$updatePanelPlot
scEx_log <- scEx_log()
projections <- projections()
- genesin <- input$DE_panelplotids
- cl4 <- input$DE_clusterSelectionPanelPlot
- dimx4 <- input$DE_dim_x
- dimy4 <- input$DE_dim_y
- sameScale <- input$DE_panelplotSameScale
-
- if (is.null(scEx_log) | is.null(projections) | is.null(cl4)) {
+ DE_updateInputPPt()
+ genesin <- isolate(input$DE_panelplotids)
+ # cl4 <- input$DE_clusterSelectionPanelPlot
+ ppgrp <- isolate(input$DE_PPGrp)
+ ppCluster <- isolate(input$DE_clusterPP)
+
+ dimx4 <- isolate(input$DE_dim_x)
+ dimy4 <- isolate(input$DE_dim_y)
+ sameScale <- isolate(input$DE_panelplotSameScale)
+ nCol <- isolate(as.numeric(input$DE_nCol))
+
+ if (is.null(scEx_log) | is.null(projections) | is.null(ppgrp)) {
return(NULL)
}
if (.schnappsEnv$DEBUGSAVE) {
@@ -193,69 +199,104 @@ output$DE_panelPlot <- renderPlot({
ylim <- NULL
}
}
- if (cl4 == "All") {
- for (i in 1:length(genesin)) {
- geneIdx <- which(toupper(featureData$symbol) == genesin[i])
- Col <- rbPal(10)[
- as.numeric(
- cut(
- as.numeric(
- assays(scEx_log)[[1]][
- rownames(featureData[geneIdx, ]),
- ]
- ),
- breaks = 10
- )
- )
- ]
- if (is(projections[, dimx4], "factor") & dimy4 == "UMI.count") {
- projections[, dimy4] <- Matrix::colSums(assays(scEx_log)[["logcounts"]][geneIdx, , drop = FALSE])
- }
-
- plot(projections[, dimx4], projections[, dimy4],
- col = Col, pch = 16, frame.plot = TRUE, ann = FALSE, ylim = ylim
- )
- title(genesin[i], line = -1.2, adj = 0.05, cex.main = 2)
- if (DEBUG) cat(file = stderr(), genesin[i])
- }
- } else {
- for (i in 1:length(genesin)) {
- geneIdx <- which(toupper(featureData$symbol) == genesin[i])
- subsetTSNE <- subset(projections, dbCluster == cl4)
-
- Col <- rbPal(10)[
- as.numeric(
- cut(
- as.numeric(
- assays(scEx_log)[[1]][
- rownames(featureData[geneIdx, ]),
- ]
- ),
- breaks = 10
- )
+ plotList <- list()
+ plotIdx <- 0
+ # if (cl4 == "All") {
+ # for (i in 1:length(genesin)) {
+ # geneIdx <- which(toupper(featureData$symbol) == genesin[i])
+ # Col <- rbPal(10)[
+ # as.numeric(
+ # cut(
+ # as.numeric(
+ # assays(scEx_log)[[1]][
+ # rownames(featureData[geneIdx, ]),
+ # ]
+ # ),
+ # breaks = 10
+ # )
+ # )
+ # ]
+ # plotIdx = plotIdx +1
+ #
+ # plotList[[plotIdx]] = ggplot(projections, aes_string(x=dimx4, y=dimy4))
+ # if (is(projections[, dimx4], "factor") & dimy4 == "UMI.count") {
+ # projections[, dimy4] <- Matrix::colSums(assays(scEx_log)[["logcounts"]][geneIdx, , drop = FALSE])
+ # plotList[[plotIdx]] = plotList[[plotIdx]] + geom_boxplot(show.legend = FALSE) + ggtitle(genesin[i])
+ # } else{
+ # plotList[[plotIdx]] = plotList[[plotIdx]] + geom_point(color = Col, show.legend = FALSE) + ggtitle(genesin[i])
+ #
+ # }
+ # if (!is.null(ylim)) {
+ # plotList[[plotIdx]] = plotList[[plotIdx]] + ylim(ylim)
+ # }
+ # # plot(projections[, dimx4], projections[, dimy4],
+ # # col = Col, pch = 16, frame.plot = TRUE, ann = FALSE, ylim = ylim
+ # # )
+ # # title(genesin[i], line = -1.2, adj = 0.05, cex.main = 2)
+ # if (DEBUG) cat(file = stderr(), genesin[i])
+ # }
+ # } else {
+ for (i in 1:length(genesin)) {
+ geneIdx <- which(toupper(featureData$symbol) == genesin[i])
+ subsetTSNE <- projections[projections[, ppCluster] %in% ppgrp, ]
+
+ Col <- rbPal(10)[
+ as.numeric(
+ cut(
+ as.numeric(
+ assays(scEx_log)[[1]][
+ rownames(featureData[geneIdx, ]),
+ ]
+ ),
+ breaks = 10
)
- ]
-
- names(Col) <- rownames(projections)
- plotCol <- Col[rownames(subsetTSNE)]
- if (is(projections[, dimx4], "factor") & dimy4 == "UMI.count") {
- projections[, dimy4] <- Matrix::colSums(assays(scEx_log)[["logcounts"]][geneIdx, , drop = FALSE])
- subsetTSNE <- subset(projections, dbCluster == cl4)
- }
-
- plot(subsetTSNE[, dimx4], subsetTSNE[, dimy4],
- col = plotCol, pch = 16, frame.plot = TRUE,
- ann = FALSE, ylim = ylim
)
- title(genesin[i], line = -1.2, adj = 0.05, cex.main = 2)
- if (DEBUG) cat(file = stderr(), cl4)
+ ]
+
+ names(Col) <- rownames(projections)
+ plotCol <- Col[rownames(subsetTSNE)]
+ if (is(projections[, dimx4], "factor") & dimy4 == "UMI.count") {
+ projections[, dimy4] <- Matrix::colSums(assays(scEx_log)[["logcounts"]][geneIdx, , drop = FALSE])
+ subsetTSNE <- projections[projections[, ppCluster] %in% ppgrp, ]
}
- }
+ plotIdx <- plotIdx + 1
+
+ plotList[[plotIdx]] <- ggplot(subsetTSNE, aes_string(x = dimx4, y = dimy4))
+ if (is(subsetTSNE[, dimx4], "factor") & dimy4 == "UMI.count") {
+ subsetTSNE[, dimy4] <- Matrix::colSums(assays(scEx_log)[["logcounts"]][geneIdx, rownames(subsetTSNE), drop = FALSE])
+ plotList[[plotIdx]] <- plotList[[plotIdx]] + geom_boxplot(show.legend = FALSE) + ggtitle(genesin[i])
+ } else {
+ plotList[[plotIdx]] <- plotList[[plotIdx]] + geom_point(color = plotCol, show.legend = FALSE) + ggtitle(genesin[i])
+ }
+ if (!is.null(ylim)) {
+ plotList[[plotIdx]] <- plotList[[plotIdx]] + ylim(ylim)
+ }
+ # plot(subsetTSNE[, dimx4], subsetTSNE[, dimy4],
+ # col = plotCol, pch = 16, frame.plot = TRUE,
+ # ann = FALSE, ylim = ylim
+ # )
+ # title(genesin[i], line = -1.2, adj = 0.05, cex.main = 2)
+ # if (DEBUG) cat(file = stderr(), ppgrp)
+ }
+ # }
+ require(ggpubr)
+ retVal <-
+ ggarrange(
+ plotlist = plotList, ncol = nCol, nrow = ceiling(length(plotList) / nCol),
+ label.x = "test", legend = "right",
+ common.legend = T
+ )
+ retVal <-
+ annotate_figure(retVal,
+ top = text_grob(paste("using projection", ppCluster, "with elements", paste(ppgrp, collapse = ", ")))
+ )
printTimeEnd(start.time, "DE_panelPlot")
exportTestValues(DE_panelPlot = {
ls()
})
+ .schnappsEnv[["DE_panelPlot"]] <- retVal
+ retVal
})
diff --git a/inst/app/contributions/DE_DataExploration/parameters.R b/inst/app/contributions/DE_DataExploration/parameters.R
index eb6b12f59d5415114ea0379db0f4447597772713..490e43db15207623e9095911c035c2b72f94c37d 100644
--- a/inst/app/contributions/DE_DataExploration/parameters.R
+++ b/inst/app/contributions/DE_DataExploration/parameters.R
@@ -47,10 +47,12 @@ myNormalizationParameters <- list(
value = 200
),
numericInput("DE_seuratSCtransform_scaleFactor",
- label = "Scaling to use for transformed data",
- min = 1, max = 30000, step = 10,
- value = 1000
- )
+ label = "Scaling to use for transformed data",
+ min = 1, max = 30000, step = 10,
+ value = 1000
+ ),
+ textInput("DE_seuratSCtransformm_keepfeatures", "comma separated list of genes keep", value = "")
+
),
DE_seuratRefBased = tagList(
numericInput("DE_seuratRefBased_nfeatures",
@@ -63,14 +65,17 @@ myNormalizationParameters <- list(
value = 200
),
numericInput("DE_seuratRefBased_scaleFactor",
- label = "Scaling to use for transformed data",
- min = 1, max = 30000, step = 10,
- value = 1000
- )
+ label = "Scaling to use for transformed data",
+ min = 1, max = 30000, step = 10,
+ value = 1000
+ ),
+ textInput("DE_seuratRefBased_keepfeatures", "comma separated list of genes keep", value = "")
)
)
-DE_seuratRefBasedFunc <- function(scEx, nfeatures = 3000, k.filter = 100, scalingFactor = 1000) {
+# DE_seuratRefBasedFunc ----
+DE_seuratRefBasedFunc <- function(scEx, nfeatures = 3000, k.filter = 100,
+ scalingFactor = 1000, keep.features = "") {
require(Seurat)
cellMeta <- colData(scEx)
# split in different samples
@@ -86,16 +91,20 @@ DE_seuratRefBasedFunc <- function(scEx, nfeatures = 3000, k.filter = 100, scalin
integrated <- tryCatch(
{
# save(file = "~/SCHNAPPsDebug/DE_seuratRefBased.RData", list = c(ls(), ls(envir = globalenv())))
+ # load(file = "~/SCHNAPPsDebug/DE_seuratRefBased.RData")
features <- SelectIntegrationFeatures(object.list = seur.list, nfeatures = nfeatures)
+
+ keep.features = keep.features[keep.features %in% rownames(scEx)]
+ features = unique(c(features, keep.features))
+
seur.list <- PrepSCTIntegration(
object.list = seur.list, anchor.features = features,
verbose = TRUE
)
# take the sample with the highest number of cells as reference
- reference_dataset <- order(unlist(lapply(seur.list, FUN = function(x) {
- ncol(x)
- })), decreasing = T)[1]
-
+ reference_dataset <- order(unlist(lapply(seur.list, FUN = function(x) {ncol(x)})), decreasing =T)[1]
+
+
anchors <- FindIntegrationAnchors(
object.list = seur.list, normalization.method = "SCT",
anchor.features = features, verbose = TRUE, k.filter = k.filter,
@@ -138,6 +147,7 @@ DE_seuratRefBasedButton <- reactiveVal(
label = "DE_seuratRefBasedButton",
value = ""
)
+# DE_seuratRefBased ----
DE_seuratRefBased <- reactive({
if (DEBUG) cat(file = stderr(), "DE_seuratRefBased started.\n")
start.time <- base::Sys.time()
@@ -167,13 +177,16 @@ DE_seuratRefBased <- reactive({
save(file = "~/SCHNAPPsDebug/DE_seuratRefBased.RData", list = c(ls(), ls(envir = globalenv())))
}
# load(file="~/SCHNAPPsDebug/DE_seuratRefBased.RData")
-
-
-
+ .schnappsEnv$normalizationFactor = scalingFactor
+ featureData <- rowData(scEx)
+ geneid <- geneName2Index(geneNames, featureData)
+
+
# # TODO ?? define scaling factor somewhere else???
# sfactor = max(max(assays(scEx)[["counts"]]),1000)
- retVal <- DE_seuratRefBasedFunc(scEx = scEx, nfeatures = nfeatures, k.filter = k.filter, scalingFactor = scalingFactor)
-
+ retVal <- DE_seuratRefBasedFunc(scEx = scEx, nfeatures = nfeatures, k.filter = k.filter,
+ scalingFactor = scalingFactor, keep.features = geneid)
+
if (is.null(retVal)) {
showNotification("An error occurred during Seurat normalization, please check console", id = "DE_seuratError", duration = NULL, type = "error")
}
@@ -191,7 +204,8 @@ DE_seuratRefBased <- reactive({
})
# DE_seuratSCtransformFunc =======
-DE_seuratSCtransformFunc <- function(scEx, nfeatures = 3000, k.filter = 100, scalingFactor = 1000) {
+DE_seuratSCtransformFunc <- function(scEx, nfeatures = 3000, k.filter = 100,
+ scalingFactor = 1000, keep.features = "") {
require(Seurat)
cellMeta <- colData(scEx)
# split in different samples
@@ -208,14 +222,20 @@ DE_seuratSCtransformFunc <- function(scEx, nfeatures = 3000, k.filter = 100, sca
}
features <- SelectIntegrationFeatures(object.list = seur.list, nfeatures = nfeatures)
+ keep.features = keep.features[keep.features %in% rownames(scEx)]
+ features = unique(c(features, keep.features))
+
seur.list <- PrepSCTIntegration(
object.list = seur.list, anchor.features = features,
verbose = TRUE
)
+
anchors <- FindIntegrationAnchors(
object.list = seur.list, normalization.method = "SCT",
anchor.features = features, verbose = TRUE, k.filter = k.filter
)
+ keep.features = keep.features[keep.features %in% rownames(scEx)]
+ anchors = unique(c(anchors, keep.features))
integrated <- IntegrateData(
anchorset = anchors, normalization.method = "SCT",
verbose = TRUE
@@ -281,16 +301,18 @@ DE_seuratSCtransform <- reactive({
return(NULL)
}
if (.schnappsEnv$DEBUGSAVE) {
- save(file = "~/SCHNAPPsDebug/DE_seuratSCtransform.RData", list = c(ls(), ls(envir = globalenv())))
+ save(file = "~/SCHNAPPsDebug/DE_seuratSCtransform.RData", list = c(ls()))
}
# load(file="~/SCHNAPPsDebug/DE_seuratSCtransform.RData")
-
-
-
+ .schnappsEnv$normalizationFactor <- scalingFactor
+ featureData <- rowData(scEx)
+ geneid <- geneName2Index(geneNames, featureData)
+
# # TODO ?? define scaling factor somewhere else???
# sfactor = max(max(assays(scEx)[["counts"]]),1000)
- retVal <- DE_seuratSCtransformFunc(scEx = scEx, nfeatures = nfeatures, k.filter = k.filter, scalingFactor = scalingFactor)
-
+ retVal <- DE_seuratSCtransformFunc(scEx = scEx, nfeatures = nfeatures, k.filter = k.filter,
+ scalingFactor = scalingFactor, keep.features = geneid)
+
if (is.null(retVal)) {
if (DEBUG) green(cat(file = stderr(), "An error occurred during Seurat normalization, please check console\n"))
showNotification("An error occurred during Seurat normalization, please check console", id = "DE_seuratError", duration = NULL, type = "error")
@@ -479,6 +501,7 @@ DE_logGeneNormalization <- reactive(label = "rlogGene", {
# turn normalization button green
addClass("updateNormalization", "green")
+ .schnappsEnv$normalizationFactor <- sfactor
exportTestValues(DE_logGeneNormalization = {
assays(retVal)[["logcounts"]]
})
@@ -572,6 +595,7 @@ DE_logNormalization <- reactive(label = "rlogNorm", {
# turn normalization button green
addClass("updateNormalization", "green")
+ .schnappsEnv$normalizationFactor <- sfactor
exportTestValues(DE_logNormalization = {
assays(retVal)[["logcounts"]]
})
diff --git a/inst/app/contributions/DE_DataExploration/reactives.R b/inst/app/contributions/DE_DataExploration/reactives.R
index 11f406837fcb1b69200648ce2109a1cdce2b7033..1be92301217aca499da32f41addc3a7a6006a3ff 100644
--- a/inst/app/contributions/DE_DataExploration/reactives.R
+++ b/inst/app/contributions/DE_DataExploration/reactives.R
@@ -1,6 +1,117 @@
suppressMessages(require(ggplot2))
+.schnappsEnv$coE_PPGrp <- "sampleNames"
+observe({
+ if (DEBUG) cat(file = stderr(), paste0("observe: DE_PPGrp\n"))
+ .schnappsEnv$DE_PPGrp <- input$DE_PPGrp
+})
+.schnappsEnv$coE_PPSelection <- "1"
+observe({
+ if (DEBUG) cat(file = stderr(), paste0("observe: DE_clusterPP\n"))
+ .schnappsEnv$DE_clusterPP <- input$DE_clusterPP
+})
+
+# DE_updateInputPPt ====
+DE_updateInputPPt <- reactive({
+ if (DEBUG) cat(file = stderr(), "DE_updateInputPPt started.\n")
+ start.time <- base::Sys.time()
+ on.exit({
+ printTimeEnd(start.time, "DE_updateInputPPt")
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "DE_updateInputPPt")
+ }
+ })
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("DE_updateInputPPt", id = "DE_updateInputPPt", duration = NULL)
+ }
+ tsneData <- projections()
+
+ # Can use character(0) to remove all choices
+ if (is.null(tsneData)) {
+ return(NULL)
+ }
+ # save(file = "~/SCHNAPPsDebug/DE_updateInputPPt.Rdata", list = c(ls(), ls(envir = globalenv())))
+ # load(file = "~/SCHNAPPsDebug/DE_updateInputPPt.Rdata")
+
+ coln <- colnames(tsneData)
+ choices <- c()
+ for (cn in coln) {
+ if (length(levels(as.factor(tsneData[, cn]))) < 50) {
+ choices <- c(choices, cn)
+ }
+ }
+ if (length(choices) == 0) {
+ choices <- c("no valid columns")
+ }
+ updateSelectInput(
+ session,
+ "DE_clusterPP",
+ choices = choices,
+ selected = .schnappsEnv$DE_PPGrp
+ )
+})
+
+observeEvent(input$DE_clusterPP,{
+ projections <- projections()
+ if (DEBUG) cat(file = stderr(), "observeEvent: input$DE_clusterPP\n")
+ # Can use character(0) to remove all choices
+ if (is.null(projections)) {
+ return(NULL)
+ }
+ if(!input$DE_clusterPP %in% colnames(projections)) return(NULL)
+ choicesVal = levels(projections[, input$DE_clusterPP])
+ updateSelectInput(
+ session,
+ "DE_PPGrp",
+ choices = choicesVal,
+ selected = .schnappsEnv$DE_clusterPP
+ )
+
+})
+
+
+
+
+observe({
+ clicked = input$save2HistScater
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVio \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "scater plot",
+ plotData = .schnappsEnv[["DE_scaterPNG"]])
+
+})
+
+observe({
+ clicked = input$save2HistPanel
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistPanel \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "Panel plot",
+ plotData = .schnappsEnv[["DE_panelPlot"]])
+
+})
+
+
# DE_scaterPNG ----
#' DE_scaterPNG
@@ -82,7 +193,7 @@ DE_scaterPNG <- reactive({
alt = "Scater plot should be here"
)
# end calculation
-
+ .schnappsEnv[["DE_scaterPNG"]] <- p1
printTimeEnd(start.time, "DE_scaterPNG")
exportTestValues(DE_scaterPNG = {
retVal
diff --git a/inst/app/contributions/DE_DataExploration/ui.R b/inst/app/contributions/DE_DataExploration/ui.R
index edd9a81d7e1ef50b7425c9e01b72f160847fd76e..d1425676acc1ab651a0ec85e29c25e883c8355a1 100644
--- a/inst/app/contributions/DE_DataExploration/ui.R
+++ b/inst/app/contributions/DE_DataExploration/ui.R
@@ -88,17 +88,29 @@ tabList <- list(
)
),
fluidRow(
- column(
- width = 3,
- uiOutput("DE_clusterSelectionPanelPlot")
+ column(width = 12, offset = 1,
+ actionButton("updatePanelPlot", "apply changes", width = '80%',
+ style = "color: #fff; background-color: #A00272; border-color: #2e6da4")
+ )
+ ),
+ fluidRow(
+ column(width = 3,
+ # uiOutput("DE_clusterSelectionPanelPlot")
+ selectInput(inputId = "DE_clusterPP", label = "Clusters/Factor to use",
+ choices = c("dbCluster", "sampleNames"),
+ selected = "dbCluster")
),
- column(
- width = 3,
- selectInput("DE_dim_x",
- label = "X",
- choices = c("tsne1", "tsne2", "tsne3"),
- selected = "tsne1"
- )
+ column(width = 3,
+ selectInput(inputId = "DE_PPGrp", label = "Values to use",
+ choices = c("1","2"), selected = "1", multiple = TRUE)
+ )),
+ fluidRow(
+ column(width = 3,
+ selectInput("DE_dim_x",
+ label = "X",
+ choices = c("tsne1", "tsne2", "tsne3"),
+ selected = "tsne1"
+ )
),
column(
width = 3,
@@ -110,6 +122,14 @@ tabList <- list(
), column(
2,
checkboxInput("DE_panelplotSameScale", "same scale", value = TRUE)
+ ),
+ column(
+ 2,
+ selectInput("DE_nCol",
+ label = "number of columns for plot",
+ choices = c(1:10),
+ selected = 4
+ )
)
),
fluidRow(
@@ -120,8 +140,11 @@ tabList <- list(
),
fluidRow(column(
12,
- jqui_resizable(plotOutput("DE_panelPlot"))
- ))
+ jqui_resizable(plotOutput("DE_panelPlot") )
+ )
+ ),
+ br(),
+ actionButton("save2HistPanel", "save to history")
)
),
# DE_scaterQC ----
@@ -138,7 +161,10 @@ tabList <- list(
offset = 1,
imageOutput("DE_scaterQC") %>% withSpinner() # PNG output with temp file
)
- )
+ ),
+ br(),
+ actionButton("save2HistScater", "save to history")
+
)
)
)
diff --git a/inst/app/contributions/coE_coExpression/outputs.R b/inst/app/contributions/coE_coExpression/outputs.R
index 2dad63455cf641d81e4c488e88ca5ca99fc404dd..6fc448668c652ea609e5186fa1d8568a365f508f 100644
--- a/inst/app/contributions/coE_coExpression/outputs.R
+++ b/inst/app/contributions/coE_coExpression/outputs.R
@@ -97,8 +97,8 @@ output$coE_geneGrp_vio_plot <- renderPlot({
sampCol = sampCol,
ccols = ccols
)
-
- exportTestValues(coE_geneGrp_vio_plot = {
+ .schnappsEnv[["coE_geneGrp_vio_plot"]] <- retVal
+ exportTestValues(coE_geneGrp_vio_plot = {
retVal
})
return(retVal)
diff --git a/inst/app/contributions/coE_coExpression/reactives.R b/inst/app/contributions/coE_coExpression/reactives.R
index 2cc8f43a5adfbe64784ef4a4c180a4d469ea334b..c09d3684e48964128945be9a074df489996f3010 100644
--- a/inst/app/contributions/coE_coExpression/reactives.R
+++ b/inst/app/contributions/coE_coExpression/reactives.R
@@ -286,6 +286,7 @@ coE_topExpCCTable <- reactive({
numProje <- projections[, nums]
# colnames(numProje)
genesin <- unique(genesin)
+ scCells <- scCells[scCells %in% colnames(assays(scEx_log)[[1]])]
# we only work on cells that have been selected
mat <- assays(scEx_log)[[1]][genesin, scCells, drop = FALSE]
# only genes that express at least coEtgminExpr UMIs
@@ -509,6 +510,27 @@ coE_geneGrp_vioFunc <- function(genesin, projections, scEx, featureData, minExpr
return(p1)
}
+# save to history violoin observer ----
+observe({
+ clicked = input$save2HistVio
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVio \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "violin plot",
+ plotData = .schnappsEnv[["coE_geneGrp_vio_plot"]])
+
+})
+
+
#' coE_somFunction
#' iData = expression matrix, rows = genes
#' cluster genes in SOM
@@ -771,7 +793,7 @@ coE_updateInputXviolinPlot <- reactive({
coln <- colnames(tsneData)
choices <- c()
for (cn in coln) {
- if (length(levels(as.factor(tsneData[, cn]))) < 20) {
+ if (length(levels(as.factor(tsneData[, cn]))) < 50) {
choices <- c(choices, cn)
}
}
diff --git a/inst/app/contributions/coE_coExpression/report.Rmd b/inst/app/contributions/coE_coExpression/report.Rmd
index 8b6fa8e517c71441e01c70e3505139e84c6ce8ba..5c197c8b63b3506a22fc38860edee337e0018208 100644
--- a/inst/app/contributions/coE_coExpression/report.Rmd
+++ b/inst/app/contributions/coE_coExpression/report.Rmd
@@ -115,7 +115,7 @@ dimY <- `r input$"coE_selected-dimension_y"`
DEBUGSAVE <- FALSE
grpNs <- groupNames$namesDF
-grpN <- make.names(input$groupName)
+grpN <- make.names(input$groupName, unique = TRUE)
dimY <- input$"coE_selected-dimension_y"
dimX <- input$"coE_selected-dimension_x"
diff --git a/inst/app/contributions/coE_coExpression/ui.R b/inst/app/contributions/coE_coExpression/ui.R
index d01243a71334d6500394d403bfdc54b56fac1c5f..a25c968ad7d65aec51b17dd7cf2431cc93cf811c 100644
--- a/inst/app/contributions/coE_coExpression/ui.R
+++ b/inst/app/contributions/coE_coExpression/ui.R
@@ -162,11 +162,12 @@ tabList <- list(
)
),
br(),
- fluidRow(column(
- width = 12,
- # jqui_resizable(plotly::plotlyOutput("coE_geneGrp_vio_plot") )
- jqui_resizable(plotOutput("coE_geneGrp_vio_plot"))
- ))
+ fluidRow(column(width = 12,
+ # jqui_resizable(plotly::plotlyOutput("coE_geneGrp_vio_plot") )
+ jqui_resizable(plotOutput("coE_geneGrp_vio_plot") )
+ )),
+ br(),
+ actionButton("save2HistVio", "save to history")
)
),
# SOMcluster ----
diff --git a/inst/app/contributions/gQC_generalQC/outputs.R b/inst/app/contributions/gQC_generalQC/outputs.R
index 776120721ed66b6e2438e5689119416ffe9a65d1..c2c739557e2abc9d91ac46111c758f0809c8a7cd 100644
--- a/inst/app/contributions/gQC_generalQC/outputs.R
+++ b/inst/app/contributions/gQC_generalQC/outputs.R
@@ -173,10 +173,13 @@ output$gQC_plotUmiHist <- renderPlot({
dat <- data.frame(counts = Matrix::colSums(assays(scEx)[["counts"]]))
dat$sample <- colData(scEx)$sampleNames
- ggplot(data = dat, aes(counts, fill = sample)) +
+ retVal <- ggplot(data = dat, aes(counts, fill = sample)) +
geom_histogram(bins = 50) +
labs(title = "Histogram for raw counts", x = "count", y = "Frequency") +
scale_fill_manual(values = scols, aesthetics = "fill")
+
+ .schnappsEnv[["gQC_plotUmiHist"]] <- retVal
+ return(retVal)
})
output$gQC_plotSampleHist <- renderPlot({
@@ -202,7 +205,9 @@ output$gQC_plotSampleHist <- renderPlot({
save(file = "~/SCHNAPPsDebug/sampleHist.RData", list = c(ls(), ls(envir = globalenv())))
}
# load(file = "~/SCHNAPPsDebug/sampleHist.RData")
- gQC_sampleHistFunc(sampleInf, scols)
+ retVal <- gQC_sampleHistFunc(sampleInf, scols)
+ .schnappsEnv[["gQC_plotSampleHist"]] <- retVal
+ return(retVal)
})
output$gQC_variancePCA <- renderPlot({
@@ -217,12 +222,23 @@ output$gQC_variancePCA <- renderPlot({
if (!is.null(getDefaultReactiveDomain())) {
showNotification("gQC_variancePCA", id = "gQC_variancePCA", duration = NULL)
}
-
- if (DEBUG) cat(file = stderr(), "output$gQC_variancePCA\n")
- h2("Variances of PCs")
pca <- pca()
if (is.null(pca)) {
return(NULL)
}
- barplot(pca$var_pcs, main = "Variance captured by first PCs")
+
+ if (.schnappsEnv$DEBUGSAVE) {
+ save(file = "~/SCHNAPPsDebug/gQC_variancePCA.RData", list = c(ls(), ls(envir = globalenv())))
+ }
+ # load(file = "~/SCHNAPPsDebug/gQC_variancePCA.RData")
+
+ # h2("Variances of PCs")
+
+
+
+ df <- data.frame(var = pca$var_pcs, pc = 1:length(pca$var_pcs))
+ retVal <- ggplot(data = df,aes(x=pc, y=var)) + geom_bar(stat = "identity")
+ .schnappsEnv[["gQC_variancePCA"]] <- retVal
+ return(retVal)
+ # barplot(pca$var_pcs, main = "Variance captured by first PCs")
})
diff --git a/inst/app/contributions/gQC_generalQC/reactives.R b/inst/app/contributions/gQC_generalQC/reactives.R
index af9b612028948e5cb24b2f4fd46c5478266879b3..1c9b93acd86b5feb787b8a6bd472f41685dc1908 100644
--- a/inst/app/contributions/gQC_generalQC/reactives.R
+++ b/inst/app/contributions/gQC_generalQC/reactives.R
@@ -4,6 +4,68 @@ suppressMessages(require(SingleCellExperiment))
# here we define reactive values/variables
+# save to history violoin observer ----
+observe({
+ clicked = input$save2Histumi
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVio \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "UMI histogram",
+ plotData = .schnappsEnv[["gQC_plotUmiHist"]])
+
+})
+
+
+# save to history save2HistSample observer ----
+observe({
+ clicked = input$save2HistSample
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVio \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "Sample histogram",
+ plotData = .schnappsEnv[["gQC_plotSampleHist"]])
+
+})
+
+# save to history save2HistSample observer ----
+observe({
+ clicked = input$save2Histvar
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVio \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlot", comment = "PC variance",
+ plotData = .schnappsEnv[["gQC_variancePCA"]])
+
+})
+
+
# gQC_scaterReadsFunc ----
#' gQC_scaterReadsFunc
#' calculate the QC metrix and return updated singleCellExperiment object
@@ -94,11 +156,14 @@ gQC_sampleHistFunc <- function(samples, scols) {
}
counts <- table(samples)
- barplot(counts,
- main = "histogram of number of cell per sample",
- xlab = "Samples",
- col = scols
- )
+ df <- as.data.frame(counts)
+ ggplot(data = df,aes(x=samples, y=Freq, fill=samples)) + geom_bar(stat = "identity") +
+ scale_color_manual(values=scols)
+ # barplot(counts,
+ # main = "histogram of number of cell per sample",
+ # xlab = "Samples",
+ # col=scols
+ # )
}
diff --git a/inst/app/contributions/gQC_generalQC/report.Rmd b/inst/app/contributions/gQC_generalQC/report.Rmd
index 17bce71a2f6a0922dab950038f866fa282222425..ad98363d9c1bde20111e0e50e3ac390cdf1997f6 100644
--- a/inst/app/contributions/gQC_generalQC/report.Rmd
+++ b/inst/app/contributions/gQC_generalQC/report.Rmd
@@ -269,7 +269,7 @@ ccols : `r clusterCols$colPal`
```{r gqc_UMAP, echo=TRUE}
DEBUGSAVE <- FALSE
grpNs <- groupNames$namesDF
-grpN <- make.names(input$groupName)
+grpN <- make.names(input$groupName, unique = TRUE)
dimY <- input$"gQC_umap_main-dimension_y"
dimX <- input$"gQC_umap_main-dimension_x"
diff --git a/inst/app/contributions/gQC_generalQC/ui.R b/inst/app/contributions/gQC_generalQC/ui.R
index ab5a5bfa8d5511d5cd227545cd6f5583a1b0dc2e..f3574352ad0f29b92d8573bda78350b42a82dd6d 100644
--- a/inst/app/contributions/gQC_generalQC/ui.R
+++ b/inst/app/contributions/gQC_generalQC/ui.R
@@ -22,7 +22,10 @@ tabList <- list(
10,
offset = 1,
plotOutput("gQC_plotUmiHist") %>% withSpinner()
- ))
+ )),
+ br(),
+ actionButton("save2Histumi", "save to history")
+
),
shinydashboard::tabItem(
@@ -32,7 +35,9 @@ tabList <- list(
10,
offset = 1,
plotOutput("gQC_plotSampleHist") %>% withSpinner()
- ))
+ )),
+ br(),
+ actionButton("save2HistSample", "save to history")
),
shinydashboard::tabItem(
@@ -42,8 +47,11 @@ tabList <- list(
10,
offset = 1,
plotOutput("gQC_variancePCA") %>% withSpinner()
- ))
+ )),
+ br(),
+ actionButton("save2Histvar", "save to history")
),
+
tsnePlotTab = shinydashboard::tabItem(
tabName = "gQC_tsnePlot",
shinyjs::useShinyjs(),
diff --git a/inst/app/contributions/sCA_subClusterAnalysis/outputs.R b/inst/app/contributions/sCA_subClusterAnalysis/outputs.R
index 82911846d6cf38914838b5a2b898875507909a40..7e39780993459661adba9c9710e8c27333b0e78f 100644
--- a/inst/app/contributions/sCA_subClusterAnalysis/outputs.R
+++ b/inst/app/contributions/sCA_subClusterAnalysis/outputs.R
@@ -205,6 +205,8 @@ output$sCA_volcanoPlot <- plotly::renderPlotly({
)
# retVal
+ .schnappsEnv[["sCA_volcanoPlot"]] <- retVal
+
exportTestValues(dgeVolcanoPlot = {
str(retVal)
})
diff --git a/inst/app/contributions/sCA_subClusterAnalysis/reactives.R b/inst/app/contributions/sCA_subClusterAnalysis/reactives.R
index 1430dd1e652750f5ccb9ace48176a4812269fc29..eab8588742fc5b39b2129881570430ec329316f2 100644
--- a/inst/app/contributions/sCA_subClusterAnalysis/reactives.R
+++ b/inst/app/contributions/sCA_subClusterAnalysis/reactives.R
@@ -90,7 +90,7 @@ myDiffExpFunctions <- list(
#' Seurat FindMarkers
#'
#' cellMeta = colData(scEx)
-sCA_seuratFindMarkers <- function(scEx, cells.1, cells.2, test = "wilcox") {
+sCA_seuratFindMarkers <- function(scEx, cells.1, cells.2, test="wilcox", normFact = 1){
if (DEBUG) cat(file = stderr(), "sCA_seuratFindMarkers started.\n")
start.time <- base::Sys.time()
on.exit({
@@ -107,7 +107,7 @@ sCA_seuratFindMarkers <- function(scEx, cells.1, cells.2, test = "wilcox") {
showNotification("Please install DESeq2", id = "sCA_dge_deseq2NOTFOUND", duration = NULL, type = "error")
}
if (.schnappsEnv$DEBUGSAVE) {
- save(file = "~/SCHNAPPsDebug/sCA_seuratFindMarkers.RData", list = c(ls(), ls(envir = globalenv())))
+ save(file = "~/SCHNAPPsDebug/sCA_seuratFindMarkers.RData", list = c(ls()))
}
# load(file='~/SCHNAPPsDebug/sCA_seuratFindMarkers.RData')
@@ -120,23 +120,24 @@ sCA_seuratFindMarkers <- function(scEx, cells.1, cells.2, test = "wilcox") {
meta.data = meta.data
)
# we remove e.g. "genes" from total seq (CD3-TotalSeqB)
- useGenes <- which(rownames(seurDat@assays$RNA@data) %in% rownames(as(assays(scEx)[[1]], "dgCMatrix")))
- seurDat@assays$RNA@data <- as(assays(scEx)[[1]], "dgCMatrix")[useGenes, ]
-
- markers <- Seurat::FindMarkers(seurDat@assays$RNA@data,
- cells.1 = cells.1,
- cells.2 = cells.2,
- min.pct = 0,
- test.use = test
- # test.use = "wilcox" # p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "bimod" # p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "roc" # myAUC avg_diff power pct.1 pct.2
- # test.use = "t" # p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "negbinom" # needs UMI; p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "poisson" # needs UMI; p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "LR" # p_val avg_logFC pct.1 pct.2 p_val_adj
- # test.use = "MAST" # not working: Assay in position 1, with name et is unlogged. Set `check_sanity = FALSE` to override and then proceed with caution.
- # test.use = "DESeq2" # needs UMI # done separately because the estimating process isn't working with 0s
+ useGenes = which(rownames(seurDat@assays$RNA@data) %in% rownames(as(assays(scEx)[[1]], "dgCMatrix")))
+ seurDat@assays$RNA@data = as(assays(scEx)[[1]], "dgCMatrix")[useGenes,]
+
+ markers <- Seurat::FindMarkers(seurDat@assays$RNA@data/normFact,
+ cells.1 = cells.1,
+ cells.2 = cells.2,
+ min.pct = 0,
+ test.use = test,
+ logfc.threshold = 0.001
+ # test.use = "wilcox" # p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "bimod" # p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "roc" # myAUC avg_diff power pct.1 pct.2
+ # test.use = "t" # p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "negbinom" # needs UMI; p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "poisson" # needs UMI; p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "LR" # p_val avg_logFC pct.1 pct.2 p_val_adj
+ # test.use = "MAST" # not working: Assay in position 1, with name et is unlogged. Set `check_sanity = FALSE` to override and then proceed with caution.
+ # test.use = "DESeq2" # needs UMI # done separately because the estimating process isn't working with 0s
)
if (nrow(markers) > 0) {
markers$symbol <- rData[rownames(markers), "symbol"]
@@ -148,23 +149,27 @@ sCA_seuratFindMarkers <- function(scEx, cells.1, cells.2, test = "wilcox") {
}
-sCA_dge_s_wilcox <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "wilcox")
+sCA_dge_s_wilcox <- function(scEx_log, cells.1, cells.2){
+ normFact = .schnappsEnv$normalizationFactor
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="wilcox", normFact)
}
-sCA_dge_s_bimod <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "bimod")
+sCA_dge_s_bimod <- function(scEx_log, cells.1, cells.2){
+ normFact = .schnappsEnv$normalizationFactor
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="bimod")
}
-sCA_dge_s_t <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "t")
+sCA_dge_s_t <- function(scEx_log, cells.1, cells.2){
+ normFact = .schnappsEnv$normalizationFactor
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="t", normFact)
}
-sCA_dge_s_LR <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "LR")
+sCA_dge_s_LR<- function(scEx_log, cells.1, cells.2){
+ normFact = .schnappsEnv$normalizationFactor
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="LR", normFact)
}
-sCA_dge_s_negbinom <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "negbinom")
+sCA_dge_s_negbinom <- function(scEx_log, cells.1, cells.2){
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="negbinom", normFact = 1)
}
-sCA_dge_s_poisson <- function(scEx_log, cells.1, cells.2) {
- sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test = "poisson")
+sCA_dge_s_poisson <- function(scEx_log, cells.1, cells.2){
+ sCA_seuratFindMarkers(scEx_log, cells.1, cells.2, test="poisson", normFact = 1)
}
@@ -198,7 +203,13 @@ sCA_dge_deseq2 <- function(scEx_log, cells.1, cells.2) {
group.info[cells.2, "group"] <- "Group2"
group.info[, "group"] <- factor(x = group.info[, "group"])
group.info$wellKey <- rownames(x = group.info)
- data.use <- assays(scEx_log)[[1]][, rownames(group.info)]
+ # TODO how to handle data / transformation ?
+ # it uses non-transformed org data. What happens if we loaded normalized data?
+ # can back tronsform the data in counts?
+ if (is.null(.schnappsEnv$normalizationFactor)) {
+ .schnappsEnv$normalizationFactor = 1
+ }
+ data.use = assays(scEx_log)[[1]][,rownames(group.info)]
dds1 <- DESeq2::DESeqDataSetFromMatrix(
countData = data.use,
colData = group.info,
@@ -252,8 +263,10 @@ sCA_dge_CellViewfunc <- function(scEx_log, cells.1, cells.2) {
subsetExpression <- scEx_log[complete.cases(scEx_log[, union(cells.1, cells.2)]), ]
genes.use <- rownames(subsetExpression)
# expMean exponential mean
- data.1 <- apply(subsetExpression[genes.use, cells.1], 1, expMean)
- data.2 <- apply(subsetExpression[genes.use, cells.2], 1, expMean)
+ dat <- subsetExpression[genes.use, cells.1]
+ data.1 <- apply(dat, 1, function(x) expMean(x, .schnappsEnv$normalizationFactor))
+ dat <- subsetExpression[genes.use, cells.2]
+ data.2 <- apply(dat, 1, function(x) expMean(x, .schnappsEnv$normalizationFactor))
total.diff <- (data.1 - data.2)
genes.diff <- names(which(abs(total.diff) > .2))
@@ -283,7 +296,7 @@ sCA_dge_ttest <- function(scEx_log, cells.1, cells.2) {
showNotification("sCA_dge_ttest", id = "sCA_dge_ttest", duration = NULL)
}
if (.schnappsEnv$DEBUGSAVE) {
- save(file = "~/SCHNAPPsDebug/sCA_dge_ttest.RData", list = c(ls(), ls(envir = globalenv())))
+ save(file = "~/SCHNAPPsDebug/sCA_dge_ttest.RData", list = c(ls()))
}
# load(file='~/SCHNAPPsDebug/sCA_dge_ttest.RData')
@@ -294,9 +307,10 @@ sCA_dge_ttest <- function(scEx_log, cells.1, cells.2) {
p_val <- apply(subsetExpression, 1, function(x) t.test(x[cells.1], x[cells.2])$p.value)
p_val[is.na(p_val)] <- 1
-
- data.1 <- apply(subsetExpression[genes.use, cells.1], 1, expMean)
- data.2 <- apply(subsetExpression[genes.use, cells.2], 1, expMean)
+ dat <- subsetExpression[genes.use, cells.1]
+ data.1 <- apply(dat, 1, function(x) expMean(x, normFactor = .schnappsEnv$normalizationFactor))
+ dat <- subsetExpression[genes.use, cells.2]
+ data.2 <- apply(dat, 1, function(x) expMean(x, normFactor = .schnappsEnv$normalizationFactor))
avg_diff <- (data.1 - data.2)
retVal <- data.frame(p_val = p_val, avg_diff = avg_diff, symbol = featureData[names(p_val), "symbol"])
@@ -340,8 +354,8 @@ sCA_dge <- reactive({
gCells <- sCA_getCells(projections, cl1, db1, db2)
# in case we need counts and not normalized counts
- if (dgeFunc %in% c("sCA_dge_deseq2", "sCA_dge_s_poisson", "sCA_dge_s_poisson")) {
- scEx_log <- scEx
+ if (dgeFunc %in% c("sCA_dge_deseq2", "sCA_dge_s_negbinom", "sCA_dge_s_poisson")) {
+ scEx_log = scEx
}
retVal <- do.call(dgeFunc, args = list(
scEx_log = scEx_log,
@@ -535,3 +549,25 @@ subCluster2Dplot <- function() {
p1
})
}
+
+# save to history violoin observer ----
+observe({
+ clicked = input$save2HistVolc
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistVolc \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlotly", comment = "volcano plot",
+ plotData = .schnappsEnv[["sCA_volcanoPlot"]])
+
+})
+
+
diff --git a/inst/app/contributions/sCA_subClusterAnalysis/ui.R b/inst/app/contributions/sCA_subClusterAnalysis/ui.R
index 3f848a749f57be15ccc15a7dbcc1c50a1badc7c6..d2e151b43c342de067b2e66b2516a6586e2206e5 100644
--- a/inst/app/contributions/sCA_subClusterAnalysis/ui.R
+++ b/inst/app/contributions/sCA_subClusterAnalysis/ui.R
@@ -130,7 +130,9 @@ tabList <- list(
width = 12,
jqui_resizable(plotly::plotlyOutput("sCA_volcanoPlot"))
)
- )
+ ),
+ br(),
+ actionButton("save2HistVolc", "save to history")
),
box(
title = "Differentially Expressed Genes", solidHeader = TRUE, width = 12, status = "primary",
diff --git a/inst/app/moduleServer.R b/inst/app/moduleServer.R
index aee1f9a0a90915881169808e1a3bb46f72af8da5..4c1ac53182b907863f362e7d0dade074b3cd74a9 100644
--- a/inst/app/moduleServer.R
+++ b/inst/app/moduleServer.R
@@ -118,6 +118,29 @@ clusterServer <- function(input, output, session,
}
})
+ # observe save 2 history ----
+ observe({
+ clicked = input$save2Hist
+ if (DEBUG) cat(file = stderr(), "observe input$save2Hist \n")
+ myns <- session$ns("-")
+ req(.schnappsEnv[[paste0("historyPlot-",myns)]])
+ start.time <- base::Sys.time()
+ if (DEBUG) cat(file = stderr(), "cluster: save2Hist\n")
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "renderPlotly",
+ plotData = .schnappsEnv[[paste0("historyPlot-",myns)]],
+ comment = paste(myns))
+
+ })
# clusterServer - updateInput ----
# updateInput <-
@@ -142,12 +165,12 @@ clusterServer <- function(input, output, session,
selected = .schnappsEnv$dim1
)
updateSelectInput(session, "dimension_y",
- choices = c(colnames(projections), "UmiCountPerGenes", "UmiCountPerGenes2"),
- selected = .schnappsEnv$dim2
+ choices = c(colnames(projections), "histogram", "UmiCountPerGenes", "UmiCountPerGenes2"),
+ selected = .schnappsEnv$dim2
)
updateSelectInput(session, "dimension_col",
- choices = c(colnames(projections), "UmiCountPerGenes", "UmiCountPerGenes2"),
- selected = .schnappsEnv$dimCol
+ choices = c(colnames(projections), "cellDensity" ,"UmiCountPerGenes", "UmiCountPerGenes2"),
+ selected = .schnappsEnv$dimCol
)
updateSelectInput(session, "divideXBy",
@@ -193,7 +216,7 @@ clusterServer <- function(input, output, session,
scEx_log <- scEx_log()
scEx <- scEx()
namedGroup <- input$groupNames
- grpN <- make.names(input$groupName)
+ grpN <- make.names(input$groupName, unique = TRUE)
grpNs <- groupNames$namesDF
if (is.null(projections) | is.null(brushedPs)) {
@@ -229,7 +252,7 @@ clusterServer <- function(input, output, session,
}
if (!namedGroup == "plot") {
if (namedGroup %in% colnames(grpNs)) {
- return(rownames(grpNs[grpNs[, namedGroup], ]))
+ return(rownames(grpNs[grpNs[, namedGroup] == "TRUE", ]))
} else {
return(NULL)
}
@@ -242,10 +265,11 @@ clusterServer <- function(input, output, session,
# cells.names <- rownames(projections)[subset(brushedPs, curveNumber == 0)$pointNumber + 1]
# cells.names <- rownames(projections)[subset(brushedPs)$pointNumber + 1]
cells.names <- brushedPs$key
+ cells.names <- cells.names[cells.names %in% colnames(scEx_log)]
cells.names <- unique(cells.names[!is.na(cells.names)])
- if (DEBUG) {
- cat(file = stderr(), paste("curveNumbers:", unique(brushedPs$curveNumber), "\n"))
- }
+ # if (DEBUG) {
+ # cat(file = stderr(), paste("curveNumbers:", unique(brushedPs$curveNumber), "\n"))
+ # }
printTimeEnd(start.time, "selectedCellNames")
exportTestValues(selectedCellNames = {
cells.names
@@ -266,8 +290,8 @@ clusterServer <- function(input, output, session,
if (DEBUG) cat(file = stderr(), paste("selectedCellNames is null\n"))
retVal <- NULL
}
- grpN <- make.names(input$groupName)
- grpSelected <- make.names(input$groupNames)
+ grpN <- make.names(input$groupName, unique = TRUE)
+ grpSelected <- make.names(input$groupNames, unique = TRUE)
grpNs <- groupNames$namesDF
if (length(grpN) == 0 | length(grpNs) == 0) {
if (DEBUG) cat(file = stderr(), "reactiveValues: grpN empty\n")
@@ -304,7 +328,13 @@ clusterServer <- function(input, output, session,
subsetData <- subset(projections, dbCluster %in% inpClusters)
grpSubset <- grpNs[rownames(subsetData), ]
- grpVal <- rownames(grpSubset[grpSubset[, grpN], ])
+ if (!grpN %in% colnames(grpSubset)) {
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("group name is not available", id = "nogrpN", duration = NULL, type = "error")
+ }
+ return(NULL)
+ }
+ grpVal <- rownames(grpSubset[grpSubset[, grpN] == "TRUE", ])
if (length(grpVal) > 0) {
return(grpVal)
}
@@ -373,7 +403,7 @@ clusterServer <- function(input, output, session,
projections <- projections()
grpNs <- groupNames$namesDF
grpN <- make.names(input$groupName)
-
+ grpN <- make.names(input$groupName, unique = TRUE)
# returnValues$cluster <- input$clusters
dimY <- input$dimension_y
dimX <- input$dimension_x
@@ -395,6 +425,7 @@ clusterServer <- function(input, output, session,
}
if (is.null(scEx) | is.null(tdata)) {
if (DEBUG) cat(file = stderr(), paste("output$clusterPlot:NULL\n"))
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- NULL
return(NULL)
}
# in case the normalization is not done
@@ -414,7 +445,7 @@ clusterServer <- function(input, output, session,
cat(file = stderr(), paste("cluster plot saving done\n"))
}
- # load(file=paste0("~/SCHNAPPsDebug/clusterPlot", "ns", ".RData", collapse = "."));.schnappsEnv$DEBUGSAVE=FALSE
+ # load("/Users/bernd/SCHNAPPsDebug/clusterPlot-coE_selected--.RData");.schnappsEnv$DEBUGSAVE=FALSE
if (is.null(g_id) || nchar(g_id) == 0) {
g_id <- featureData$symbol
}
@@ -442,9 +473,16 @@ clusterServer <- function(input, output, session,
geneNames2, dimX, dimY, clId, grpN, legend.position,
grpNs = grpNs, logx, logy, divXBy, divYBy, dimCol, colors = myColors
)
- if (save2History) recHistory(myns, p1)
+
+ # save p1 to .schnappsEnv for saving to history
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- p1
+
+ # add2history(type = "renderPlotly", plotData = p1, comment = paste(myns))
+ # if (save2History) recHistory(myns, p1)
# event_register(p1, 'plotly_selected')
printTimeEnd(start.time, "clusterPlot")
+ # browser()
+ # .schnappsEnv[[paste0()]] <- p
exportTestValues(clusterPlot = {
p1
})
@@ -536,7 +574,7 @@ clusterServer <- function(input, output, session,
cat(file = stderr(), "save: changeGroups\n")
save(file = "~/SCHNAPPsDebug/changeGroups.RData", list = c(ls(), ls(envir = globalenv())))
cat(file = stderr(), "done save: changeGroups\n")
- browser()
+ # browser()
}
# load(file="~/SCHNAPPsDebug/changeGroups.RData")
# in case the cell selection has changed
@@ -548,6 +586,7 @@ clusterServer <- function(input, output, session,
grpNs[rownames(visibleCells), grpN] <- FALSE
}
grpNs[cells.names, grpN] <- TRUE
+ grpNs[, grpN] <- as.factor(grpNs[, grpN] )
# Set reactive value
# cat(file = stderr(), paste("DEBUG: ",cells.names," \n"))
groupNames$namesDF <- grpNs
@@ -595,8 +634,9 @@ clusterServer <- function(input, output, session,
if (!is.null(getDefaultReactiveDomain())) {
showNotification("nCellsVisibleSelected", id = "nCellsVisibleSelected", duration = NULL)
}
+
+ grpN <- make.names(input$groupName, unique = TRUE)
- grpN <- make.names(input$groupName)
grpNs <- groupNames$namesDF
# inpClusters <- input$clusters
projections <- projections()
@@ -610,8 +650,9 @@ clusterServer <- function(input, output, session,
inpClusters <- levels(projections$dbCluster)
subsetData <- subset(projections, dbCluster %in% inpClusters)
- retVal <- paste("Number of visible cells in section", sum(grpNs[rownames(subsetData), grpN]))
+ retVal <- paste("Number of visible cells in section", sum(grpNs[rownames(subsetData), grpN] == "TRUE"))
+
exportTestValues(DummyReactive = {
retVal
})
@@ -726,15 +767,17 @@ clusterServer <- function(input, output, session,
scEx_log <- scEx_log()
# moreOptions <- input$moreOptions
retVal <- selectedCellNames()
- grpN <- make.names(input$groupName)
- grpSelected <- make.names(input$groupNames)
+ grpN <- make.names(input$groupName, unique = TRUE)
+ grpSelected <- make.names(input$groupNames, unique = TRUE)
grpNs <- groupNames$namesDF
-
+ myns <- ns("cellSelection")
if (!myshowCells) {
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- NULL
return("")
}
if (is.null(projections)) {
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- NULL
return("")
}
if (.schnappsEnv$DEBUGSAVE) {
@@ -757,6 +800,8 @@ clusterServer <- function(input, output, session,
# cells.names <- cells.names[!is.na(cells.names)]
retVal <- paste(retVal, collapse = ", ")
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- retVal
+
exportTestValues(ClusterCellSelection = {
retVal
})
@@ -783,6 +828,27 @@ tableSelectionServer <- function(input, output, session,
assign(ns("colOrder"), list(), envir = .schnappsEnv)
assign(ns("modSelectedRows"), c(), envir = .schnappsEnv)
+ observe({
+ clicked = input$save2HistTabUi
+ myns <- session$ns("cellNameTable")
+ if (DEBUG) cat(file = stderr(), "observe input$save2HistTabUi \n")
+ start.time <- base::Sys.time()
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+ req(.schnappsEnv[[paste0("historyPlot-",myns)]])
+ add2history(type = "renderDT", comment = "Table",
+ tableData = .schnappsEnv[[paste0("historyPlot-",myns)]] )
+
+ })
+
+
output$rowSelection <- renderText({
if (DEBUG) cat(file = stderr(), "cellSelection\n")
start.time <- Sys.time()
@@ -802,7 +868,7 @@ tableSelectionServer <- function(input, output, session,
selectedRows <- input$cellNameTable_rows_selected
scEx <- scEx()
# update if expanded and not showing
- input$refreshtable
+ # input$refreshtable
# we only need this for the removed genes table, so to not use too much memory we introduce this if statement
inputData <- NULL
@@ -896,6 +962,7 @@ tableSelectionServer <- function(input, output, session,
# renderDT cellNameTable ----
output$cellNameTable <- DT::renderDT({
+ myns <- session$ns("cellNameTable")
if (DEBUG) cat(file = stderr(), "output$cellNameTable\n")
start.time <- base::Sys.time()
on.exit(
@@ -915,6 +982,7 @@ tableSelectionServer <- function(input, output, session,
selectedRows <- input$cellNameTable_rows_selected
# searchStr <-
if (is.null(dataTables)) {
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- NULL
return(NULL)
}
if (.schnappsEnv$DEBUGSAVE) {
@@ -958,22 +1026,24 @@ tableSelectionServer <- function(input, output, session,
}
}
# if (DEBUG) cat(file = stderr(), paste(colState$search,"\n"))
+ dtout <- DT::datatable(dataTables,
+ rownames = F,
+ filter = "top",
+ selection = list(mode = "multiple", selected = get(ns("modSelectedRows"), envir = .schnappsEnv)),
+ options = list(
+ orderClasses = TRUE,
+ autoWidth = TRUE,
+ scrollX = TRUE,
+ pageLength = get(ns("pageLength"), envir = .schnappsEnv),
+ search = colState$search,
+ searchCols = searchColList,
+ stateSave = TRUE,
+ order = get(ns("colOrder"), envir = .schnappsEnv)
+ )
+ )
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- dtout
return(
- DT::datatable(dataTables,
- rownames = F,
- filter = "top",
- selection = list(mode = "multiple", selected = get(ns("modSelectedRows"), envir = .schnappsEnv)),
- options = list(
- orderClasses = TRUE,
- autoWidth = TRUE,
- scrollX = TRUE,
- pageLength = get(ns("pageLength"), envir = .schnappsEnv),
- search = colState$search,
- searchCols = searchColList,
- stateSave = TRUE,
- order = get(ns("colOrder"), envir = .schnappsEnv)
- )
- )
+ dtout
)
} else {
return(warning("test"))
@@ -1012,6 +1082,31 @@ pHeatMapModule <- function(input, output, session,
outfilePH <- NULL
+ # observe save 2 history ----
+ observe({
+ clicked <- input$save2HistHM
+ if (DEBUG) cat(file = stderr(), "observe input$save2Hist \n")
+ myns <- ns("pHeatMap")
+ # browser()
+ req(.schnappsEnv[[paste0("historyPlot-",myns)]])
+ start.time <- base::Sys.time()
+ if (DEBUG) cat(file = stderr(), "cluster: save2Hist\n")
+ on.exit(
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "save2Hist")
+ }
+ )
+ # show in the app that this is running
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("save2Hist", id = "save2Hist", duration = NULL)
+ }
+
+ add2history(type = "tronco",
+ plotData = .schnappsEnv[[paste0("historyPlot-",myns)]],
+ comment = paste(myns))
+
+ })
+
# pHeatMapModule - updateInput ----
# updateInput <-
# this is calling projections during loading of data
@@ -1075,6 +1170,7 @@ pHeatMapModule <- function(input, output, session,
# moreOptions <- input$moreOptions
colTree <- input$showColTree
scale <- input$normRow
+ myns <- ns("pHeatMap")
save2History <- input$save2History
pWidth <- input$heatmapWidth
pHeight <- input$heatmapHeight
@@ -1089,6 +1185,7 @@ pHeatMapModule <- function(input, output, session,
# load(file = "~/SCHNAPPsDebug/pHeatMapPlotModule.RData")
if (is.null(heatmapData) | is.null(proje) | is.null(heatmapData$mat)) {
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- NULL
return(list(
src = "empty.png",
contentType = "image/png",
@@ -1161,6 +1258,8 @@ pHeatMapModule <- function(input, output, session,
heatmapData$width <- pWidth / 72
heatmapData$height <- pHeight / 72
do.call(TRONCO::pheatmap, heatmapData)
+
+ .schnappsEnv[[paste0("historyPlot-",myns)]] <- heatmapData
# library(seriation)
# hm <- hmap(x, method = "HC_ward", main = "HC_ward")
@@ -1174,7 +1273,7 @@ pHeatMapModule <- function(input, output, session,
# if (is.null(height)) {
# height <- 96 * 7
# }
- outfilePH <<- outfile
+ outfilePH <- outfile
return(list(
src = outfilePH,
contentType = "image/png",
diff --git a/inst/app/modulesUI.R b/inst/app/modulesUI.R
index 05f6e565be219e9d14a06ad9947511d01b064070..dc1229607a540890e94cdfcf66f6509a4967d405 100644
--- a/inst/app/modulesUI.R
+++ b/inst/app/modulesUI.R
@@ -38,25 +38,25 @@ clusterUI <- function(id) {
column(
width = 4,
selectInput(ns("dimension_x"),
- label = "X",
- choices = c("tsne1", "tsne2", "tsne3"),
- selected = "tsne1"
+ label = "X",
+ choices = c("tsne1", "tsne2", "tsne3"),
+ selected = "tsne1"
)
),
column(
width = 4,
selectInput(ns("dimension_y"),
- label = "Y",
- choices = c("tsne1", "tsne2", "tsne3"),
- selected = "tsne2"
+ label = "Y",
+ choices = c("tsne1", "tsne2", "tsne3"),
+ selected = "tsne2"
)
),
column(
width = 4,
selectInput(ns("dimension_col"),
- label = "color",
- choices = c("Gene.count"),
- selected = "Gene.count"
+ label = "color",
+ choices = c("Gene.count"),
+ selected = "Gene.count"
)
)
),
@@ -83,37 +83,37 @@ clusterUI <- function(id) {
column(
width = 3,
selectInput(ns("divideXBy"),
- label = "Divide X by",
- # choices = c("None", "Gene.count", "UMI.count"),
- choices = c("None", "UmiCountPerGenes", "UmiCountPerGenes2"),
- selected = "None"
+ label = "Divide X by",
+ # choices = c("None", "Gene.count", "UMI.count"),
+ choices = c("None", "UmiCountPerGenes", "UmiCountPerGenes2"),
+ selected = "None"
)
),
column(
width = 3,
selectInput(ns("divideYBy"),
- label = "Divide Y by",
- # choices = c("None", "Gene.count", "UMI.count"),
- choices = c("None", "UmiCountPerGenes", "UmiCountPerGenes2"),
- selected = "None"
+ label = "Divide Y by",
+ # choices = c("None", "Gene.count", "UMI.count"),
+ choices = c("None", "UmiCountPerGenes", "UmiCountPerGenes2"),
+ selected = "None"
)
)
),
fluidRow(
- column(
- width = 12,
- checkboxInput(ns("addToGroup"), "Add to group/otherwise overwrite", TRUE),
- textInput(ns(id = "groupName"), label = "name group, also used in Plot to color selected cells red.", value = "cellGroupName"),
- selectInput(ns("groupNames"),
- label = "group names, !When modifying a group this list of cells is used as a reference!",
- choices = c("plot"),
- selected = "plot"
- ),
- verbatimTextOutput(ns("nCellsVisibleSelected")),
- actionButton(ns("changeGroups"), "change current selection"),
- checkboxInput(ns("showCells"), "show cell names", FALSE),
- verbatimTextOutput(ns("cellSelection")),
- uiOutput(ns("additionalOptions")) # TODO:is this still needed???
+ column(width = 12,
+ checkboxInput(ns("addToGroup"), "Add to group/otherwise overwrite", TRUE),
+ textInput(ns(id = "groupName"), label = "name group, also used in Plot to color selected cells red.", value = "cellGroupName"),
+ selectInput(ns("groupNames"),
+ label = "group names, !When modifying a group this list of cells is used as a reference!",
+ choices = c("plot"),
+ selected = "plot"
+ ),
+ verbatimTextOutput(ns("nCellsVisibleSelected")),
+ actionButton(ns("changeGroups"), "change current selection"),
+ checkboxInput(ns("showCells"), "show cell names", FALSE),
+ verbatimTextOutput(ns("cellSelection")),
+ actionButton(ns("save2Hist"), "save to history"),
+ uiOutput(ns("additionalOptions")) # TODO:is this still needed???
)
)
)
@@ -139,21 +139,27 @@ tableSelectionUi <- function(id) {
h5("Selected itmes to be copied"),
align = "left"
),
- verbatimTextOutput(ns("rowSelection"))
+ verbatimTextOutput(ns("rowSelection")),
+ )),
+ fluidRow(
+ column(width = 3,
+ actionButton(ns("save2HistTabUi"), "Save to history"),
)
- ),
+ # ,
+ # column(
+ # width = 3,
+ # actionButton(ns("refreshtable"), "Refresh table"),
+ # )
+ )
+ ),
+ box(
+ width = 12,
fluidRow(
column(
width = 3,
- downloadButton(ns("download_cellNameTable"), "Download table")
- ),
- column(
- width = 3,
- actionButton(ns("refreshtable"), "Refresh table"),
- )
- ),
+ h4("Cells", offset = 1)
+ )),
fluidRow(
- h4("Cells", offset = 1),
column(
width = 3,
checkboxInput(ns("selectAll"), "Select all rows", FALSE)
@@ -177,79 +183,75 @@ tableSelectionUi <- function(id) {
pHeatMapUI <- function(id) {
ns <- NS(id)
tagList(
- box(
- width = 12,
- fluidRow(
- column(
- width = 12,
- jqui_resizable(plotOutput(ns("pHeatMapPlot"),
- # height = "auto",
- brush = brushOpts(id = "crh1")
- ), options = list(width = "99%"))
- )
- ),
- box(
- title = "additional options", solidHeader = TRUE, width = 12, status = "primary",
- collapsible = TRUE, collapsed = TRUE,
- fluidRow(
- column(
- width = 12,
- # checkboxInput(ns("moreOptions"), "show more options", FALSE),
- checkboxInput(ns("showColTree"), label = "Show tree for cells", value = FALSE),
- )
- ),
- fluidRow(
- column(
- width = 6,
- selectInput(ns("normRow"),
- label = "scale by row (for color)",
- choices = c("row", "column", "none"),
- selected = "none"
- ),
- selectInput(
- ns("ColNames"),
- label = "group names",
- choices = c(),
- selected = "sampleNames",
- multiple = TRUE
- ),
-
- selectInput(
- ns("orderNames"),
- label = "order of columns",
- choices = c(),
- selected = "",
- multiple = TRUE
- )
- ),
- column(
- width = 6,
- numericInput(
- ns("heatmapWidth"),
- label = "width of image in pixel",
- min = 100, max = 20000, step = 10,
- value = 800
- ),
- numericInput(
- ns("heatmapHeight"),
- label = "height of image in pixel",
- min = 200, max = 20000, step = 10,
- value = 300
- )
- )
- ),
- fluidRow(
- column(
- width = 12,
- # uiOutput(ns("additionalOptions")),
- downloadButton(ns("download_pHeatMapUI"), "Download PlotData")
- )
- )
-
- # checkboxInput(ns("showCells"), "show cell names", FALSE),
- #
- # verbatimTextOutput(ns('cellSelection'))
- ) # box
+ box( width = 12,
+ fluidRow(
+ column(width = 12,
+ jqui_resizable(plotOutput(ns("pHeatMapPlot"),
+ # height = "auto",
+ brush = brushOpts(id = "crh1")
+ ),options = list( width="99%"))
+ )
+ ),
+ box(
+ title = "additional options", solidHeader = TRUE, width = 12, status = 'primary',
+ collapsible = TRUE, collapsed = TRUE,
+ fluidRow(
+ column(width = 12,
+ # checkboxInput(ns("moreOptions"), "show more options", FALSE),
+ checkboxInput(ns("showColTree"), label = "Show tree for cells", value = FALSE),
+ )
+ ),
+ fluidRow(
+ column(width = 6,
+ selectInput(ns("normRow"),
+ label = "scale by row (for color)",
+ choices = c("row", "column", "none"),
+ selected = "none"
+ ),
+ selectInput(
+ ns("ColNames"),
+ label = "group names",
+ choices = c(),
+ selected = "sampleNames",
+ multiple = TRUE
+ ),
+
+ selectInput(
+ ns("orderNames"),
+ label = "order of columns",
+ choices = c(),
+ selected = "",
+ multiple = TRUE
+ )
+ ),
+ column(width = 6,
+ numericInput(
+ ns("heatmapWidth"),
+ label = "width of image in pixel",
+ min = 100, max = 20000, step = 10,
+ value = 800
+ ),
+ numericInput(
+ ns("heatmapHeight"),
+ label = "height of image in pixel",
+ min = 200, max = 20000, step = 10,
+ value = 300
+ ))
+ ),
+ fluidRow(
+ column(width = 12,
+ # uiOutput(ns("additionalOptions")),
+ downloadButton(ns("download_pHeatMapUI"), "Download PlotData"),
+ actionButton(ns("save2HistHM"), "save to history")
+
+ )
+ )
+
+ # checkboxInput(ns("showCells"), "show cell names", FALSE),
+ #
+ # verbatimTextOutput(ns('cellSelection'))
+
+ ) # box
)
)
}
diff --git a/inst/app/outputs.R b/inst/app/outputs.R
index c220fcbe11af0e59d1ae08cf68c926537f6f9bbc..886ae158f051d5f5a1c45819b1394ecaca36123a 100644
--- a/inst/app/outputs.R
+++ b/inst/app/outputs.R
@@ -339,14 +339,19 @@ output$DEBUGSAVEstring <- renderText({
}
})
-output$save2Historystring <- renderText({
- if (DEBUG) {
- .schnappsEnv$saveHistorycheckbox <- input$save2History
- saveHistorycheckbox <- input$save2History
- } else {
- NULL
- }
-})
+# output$currentTabInfo <- renderText({
+# # browser()
+# str(input$sideBarID)
+# })
+
+# output$save2Historystring <- renderText({
+# if (DEBUG) {
+# .schnappsEnv$saveHistorycheckbox <- input$save2History
+# saveHistorycheckbox <- input$save2History
+# } else {
+# NULL
+# }
+# })
# cellSelectionMod ----
callModule(tableSelectionServer, "cellSelectionMod", inputSample)
@@ -430,6 +435,53 @@ output$clusterColorSelection <- renderUI({
})
})
+# history store to file ----
+#'
+
+askComment <- function(failed = FALSE) {
+ modalDialog(
+ textInput("HistComment", "add a comment", value = paste("created at ",date())),
+ footer = tagList(
+ modalButton("Cancel"),
+ actionButton("HistCommentok", "OK")
+ )
+ )
+}
+observeEvent(input$HistCommentok, {
+ if (DEBUG) {
+ cat(file = stderr(), "writing history.\n")
+ }
+ start.time <- base::Sys.time()
+ on.exit({
+ printTimeEnd(start.time, "HistCommentok")
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "HistCommentok")
+ }
+ })
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("writing history", id = "HistCommentok", duration = NULL)
+ }
+
+ panelLinkHistory = list("coexpressionSelected" = "coE")
+ id <- input$sideBarID
+ cat(file = stderr(), paste0("observeEvent input$save2History\n"))
+ save(file = "~/SCHNAPPsDebug/save2History.RData", list = c(ls(), ls(envir = globalenv())))
+ # cp =load(file="~/SCHNAPPsDebug/save2History.RData")
+ lsS = ls(envir = .schnappsEnv)
+ for (pl in lsS[grep(paste0("^historyPlot-",panelLinkHistory[[id]]), lsS)]) {
+ cat(file = stderr(), paste0("writing to history: ",pl ,"\n"))
+ sp <- strsplit( pl, "-" )[[1]]
+ recHistory(sp[[length(sp)]], .schnappsEnv[[pl]], envir = .schnappsEnv)
+
+ }
+
+ removeModal()
+
+})
+
+observeEvent(input$save2History, {
+ showModal(askComment())
+})
# observe: input$updateColors ----
observeEvent(
@@ -704,7 +756,7 @@ observe(label = "ob27", {
observe(label = "ob28", {
input$newPrj
- updateTextInput(session, "newPrj", value = make.names(input$newPrj))
+ updateTextInput(session, "newPrj", value = make.names(input$newPrj, unique = TRUE))
})
observeEvent(
diff --git a/inst/app/reactives.R b/inst/app/reactives.R
index 53b843d0a3ad4f5690fe1106c2fad3ad0a9d40d4..c17dcd00a945071b6e1c183d3d6b2561d4fe9958 100644
--- a/inst/app/reactives.R
+++ b/inst/app/reactives.R
@@ -36,6 +36,114 @@ if ("crayon" %in% rownames(installed.packages()) == FALSE) {
}
+# <- reactive({
+output$dimPlotPCA <- renderPlot({
+ if (DEBUG) {
+ cat(file = stderr(), "dimPlotPCA started.\n")
+ }
+ start.time <- base::Sys.time()
+ on.exit({
+ printTimeEnd(start.time, "dimPlotPCA")
+ if (!is.null(getDefaultReactiveDomain())) {
+ removeNotification(id = "dimPlotPCA")
+ }
+ })
+ if (!is.null(getDefaultReactiveDomain())) {
+ showNotification("dimPlotPCA", id = "dimPlotPCA", duration = NULL)
+ }
+
+ input$updateDimPlot
+ scEx_log <- isolate(scEx_log())
+ scEx <- isolate(scEx())
+ pca <- isolate(pca())
+ if (is.null(scEx_log)) {
+ if (DEBUG) {
+ cat(file = stderr(), "dimPlotPCA:NULL\n")
+ }
+ return(0)
+ }
+ # if (.schnappsEnv$DEBUGSAVE) {
+ save(file = "~/SCHNAPPsDebug/dimPlotPCA.RData", list = c(ls()))
+ # }
+ # load(file='~/SCHNAPPsDebug/dimPlotPCA.RData')
+
+ # return NuLL because it is not working correctly
+ return(NULL)
+
+ scEx = scEx[rownames(pca$rotation),]
+ scEx_log = scEx_log[rownames(pca$rotation),]
+
+ cellMeta = colData(scEx_log)
+ rData = rowData(scEx)
+ meta.data = cellMeta[,"sampleNames", drop = FALSE]
+ dat = assays(scEx)[[1]][rownames(scEx_log),]
+ rownames(dat) = rData[rownames(scEx_log),"symbol"]
+ rownames(pca$rotation) = rData[rownames(pca$rotation),"symbol"]
+ seurDat <- CreateSeuratObject(
+ counts = dat,
+ meta.data = meta.data
+ )
+
+ # TODO use scEx_log
+ logDat = assays(scEx_log)[[1]]
+ rData = rowData(scEx_log)
+ rownames(logDat) = rData$symbol
+ seurDat@assays$RNA@data = as(logDat,"dgCMatrix")
+ # seurDat <- NormalizeData(seurDat, normalization.method = "LogNormalize", scale.factor = 10000)
+ # seurDat <- FindVariableFeatures(seurDat, selection.method = "vst", nfeatures = 2000)
+
+ # recalculating because createDimReducObject is not working
+ all.genes <- rownames(seurDat)
+ seurDat <- ScaleData(seurDat, features = all.genes)
+ seurDat <- RunPCA(seurDat, features = VariableFeatures(object = seurDat))
+
+ colnames(pca$x) = str_replace(colnames(pca$x), "PC", "PC_")
+
+ # not working
+ seurDat[["pca"]] = CreateDimReducObject(embeddings = pca$rotation, loadings = pca$x[colnames(seurDat),], stdev = pca$var_pcs, key = "PC_", assay = "RNA")
+ seurDat <- ProjectDim(object = seurDat, reduction = "pca", assay = "RNA")
+
+ # DimPlot(seurDat, reduction = "pca")
+
+ d = DimHeatmap(seurDat, dims = 1:15, cells = NULL, balanced = TRUE, fast = FALSE, projected = TRUE, reduction = "pca")
+ d
+})
+
+# add comment to history ----
+
+commentModal <- function(failed = FALSE) {
+ modalDialog(
+ # TODO
+ # mce not working, maybe this helps eventually: https://github.com/twbs/bootstrap/issues/549
+ # if ("shinyMCE" %in% rownames(installed.packages())) {
+ # shinyMCE::tinyMCE(
+ # "Comment4history",
+ # "Please describe your work. This will be included in the history"
+ # )
+ # } else {
+ textInput("Comment4history", "Please describe your work. This will be included in the history")
+ # }
+ ,
+ footer = tagList(
+ modalButton("Cancel"),
+ actionButton("commentok", "OK")
+ )
+ )
+}
+
+# Show modal when button is clicked.
+observeEvent(input$comment2History, {
+ showModal(commentModal())
+})
+# When OK button is pressed, attempt to load the data set. If successful,
+# remove the modal. If not show another modal, but this time with a failure
+# message.
+observeEvent(input$commentok, {
+ cat(file = stderr(), paste0("commentok: \n"))
+ comment <- input$Comment4history
+ add2history(type = "text", comment = "", text2add = comment)
+ removeModal()
+})
# inputDataFunc ----
# loads singleCellExperiment
# only counts, rowData, and colData are used. Everything else needs to be recomputed
@@ -1025,7 +1133,7 @@ gsRMGenesTable <- reactive({
)
}
# load("~/SCHNAPPsDebug/removedGenesTable.RData")
-
+
scEx <- assays(dataTables$scEx)[[1]]
fd <- rowData(dataTables$scEx)
dt <- fd[useGenes, ]
@@ -1039,7 +1147,7 @@ gsRMGenesTable <- reactive({
firstCol <- firstCol <- c(firstCol, which(colnames(dt) %in% c("rowSums", "rowSamples")))
colOrder <- c(firstCol, (1:ncol(dt))[-firstCol])
dt <- dt[, colOrder]
-
+
# dt <- dt[dt$rowSums < minGenes, ]
exportTestValues(removedGenesTable = {
as.data.frame(dt)
@@ -1312,8 +1420,8 @@ scEx <- reactive({
minG = minG,
maxG = maxG
)
-
-
+ scEx = retVal
+ add2history(type = "save", comment = "scEx", scEx = retVal)
exportTestValues(scEx = {
list(rowData(retVal), colData(retVal))
})
@@ -1397,6 +1505,8 @@ scEx_log <- reactive({
}
.schnappsEnv$calculated_normalizationRadioButton <- normMethod
+ add2history(type = "save", comment = "scEx_log", scEx_log = scEx_log)
+
exportTestValues(scEx_log = {
assays(scEx_log)["logcounts"]
})
@@ -1468,11 +1578,13 @@ scExLogMatrixDisplay <- reactive({
# rownames(retVal) <-
# make.names(rowData(scEx)$symbol, unique = TRUE)
}
-
+ rownames(retVal) <-
+ retVal$symbol
+
return(retVal)
})
-pcaFunc <- function(scEx_log, rank, center, scale, pcaGenes, featureData, pcaN) {
+pcaFunc <- function(scEx_log, rank, center, scale, pcaGenes, featureData, pcaN, maxGenes = 100) {
if (DEBUG) {
cat(file = stderr(), "pcaFunc started.\n")
}
@@ -1491,7 +1603,7 @@ pcaFunc <- function(scEx_log, rank, center, scale, pcaGenes, featureData, pcaN)
}
if (.schnappsEnv$DEBUGSAVE) {
- save(file = "~/SCHNAPPsDebug/pcaFunc.RData", list = c(ls(), ls(envir = globalenv())))
+ save(file = "~/SCHNAPPsDebug/pcaFunc.RData", list = c(ls()))
}
# load(file="~/SCHNAPPsDebug/pcaFunc.RData")
genesin <- geneName2Index(pcaGenes, featureData)
@@ -1548,23 +1660,41 @@ pcaFunc <- function(scEx_log, rank, center, scale, pcaGenes, featureData, pcaN)
assays(scEx_log)[["logcounts"]] <-
as(assays(scEx_log)[["logcounts"]], "dgCMatrix")
}
- BiocSingular::runPCA(
- # t(assays(scEx_log)[["logcounts"]]),
- scEx_log[genesin, ],
- ncomponents = rank,
- ntop = pcaN,
- exprs_values = "logcounts",
- # rank = rank,
- # center = center,
- scale = scale
- # ,
- # method = "irlba",
- # BPPARAM = bpparam(),
- # BPPARAM = SnowParam(workers = 3, type = "SOCK),
- # BPPARAM = MulticoreParam(
- # workers = ifelse(detectCores()>1, detectCores()-1, 1))
- # BSPARAM = IrlbaParam()
- )
+ x <- assays(scEx_log)[["logcounts"]]
+ genesin = genesin[genesin %in% rownames(scEx_log)]
+ x <- as.matrix(x)[genesin, , drop = FALSE]
+ rv <- rowVars((as.matrix(x)))
+ if (scale) {
+ if(maxGenes > 0) {
+ keep <- order(rv, decreasing = TRUE)[1:maxGenes]
+ } else {
+ keep <- rv >= 1e-8
+ }
+ x <- x[keep,,drop=FALSE]/sqrt(rv[keep])
+ rv <- rep(1, nrow(x))
+ }
+ x <- t(x)
+ pca <- runPCA(x, rank=rank, get.rotation=TRUE)
+ rownames(pca$rotation) = genesin[keep]
+ rownames(pca$x) = colnames(scEx_log)
+ pca
+ # BiocSingular::runPCA(
+ # x,
+ # # scEx_log[genesin, ],
+ # # ncomponents = rank,
+ # ntop = pcaN,
+ # # exprs_values = "logcounts",
+ # rank = rank,
+ # # center = center,
+ # scale = scale
+ # # ,
+ # # method = "irlba",
+ # # BPPARAM = bpparam(),
+ # # BPPARAM = SnowParam(workers = 3, type = "SOCK),
+ # # BPPARAM = MulticoreParam(
+ # # workers = ifelse(detectCores()>1, detectCores()-1, 1))
+ # # BSPARAM = IrlbaParam()
+ # )
})
if (is.null(scaterPCA)) {
@@ -1575,16 +1705,16 @@ pcaFunc <- function(scEx_log, rank, center, scale, pcaGenes, featureData, pcaN)
#
# rownames(scaterPCA$x) = colnames(scEx_log)
return(list(
- # x = scaterPCA$x,
- x = SingleCellExperiment::reducedDim(scaterPCA, "PCA"),
- # var_pcs = scaterPCA$sdev
- var_pcs = attr(
- SingleCellExperiment::reducedDim(scaterPCA, "PCA"),
- "percentVar"
- )
+ x = scaterPCA$x,
+ # x = SingleCellExperiment::reducedDim(scaterPCA, "PCA"),
+ var_pcs = scaterPCA$sdev,
+ rotation = scaterPCA$rotation
+ # var_pcs = attr(
+ # SingleCellExperiment::reducedDim(scaterPCA, "PCA"),
+ # "percentVar"
+ # )
))
}
-
# pca ----
pca <- reactive({
if (DEBUG) {
@@ -1943,7 +2073,9 @@ projections <- reactive({
projections <- pd
if (!is.null(pca)) {
- projections <- cbind(projections, pca$x[rownames(projections), ])
+ comColNames = colnames(projections) %in% colnames(pca$x)
+ colnames(projections)[comColNames] = paste0(colnames(projections)[comColNames], ".old")
+ projections <- cbind(projections, pca$x[rownames(projections),])
}
withProgress(message = "Performing projections", value = 0, {
@@ -1968,9 +2100,9 @@ projections <- reactive({
# browser()
# TODO here, dbCluster is probably overwritten and appended a ".1"
if (is(tmp, "data.frame")) {
- cn <- make.names(c(colnames(projections), colnames(tmp)))
+ cn <- make.names(c(colnames(projections), colnames(tmp)), unique = TRUE)
} else {
- cn <- make.names(c(colnames(projections), make.names(proj[1])))
+ cn <- make.names(c(colnames(projections), make.names(proj[1])), unique = TRUE)
}
if (length(tmp) == 0) {
next()
@@ -2036,7 +2168,8 @@ projections <- reactive({
if (!"sampleNames" %in% colnames(projections)) {
projections$sampleNames <- "1"
}
-
+ add2history(type = "save", comment = "projections", projections = projections)
+
exportTestValues(projections = {
projections
})
@@ -2044,7 +2177,7 @@ projections <- reactive({
})
# initializeGroupNames ----
-# TODO shouldn't this be an observer???
+# TODO shouldn't this be an observer??? or just a function???
initializeGroupNames <- reactive({
if (DEBUG) {
cat(file = stderr(), "initializeGroupNames started.\n")
@@ -2067,22 +2200,31 @@ initializeGroupNames <- reactive({
if (is.null(scEx)) {
return(NULL)
}
- if (.schnappsEnv$DEBUGSAVE) {
- save(file = "~/SCHNAPPsDebug/initializeGroupNames.RData", list = c(ls(), ls(envir = globalenv())))
- }
- # load(file="~/SCHNAPPsDebug/initializeGroupNames.RData")
isolate({
- df <-
- data.frame(
- all = rep(TRUE, dim(scEx)[2]),
- none = rep(FALSE, dim(scEx)[2])
- )
- rownames(df) <- colnames(scEx)
- groupNames$namesDF <- df
+ grpNs <- groupNames$namesDF
+ if (.schnappsEnv$DEBUGSAVE) {
+ save(file = "~/SCHNAPPsDebug/initializeGroupNames.RData", list = c(ls(), ls(envir = globalenv())))
+ }
+ # load(file="~/SCHNAPPsDebug/initializeGroupNames.RData")
+ # TODO ??? if cells have been removed it is possible that other cells that were excluded previously show up
+ # this will invalidate all previous selections.
+ if (is_empty(data.frame()) | !all(colnames(scEx) %in% rownames(grpNs))) {
+ df <-
+ data.frame(
+ all = rep(TRUE, dim(scEx)[2]),
+ none = rep(FALSE, dim(scEx)[2])
+ )
+ rownames(df) <- colnames(scEx)
+ groupNames$namesDF <- df
+ } else {
+ groupNames$namesDF = groupNames$namesDF[colnames(scEx),]
+ }
})
})
-observe(label = "ob1", initializeGroupNames())
+# since initializeGroupNames depends on scEx only this will be set when the org data is changed.
+observe(initializeGroupNames())
+
# sample --------
sample <- reactive({
if (DEBUG) {
diff --git a/inst/app/runDevApp.R b/inst/app/runDevApp.R
index acc8618f00c622adfeb000dc3038981241854531..b116732ac7971967c08c694a73d2e5f4579454f3 100644
--- a/inst/app/runDevApp.R
+++ b/inst/app/runDevApp.R
@@ -6,14 +6,15 @@
.schnappsEnv <- new.env(parent=emptyenv())
# }
- localContributionDir = "~/Rstudio/scShinyHub-github/bjContributions/"
+ localContributionDir = "~/Rstudio/scShinyHubContributionsBJ/"
# localContributionDir = ""
- defaultValueSingleGene = "LYZ"
-defaultValueMultiGenes = "tbx18, wt1, msln, edf1, tagln2, anxa5, ctgf, fstl1,naca, rack1, eef2, npm1, bmp4, pparg, ucp2, vim,col1a1, col3a1, col18a1, sparc, bgn, mmp2, postn,ccl2, ccl7, il33, vcan"
-defaultValueRegExGene = "" # tip: '^CD7$|^KIT$; genes with min expression
+ defaultValueSingleGene = "itgae" # CD52
+ defaultValueMultiGenes = " itgae, cd69, itga1" # CD52, S100A9, S100A4
+ defaultValueMultiGenes = "prf1, Gzmb, IFNG, PDCD1, HAVCR2, LAG3, TSC22D3,ZFP36L2"
+ defaultValueRegExGene = "" # tip: '^CD7$|^KIT$; genes with min expression
DEBUG = TRUE
DEBUGSAVE = F
-historyFile = "~/Rstudio/Schnapps/history.File.pdf"
+historyPath = "~/Rstudio/Schnapps/history"
assign(".SCHNAPPs_locContributionDir", localContributionDir, envir = .schnappsEnv)
assign(".SCHNAPPs_defaultValueSingleGene", defaultValueSingleGene, envir = .schnappsEnv)
@@ -27,7 +28,7 @@ assign("defaultValueMultiGenes", defaultValueMultiGenes, envir = .schnappsEnv)
assign("defaultValueRegExGene", defaultValueRegExGene, envir = .schnappsEnv)
assign("DEBUG", DEBUG, envir = .schnappsEnv)
assign("DEBUGSAVE", DEBUGSAVE, envir = .schnappsEnv)
-assign("historyFile", historyFile, envir = .schnappsEnv)
+assign("historyPath", historyPath, envir = .schnappsEnv)
ls(.schnappsEnv)
devscShinyApp = TRUE
diff --git a/inst/app/server.R b/inst/app/server.R
index 23eebc2ee16d736208dd1430dbf28cfeffa83fb2..9bcf64d0f21cd4228ed065aa6227057d48fe4927 100644
--- a/inst/app/server.R
+++ b/inst/app/server.R
@@ -124,7 +124,7 @@ scShinyServer <- shinyServer(function(input, output, session) {
}
# TODO ??? clean directory??
}
-
+
if (exists("devscShinyApp")) {
if (devscShinyApp) {
packagePath <- "inst/app"
@@ -138,10 +138,33 @@ scShinyServer <- shinyServer(function(input, output, session) {
"Readme.txt", "report.html", "sessionData.RData",
"normalizedCounts.csv", "variables.used.txt"
)
-
+
base::options(shiny.maxRequestSize = 2000 * 1024^2)
-
+
+ ### history setup
+ if (exists("historyPath", envir = .schnappsEnv)) {
+ if (!is.null(x = .schnappsEnv$historyPath)) {
+ if (!dir.exists(.schnappsEnv$historyPath)){
+ dir.create(.schnappsEnv$historyPath, recursive = T)
+ }
+ if (!exists("historyFile", envir = .schnappsEnv)) {
+ .schnappsEnv$historyFile = paste0("history.",format(Sys.time(), "%Y-%b-%d.%H.%M"),".Rmd")
+ }
+ if (is.null(.schnappsEnv$historyFile)) {
+ .schnappsEnv$historyFile = "history2.Rmd"
+ }
+ .schnappsEnv$historyFile <- paste0(.schnappsEnv$historyPath,"/", basename(.schnappsEnv$historyFile))
+ line=paste0("---\ntitle: \"history\"\noutput: html_document\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(echo = TRUE)\n```\n" )
+ write(line,file=.schnappsEnv$historyFile,append=FALSE)
+
+ } else {
+ rm("historyPath", envir = .schnappsEnv)
+ }
+ }
+
+
# TODO check if file exists
+ # TODO as parameter to load user specified information
# TODO have this as an option to load other files
if (file.exists(paste0(packagePath, "/geneLists.RData"))) {
base::load(file = paste0(packagePath, "/geneLists.RData"))
@@ -150,16 +173,17 @@ scShinyServer <- shinyServer(function(input, output, session) {
geneLists <- list(emtpy = list())
}
}
-
+
if (DEBUG) base::cat(file = stderr(), "ShinyServer running\n")
# base calculations that are quite expensive to calculate
# display name, reactive name to be executed
+ # TODO do we still need this?
heavyCalculations <- list(
c("pca", "pca"),
c("scran_Cluster", "scran_Cluster"),
c("projections", "projections")
)
-
+
# base projections
# display name, reactive to calculate projections
projectionFunctions <- list(
@@ -169,18 +193,18 @@ scShinyServer <- shinyServer(function(input, output, session) {
c("before filter", "beforeFilterPrj")
)
.schnappsEnv$projectionFunctions <- projectionFunctions
-
+
# differential expression functions
# used in subcluster analysis
.schnappsEnv$diffExpFunctions <- list()
diffExpFunctions <- list()
-
+
# load global reactives, modules, etc ----
base::source(paste0(packagePath, "/reactives.R"), local = TRUE)
base::source(paste0(packagePath, "/outputs.R"), local = TRUE)
base::source(paste0(packagePath, "/modulesUI.R"), local = TRUE)
base::source(paste0(packagePath, "/moduleServer.R"), local = TRUE)
-
+
# bookmarking ----
# couldn't get bookmarking to work, esp. with the input file
# setBookmarkExclude(c("bookmark1"))
@@ -192,7 +216,7 @@ scShinyServer <- shinyServer(function(input, output, session) {
# if (DEBUG) cat(file = stderr(), paste("bookmarking: DONE\n"))
# })
# Need to exclude the buttons from themselves being bookmarked
-
+
# load contribution reactives ----
# parse all reactives.R files under contributions to include in application
uiFiles <- base::dir(
@@ -205,12 +229,12 @@ scShinyServer <- shinyServer(function(input, output, session) {
myProjections <- NULL
myDiffExpFunctions <- NULL
base::source(fp, local = TRUE)
-
+
heavyCalculations <- append2list(myHeavyCalculations, heavyCalculations)
projectionFunctions <- append2list(myProjections, projectionFunctions)
diffExpFunctions <- append2list(myDiffExpFunctions, diffExpFunctions)
}
-
+
# update diffExpression radiobutton
dgeChoices <- c()
if (length(diffExpFunctions) > 0) {
@@ -229,7 +253,7 @@ scShinyServer <- shinyServer(function(input, output, session) {
choices = dgeChoices
)
.schnappsEnv$diffExpFunctions <- diffExpFunctions
-
+
# load contribution outputs ----
# parse all outputs.R files under contributions to include in application
uiFiles <- base::dir(
diff --git a/inst/app/serverFunctions.R b/inst/app/serverFunctions.R
index 4b69d91b3f528e060a5bec0aead1bb934f7ca234..6b2f5dbd77c870e423cbf1ff98f1d087eea94395 100644
--- a/inst/app/serverFunctions.R
+++ b/inst/app/serverFunctions.R
@@ -1,5 +1,7 @@
suppressMessages(library(magrittr))
require(digest)
+
+# printTimeEnd ----
printTimeEnd <- function(start.time, messtr) {
end.time <- base::Sys.time()
if (DEBUG) {
@@ -8,7 +10,7 @@ printTimeEnd <- function(start.time, messtr) {
}
-# some comments removed because they cause too much traffic
+# some comments removed because they cause too much traffic ----
geneName2Index <- function(g_id, featureData) {
# if (DEBUG) cat(file = stderr(), "geneName2Index started.\n")
# start.time <- base::Sys.time()
@@ -53,7 +55,7 @@ geneName2Index <- function(g_id, featureData) {
return(geneid)
}
-
+# updateProjectionsWithUmiCount ----
updateProjectionsWithUmiCount <- function(dimX, dimY, geneNames, geneNames2 = NULL, scEx, projections) {
featureData <- rowData(scEx)
# if ((dimY == "UmiCountPerGenes") | (dimX == "UmiCountPerGenes")) {
@@ -88,7 +90,7 @@ updateProjectionsWithUmiCount <- function(dimX, dimY, geneNames, geneNames2 = NU
}
-# append to heavyCalculations
+# append to heavyCalculations ----
append2list <- function(myHeavyCalculations, heavyCalculations) {
for (hc in myHeavyCalculations) {
if (length(hc) == 2 & is.character(hc[1]) & is.character(hc[2])) {
@@ -131,12 +133,19 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
geneNames2 = geneNames2,
scEx = scEx_log, projections = projections
)
- if (!all(c(dimX, dimY, dimCol) %in% colnames(projections))) {
- return(NULL)
- }
- if (!all(c(dimX, dimY, dimCol) %in% colnames(projections))) {
- return(NULL)
+ # histogram as y and cellDensity as color is not allowed
+
+ if (dimY == "histogram") {
+ if (!all(c(dimX, dimCol) %in% colnames(projections))) {
+ return(NULL)
+ }
+ } else {
+ # need to do proper checking of possibilities
+ # removing dimCol for now
+ if (!all(c(dimX, dimY) %in% colnames(projections))) {
+ return(NULL)
+ }
}
projections <- cbind(projections, expression)
@@ -158,6 +167,12 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
} else {
subsetData <- projections
}
+ #ensure that the highest values are plotted last.
+ if (dimCol %in% colnames(subsetData)){
+ if (is.numeric(subsetData[,dimCol])){
+ subsetData <- subsetData[order(subsetData[,dimCol]),]
+ }
+ }
# subsetData$dbCluster = factor(subsetData$dbCluster)
# if there are more than 18 samples ggplot cannot handle different shapes and we ignore the
# sample information
@@ -184,7 +199,7 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
if (divXBy != "None") {
subsetData[, dimX] <- subsetData[, dimX] / subsetData[, divXBy]
}
- if (divYBy != "None") {
+ if (divYBy != "None" & dimY != "histogram") {
subsetData[, dimY] <- subsetData[, dimY] / subsetData[, divYBy]
}
@@ -198,8 +213,12 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
if (is.factor(subsetData[, dimX]) | is.logical(subsetData[, dimX])) {
typeX <- NULL
}
- if (is.factor(subsetData[, dimY]) | is.logical(subsetData[, dimY])) {
- typeY <- NULL
+ if (dimY != "histogram"){
+ if (is.factor(subsetData[, dimY]) | is.logical(subsetData[, dimY])) {
+ typeY <- NULL
+ }
+ } else {
+ typeX = NULL
}
xAxis <- list(
title = dimX,
@@ -214,14 +233,45 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
if (dimX == "barcode") {
subsetData$"__dimXorder" <- rank(subsetData[, dimY])
dimX <- "__dimXorder"
+ if (dimY == "histogram"){
+ # Error message
+ return(NULL)
+ }
}
-
- if (is.factor(subsetData[, dimX]) | is.logical(subsetData[, dimX])) {
- subsetData[, dimX] <- as.character(subsetData[, dimX])
- }
- if (is.factor(subsetData[, dimY]) | is.logical(subsetData[, dimY])) {
- subsetData[, dimY] <- as.character(subsetData[, dimY])
- }
+ # save(file = "~/SCHNAPPsDebug/2dplot.RData", list = ls())
+ # load("~/SCHNAPPsDebug/2dplot.RData")
+
+ if (dimY != "histogram"){
+ if (is.factor(subsetData[, dimX]) | is.logical(subsetData[, dimX])) {
+ subsetData[, dimX] <- as.character(subsetData[, dimX])
+ }
+ if (is.factor(subsetData[, dimY]) | is.logical(subsetData[, dimY])) {
+ subsetData[, dimY] <- as.character(subsetData[, dimY])
+ }
+ } else {
+ # if (is.factor(subsetData[, dimX]) | is.logical(subsetData[, dimX])) {
+ # # barchart
+ # # subsetData[, dimX] <- as.character(subsetData[, dimX])
+ # } else {
+ # histogram
+ p <- plot_ly( x=~subsetData[, dimX], type = "histogram") %>%
+ layout(
+ xaxis = xAxis,
+ yaxis = yAxis,
+ title = gtitle,
+ dragmode = "select"
+ )
+ return (p)
+ # %>%
+ # layout(yaxis=list(type='linear'))
+ # }
+
+ }
+
+ if (dimCol == "cellDensity") {
+ subsetData$cellDensity <- get_density(subsetData[,dimX], subsetData[,dimY], n = 100)
+ }
+
# dimCol = "Gene.count"
# dimCol = "sampleNames"
# subsetData$"__key__" = rownames(subsetData)
@@ -255,9 +305,9 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
selectedCells <- NULL
if (length(grpN) > 0) {
- if (length(grpNs[rownames(subsetData), grpN]) > 0 & sum(grpNs[rownames(subsetData), grpN], na.rm = TRUE) > 0) {
+ if (length(grpNs[rownames(subsetData), grpN] == "TRUE") > 0 & sum(grpNs[rownames(subsetData), grpN] == "TRUE", na.rm = TRUE) > 0) {
grpNSub <- grpNs[rownames(subsetData), ]
- selectedCells <- rownames(grpNSub[grpNSub[, grpN], ])
+ selectedCells <- rownames(grpNSub[grpNSub[, grpN] == "TRUE", ])
}
}
if (!is.null(selectedCells)) {
@@ -305,11 +355,11 @@ plot2Dprojection <- function(scEx_log, projections, g_id, featureData,
# functions should go in external file
-
+# n_fun ----
n_fun <- function(x) {
return(data.frame(y = -0.5, label = paste0(length(x), "\ncells")))
}
-
+#' diffLRT ----
diffLRT <- function(x, y, xmin = 1) {
lrtX <- bimodLikData(x)
lrtY <- bimodLikData(y)
@@ -349,8 +399,11 @@ set.ifnull <- function(x, y) {
return(x)
}
-expMean <- function(x) {
- return(log(mean(exp(x) - 1) + 1))
+expMean <- function(x, normFactor = 1) {
+ if (is.null(normFactor)){
+ normFactor = 1
+ }
+ return(log(mean(exp(x/normFactor) - 1) + 1)*normFactor)
}
@@ -395,9 +448,10 @@ heatmapPlotFromModule <- function(heatmapData, moduleName, input, projections) {
# twoDplotFromModule ----
#' function to be used in markdown docs to ease the plotting of the clusterServer module
+# TODO relies on reactive groupNames, should be a variable! Same goes for input$groupName!
twoDplotFromModule <- function(twoDData, moduleName, input, projections, g_id, legend.position = "none") {
grpNs <- groupNames$namesDF
- grpN <- make.names(input$groupName)
+ grpN <- make.names(input$groupName, unique = TRUE)
dimY <- input[[paste0(moduleName, "-dimension_y")]]
dimX <- input[[paste0(moduleName, "-dimension_x")]]
@@ -563,17 +617,19 @@ flattenCorrMatrix <- function(cormat, pmat) {
)
}
+
+# recHistory ----
# record history in env
# needs pdftk https://www.pdflabs.com/tools/pdftk-server/
# only save to history file if variable historyFile in schnappsEnv is set
-if (!all(c("pdftools") %in% rownames(installed.packages()))) {
+if (!all(c("pdftools", "gridExtra", "png") %in% rownames(installed.packages()))) {
recHistory <- function(...) {
return(NULL)
}
} else {
require(pdftools)
- recHistory <- function(name, plot1) {
- if (!exists("historyFile", envir = .schnappsEnv)) {
+ recHistory <- function(name, plot1, envir = .schnappsEnv) {
+ if (!exists("historyFile", envir = envir)) {
return(NULL)
}
if (!exists("history", envir = .schnappsEnv)) {
@@ -581,21 +637,72 @@ if (!all(c("pdftools") %in% rownames(installed.packages()))) {
}
name <- paste(name, date())
tmpF <- tempfile(fileext = ".pdf")
- plot1 <-
- plot1 %>% layout(title = name)
- if ("plotly" %in% class(plot1)) {
- # requires orca bing installed (https://github.com/plotly/orca#installation)
- withr::with_dir(dirname(tmpF), plotly::orca(p = plot1, file = basename(tmpF)))
- if (file.exists(.schnappsEnv$historyFile)) {
- tmpF2 <- tempfile(fileext = ".pdf")
- file.copy(.schnappsEnv$historyFile, tmpF2)
- pdf_combine(c(tmpF2, tmpF), output = .schnappsEnv$historyFile)
- } else {
- file.copy(tmpF, .schnappsEnv$historyFile)
+ cat(file = stderr(), paste0("history tmp File: ", tmpF, "\n"))
+ # save(file = "~/SCHNAPPsDebug/save2History2.RData", list = c(ls(), ls(envir = globalenv())))
+ # cp =load(file="~/SCHNAPPsDebug/save2History2.RData")
+ clP <- class(plot1)
+ cat(file = stderr(), paste0("class: ", clP[1], "\n"))
+ # here we create a PDF file for a given plot that is then combined later
+ created <- FALSE
+ switch(clP[1],
+ "plotly" = {
+ cat(file = stderr(), paste0("plotly\n"))
+ plot1 <- plot1 %>% layout(title = name)
+ if ("plotly" %in% class(plot1)) {
+ # requires orca bing installed (https://github.com/plotly/orca#installation)
+ withr::with_dir(dirname(tmpF), plotly::orca(p = plot1, file = basename(tmpF)))
+ }
+ created <- TRUE
+ },
+ "character" = {
+ # in case this is a link to a file:
+ cat(file = stderr(), paste0("character\n"))
+ if (file.exists(plot1)) {
+ if (tools::file_ext(plot1) == "png") {
+ pdf(tmpF)
+ img <- png::readPNG(plot1)
+ plot(1:2, type = "n")
+ rasterImage(img, 1.2, 1.27, 1.8, 1.73, interpolate = FALSE)
+ dev.off()
+ }
+ created <- TRUE
+ }
+ },
+ "datatables" = {
+ # # // this takes too long
+ # cat(file = stderr(), paste0("datatables\n"))
+ # save(file = "~/SCHNAPPsDebug/save2History2.RData", list = c(ls(), ls(envir = globalenv())))
+ # # cp =load(file="~/SCHNAPPsDebug/save2History2.RData")
+ #
+ # pdf(tmpF)
+ # if (nrow(img) > 20) {
+ # maxrow = 20
+ # } else {
+ # maxrow = nrow(plot1)
+ # }
+ # gridExtra::grid.table(img[maxrow],)
+ # dev.off()
+ # created = TRUE
}
- return(TRUE)
+ )
+
+ if (!created) {
+ return(FALSE)
}
+ if (file.exists(.schnappsEnv$historyFile)) {
+ tmpF2 <- tempfile(fileext = ".pdf")
+ file.copy(.schnappsEnv$historyFile, tmpF2)
+ tryCatch(
+ pdf_combine(c(tmpF2, tmpF), output = .schnappsEnv$historyFile),
+ error = function(x) {
+ cat(file = stderr(), paste0("problem while combining PDF files:", x, "\n"))
+ }
+ )
+ } else {
+ file.copy(tmpF, .schnappsEnv$historyFile)
+ }
+ return(TRUE)
# pdf(file = tmpF,onefile = TRUE)
# ggsave(filename = tmpF, plot = plot1, device = pdf())
# dev.off()
@@ -736,3 +843,110 @@ updateButtonColor <- function(buttonName, parameters) {
# }
# })
# }
+
+add2history <- function(type, comment = "", ...) {
+ if (!exists("historyPath", envir = .schnappsEnv)) {
+ # if this variable is not set we are not saving
+ return(NULL)
+ }
+
+ varnames <- lapply(substitute(list(...))[-1], deparse)
+ arg <- list(...)
+ if(is.null(arg[[1]])) return(NULL)
+ if (.schnappsEnv$DEBUGSAVE) {
+ save(file = "~/SCHNAPPsDebug/add2history.RData", list = c(ls()))
+ }
+ # load(file='~/SCHNAPPsDebug/add2history.RData')
+ if (type == "text") {
+ cat(file = stderr(), paste0("history text: \n"))
+ assign(names(varnames[1]), arg[1])
+ line <- paste0(
+ "\n", get(names(varnames[1])), "\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+
+ }
+
+ if (type == "save") {
+ # browser()
+ tfile <- tempfile(pattern = paste0(names(varnames[1]), "."), tmpdir = .schnappsEnv$historyPath, fileext = ".RData")
+ assign(names(varnames[1]), arg[1])
+ save(file = tfile, list = c(names(varnames[1])))
+ # the load is commented out because it is not used at the moment and only takes time to load
+ line <- paste0(
+ "```{R}\n#load ", names(varnames[1]), "\n#load(file = \"", basename(tfile),
+ "\")\n```\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+ }
+
+ if (type == "renderPlotly") {
+ tfile <- tempfile(pattern = paste0(names(varnames[1]), "."), tmpdir = .schnappsEnv$historyPath, fileext = ".RData")
+ assign(names(varnames[1]), arg[1])
+ save(file = tfile, list = c(names(varnames[1])))
+
+ line <- paste0(
+ "```{R}\n#load ", names(varnames[1]), "\nload(file = \"", basename(tfile),
+ "\")\nhtmltools::tagList(", names(varnames[1]), ")\n```\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+ }
+
+ if (type == "tronco") {
+ # browser()
+ tfile <- tempfile(pattern = paste0(names(varnames[1]), "."), tmpdir = .schnappsEnv$historyPath, fileext = ".RData")
+ assign(names(varnames[1]), arg[[1]])
+ save(file = tfile, list = c(names(varnames[1])))
+
+ line <- paste0(
+ "```{R}\n#load ", names(varnames[1]), "\nload(file = \"", basename(tfile),"\")\n",
+ "\n", names(varnames[1]) ,"$filename <- NULL \n",
+ "\ndo.call(TRONCO::pheatmap, ", names(varnames[1]), ")\n```\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+ }
+
+ if (type == "renderPlot") {
+ tfile <- tempfile(pattern = paste0(names(varnames[1]), "."), tmpdir = .schnappsEnv$historyPath, fileext = ".RData")
+ assign(names(varnames[1]), arg[[1]])
+ save(file = tfile, list = c(names(varnames[1])))
+
+ line <- paste0(
+ "```{R}\n#load ", names(varnames[1]), "\nload(file = \"", basename(tfile),"\")\n",
+ "\n", names(varnames[1]), "\n```\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+
+ }
+
+ if (type == "renderDT") {
+ tfile <- tempfile(pattern = paste0(names(varnames[1]), "."), tmpdir = .schnappsEnv$historyPath, fileext = ".RData")
+ assign(names(varnames[1]), arg[[1]])
+ save(file = tfile, list = c(names(varnames[1])))
+
+ line <- paste0(
+ "```{R}\n#load ", names(varnames[1]), "\nload(file = \"", basename(tfile),"\")\n",
+ "\n", names(varnames[1]), "\n```\n"
+ )
+ write(line, file = .schnappsEnv$historyFile, append = TRUE)
+
+ }
+}
+
+
+
+
+# Get density of points in 2 dimensions. ----
+# @param x A numeric vector.
+# @param y A numeric vector.
+# @param n Create a square n by n grid to compute density.
+# @return The density within each square.
+get_density <- function(x, y, ...) {
+ dens <- MASS::kde2d(x, y, ...)
+ ix <- findInterval(x, dens$x)
+ iy <- findInterval(y, dens$y)
+ ii <- cbind(ix, iy)
+ return(dens$z[ii])
+}
+
+
diff --git a/inst/app/tabs.R b/inst/app/tabs.R
index 8852b295be093f01daa0903eb9a6d1284c91fa5d..eca6e872664c5c9c167305840b1b0c38271319d8 100644
--- a/inst/app/tabs.R
+++ b/inst/app/tabs.R
@@ -337,6 +337,26 @@ generalParametersTab <- shinydashboard::tabItem(
),
checkbsTT(item = "tabsetPCA"),
),
+ fluidRow(
+ box(
+ title = "DimPlot for PCA", solidHeader = TRUE, width = 12, status = 'primary', collapsible = TRUE, collapsed = TRUE,
+ # The id lets us use input$tabset1 on the server to find the current tab
+ id = "dimPlotPCA",
+ fluidRow(
+ column(12,
+ offset = 1,
+ actionButton("updateDimPlot", "generate plot", width = '80%',
+ style = "color: #fff; background-color: #A00272; border-color: #2e6da4")
+ ),
+ ),
+ fluidRow(
+ column(width = 12,
+ jqui_resizable(plotOutput("dimPlotPCA"))
+ )
+ ),
+ checkbsTT(item = "dimPlotPCA"),
+ )
+ ),
fluidRow(
tabBox(
title = "Parameters for clustering", width = 12,
diff --git a/inst/app/ui.R b/inst/app/ui.R
index 3c880ee0c89b7950ad5fbb88bb6ee39a943260f9..f355a6c5f5499405d62660b1aede5434c114afa0 100644
--- a/inst/app/ui.R
+++ b/inst/app/ui.R
@@ -156,10 +156,13 @@ scShinyUI <- shinyUI(
downloadButton("RDSsave", "Download RData", class = "butt"),
if (DEBUG) checkboxInput("DEBUGSAVE", "Save for DEBUG", FALSE),
verbatimTextOutput("DEBUGSAVEstring"),
- if (exists("historyFile", envir = .schnappsEnv)) {
- checkboxInput("save2History", "save to history file", FALSE)
- },
- verbatimTextOutput("save2Historystring")
+ if (exists("historyPath", envir = .schnappsEnv)){
+ # checkboxInput("save2History", "save to history file", FALSE)
+ actionButton("comment2History", "Add comment to history")
+ }
+ # ,
+ # verbatimTextOutput("save2Historystring")
+ # ,verbatimTextOutput("currentTabInfo")
), # dashboard side bar
shinydashboard::dashboardBody(
shinyjs::useShinyjs(debug = TRUE),
diff --git a/inst/develo/heatMapBIG.Rmd b/inst/develo/heatMapBIG.Rmd
new file mode 100644
index 0000000000000000000000000000000000000000..5def42cf06505760e2b76e20e481fbe18e456fdc
--- /dev/null
+++ b/inst/develo/heatMapBIG.Rmd
@@ -0,0 +1,82 @@
+---
+title: "heaptmapBIG"
+author: "Bernd Jagla"
+date: "9/10/2019"
+output: html_document
+---
+
+```{r setup, include=FALSE}
+load("~/Downloads/pHeatMap_data/sessionData.RData")
+```
+
+
+```{r cars, fig.height=80, fig.width=10}
+ if (is.null(scale)) {
+ heatmapData$scale = "none"
+ } else {
+ heatmapData$scale = "row"
+ }
+ if (length(addColNames) > 0 & moreOptions) {
+ heatmapData$annotation_col <- proje[rownames(heatmapData$annotation_col), addColNames, drop = FALSE]
+ }
+ if (sum(orderColNames %in% colnames(proje)) > 0 & moreOptions) {
+ heatmapData$cluster_cols <- FALSE
+ colN <- rownames(psych::dfOrder(proje, orderColNames))
+ colN <- colN[colN %in% colnames(heatmapData$mat)]
+ heatmapData$mat <- heatmapData$mat[, colN, drop = FALSE]
+ }
+do.call(TRONCO::pheatmap, heatmapData)
+
+
+```
+
+```{r}
+library("PerformanceAnalytics")
+chart.Correlation(heatmapData$mat, histogram=TRUE, pch=19)
+```
+
+
+```{r}
+library("Hmisc")
+colnames(heatmapData$mat)
+rownames(proje)
+colnames(proje)
+nums <- unlist(lapply(proje, is.numeric))
+numProje = proje[,nums]
+colnames(numProje)
+
+numProje <- t(numProje)[,colnames(heatmapData$mat)]
+rownames(numProje)
+corrInput <- as.matrix(rbind(numProje,heatmapData$mat))
+rownames(corrInput)
+res2 <- rcorr(t(corrInput))
+# res2
+sum(rownames(res2$P) %in% colnames(proje[, nums]))
+# ++++++++++++++++++++++++++++
+# flattenCorrMatrix
+# ++++++++++++++++++++++++++++
+# cormat : matrix of the correlation coefficients
+# pmat : matrix of the correlation p-values
+flattenCorrMatrix <- function(cormat, pmat) {
+ ut <- upper.tri(cormat)
+ data.frame(
+ row = rownames(cormat)[row(cormat)[ut]],
+ column = rownames(cormat)[col(cormat)[ut]],
+ cor =(cormat)[ut],
+ p = pmat[ut]
+ )
+}
+cormat = res2$r
+pmat = res2$P
+ut <- upper.tri(upper.tri(res2$r))
+
+
+flatMat <- flattenCorrMatrix(res2$r, res2$P)
+flatMat[flatMat$column %in% colnames(proje[, nums]) &
+ (!flatMat$row %in% colnames(proje[, nums])) , ]
+flatMat = flatMat[order(flatMat$cor, decreasing = F),]
+DT::datatable(flatMat[flatMat$row == "PC5" &
+ flatMat$p < 0.005,])
+
+```
+
diff --git a/inst/develo/human_cycle_markers.rds b/inst/develo/human_cycle_markers.rds
new file mode 100644
index 0000000000000000000000000000000000000000..91c5021c1d61542309f5bb428c1e6e7f7bd70d5e
Binary files /dev/null and b/inst/develo/human_cycle_markers.rds differ
diff --git a/inst/develo/mouse_cycle_markers.rds b/inst/develo/mouse_cycle_markers.rds
new file mode 100644
index 0000000000000000000000000000000000000000..81ad872d91be411e51d43d33932e5b16ef136001
Binary files /dev/null and b/inst/develo/mouse_cycle_markers.rds differ