inst/app/app_Reactive.R
In eisascience/HISTA: The Human Infertility Single-cell Testis Atlas Shiny App. Jan.26.2021
# Reactive sections
#returns DF of tSNE
tSNE_AllCells_DF_Rx <- reactive({
# data, tsneBrSDACS, tsneDSNDGE, tsneSNDGE
# print(input$data)
if(input$data == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
#returns DF of tsne for GC (Tsne1_SDAQC4sperm)
tSNE_GermCells_DF_Rx <- reactive({
# data, tsneBrSDACS, tsneDSNDGE, tsneSNDGE
# print(input$data)
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4sperm", "Tsne2_SDAQC4sperm")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
rownames(tempDF) <- datat$barcode
# tempDF <- tempDF[!is.na(tempDF$tSNE1), ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
#gets tSNE_AllCells_DF_Rx and plots tSNE vs SDA score
tSNEwSDAScoreProj_Rx <- reactive({
#ggplotly
tempDF <- tSNE_AllCells_DF_Rx()
ggplot(cbind(tempDF, SDAComp=datat[,get(paste0("SDAV", input$ComponentNtext, sep=""))]),
aes(tSNE1, tSNE2, color=cut(asinh(SDAComp), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("CS", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
ggtitle(paste0("SDAV", input$ComponentNtext, " \n",
StatFac[paste0("SDAV", input$ComponentNtext, sep=""),2], sep="")) +
simplify2 + coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)
})
#gets tSNE_SDA_CT_Rx and plots tSNE per CT vs SDA score
tSNEwSDAScoreProjPerCT_GEX_Rx <- reactive({
#ggplotly
tempDF <- tSNE_SDA_CT_GEX_Rx()
# print(head(tempDF))
if(input$DimReduxCT_ctselect_gex == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
if(input$Genetext_celltype_gex %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext_celltype_gex)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
#ggplotly
#as.numeric(input$NoOfGenes)
LoadOrdVal <- round(results$loadings[[1]][,as.character(input$Genetext_celltype_gex)][order(abs(results$loadings[[1]][,as.character(input$Genetext)]), decreasing = T)], 3)
tempDF[rownames(GeneExpr), ]$GeneExpr <- GeneExpr[,1]
(ggplot(tempDF,
aes(tSNE1, tSNE2, color=cut(asinh(GeneExpr), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("EX", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)) +
labs(title = paste("Gene: ", input$Genetext_celltype_gex, sep=""),
subtitle = paste("Found in comps: \n",
paste(names(LoadOrdVal)[1:5], collapse = ", "),
"\n",
paste(LoadOrdVal[1:5], collapse = ", "),
"\n",
paste(names(LoadOrdVal)[6:10], collapse = ", "),
"\n",
paste(LoadOrdVal[6:10], collapse = ", "),
"\n"),
caption = "Imputed GEX")
})
#gets tSNE_SDA_CT_Rx and plots tSNE per CT vs SDA score
tSNEwSDAScoreProjPerCT_Rx <- reactive({
#ggplotly
tempDF <- tSNE_SDA_CT_Rx()
# limValX <- max(c(abs(min(tempDF$tSNE1)), max(tempDF$tSNE1)) )
# limValX = limValX + limValX*0.1
#
# limValY <- max(c(abs(min(tempDF$tSNE2)), max(tempDF$tSNE2)) )
# limValY = limValY + limValY*0.1
# print(head(tempDF))
if(input$DimReduxCT_ctselect == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
tempMeta <- datat[,get(paste0("SDAV", input$ComponentNtext_DimReduxCT, sep=""))]
names(tempMeta) <- datat$barcode
tempMeta <- tempMeta[rownames(tempDF)]
# print(head(tempMeta))
if(input$ComponentNtext_DimReduxCT > 150) {
BREAKS = c(-Inf, round(as.numeric(quantile(asinh(tempMeta), c(.15,.25,.5,.75,.85))), 5), Inf)
if(input$ComponentNtext_DimReduxCT > 203) {
TITLE = ggtitle(paste0("DiffComp-Rank", as.numeric(input$ComponentNtext_DimReduxCT)-199))
} else {
TITLE = ggtitle(paste0("DiffComp", as.numeric(input$ComponentNtext_DimReduxCT)-199))
}
} else {
BREAKS = c(-Inf, -1, -.5, 0, .5, 1, Inf)
TITLE = ggtitle(paste0("SDAV", input$ComponentNtext_DimReduxCT, " \n",
StatFac[paste0("SDAV", input$ComponentNtext_DimReduxCT, sep=""),2], sep=""))
}
ggplot(cbind(tempDF, SDAComp=tempMeta),
aes(tSNE1, tSNE2, color=cut(asinh(SDAComp), breaks = BREAKS))) +
geom_point(size=0.5) + theme_classic(base_size = 10) +
scale_color_manual("CS", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 + TITLE +
coord_cartesian(xlim = c(-AddPer(abs(quantile(tempDF$tSNE1, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE1, .98), perc=percH)),
ylim = c(-AddPer(abs(quantile(tempDF$tSNE2, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE2, .98), perc=percH)), expand = T) +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
# if(LocalRun) AugmentPlot(ggf) else ggf
})
#get tSNE_AllCells_DF_Rx and plot tSNE vs Meta per CT
tSNEwMetaPerCT_Rx <- reactive({
tempDF <- tSNE_META_CT_Rx()
# print("tSNEwMetaPerCT_Rx")
# print(head(tempDF))
tempMetaDF <- as.data.frame(datat)
rownames(tempMetaDF) <- datat$barcode
tempMetaDF <- tempMetaDF[rownames(tempDF), ]
# print(head(tempMetaDF))
if(input$ctselect_meta == "celltype") {
MetaFac <- as.character(tempMetaDF$FinalFinalPheno_old)
} else {
if(input$ctselect_meta == "donrep"){
MetaFac <- as.character(tempMetaDF$DonRep)
} else {
if(input$ctselect_meta == "donor"){
MetaFac <- as.character(tempMetaDF$donor)
} else {
if(input$ctselect_meta == "COND.ID"){
MetaFac <- as.character(tempMetaDF$COND.ID)
} else {
if(input$ctselect_meta == "experiment"){
MetaFac <- as.character(tempMetaDF$experiment)
} else {
if(input$ctselect_meta == "Phase"){
MetaFac <- as.character(tempMetaDF$Phase)
} else {
}
}
}
}
}
}
if(input$DimReduxCT_ctselect_meta == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
#ggplotly
ggplot(tempDF, aes(tSNE1, tSNE2, color=factor(MetaFac))) +
geom_point(size=0.5)+ theme_classic(base_size = 10) +
theme(legend.position = "right", aspect.ratio=1,
legend.title = element_blank()) +
ggtitle("t-SNE - Final Pheno") +
scale_color_manual(values=(col_vector)) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol =2)) +
simplify2 +
coord_cartesian(xlim = c(-AddPer(abs(quantile(tempDF$tSNE1, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE1, .98), perc=percH)),
ylim = c(-AddPer(abs(quantile(tempDF$tSNE2, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE2, .98), perc=percH)), expand = T) +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
})
#gets tSNE_AllCells_DF_Rx and plots tSNE vs Meta
tSNEwMeta_Rx <- reactive({
tempDF <- tSNE_AllCells_DF_Rx()
if(input$metaselect == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
#ggplotly
ggplot(tempDF, aes(tSNE1, tSNE2, color=factor(MetaFac))) +
geom_point(size=0.1)+ theme_classic(base_size = 10) +
theme(legend.position = "right", aspect.ratio=1,
legend.title = element_blank()) +
ggtitle("t-SNE - Final Pheno") +
scale_color_manual(values=(col_vector)) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol =2)) +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)
})
tSNE_SDA_CT_Rx <- reactive({
if(input$DimReduxCT_ctselect == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}
}
}
}
if(input$data3 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
# tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
# rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
tSNE_SDA_CT_GEX_Rx <- reactive({
if(input$DimReduxCT_ctselect_gex == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}
}
}
}
if(input$data2 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
tSNE_META_CT_Rx <- reactive({
if(input$DimReduxCT_ctselect_meta == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
if(input$data4 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
# tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
#
# rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
# print("tSNE_META_CT_Rx")
# print(head(tempDF))
return(tempDF)
})
GeneExprPerCellType_DF_Rx <- reactive({
if(input$celltypeselect2 == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect2 == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect2 == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect2 == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect2 == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect2 == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect2 == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect2 == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect2 == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect2 == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect2 == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect2 == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect2 == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect2 == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
if(input$metaselect2 == "experiment") {
MetaFac <- (datat$experiment)
} else if(input$metaselect2 == "FinalFinalPheno_old") {
MetaFac <- (datat$experiment)
} else {
}
if(input$Genetext2 %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext2)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
GeneExpr <- as.data.frame(GeneExpr)
GeneExpr$barcode <- rownames(GeneExpr)
GeneExpr<- GeneExpr[datat$barcode, ]
GeneExpr$MetaFac <- MetaFac
GeneExpr <- GeneExpr[MyCells,-2]
colnames(GeneExpr) <- c("gene", "meta")
tempCom <- combn(levels(factor(GeneExpr$meta)),2)
my_comparisons <- lapply(1:ncol(tempCom), function(xN){
c(tempCom[1,xN], tempCom[2,xN])
})
return(list(GeneExpr = GeneExpr, my_comparisons = my_comparisons))
})
GeneExprAcroosCellType_DF_Rx <- reactive({
MyCells <- datat$barcode
if(input$metaselect3 == "experiment") {
# MetaFac <- (datat$experiment)
} else if(input$metaselect3 == "scope1") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
}
if(input$Genetext3 %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[MyCells,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext3)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
if(input$condSelect1 == "all"){
MyCells <- datat$barcode
} else {
if(input$condSelect1 == "cnt"){
MyCells <- datat[datat$DONR.ID %in% c("AdHu173", "AdHu174", "AdHu175", "UtahD1", "UtahD2", "UtahD3"),]$barcode
} else {
if(input$condSelect1 == "inf1"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI1"),]$barcode
} else {
if(input$condSelect1 == "inf2"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI2"),]$barcode
} else{
if(input$condSelect1 == "ks"){
MyCells <- datat[datat$DONR.ID %in% c("UtahK1", "UtahK2"),]$barcode
} else{
if(input$condSelect1 == "juv"){
MyCells <- datat[datat$DONR.ID %in% c("Juv1", "Juv2"),]$barcode
}
}
}
}
}
}
# MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
GeneExpr <- as.data.frame(GeneExpr)
GeneExpr$barcode <- rownames(GeneExpr)
# print(head(rownames(GeneExpr)))
# print(head(MetaFac))
GeneExpr$MetaFac <- MetaFac
# GeneExpr<- GeneExpr[datat$barcode, ]
GeneExpr <- GeneExpr[MyCells,-2]
colnames(GeneExpr) <- c("gene", "meta")
tempCom <- combn(levels(factor(GeneExpr$meta)),2)
my_comparisons <- lapply(1:ncol(tempCom), function(xN){
c(tempCom[1,xN], tempCom[2,xN])
})
return(list(GeneExpr = GeneExpr, my_comparisons = my_comparisons))
})
geneExprPerCond_box_Rx <- reactive({
GeneExpr <- GeneExprPerCellType_DF_Rx()$GeneExpr
my_comparisons <- GeneExprPerCellType_DF_Rx()$my_comparisons
CellType = input$celltypeselect2
if(input$Genetext2 %in% colnames(results$loadings[[1]])){
geneN = input$Genetext2
} else {
geneN = paste0(input$Genetext2 , " not in HISTA")
}
TestName = "Wilcox Rank Sum"
ggboxplot(GeneExpr, x = "meta", y = "gene", palette = "jco",
add = "jitter", col="meta") +
stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(geneN), " expression :: ", TestName, " test :: ", CellType)) +
xlab("") + ylab(as.character(geneN)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
})
geneExprPerCT_box_Rx <- reactive({
GeneExpr <- GeneExprAcroosCellType_DF_Rx()$GeneExpr
my_comparisons <- GeneExprAcroosCellType_DF_Rx()$my_comparisons
GeneExpr$meta <- factor(GeneExpr$meta)
GeneExpr$meta <- factor(GeneExpr$meta, levels = gtools::mixedsort(levels(GeneExpr$meta)) )
if(input$Genetext3 %in% colnames(results$loadings[[1]])){
geneN = input$Genetext3
} else {
geneN = paste0(input$Genetext3 , " not in HISTA")
}
TestName = "Wilcox Rank Sum"
ggboxplot(GeneExpr, x = "meta", y = "gene", palette = col_vector,
add = "jitter", col="meta") +
# stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(geneN), " expression :: "
#, TestName, " test "
)) +
xlab("") + ylab(as.character(geneN)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + coord_flip()
})
## celltypes_SDAperCT_box_Rx ----
celltypes_SDAperCT_box_Rx <- reactive({
if(input$celltypes_condSelect == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypes_condSelect == "cnt"){
MyCells <- datat[datat$DONR.ID %in% c("AdHu173", "AdHu174", "AdHu175", "UtahD1", "UtahD2", "UtahD3"),]$barcode
} else {
if(input$celltypes_condSelect == "inf1"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI1"),]$barcode
} else {
if(input$celltypes_condSelect == "inf2"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI2"),]$barcode
} else{
if(input$celltypes_condSelect == "ks"){
MyCells <- datat[datat$DONR.ID %in% c("UtahK1", "UtahK2"),]$barcode
} else{
if(input$celltypes_condSelect == "juv"){
MyCells <- datat[datat$DONR.ID %in% c("Juv1", "Juv2"),]$barcode
}
}
}
}
}
}
print(MyCells)
compID = paste0("SDAV", input$celltypes_sdaN_in, sep="")
tempMeta <- as.data.frame(datat)[,c(compID,
"FinalFinalPheno_old" )]
rownames(tempMeta) <- datat$barcode
tempMeta = tempMeta[MyCells,]
colnames(tempMeta) = c("score", "pheno")
ggboxplot(tempMeta, x = "pheno", y = "score", palette = col_vector,
add = "jitter", col="pheno") +
# stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(compID), " expression :: "
#, TestName, " test "
)) +
xlab("") + ylab(as.character(compID)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + coord_flip()
})
ComboTopSDAgenes_Rx <- reactive({
if(input$celltypeselect3 == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect3 == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect3 == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect3 == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect3 == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect3 == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect3 == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect3 == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect3 == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect3 == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect3 == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect3 == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect3 == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect3 == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
# if(input$metaselect3 == "experiment") {
# MetaFac <- (datat$experiment)
# } else if(input$metaselect3 == "FinalFinalPheno_old") {
# MetaFac <- (datat$FinalFinalPheno_old)
# } else {
#
#
# }
# print(head(results$scores))
# GeneExpr <- as.data.frame(GeneExpr)
# GeneExpr$barcode <- rownames(GeneExpr)
# GeneExpr<- GeneExpr[datat$barcode, ]
# GeneExpr$MetaFac <- MetaFac
# GeneExpr <- GeneExpr[MyCells,-2]
# colnames(GeneExpr) <- c("gene", "meta")
#
# tempCom <- combn(levels(factor(GeneExpr$meta)),2)
#
# my_comparisons <- lapply(1:ncol(tempCom), function(xN){
# c(tempCom[1,xN], tempCom[2,xN])
# })
#
return(list(Scores = results$scores[MyCells,], Meta=as.data.frame( subset(datat, barcode %in% MyCells))$experiment))
})
ComboTopSDAgenes_DF_Rx <- reactive({
Out1 <- print_gene_list(as.numeric(input$ComponentNtext), PosOnly = T) %>%
#group_by(package) %>%
#tally() %>%
#arrange(desc(n), tolower(package)) %>%
#mutate(percentage = n / nrow(pkgData()) * 100) %>%
#select("Package name" = package, "% of downloads" = percentage) %>%
as.data.frame() %>% head(as.numeric(input$NoOfGenes))
Out1 <- Out1$Gene.Name
Out2 <- print_gene_list(as.numeric(input$ComponentNtext), NegOnly = T) %>%
#group_by(package) %>%
#tally() %>%
#arrange(desc(n), tolower(package)) %>%
#mutate(percentage = n / nrow(pkgData()) * 100) %>%
#select("Package name" = package, "% of downloads" = percentage) %>%
as.data.frame() %>% head(as.numeric(input$NoOfGenes))
Out2 <- Out2$Gene.Name
data.frame(Pos=Out1, Neg=Out2)
})
PseudotimeGEX_RX <- reactive({
Scores <- results$scores
tempDF <- tSNE_GermCells_DF_Rx()
if(input$metaselect_pseudo_gene == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect_pseudo_gene == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect_pseudo_gene == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect_pseudo_gene == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect_pseudo_gene == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect_pseudo_gene == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
tempDF$MetFacZ <- MetaFac
tempDF$PT <- datat$PseudoTime
tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# tempDF$Scores <- Scores[rownames(tempDF), paste0("SDAV", as.numeric(input$ComponentName_pseudo))]
# tempDF$barcode <- rownames(tempDF)
# input = list(Genetext_pseudo = "PRM1")
if(input$Genetext_pseudo %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext_pseudo)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
tempDF$GeneExpr = GeneExpr[rownames(tempDF), ]
tempDF$barcode = rownames(tempDF)
# head(tempDF)
tempDF
})
PseudotimeGeneral_RX <- reactive({
Scores <- results$scores
tempDF <- tSNE_GermCells_DF_Rx()
PT <- datat$PseudoTime
MetaFac <- datat$PseudoTime
if(input$metaselect_pseudo == "pseudotime") {
MetaFac <- datat$PseudoTime
} else{
if(input$metaselect_pseudo == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect_pseudo == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect_pseudo == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect_pseudo == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect_pseudo == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect_pseudo == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
}
tempDF$MetFacZ <- MetaFac
tempDF$PT <- PT
tempDF <- tempDF[!is.na(tempDF$tSNE1),]
tempDF$Scores <- Scores[rownames(tempDF), paste0("SDAV", as.numeric(input$ComponentName_pseudo))]
tempDF$barcode <- rownames(tempDF)
# tempDF = tempDF[sample(1:nrow(tempDF), 500, replace = F), ]
if(input$metaselect_pseudo == "pseudotime") {
tempDF$MetFacZ <- as.numeric(as.character(tempDF$MetFacZ))
} else {
tempDF$MetFacZ <- factor(as.character(tempDF$MetFacZ))
}
return(tempDF)
})
PseudotimeSDA_gene_Rx <- reactive({
tempDF <- PseudotimeGEX_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
input$Genetext_pseudo
ggpp = ggplot(merge_sda_melt, aes(PT, GeneExpr, colour=(GeneExpr))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
ggtitle(paste0("", (input$Genetext_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-8,8) + scale_color_viridis()
ggpp
})
PseudotimeSDA_geneMeta_Rx <- reactive({
tempDF <- PseudotimeGEX_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
# print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
# input$Genetext_pseudo
ggpp = ggplot(merge_sda_melt, aes(PT, GeneExpr, colour=(MetFacZ))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
ggtitle(paste0("", (input$Genetext_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-1,8) + scale_colour_manual(values=col_vector)
ggpp
})
PseudotimeSDA_Rx <- reactive({
tempDF <- PseudotimeGeneral_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
ggpp = ggplot(merge_sda_melt, aes(PT, value, colour=(MetFacZ))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
# ggtitle(paste0("SDA Comp: ", as.numeric(input$ComponentName_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-8,8)
print("ggpp made")
if(input$metaselect_pseudo == "pseudotime") {
ggpp = ggpp + scale_color_viridis()
} else {
ggpp = ggpp + scale_colour_manual(values=col_vector) + facet_wrap(~MetFacZ,
ncol=3,
scales = "fixed")
}
print("color type corrected")
ggpp
})
SDAScoresChi_DF_Rx <- reactive({
SDAScores <- results$scores
ComponentN <- 1:ncol(SDAScores)
MetaDF <- as.data.frame(datat)
rownames(MetaDF) <- datat$barcode
MetaDF <- MetaDF[rownames(SDAScores),]
if(input$metaselect_chisqr == "celltype") {
MetaFac <- (MetaDF$FinalFinalPheno_old)
} else {
if(input$metaselect_chisqr == "donrep"){
MetaFac <- (MetaDF$DonRep)
} else {
if(input$metaselect_chisqr == "donor"){
MetaFac <- (MetaDF$donor)
} else {
if(input$metaselect_chisqr == "COND.ID"){
MetaFac <- (MetaDF$COND.ID)
} else {
if(input$metaselect_chisqr == "experiment"){
MetaFac <- (MetaDF$experiment)
} else {
if(input$metaselect_chisqr == "Phase"){
MetaFac <- (MetaDF$Phase)
} else {
}
}
}
}
}
}
NegCompsDF <- as.data.frame(lapply(levels(factor(MetaFac)), function(CondX){
apply(SDAScores[rownames(MetaDF)[which(MetaFac == CondX)], ], 2,
function(x){
round(sum(x<=0)/nrow(SDAScores)*100, 2)
})
}))
colnames(NegCompsDF) <- levels(factor(MetaFac))
PosCompsDF <- as.data.frame(lapply(levels(factor(MetaFac)), function(CondX){
apply(SDAScores[rownames(MetaDF)[which(MetaFac == CondX)], ], 2,
function(x){
round(sum(x>0)/nrow(SDAScores)*100, 2)
})
}))
colnames(PosCompsDF) <- levels(factor(MetaFac))
list(NegCompsDF=NegCompsDF, PosCompsDF=PosCompsDF)
})
SDAScoresChiNeg_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
# SDAScores <- results$scores
# ComponentN <- 1:ncol(SDAScores)
# MetaDF <- as.data.frame(datat)
# rownames(MetaDF) <- datat$barcode
# MetaDF <- MetaDF[rownames(SDAScores),]
#
#
# NegCompsDF <- as.data.frame(lapply(levels(factor(MetaDF$experiment)), function(CondX){
#
# apply(SDAScores[rownames(MetaDF)[which(MetaDF$experiment == CondX)], ], 2,
# function(x){
# round(sum(x<0)/nrow(SDAScores)*100, 2)
# })
# }))
#
# colnames(NegCompsDF) <- levels(factor(MetaDF$experiment))
#
# # print(head(NegCompsDF))
# # print(min(NegCompsDF))
#
#
# NegCompsDF <- NegCompsDF[gtools::mixedsort(rownames(NegCompsDF)),]
# NegCompsDF$SDA <- factor(rownames(NegCompsDF), levels=rownames(NegCompsDF))
# print(head(NegCompsDF))
NegCompsDF = SDAScoresChi_DF_Rx()$NegCompsDF
# ChiT <- chisq.test(NegCompsDF[,1:(ncol(NegCompsDF)-1)])
ChiT <- chisq.test(NegCompsDF[])
ChiTres <- ChiT$residuals
ChiTres[which(is.na(ChiTres))] = 0
ChiResSD <- round(apply(ChiTres, 1, sd),2)
ChiResSD[which(is.na(ChiResSD))] <- 0
ChiResSD[ChiResSD < 0.2] <- ""
# if(is.null(envv$SDAScoresChi_clusBTN)) {
# clustStat = F
# } else {
# clustStat <- ifelse(envv$SDAScoresChi_clusBTN=="ON", T, F)
# }
if(input$clustStat_chisqr == "True") {
clustStat = T
} else {
clustStat = F
}
# HM <- pheatmap::pheatmap((t(ChiT$residuals)),
# cluster_cols = clustStat, cluster_rows = clustStat,
# color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdBu")))(10),
# labels_col = paste0(rownames(NegCompsDF), " sd_", ChiResSD))
outLS <- list(obj=(t(ChiT$residuals)),
clustStat = clustStat,
label_col = paste0(rownames(NegCompsDF), " sd_", ChiResSD))
# return((HM$gtable))
return(outLS)
})
SDAScoresChiPos_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
# SDAScores <- results$scores
# ComponentN <- 1:ncol(SDAScores)
# MetaDF <- as.data.frame(datat)
# rownames(MetaDF) <- datat$barcode
# MetaDF <- MetaDF[rownames(SDAScores),]
#
#
#
#
# PosCompsDF <- as.data.frame(lapply(levels(factor(MetaDF$experiment)), function(CondX){
#
# apply(SDAScores[rownames(MetaDF)[which(MetaDF$experiment == CondX)], ], 2,
# function(x){
# round(sum(x>0)/nrow(SDAScores)*100, 2)
# })
# }))
#
# colnames(PosCompsDF) <- levels(factor(MetaDF$experiment))
#
# # print(head(PosCompsDF))
# # print(min(PosCompsDF))
#
#
# PosCompsDF <- PosCompsDF[gtools::mixedsort(rownames(PosCompsDF)),]
# PosCompsDF$SDA <- factor(rownames(PosCompsDF), levels=rownames(PosCompsDF))
PosCompsDF = SDAScoresChi_DF_Rx()$PosCompsDF
# print(head(PosCompsDF))
ChiT <- chisq.test(PosCompsDF[,1:(ncol(PosCompsDF)-1)])
ChiTres <- ChiT$residuals
ChiTres[which(is.na(ChiTres))] = 0
ChiResSD <- round(apply(ChiTres, 1, sd),2)
ChiResSD[which(is.na(ChiResSD))] <- 0
ChiResSD[ChiResSD < 0.2] <- ""
# if(is.null(envv$SDAScoresChi_clusBTN)) {
# clustStat = F
# } else {
# clustStat <- ifelse(envv$SDAScoresChi_clusBTN=="ON", T, F)
# }
# clustStat = T
if(input$clustStat_chisqr == "True") {
clustStat = T
} else {
clustStat = F
}
# HM <- pheatmap::pheatmap((t(ChiT$residuals)),
# cluster_cols = clustStat, cluster_rows = clustStat,
# color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdBu")))(10),
# labels_col = paste0(rownames(PosCompsDF), " sd_", ChiResSD))
#
# return(grid.draw(HM$gtable))
outLS <- list(obj=(t(ChiT$residuals)),
clustStat = clustStat,
label_col = paste0(rownames(PosCompsDF), " sd_", ChiResSD))
# return((HM$gtable))
return(outLS)
})
SDAScoresAcross_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No Comp")
} else {
SDAScores <- results$scores
ComponentN <- as.numeric(input$ComponentNtext)
ggplot(data.table(cell_index = 1:nrow(SDAScores),
score = SDAScores[, paste0("SDAV", ComponentN)],
experiment = gsub("_.*", "", gsub("[A-Z]+\\.", "", rownames(SDAScores))),
ColFac = ColFac_DONR.ID),
aes(cell_index, score, colour = ColFac)) +
geom_point(size = 0.5, stroke = 0) +
xlab("Cell Index") + ylab("Score") +
#scale_color_brewer(palette = "Paired") +
theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
scale_colour_manual(values =(col_vector),
guide = guide_legend(nrow=2)) +
#guides(color = guide_legend(ncol = 2, override.aes = list(size = 2))) +
ggtitle(paste0("SDAV", ComponentN))
}
})
SDAGOpos_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No GO")
} else {
go_volcano_plot(component = paste("V", input$ComponentNtext, "P", sep=""))+ theme_classic(base_size = 10)+ theme(aspect.ratio = 1)
}
})
SDAGOneg_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No GO")
} else {
go_volcano_plot(component = paste("V", input$ComponentNtext, "N", sep=""))+ theme_classic(base_size = 10)+ theme(aspect.ratio = 1)
}
})
ChrLocLoadings_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No Comp")
} else {
pgl <- genome_loadings(results$loadings[[1]][as.numeric(input$ComponentNtext),],
label_both = T,
max.items = as.numeric(input$NoOfGenes),
gene_locations = gene_locations,
chromosome_lengths = chromosome.lengths) + theme(aspect.ratio = .5)
return(pgl)
}
})
## Soma only LN19 figs --------------------
tSNE_somaWLN_Pheno3_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=Pheno3)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_COND.ID_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=COND.ID)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_DONR.ID_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=DONR.ID)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_nCount_RNA_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=log10(nCount_RNA))) +
geom_point(size=0.5) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
scale_color_distiller(palette = "Spectral")
})
## LC only figs ----------------
DimRedux_LConly_donors_Rx <- reactive({
ggplot(datat_LConlyLS$LC_UMAP, aes(UMAP1, UMAP2, color=donor)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConly_phenotype_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP)
ggplot(datat_LConlyLS$LC_UMAP, aes(UMAP1, UMAP2, color=phenotype)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = c(col_vector[41],"#E5C494", col_vector[42], "#BEAED4", "#7FC97F")) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_donors_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
ggplot(datat_LConlyLS$LC_UMAP_zhao, aes(UMAP_1, UMAP_2, color=donor)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_phenotype_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
ggplot(datat_LConlyLS$LC_UMAP_zhao, aes(UMAP_1, UMAP_2, color=phenotype)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = c( "#E5C494", "#BEAED4", "#7FC97F")) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_phenotypeProp_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
barplot(datat_LConlyLS$LC_UMAP_type_prop, col = c("#7FC97F", "#E5C494", "#BEAED4"),
legend.text = T, xlim = c(0,5), main="SDA Proportions by Condition", names = c("CNT", "KS", "INFiNOA"), cex.names=1.5, cex.axis=1.5, border=NA, args.legend = list(x="topright"))
})
DimRedux_LConlyZhao_KeyGenesViolin_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
KeyLCgenes = c("FZD1", "SRD5A1", "SHROOM2", "NOTCH2", "DLK1", "IGF1",
"IGF2", "CFD", "PTCH2", "CYP17A1", "LHCGR", "STAR", "HSD17B3", "IGFBP7", "IGFBP3", "SFRP1")
# head(reshape2::melt(datat_LConlyLS$LC_UMAP_zhao[,c(KeyLCgenes, "origin", "experiment", "donor", "phenotype")]))
ggplot(reshape2::melt(datat_LConlyLS$LC_UMAP_zhao[,c(KeyLCgenes, "origin", "experiment", "donor", "phenotype")]),
aes(x = variable, y = value)) +
geom_violin(alpha = 0.8) +
geom_point(position = position_jitter(seed = 1, width = 0.2), alpha = .5, aes(color=origin)) +
facet_wrap(~phenotype) +
theme_classic(base_size = 10) +
theme(legend.position = "bottom",
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
})
## gene expression ----------
tSNE_geneExpr_Rx <- reactive({
tempDF <- as.data.frame(tSNE_AllCells_DF_Rx())
if(input$Genetext %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
#ggplotly
#as.numeric(input$NoOfGenes)
LoadOrdVal <- round(results$loadings[[1]][,as.character(input$Genetext)][order(abs(results$loadings[[1]][,as.character(input$Genetext)]), decreasing = T)], 3)
tempDF[rownames(GeneExpr), ]$GeneExpr <- GeneExpr[,1]
(ggplot(tempDF,
aes(tSNE1, tSNE2, color=cut(asinh(GeneExpr), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("EX", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)) +
labs(title = paste("Gene: ", input$Genetext, sep=""),
subtitle = paste("Found in comps: \n",
paste(names(LoadOrdVal)[1:5], collapse = ", "),
"\n",
paste(LoadOrdVal[1:5], collapse = ", "),
"\n",
paste(names(LoadOrdVal)[6:10], collapse = ", "),
"\n",
paste(LoadOrdVal[6:10], collapse = ", "),
"\n"),
caption = "Imputed GEX")
})
## lncRNA top loaded----
# output$lncRNA_topLoaded_Rx <- reactive({
#
#
# lncLS$PosLoaded_top[[as.numeric(input$ComponentNtext_lncRNATopLoaded)]]
# lncLS$NegLoaded_top[[as.numeric(input$ComponentNtext_lncRNATopLoaded)]]
#
# })
## CompCor ----------
CompCor_Rx <- reactive({
annotDF = data.frame(Germ.Soma = SDAannotation$Cell.Type,
Pathology = SDAannotation$Pathology,
row.names = paste0("SDA", 1:150))
my_colour = list(
Germ.Soma = rev(col_vector)[c(1:length(levels(factor(annotDF$Germ.Soma))))],
Pathology = (col_vector)[c(1:length(levels(factor(annotDF$Pathology))))]
)
names(my_colour$Germ.Soma) <- levels(factor(annotDF$Germ.Soma))
names(my_colour$Pathology) <- levels(factor(annotDF$Pathology))
annotDF = subset(annotDF, Pathology != "Removed")
annotDF = subset(annotDF, Germ.Soma != "Multiple cell types")
lnRNASDAusageMat = results$loadings[[1]][,c(SDA_Top100neg[1:input$CompCorSDAnum_ngene,as.numeric(input$CompCorSDAnum)],
SDA_Top100pos[1:input$CompCorSDAnum_ngene,as.numeric(input$CompCorSDAnum)])]
rownames(lnRNASDAusageMat) = gsub("V", "", rownames(lnRNASDAusageMat))
lnRNASDAusageMat = lnRNASDAusageMat[rownames(annotDF),]
my_colour$Germ.Soma = my_colour$Germ.Soma[levels(factor(annotDF$Germ.Soma))]
my_colour$Pathology = my_colour$Pathology[levels(factor(annotDF$Pathology))]
return(list(lnRNASDAusageMat = lnRNASDAusageMat,
annotDF = annotDF,
my_colour = my_colour))
})
## CompCorCust ----------
CompCorCust_Rx <- reactive({
annotDF = data.frame(Germ.Soma = SDAannotation$Cell.Type,
Pathology = SDAannotation$Pathology,
row.names = paste0("SDA", 1:150))
my_colour = list(
Germ.Soma = rev(col_vector)[c(1:length(levels(factor(annotDF$Germ.Soma))))],
Pathology = (col_vector)[c(1:length(levels(factor(annotDF$Pathology))))]
)
names(my_colour$Germ.Soma) <- levels(factor(annotDF$Germ.Soma))
names(my_colour$Pathology) <- levels(factor(annotDF$Pathology))
annotDF = subset(annotDF, Pathology != "Removed")
annotDF = subset(annotDF, Germ.Soma != "Multiple cell types")
GeneSet <- input$GeneSet_TLC
#GeneSet <- "'PRM1', 'SPATA42', 'SPRR4', 'NUPR2', 'HBZ', 'DYNLL2'"
if(length(grep(",", GeneSet)) == 0){
if(length(grep('"', GeneSet)) + length(grep("'", GeneSet))>0) {
GeneSet <- unlist(strsplit(gsub("'", '', gsub('"', '', GeneSet)), " "))
} else {
GeneSet <- unlist(strsplit(GeneSet, " "))
}
#print(GeneSet)
}else {
GeneSet <- (unlist(strsplit(gsub(" ", "", gsub("'", '', gsub('"', '', GeneSet))), ",")))
#print(GeneSet)
}
GeneSet = unique(GeneSet)
# print("length of your genes:")
# print(length(GeneSet))
GeneSetNot <- GeneSet[!GeneSet %in% colnames(results$loadings[[1]][,])]
GeneSet <- GeneSet[GeneSet %in% colnames(results$loadings[[1]][,])]
print(GeneSet)
lnRNASDAusageMat = results$loadings[[1]][,GeneSet]
rownames(lnRNASDAusageMat) = gsub("V", "", rownames(lnRNASDAusageMat))
lnRNASDAusageMat = lnRNASDAusageMat[rownames(annotDF),]
my_colour$Germ.Soma = my_colour$Germ.Soma[levels(factor(annotDF$Germ.Soma))]
my_colour$Pathology = my_colour$Pathology[levels(factor(annotDF$Pathology))]
return(list(lnRNASDAusageMat = lnRNASDAusageMat,
annotDF = annotDF,
my_colour = my_colour))
})
## GeneCor_Rx ----------
GeneCor_Rx <- reactive({
if(input$celltypeselect_geneCor == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect_geneCor == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect_geneCor == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect_geneCor == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect_geneCor == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect_geneCor == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect_geneCor == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect_geneCor == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect_geneCor == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
GeneSet <- input$GeneSet_geneCor
if(length(grep(",", GeneSet)) == 0){
if(length(grep('"', GeneSet)) + length(grep("'", GeneSet))>0) {
GeneSet <- unlist(strsplit(gsub("'", '', gsub('"', '', GeneSet)), " "))
} else {
GeneSet <- unlist(strsplit(GeneSet, " "))
}
#print(GeneSet)
}else {
GeneSet <- (unlist(strsplit(gsub(" ", "", gsub("'", '', gsub('"', '', GeneSet))), ",")))
#print(GeneSet)
}
GeneSet = unique(GeneSet)
GeneSetNot <- GeneSet[!GeneSet %in% colnames(results$loadings[[1]][,])]
print("length of your genes:")
print(length(GeneSet))
GeneSet <- GeneSet[GeneSet %in% colnames(results$loadings[[1]][,])]
print("length of your genes in this dataset:")
print(length(GeneSet))
GeneExpr <- results$scores[MyCells, ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*%
results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),
GeneSet]
# tempCor = cor(GeneExpr)
# ph = pheatmap::pheatmap(tempCor)
#
#
# corrplot::corrplot(tempCor[ph$tree_row$labels[ph$tree_row$order],
# ph$tree_row$labels[ph$tree_row$order]],
# col = rev(corrplot::COL2('RdYlBu', 100)), is.corr = T)
cor(GeneExpr)
})
eisascience/HISTA documentation built on Jan. 28, 2024, 4:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# Reactive sections
#returns DF of tSNE
tSNE_AllCells_DF_Rx <- reactive({
# data, tsneBrSDACS, tsneDSNDGE, tsneSNDGE
# print(input$data)
if(input$data == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
#returns DF of tsne for GC (Tsne1_SDAQC4sperm)
tSNE_GermCells_DF_Rx <- reactive({
# data, tsneBrSDACS, tsneDSNDGE, tsneSNDGE
# print(input$data)
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4sperm", "Tsne2_SDAQC4sperm")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
rownames(tempDF) <- datat$barcode
# tempDF <- tempDF[!is.na(tempDF$tSNE1), ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
#gets tSNE_AllCells_DF_Rx and plots tSNE vs SDA score
tSNEwSDAScoreProj_Rx <- reactive({
#ggplotly
tempDF <- tSNE_AllCells_DF_Rx()
ggplot(cbind(tempDF, SDAComp=datat[,get(paste0("SDAV", input$ComponentNtext, sep=""))]),
aes(tSNE1, tSNE2, color=cut(asinh(SDAComp), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("CS", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
ggtitle(paste0("SDAV", input$ComponentNtext, " \n",
StatFac[paste0("SDAV", input$ComponentNtext, sep=""),2], sep="")) +
simplify2 + coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)
})
#gets tSNE_SDA_CT_Rx and plots tSNE per CT vs SDA score
tSNEwSDAScoreProjPerCT_GEX_Rx <- reactive({
#ggplotly
tempDF <- tSNE_SDA_CT_GEX_Rx()
# print(head(tempDF))
if(input$DimReduxCT_ctselect_gex == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
if(input$Genetext_celltype_gex %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext_celltype_gex)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
#ggplotly
#as.numeric(input$NoOfGenes)
LoadOrdVal <- round(results$loadings[[1]][,as.character(input$Genetext_celltype_gex)][order(abs(results$loadings[[1]][,as.character(input$Genetext)]), decreasing = T)], 3)
tempDF[rownames(GeneExpr), ]$GeneExpr <- GeneExpr[,1]
(ggplot(tempDF,
aes(tSNE1, tSNE2, color=cut(asinh(GeneExpr), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("EX", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)) +
labs(title = paste("Gene: ", input$Genetext_celltype_gex, sep=""),
subtitle = paste("Found in comps: \n",
paste(names(LoadOrdVal)[1:5], collapse = ", "),
"\n",
paste(LoadOrdVal[1:5], collapse = ", "),
"\n",
paste(names(LoadOrdVal)[6:10], collapse = ", "),
"\n",
paste(LoadOrdVal[6:10], collapse = ", "),
"\n"),
caption = "Imputed GEX")
})
#gets tSNE_SDA_CT_Rx and plots tSNE per CT vs SDA score
tSNEwSDAScoreProjPerCT_Rx <- reactive({
#ggplotly
tempDF <- tSNE_SDA_CT_Rx()
# limValX <- max(c(abs(min(tempDF$tSNE1)), max(tempDF$tSNE1)) )
# limValX = limValX + limValX*0.1
#
# limValY <- max(c(abs(min(tempDF$tSNE2)), max(tempDF$tSNE2)) )
# limValY = limValY + limValY*0.1
# print(head(tempDF))
if(input$DimReduxCT_ctselect == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
tempMeta <- datat[,get(paste0("SDAV", input$ComponentNtext_DimReduxCT, sep=""))]
names(tempMeta) <- datat$barcode
tempMeta <- tempMeta[rownames(tempDF)]
# print(head(tempMeta))
if(input$ComponentNtext_DimReduxCT > 150) {
BREAKS = c(-Inf, round(as.numeric(quantile(asinh(tempMeta), c(.15,.25,.5,.75,.85))), 5), Inf)
if(input$ComponentNtext_DimReduxCT > 203) {
TITLE = ggtitle(paste0("DiffComp-Rank", as.numeric(input$ComponentNtext_DimReduxCT)-199))
} else {
TITLE = ggtitle(paste0("DiffComp", as.numeric(input$ComponentNtext_DimReduxCT)-199))
}
} else {
BREAKS = c(-Inf, -1, -.5, 0, .5, 1, Inf)
TITLE = ggtitle(paste0("SDAV", input$ComponentNtext_DimReduxCT, " \n",
StatFac[paste0("SDAV", input$ComponentNtext_DimReduxCT, sep=""),2], sep=""))
}
ggplot(cbind(tempDF, SDAComp=tempMeta),
aes(tSNE1, tSNE2, color=cut(asinh(SDAComp), breaks = BREAKS))) +
geom_point(size=0.5) + theme_classic(base_size = 10) +
scale_color_manual("CS", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 + TITLE +
coord_cartesian(xlim = c(-AddPer(abs(quantile(tempDF$tSNE1, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE1, .98), perc=percH)),
ylim = c(-AddPer(abs(quantile(tempDF$tSNE2, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE2, .98), perc=percH)), expand = T) +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
# if(LocalRun) AugmentPlot(ggf) else ggf
})
#get tSNE_AllCells_DF_Rx and plot tSNE vs Meta per CT
tSNEwMetaPerCT_Rx <- reactive({
tempDF <- tSNE_META_CT_Rx()
# print("tSNEwMetaPerCT_Rx")
# print(head(tempDF))
tempMetaDF <- as.data.frame(datat)
rownames(tempMetaDF) <- datat$barcode
tempMetaDF <- tempMetaDF[rownames(tempDF), ]
# print(head(tempMetaDF))
if(input$ctselect_meta == "celltype") {
MetaFac <- as.character(tempMetaDF$FinalFinalPheno_old)
} else {
if(input$ctselect_meta == "donrep"){
MetaFac <- as.character(tempMetaDF$DonRep)
} else {
if(input$ctselect_meta == "donor"){
MetaFac <- as.character(tempMetaDF$donor)
} else {
if(input$ctselect_meta == "COND.ID"){
MetaFac <- as.character(tempMetaDF$COND.ID)
} else {
if(input$ctselect_meta == "experiment"){
MetaFac <- as.character(tempMetaDF$experiment)
} else {
if(input$ctselect_meta == "Phase"){
MetaFac <- as.character(tempMetaDF$Phase)
} else {
}
}
}
}
}
}
if(input$DimReduxCT_ctselect_meta == "all"){
percH = .5
percL = percH
} else {
percH = .2
percL = .05
}
#ggplotly
ggplot(tempDF, aes(tSNE1, tSNE2, color=factor(MetaFac))) +
geom_point(size=0.5)+ theme_classic(base_size = 10) +
theme(legend.position = "right", aspect.ratio=1,
legend.title = element_blank()) +
ggtitle("t-SNE - Final Pheno") +
scale_color_manual(values=(col_vector)) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol =2)) +
simplify2 +
coord_cartesian(xlim = c(-AddPer(abs(quantile(tempDF$tSNE1, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE1, .98), perc=percH)),
ylim = c(-AddPer(abs(quantile(tempDF$tSNE2, .01)), perc=percL),
AddPer( quantile(tempDF$tSNE2, .98), perc=percH)), expand = T) +
theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
})
#gets tSNE_AllCells_DF_Rx and plots tSNE vs Meta
tSNEwMeta_Rx <- reactive({
tempDF <- tSNE_AllCells_DF_Rx()
if(input$metaselect == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
#ggplotly
ggplot(tempDF, aes(tSNE1, tSNE2, color=factor(MetaFac))) +
geom_point(size=0.1)+ theme_classic(base_size = 10) +
theme(legend.position = "right", aspect.ratio=1,
legend.title = element_blank()) +
ggtitle("t-SNE - Final Pheno") +
scale_color_manual(values=(col_vector)) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol =2)) +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)
})
tSNE_SDA_CT_Rx <- reactive({
if(input$DimReduxCT_ctselect == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}
}
}
}
if(input$data3 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data3 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
# tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
# rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
tSNE_SDA_CT_GEX_Rx <- reactive({
if(input$DimReduxCT_ctselect_gex == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect_gex == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}
}
}
}
if(input$data2 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data2 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
return(tempDF)
})
tSNE_META_CT_Rx <- reactive({
if(input$DimReduxCT_ctselect_meta == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "all"){
MyCells <- datat$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$DimReduxCT_ctselect_meta == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
if(input$data4 == "tsneBrSDACS") {
tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "tsneDSNDGE") {
tempDF <- as.data.frame(datat)[, c("Tsne1", "Tsne2")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "tsneImpDGE"){
tempDF <- as.data.frame(datat)[, c("Tsne1_imputed", "Tsne2_imputed")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
} else {
if(input$data4 == "umapBrSDACS"){
tempDF <- as.data.frame(datat)[, c("UMAP1_scores", "UMAP2_scores")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
}
}
}
}
tempDF$tSNE1 <- as.numeric(tempDF$tSNE1)
tempDF$tSNE2 <- as.numeric(tempDF$tSNE2)
rownames(tempDF) <- datat$barcode
# tempDF <- as.data.frame(datat)[, c("Tsne1_SDAQC4b", "Tsne2_SDAQC4b")]; colnames(tempDF) <- c("tSNE1", "tSNE2")
#
# rownames(tempDF) <- datat$barcode
tempDF <- tempDF[MyCells, ]
tempDF$GeneExpr <- rep(0, nrow(tempDF))
# print("tSNE_META_CT_Rx")
# print(head(tempDF))
return(tempDF)
})
GeneExprPerCellType_DF_Rx <- reactive({
if(input$celltypeselect2 == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect2 == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect2 == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect2 == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect2 == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect2 == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect2 == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect2 == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect2 == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect2 == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect2 == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect2 == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect2 == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect2 == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
if(input$metaselect2 == "experiment") {
MetaFac <- (datat$experiment)
} else if(input$metaselect2 == "FinalFinalPheno_old") {
MetaFac <- (datat$experiment)
} else {
}
if(input$Genetext2 %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext2)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
GeneExpr <- as.data.frame(GeneExpr)
GeneExpr$barcode <- rownames(GeneExpr)
GeneExpr<- GeneExpr[datat$barcode, ]
GeneExpr$MetaFac <- MetaFac
GeneExpr <- GeneExpr[MyCells,-2]
colnames(GeneExpr) <- c("gene", "meta")
tempCom <- combn(levels(factor(GeneExpr$meta)),2)
my_comparisons <- lapply(1:ncol(tempCom), function(xN){
c(tempCom[1,xN], tempCom[2,xN])
})
return(list(GeneExpr = GeneExpr, my_comparisons = my_comparisons))
})
GeneExprAcroosCellType_DF_Rx <- reactive({
MyCells <- datat$barcode
if(input$metaselect3 == "experiment") {
# MetaFac <- (datat$experiment)
} else if(input$metaselect3 == "scope1") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
}
if(input$Genetext3 %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[MyCells,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext3)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
if(input$condSelect1 == "all"){
MyCells <- datat$barcode
} else {
if(input$condSelect1 == "cnt"){
MyCells <- datat[datat$DONR.ID %in% c("AdHu173", "AdHu174", "AdHu175", "UtahD1", "UtahD2", "UtahD3"),]$barcode
} else {
if(input$condSelect1 == "inf1"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI1"),]$barcode
} else {
if(input$condSelect1 == "inf2"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI2"),]$barcode
} else{
if(input$condSelect1 == "ks"){
MyCells <- datat[datat$DONR.ID %in% c("UtahK1", "UtahK2"),]$barcode
} else{
if(input$condSelect1 == "juv"){
MyCells <- datat[datat$DONR.ID %in% c("Juv1", "Juv2"),]$barcode
}
}
}
}
}
}
# MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
GeneExpr <- as.data.frame(GeneExpr)
GeneExpr$barcode <- rownames(GeneExpr)
# print(head(rownames(GeneExpr)))
# print(head(MetaFac))
GeneExpr$MetaFac <- MetaFac
# GeneExpr<- GeneExpr[datat$barcode, ]
GeneExpr <- GeneExpr[MyCells,-2]
colnames(GeneExpr) <- c("gene", "meta")
tempCom <- combn(levels(factor(GeneExpr$meta)),2)
my_comparisons <- lapply(1:ncol(tempCom), function(xN){
c(tempCom[1,xN], tempCom[2,xN])
})
return(list(GeneExpr = GeneExpr, my_comparisons = my_comparisons))
})
geneExprPerCond_box_Rx <- reactive({
GeneExpr <- GeneExprPerCellType_DF_Rx()$GeneExpr
my_comparisons <- GeneExprPerCellType_DF_Rx()$my_comparisons
CellType = input$celltypeselect2
if(input$Genetext2 %in% colnames(results$loadings[[1]])){
geneN = input$Genetext2
} else {
geneN = paste0(input$Genetext2 , " not in HISTA")
}
TestName = "Wilcox Rank Sum"
ggboxplot(GeneExpr, x = "meta", y = "gene", palette = "jco",
add = "jitter", col="meta") +
stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(geneN), " expression :: ", TestName, " test :: ", CellType)) +
xlab("") + ylab(as.character(geneN)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
})
geneExprPerCT_box_Rx <- reactive({
GeneExpr <- GeneExprAcroosCellType_DF_Rx()$GeneExpr
my_comparisons <- GeneExprAcroosCellType_DF_Rx()$my_comparisons
GeneExpr$meta <- factor(GeneExpr$meta)
GeneExpr$meta <- factor(GeneExpr$meta, levels = gtools::mixedsort(levels(GeneExpr$meta)) )
if(input$Genetext3 %in% colnames(results$loadings[[1]])){
geneN = input$Genetext3
} else {
geneN = paste0(input$Genetext3 , " not in HISTA")
}
TestName = "Wilcox Rank Sum"
ggboxplot(GeneExpr, x = "meta", y = "gene", palette = col_vector,
add = "jitter", col="meta") +
# stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(geneN), " expression :: "
#, TestName, " test "
)) +
xlab("") + ylab(as.character(geneN)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + coord_flip()
})
## celltypes_SDAperCT_box_Rx ----
celltypes_SDAperCT_box_Rx <- reactive({
if(input$celltypes_condSelect == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypes_condSelect == "cnt"){
MyCells <- datat[datat$DONR.ID %in% c("AdHu173", "AdHu174", "AdHu175", "UtahD1", "UtahD2", "UtahD3"),]$barcode
} else {
if(input$celltypes_condSelect == "inf1"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI1"),]$barcode
} else {
if(input$celltypes_condSelect == "inf2"){
MyCells <- datat[datat$DONR.ID %in% c("UtahI2"),]$barcode
} else{
if(input$celltypes_condSelect == "ks"){
MyCells <- datat[datat$DONR.ID %in% c("UtahK1", "UtahK2"),]$barcode
} else{
if(input$celltypes_condSelect == "juv"){
MyCells <- datat[datat$DONR.ID %in% c("Juv1", "Juv2"),]$barcode
}
}
}
}
}
}
print(MyCells)
compID = paste0("SDAV", input$celltypes_sdaN_in, sep="")
tempMeta <- as.data.frame(datat)[,c(compID,
"FinalFinalPheno_old" )]
rownames(tempMeta) <- datat$barcode
tempMeta = tempMeta[MyCells,]
colnames(tempMeta) = c("score", "pheno")
ggboxplot(tempMeta, x = "pheno", y = "score", palette = col_vector,
add = "jitter", col="pheno") +
# stat_compare_means(comparisons = my_comparisons, method = "wilcox.test", label = "p.signif") +
theme_classic(base_size = 10) +
ggtitle( paste0(as.character(compID), " expression :: "
#, TestName, " test "
)) +
xlab("") + ylab(as.character(compID)) +
theme(legend.position="none",
legend.direction="horizontal",
legend.title = element_blank(),
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1)) + coord_flip()
})
ComboTopSDAgenes_Rx <- reactive({
if(input$celltypeselect3 == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect3 == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect3 == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect3 == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect3 == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect3 == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect3 == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect3 == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect3 == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect3 == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect3 == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect3 == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect3 == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect3 == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
# if(input$metaselect3 == "experiment") {
# MetaFac <- (datat$experiment)
# } else if(input$metaselect3 == "FinalFinalPheno_old") {
# MetaFac <- (datat$FinalFinalPheno_old)
# } else {
#
#
# }
# print(head(results$scores))
# GeneExpr <- as.data.frame(GeneExpr)
# GeneExpr$barcode <- rownames(GeneExpr)
# GeneExpr<- GeneExpr[datat$barcode, ]
# GeneExpr$MetaFac <- MetaFac
# GeneExpr <- GeneExpr[MyCells,-2]
# colnames(GeneExpr) <- c("gene", "meta")
#
# tempCom <- combn(levels(factor(GeneExpr$meta)),2)
#
# my_comparisons <- lapply(1:ncol(tempCom), function(xN){
# c(tempCom[1,xN], tempCom[2,xN])
# })
#
return(list(Scores = results$scores[MyCells,], Meta=as.data.frame( subset(datat, barcode %in% MyCells))$experiment))
})
ComboTopSDAgenes_DF_Rx <- reactive({
Out1 <- print_gene_list(as.numeric(input$ComponentNtext), PosOnly = T) %>%
#group_by(package) %>%
#tally() %>%
#arrange(desc(n), tolower(package)) %>%
#mutate(percentage = n / nrow(pkgData()) * 100) %>%
#select("Package name" = package, "% of downloads" = percentage) %>%
as.data.frame() %>% head(as.numeric(input$NoOfGenes))
Out1 <- Out1$Gene.Name
Out2 <- print_gene_list(as.numeric(input$ComponentNtext), NegOnly = T) %>%
#group_by(package) %>%
#tally() %>%
#arrange(desc(n), tolower(package)) %>%
#mutate(percentage = n / nrow(pkgData()) * 100) %>%
#select("Package name" = package, "% of downloads" = percentage) %>%
as.data.frame() %>% head(as.numeric(input$NoOfGenes))
Out2 <- Out2$Gene.Name
data.frame(Pos=Out1, Neg=Out2)
})
PseudotimeGEX_RX <- reactive({
Scores <- results$scores
tempDF <- tSNE_GermCells_DF_Rx()
if(input$metaselect_pseudo_gene == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect_pseudo_gene == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect_pseudo_gene == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect_pseudo_gene == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect_pseudo_gene == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect_pseudo_gene == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
tempDF$MetFacZ <- MetaFac
tempDF$PT <- datat$PseudoTime
tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# tempDF$Scores <- Scores[rownames(tempDF), paste0("SDAV", as.numeric(input$ComponentName_pseudo))]
# tempDF$barcode <- rownames(tempDF)
# input = list(Genetext_pseudo = "PRM1")
if(input$Genetext_pseudo %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext_pseudo)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
tempDF$GeneExpr = GeneExpr[rownames(tempDF), ]
tempDF$barcode = rownames(tempDF)
# head(tempDF)
tempDF
})
PseudotimeGeneral_RX <- reactive({
Scores <- results$scores
tempDF <- tSNE_GermCells_DF_Rx()
PT <- datat$PseudoTime
MetaFac <- datat$PseudoTime
if(input$metaselect_pseudo == "pseudotime") {
MetaFac <- datat$PseudoTime
} else{
if(input$metaselect_pseudo == "celltype") {
MetaFac <- (datat$FinalFinalPheno_old)
} else {
if(input$metaselect_pseudo == "donrep"){
MetaFac <- (datat$DonRep)
} else {
if(input$metaselect_pseudo == "donor"){
MetaFac <- (datat$donor)
} else {
if(input$metaselect_pseudo == "COND.ID"){
MetaFac <- (datat$COND.ID)
} else {
if(input$metaselect_pseudo == "experiment"){
MetaFac <- (datat$experiment)
} else {
if(input$metaselect_pseudo == "Phase"){
MetaFac <- (datat$Phase)
} else {
}
}
}
}
}
}
}
tempDF$MetFacZ <- MetaFac
tempDF$PT <- PT
tempDF <- tempDF[!is.na(tempDF$tSNE1),]
tempDF$Scores <- Scores[rownames(tempDF), paste0("SDAV", as.numeric(input$ComponentName_pseudo))]
tempDF$barcode <- rownames(tempDF)
# tempDF = tempDF[sample(1:nrow(tempDF), 500, replace = F), ]
if(input$metaselect_pseudo == "pseudotime") {
tempDF$MetFacZ <- as.numeric(as.character(tempDF$MetFacZ))
} else {
tempDF$MetFacZ <- factor(as.character(tempDF$MetFacZ))
}
return(tempDF)
})
PseudotimeSDA_gene_Rx <- reactive({
tempDF <- PseudotimeGEX_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
input$Genetext_pseudo
ggpp = ggplot(merge_sda_melt, aes(PT, GeneExpr, colour=(GeneExpr))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
ggtitle(paste0("", (input$Genetext_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-8,8) + scale_color_viridis()
ggpp
})
PseudotimeSDA_geneMeta_Rx <- reactive({
tempDF <- PseudotimeGEX_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
# print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
# input$Genetext_pseudo
ggpp = ggplot(merge_sda_melt, aes(PT, GeneExpr, colour=(MetFacZ))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
ggtitle(paste0("", (input$Genetext_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-1,8) + scale_colour_manual(values=col_vector)
ggpp
})
PseudotimeSDA_Rx <- reactive({
tempDF <- PseudotimeGeneral_RX()
merge_sda_melt <- reshape2::melt(tempDF, id.vars = c("barcode","tSNE1", "tSNE2", "GeneExpr", "MetFacZ", "PT"))
print("melted table")
# print(head(rownames(tempDF)))
# print(head(rownames(Scores)))
# tempDF <- tempDF[!is.na(tempDF$tSNE1),]
# Scores <-Scores[rownames(tempDF),]
# print(head(merge_sda_melt))
# plot(merge_sda_melt$PT,
# merge_sda_melt$value)
ggpp = ggplot(merge_sda_melt, aes(PT, value, colour=(MetFacZ))) +
geom_point(alpha=1, size=.2) +
geom_smooth(method = lm, formula = y ~ splines::bs(x, 50), se = FALSE) +
# stat_smooth(aes(PT, value), size=1, alpha = 0.6, method = "gam", formula = y ~ s(x, k = 20), se = F) +#colour="black",
ylab("Cell Component Score") +
xlab("Pseudotime") +
# ggtitle(paste0("SDA Comp: ", as.numeric(input$ComponentName_pseudo)))+
theme_classic(base_size = 10) +
theme(legend.position = "none") +
ylim(-8,8)
print("ggpp made")
if(input$metaselect_pseudo == "pseudotime") {
ggpp = ggpp + scale_color_viridis()
} else {
ggpp = ggpp + scale_colour_manual(values=col_vector) + facet_wrap(~MetFacZ,
ncol=3,
scales = "fixed")
}
print("color type corrected")
ggpp
})
SDAScoresChi_DF_Rx <- reactive({
SDAScores <- results$scores
ComponentN <- 1:ncol(SDAScores)
MetaDF <- as.data.frame(datat)
rownames(MetaDF) <- datat$barcode
MetaDF <- MetaDF[rownames(SDAScores),]
if(input$metaselect_chisqr == "celltype") {
MetaFac <- (MetaDF$FinalFinalPheno_old)
} else {
if(input$metaselect_chisqr == "donrep"){
MetaFac <- (MetaDF$DonRep)
} else {
if(input$metaselect_chisqr == "donor"){
MetaFac <- (MetaDF$donor)
} else {
if(input$metaselect_chisqr == "COND.ID"){
MetaFac <- (MetaDF$COND.ID)
} else {
if(input$metaselect_chisqr == "experiment"){
MetaFac <- (MetaDF$experiment)
} else {
if(input$metaselect_chisqr == "Phase"){
MetaFac <- (MetaDF$Phase)
} else {
}
}
}
}
}
}
NegCompsDF <- as.data.frame(lapply(levels(factor(MetaFac)), function(CondX){
apply(SDAScores[rownames(MetaDF)[which(MetaFac == CondX)], ], 2,
function(x){
round(sum(x<=0)/nrow(SDAScores)*100, 2)
})
}))
colnames(NegCompsDF) <- levels(factor(MetaFac))
PosCompsDF <- as.data.frame(lapply(levels(factor(MetaFac)), function(CondX){
apply(SDAScores[rownames(MetaDF)[which(MetaFac == CondX)], ], 2,
function(x){
round(sum(x>0)/nrow(SDAScores)*100, 2)
})
}))
colnames(PosCompsDF) <- levels(factor(MetaFac))
list(NegCompsDF=NegCompsDF, PosCompsDF=PosCompsDF)
})
SDAScoresChiNeg_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
# SDAScores <- results$scores
# ComponentN <- 1:ncol(SDAScores)
# MetaDF <- as.data.frame(datat)
# rownames(MetaDF) <- datat$barcode
# MetaDF <- MetaDF[rownames(SDAScores),]
#
#
# NegCompsDF <- as.data.frame(lapply(levels(factor(MetaDF$experiment)), function(CondX){
#
# apply(SDAScores[rownames(MetaDF)[which(MetaDF$experiment == CondX)], ], 2,
# function(x){
# round(sum(x<0)/nrow(SDAScores)*100, 2)
# })
# }))
#
# colnames(NegCompsDF) <- levels(factor(MetaDF$experiment))
#
# # print(head(NegCompsDF))
# # print(min(NegCompsDF))
#
#
# NegCompsDF <- NegCompsDF[gtools::mixedsort(rownames(NegCompsDF)),]
# NegCompsDF$SDA <- factor(rownames(NegCompsDF), levels=rownames(NegCompsDF))
# print(head(NegCompsDF))
NegCompsDF = SDAScoresChi_DF_Rx()$NegCompsDF
# ChiT <- chisq.test(NegCompsDF[,1:(ncol(NegCompsDF)-1)])
ChiT <- chisq.test(NegCompsDF[])
ChiTres <- ChiT$residuals
ChiTres[which(is.na(ChiTres))] = 0
ChiResSD <- round(apply(ChiTres, 1, sd),2)
ChiResSD[which(is.na(ChiResSD))] <- 0
ChiResSD[ChiResSD < 0.2] <- ""
# if(is.null(envv$SDAScoresChi_clusBTN)) {
# clustStat = F
# } else {
# clustStat <- ifelse(envv$SDAScoresChi_clusBTN=="ON", T, F)
# }
if(input$clustStat_chisqr == "True") {
clustStat = T
} else {
clustStat = F
}
# HM <- pheatmap::pheatmap((t(ChiT$residuals)),
# cluster_cols = clustStat, cluster_rows = clustStat,
# color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdBu")))(10),
# labels_col = paste0(rownames(NegCompsDF), " sd_", ChiResSD))
outLS <- list(obj=(t(ChiT$residuals)),
clustStat = clustStat,
label_col = paste0(rownames(NegCompsDF), " sd_", ChiResSD))
# return((HM$gtable))
return(outLS)
})
SDAScoresChiPos_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
# SDAScores <- results$scores
# ComponentN <- 1:ncol(SDAScores)
# MetaDF <- as.data.frame(datat)
# rownames(MetaDF) <- datat$barcode
# MetaDF <- MetaDF[rownames(SDAScores),]
#
#
#
#
# PosCompsDF <- as.data.frame(lapply(levels(factor(MetaDF$experiment)), function(CondX){
#
# apply(SDAScores[rownames(MetaDF)[which(MetaDF$experiment == CondX)], ], 2,
# function(x){
# round(sum(x>0)/nrow(SDAScores)*100, 2)
# })
# }))
#
# colnames(PosCompsDF) <- levels(factor(MetaDF$experiment))
#
# # print(head(PosCompsDF))
# # print(min(PosCompsDF))
#
#
# PosCompsDF <- PosCompsDF[gtools::mixedsort(rownames(PosCompsDF)),]
# PosCompsDF$SDA <- factor(rownames(PosCompsDF), levels=rownames(PosCompsDF))
PosCompsDF = SDAScoresChi_DF_Rx()$PosCompsDF
# print(head(PosCompsDF))
ChiT <- chisq.test(PosCompsDF[,1:(ncol(PosCompsDF)-1)])
ChiTres <- ChiT$residuals
ChiTres[which(is.na(ChiTres))] = 0
ChiResSD <- round(apply(ChiTres, 1, sd),2)
ChiResSD[which(is.na(ChiResSD))] <- 0
ChiResSD[ChiResSD < 0.2] <- ""
# if(is.null(envv$SDAScoresChi_clusBTN)) {
# clustStat = F
# } else {
# clustStat <- ifelse(envv$SDAScoresChi_clusBTN=="ON", T, F)
# }
# clustStat = T
if(input$clustStat_chisqr == "True") {
clustStat = T
} else {
clustStat = F
}
# HM <- pheatmap::pheatmap((t(ChiT$residuals)),
# cluster_cols = clustStat, cluster_rows = clustStat,
# color = colorRampPalette(rev(brewer.pal(n = 7, name ="RdBu")))(10),
# labels_col = paste0(rownames(PosCompsDF), " sd_", ChiResSD))
#
# return(grid.draw(HM$gtable))
outLS <- list(obj=(t(ChiT$residuals)),
clustStat = clustStat,
label_col = paste0(rownames(PosCompsDF), " sd_", ChiResSD))
# return((HM$gtable))
return(outLS)
})
SDAScoresAcross_Rx <- reactive({
# ColFac_DONR.ID <- CDID()
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No Comp")
} else {
SDAScores <- results$scores
ComponentN <- as.numeric(input$ComponentNtext)
ggplot(data.table(cell_index = 1:nrow(SDAScores),
score = SDAScores[, paste0("SDAV", ComponentN)],
experiment = gsub("_.*", "", gsub("[A-Z]+\\.", "", rownames(SDAScores))),
ColFac = ColFac_DONR.ID),
aes(cell_index, score, colour = ColFac)) +
geom_point(size = 0.5, stroke = 0) +
xlab("Cell Index") + ylab("Score") +
#scale_color_brewer(palette = "Paired") +
theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
scale_colour_manual(values =(col_vector),
guide = guide_legend(nrow=2)) +
#guides(color = guide_legend(ncol = 2, override.aes = list(size = 2))) +
ggtitle(paste0("SDAV", ComponentN))
}
})
SDAGOpos_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No GO")
} else {
go_volcano_plot(component = paste("V", input$ComponentNtext, "P", sep=""))+ theme_classic(base_size = 10)+ theme(aspect.ratio = 1)
}
})
SDAGOneg_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No GO")
} else {
go_volcano_plot(component = paste("V", input$ComponentNtext, "N", sep=""))+ theme_classic(base_size = 10)+ theme(aspect.ratio = 1)
}
})
ChrLocLoadings_Rx <- reactive({
if(! (as.numeric(input$ComponentNtext) %in% 1:150)){
print("No Comp")
} else {
pgl <- genome_loadings(results$loadings[[1]][as.numeric(input$ComponentNtext),],
label_both = T,
max.items = as.numeric(input$NoOfGenes),
gene_locations = gene_locations,
chromosome_lengths = chromosome.lengths) + theme(aspect.ratio = .5)
return(pgl)
}
})
## Soma only LN19 figs --------------------
tSNE_somaWLN_Pheno3_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=Pheno3)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_COND.ID_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=COND.ID)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_DONR.ID_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=DONR.ID)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
tSNE_somaWLN_nCount_RNA_Rx <- reactive({
ggplot(datat_SomaWLN19, aes(Seurat_tSNE1, Seurat_tSNE2, color=log10(nCount_RNA))) +
geom_point(size=0.5) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
scale_color_distiller(palette = "Spectral")
})
## LC only figs ----------------
DimRedux_LConly_donors_Rx <- reactive({
ggplot(datat_LConlyLS$LC_UMAP, aes(UMAP1, UMAP2, color=donor)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConly_phenotype_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP)
ggplot(datat_LConlyLS$LC_UMAP, aes(UMAP1, UMAP2, color=phenotype)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = c(col_vector[41],"#E5C494", col_vector[42], "#BEAED4", "#7FC97F")) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_donors_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
ggplot(datat_LConlyLS$LC_UMAP_zhao, aes(UMAP_1, UMAP_2, color=donor)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = col_vector) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_phenotype_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
ggplot(datat_LConlyLS$LC_UMAP_zhao, aes(UMAP_1, UMAP_2, color=phenotype)) +
geom_point(size=0.6, alpha = 0.6) + theme_classic(base_size = 10) +
theme(legend.position = "bottom") +
# ggtitle("Reprocessing of: \nMahyari-Guo-Conrad Testis somatic cells (2021) + \n Laurentino-Neuhaus (2019) ") +
scale_color_manual(values = c( "#E5C494", "#BEAED4", "#7FC97F")) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1), ncol = 3))
})
DimRedux_LConlyZhao_phenotypeProp_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
barplot(datat_LConlyLS$LC_UMAP_type_prop, col = c("#7FC97F", "#E5C494", "#BEAED4"),
legend.text = T, xlim = c(0,5), main="SDA Proportions by Condition", names = c("CNT", "KS", "INFiNOA"), cex.names=1.5, cex.axis=1.5, border=NA, args.legend = list(x="topright"))
})
DimRedux_LConlyZhao_KeyGenesViolin_Rx <- reactive({
# head(datat_LConlyLS$LC_UMAP_zhao)
KeyLCgenes = c("FZD1", "SRD5A1", "SHROOM2", "NOTCH2", "DLK1", "IGF1",
"IGF2", "CFD", "PTCH2", "CYP17A1", "LHCGR", "STAR", "HSD17B3", "IGFBP7", "IGFBP3", "SFRP1")
# head(reshape2::melt(datat_LConlyLS$LC_UMAP_zhao[,c(KeyLCgenes, "origin", "experiment", "donor", "phenotype")]))
ggplot(reshape2::melt(datat_LConlyLS$LC_UMAP_zhao[,c(KeyLCgenes, "origin", "experiment", "donor", "phenotype")]),
aes(x = variable, y = value)) +
geom_violin(alpha = 0.8) +
geom_point(position = position_jitter(seed = 1, width = 0.2), alpha = .5, aes(color=origin)) +
facet_wrap(~phenotype) +
theme_classic(base_size = 10) +
theme(legend.position = "bottom",
axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))
})
## gene expression ----------
tSNE_geneExpr_Rx <- reactive({
tempDF <- as.data.frame(tSNE_AllCells_DF_Rx())
if(input$Genetext %in% colnames(results$loadings[[1]])){
# results$loadings[[1]][,"PRM1"]
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),as.character(input$Genetext)]
} else {
GeneExpr <- results$scores[,ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*% rep(0, nrow(results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE), ]))
}
#ggplotly
#as.numeric(input$NoOfGenes)
LoadOrdVal <- round(results$loadings[[1]][,as.character(input$Genetext)][order(abs(results$loadings[[1]][,as.character(input$Genetext)]), decreasing = T)], 3)
tempDF[rownames(GeneExpr), ]$GeneExpr <- GeneExpr[,1]
(ggplot(tempDF,
aes(tSNE1, tSNE2, color=cut(asinh(GeneExpr), breaks = c(-Inf, -1, -.5, 0, .5, 1, Inf)))) +
geom_point(size=0.1) + theme_classic(base_size = 10) +
scale_color_manual("EX", values = rev(c("red", "orange", "yellow", "lightblue", "dodgerblue", "blue")) ) +
guides(colour = guide_legend(override.aes = list(size=2, alpha=1))) +
theme(legend.position = "bottom", aspect.ratio=1) +
simplify2 +
coord_cartesian(xlim = NULL, ylim = NULL, expand = FALSE)) +
labs(title = paste("Gene: ", input$Genetext, sep=""),
subtitle = paste("Found in comps: \n",
paste(names(LoadOrdVal)[1:5], collapse = ", "),
"\n",
paste(LoadOrdVal[1:5], collapse = ", "),
"\n",
paste(names(LoadOrdVal)[6:10], collapse = ", "),
"\n",
paste(LoadOrdVal[6:10], collapse = ", "),
"\n"),
caption = "Imputed GEX")
})
## lncRNA top loaded----
# output$lncRNA_topLoaded_Rx <- reactive({
#
#
# lncLS$PosLoaded_top[[as.numeric(input$ComponentNtext_lncRNATopLoaded)]]
# lncLS$NegLoaded_top[[as.numeric(input$ComponentNtext_lncRNATopLoaded)]]
#
# })
## CompCor ----------
CompCor_Rx <- reactive({
annotDF = data.frame(Germ.Soma = SDAannotation$Cell.Type,
Pathology = SDAannotation$Pathology,
row.names = paste0("SDA", 1:150))
my_colour = list(
Germ.Soma = rev(col_vector)[c(1:length(levels(factor(annotDF$Germ.Soma))))],
Pathology = (col_vector)[c(1:length(levels(factor(annotDF$Pathology))))]
)
names(my_colour$Germ.Soma) <- levels(factor(annotDF$Germ.Soma))
names(my_colour$Pathology) <- levels(factor(annotDF$Pathology))
annotDF = subset(annotDF, Pathology != "Removed")
annotDF = subset(annotDF, Germ.Soma != "Multiple cell types")
lnRNASDAusageMat = results$loadings[[1]][,c(SDA_Top100neg[1:input$CompCorSDAnum_ngene,as.numeric(input$CompCorSDAnum)],
SDA_Top100pos[1:input$CompCorSDAnum_ngene,as.numeric(input$CompCorSDAnum)])]
rownames(lnRNASDAusageMat) = gsub("V", "", rownames(lnRNASDAusageMat))
lnRNASDAusageMat = lnRNASDAusageMat[rownames(annotDF),]
my_colour$Germ.Soma = my_colour$Germ.Soma[levels(factor(annotDF$Germ.Soma))]
my_colour$Pathology = my_colour$Pathology[levels(factor(annotDF$Pathology))]
return(list(lnRNASDAusageMat = lnRNASDAusageMat,
annotDF = annotDF,
my_colour = my_colour))
})
## CompCorCust ----------
CompCorCust_Rx <- reactive({
annotDF = data.frame(Germ.Soma = SDAannotation$Cell.Type,
Pathology = SDAannotation$Pathology,
row.names = paste0("SDA", 1:150))
my_colour = list(
Germ.Soma = rev(col_vector)[c(1:length(levels(factor(annotDF$Germ.Soma))))],
Pathology = (col_vector)[c(1:length(levels(factor(annotDF$Pathology))))]
)
names(my_colour$Germ.Soma) <- levels(factor(annotDF$Germ.Soma))
names(my_colour$Pathology) <- levels(factor(annotDF$Pathology))
annotDF = subset(annotDF, Pathology != "Removed")
annotDF = subset(annotDF, Germ.Soma != "Multiple cell types")
GeneSet <- input$GeneSet_TLC
#GeneSet <- "'PRM1', 'SPATA42', 'SPRR4', 'NUPR2', 'HBZ', 'DYNLL2'"
if(length(grep(",", GeneSet)) == 0){
if(length(grep('"', GeneSet)) + length(grep("'", GeneSet))>0) {
GeneSet <- unlist(strsplit(gsub("'", '', gsub('"', '', GeneSet)), " "))
} else {
GeneSet <- unlist(strsplit(GeneSet, " "))
}
#print(GeneSet)
}else {
GeneSet <- (unlist(strsplit(gsub(" ", "", gsub("'", '', gsub('"', '', GeneSet))), ",")))
#print(GeneSet)
}
GeneSet = unique(GeneSet)
# print("length of your genes:")
# print(length(GeneSet))
GeneSetNot <- GeneSet[!GeneSet %in% colnames(results$loadings[[1]][,])]
GeneSet <- GeneSet[GeneSet %in% colnames(results$loadings[[1]][,])]
print(GeneSet)
lnRNASDAusageMat = results$loadings[[1]][,GeneSet]
rownames(lnRNASDAusageMat) = gsub("V", "", rownames(lnRNASDAusageMat))
lnRNASDAusageMat = lnRNASDAusageMat[rownames(annotDF),]
my_colour$Germ.Soma = my_colour$Germ.Soma[levels(factor(annotDF$Germ.Soma))]
my_colour$Pathology = my_colour$Pathology[levels(factor(annotDF$Pathology))]
return(list(lnRNASDAusageMat = lnRNASDAusageMat,
annotDF = annotDF,
my_colour = my_colour))
})
## GeneCor_Rx ----------
GeneCor_Rx <- reactive({
if(input$celltypeselect_geneCor == "leydig"){
MyCells <- datat[datat$FinalFinalPheno == "Leydig",]$barcode
} else {
if(input$celltypeselect_geneCor == "sertoli"){
MyCells <- datat[datat$FinalFinalPheno == "Sertoli",]$barcode
} else {
if(input$celltypeselect_geneCor == "neuro"){
MyCells <- datat[datat$FinalFinalPheno == "Neuro",]$barcode
} else {
if(input$celltypeselect_geneCor == "myoid"){
MyCells <- datat[datat$FinalFinalPheno == "Myoid",]$barcode
} else {
if(input$celltypeselect_geneCor == "endothelial"){
MyCells <- datat[datat$FinalFinalPheno == "Endothelial",]$barcode
} else {
if(input$celltypeselect_geneCor == "myeloid"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Macrophage-M2", "Macrophage-M1"),]$barcode
} else {
if(input$celltypeselect_geneCor == "adaptive"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Lymphoid-Bcell", "Lymphoid-Tcell"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct",
"Gamete_Meiotic_Pach_Dip_2nd_Scts",
"Gamete_Meiotic_preLep_Lep_Zyg_Scts",
"Gamete_RoundSpermatid",
"Gamete_UndiffSg"),]$barcode
} else {
if(input$celltypeselect_geneCor == "all"){
MyCells <- datat$barcode
} else {
if(input$celltypeselect_geneCor == "germ_DiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_DifferentiatingSgSct"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_PrePachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_preLep_Lep_Zyg_Scts"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_PachSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_Meiotic_Pach_Dip_2nd_Scts"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_Std"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_RoundSpermatid"),]$barcode
} else {
if(input$celltypeselect_geneCor == "germ_UnDiffSgSct"){
MyCells <- datat[datat$FinalFinalPheno %in% c("Gamete_UndiffSg"),]$barcode
}
}
}
}
}
}
}
}
}
}
}}}
}
GeneSet <- input$GeneSet_geneCor
if(length(grep(",", GeneSet)) == 0){
if(length(grep('"', GeneSet)) + length(grep("'", GeneSet))>0) {
GeneSet <- unlist(strsplit(gsub("'", '', gsub('"', '', GeneSet)), " "))
} else {
GeneSet <- unlist(strsplit(GeneSet, " "))
}
#print(GeneSet)
}else {
GeneSet <- (unlist(strsplit(gsub(" ", "", gsub("'", '', gsub('"', '', GeneSet))), ",")))
#print(GeneSet)
}
GeneSet = unique(GeneSet)
GeneSetNot <- GeneSet[!GeneSet %in% colnames(results$loadings[[1]][,])]
print("length of your genes:")
print(length(GeneSet))
GeneSet <- GeneSet[GeneSet %in% colnames(results$loadings[[1]][,])]
print("length of your genes in this dataset:")
print(length(GeneSet))
GeneExpr <- results$scores[MyCells, ifelse( StatFac$Lab == "Removed", FALSE, TRUE)] %*%
results$loadings[[1]][ifelse( StatFac$Lab == "Removed", FALSE, TRUE),
GeneSet]
# tempCor = cor(GeneExpr)
# ph = pheatmap::pheatmap(tempCor)
#
#
# corrplot::corrplot(tempCor[ph$tree_row$labels[ph$tree_row$order],
# ph$tree_row$labels[ph$tree_row$order]],
# col = rev(corrplot::COL2('RdYlBu', 100)), is.corr = T)
cor(GeneExpr)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.