Commit 430edcf3 authored by Jean-Karim Heriche's avatar Jean-Karim Heriche

Added dimensionality reduction section with PCA and UMAP.

parent 8aa301e1
......@@ -23,12 +23,14 @@ RUN R -e "install.packages('DT', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('shiny', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('shinyFiles', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('shinycssloaders', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('shinybusy', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('shinydashboard', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('ggplot2', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('plotly', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('RANN', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "install.packages('BiocManager', repos='https://ftp.gwdg.de/pub/misc/cran/')"
RUN R -e "BiocManager::install('aoles/RBioFormats')"
RUN R -e "install.packages('uwot', repos='https://ftp.gwdg.de/pub/misc/cran/')"
# Copy the app to the image
RUN mkdir -p /usr/local/app/image-data-explorer
......
## Install required packages if missing
## CRAN packages
pkg <- c("DT", "shiny", "shinyFiles", "shinycssloaders", "shinydashboard", "ggplot2", "plotly", "RANN", "BiocManager")
pkg <- c("DT", "shiny", "shinyFiles", "shinycssloaders", "shinydashboard", "shinybusy", "ggplot2", "plotly", "RANN", "BiocManager", "uwot")
new.pkg <- pkg[!(pkg %in% installed.packages())]
if (length(new.pkg)) {
message(paste0("Installing ", new.pkg, "\n"))
install.packages(new.pkg)
}
## Bioconductor packages
......@@ -15,16 +16,18 @@ if(!"RBioFormats" %in% installed.packages()) {
library(devtools)
install_github("jkh1/EBImage")
library(DT) # R interface to the js DataTables library
library(EBImage) # patched version with improved Shiny integration
library(RBioFormats)
library(RANN)
library(uwot)
library(shiny)
library(shinyFiles) # File and directory selectors
library(shinycssloaders) # Loading/busy animations
library(shinydashboard)
library(shinybusy)
library(DT) # R interface to the js DataTables library
library(ggplot2)
library(plotly)
library(RANN)
## Increase amount of RAM allocated to the JVM to allow BioFormats to read large files.
# options(java.parameters = "-Xmx8g" )
......@@ -47,9 +50,12 @@ ui <- function(request) {
## Sidebar panel for inputs
sidebarMenu(
id = "menu",
menuItem("Input data", tabName = "datafile", icon = icon("file-import")),
menuItem("Explore", tabName = "explore", icon = icon("microscope")),
menuItem("Annotate", tabName = "annotate", icon = icon("edit"))
menuItem(HTML("&nbsp;&nbsp;Input data"), tabName = "datafile", icon = icon("file-import")),
menuItem(HTML("&nbsp;&nbsp;Explore"), tabName = "explore", icon = icon("microscope")),
menuItem(HTML("&nbsp;&nbsp;Annotate"), tabName = "annotate", icon = icon("edit")),
menuItem(HTML("&nbsp;&nbsp;Dimensionality<br>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;reduction"),
tabName = "reduce", icon = icon("project-diagram"))
# menuItem(HTML("&nbsp;&nbsp;Clustering"), tabName = "cluster", icon = icon("object-group"))
)
),
......@@ -231,6 +237,34 @@ ui <- function(request) {
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
)
)
),
tabItem(tabName = "reduce",
column(width = 3,
box( width = NULL,
title = "Columns to consider", solidHeader = TRUE, status = "primary",
## Select columns to hide
uiOutput("featuresToReduce"),
checkboxInput("select.numeric.cols", "Select all numeric columns", FALSE)
)
),
column(width = 3,
box( width = NULL,
title = "Algorithm", solidHeader = TRUE, status = "primary",
## Select columns to hide
uiOutput("dimReductionMethod")
)
),
column(width = 3,
box( width = NULL,
title = "Parameters", solidHeader = TRUE, status = "primary",
uiOutput("dimReductionParams")
)
),
actionButton("dimReductionButton", "Apply", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
),
tabItem(tabName = "cluster"
)
) # tabItems
) # dashboardBody
......@@ -246,6 +280,20 @@ server <- function(input, output, session) {
## Server-side directories we're allowed to navigate to find the image root dir
roots = c(home = "~", wd = '.', tier2 = '/g/tier2')
# Vector of names of user input (i.e. inputId) that we may want to restore from file
# Values are stored in rv$inputChoices
inputChoices.params <- c("selectedVar", "colsOnHover", "colsToHide", "groupLabels", "roiX", "roiY",
"roiFrame", "imgRoot", "fileCol1", "fileCol2", "normalize.img1", "normalize.img2")
## Reactive values we will use
rv <- reactiveValues(inputChoices = setNames(vector("list", length(inputChoices.params)),inputChoices.params),
data = NULL, currentRows = NULL, selectedRows = NULL, clusters = NULL, imgRoot = NULL,
imgPath1 = NULL, imgPath2 = NULL, pixelPosition = NULL, selectedFrame = NULL,
metadataImg1 = NULL, metadataImg2 = NULL, colsToHide = NULL, colsOnHover = NULL,
annotationCol = NULL, annotationLabels = NULL)
observeEvent(input$refresh, { session$reload() })
####################
......@@ -266,6 +314,7 @@ server <- function(input, output, session) {
selectizeInput(inputId = "selectedVar",
label = "Select 1 or 2 variables to plot",
multiple = TRUE,
selected = rv$inputChoices[["selectedVar"]],
choices = names(rv$data),
options = list(maxItems = 2))
})
......@@ -275,6 +324,7 @@ server <- function(input, output, session) {
selectizeInput(inputId = "colsOnHover",
label = "Values from these columns will be displayed when hovering over a point",
multiple = TRUE,
selected = rv$inputChoices[["colsOnHover"]],
choices = names(rv$data),
options = list(maxItems = 10))
})
......@@ -284,6 +334,7 @@ server <- function(input, output, session) {
selectizeInput(inputId = "colsToHide",
label = "These columns will not be displayed",
multiple = TRUE,
selected = rv$inputChoices[["colsToHide"]],
choices = names(rv$data))
})
......@@ -292,6 +343,7 @@ server <- function(input, output, session) {
selectizeInput(inputId = "groupLabels",
label = "Select column containing group labels",
multiple = FALSE,
selected = rv$inputChoices[["groupLabels"]],
choices = c("",names(rv$data)),
options = list(maxItems = 1))
})
......@@ -301,8 +353,8 @@ server <- function(input, output, session) {
colNames <- names(rv$data)
## Try to infer from name and set as default
found <- grepl("coordinate_x", colNames, ignore.case = TRUE)
selection <- NULL
if(any(found)) {
selection <- rv$inputChoices[["roiX"]]
if(is.null(selection) && any(found)) {
selection <- colNames[found]
}
selectizeInput(inputId = "roiX",
......@@ -316,8 +368,8 @@ server <- function(input, output, session) {
colNames <- names(rv$data)
## Try to infer from name and set as default
found <- grepl("coordinate_y", colNames, ignore.case = TRUE)
selection <- NULL
if(any(found)) {
selection <- rv$inputChoices[["roiY"]]
if(is.null(selection) && any(found)) {
selection <- colNames[found]
}
selectizeInput(inputId = "roiY",
......@@ -331,8 +383,8 @@ server <- function(input, output, session) {
colNames <- names(rv$data)
## Try to infer from name and set as default
found <- grepl("coordinate_z|coordinate_time", colNames, ignore.case = TRUE)
selection <- NULL
if(any(found)) {
selection <- rv$inputChoices[["roiFrame"]]
if(is.null(selection) && any(found)) {
selection <- colNames[found]
}
selectizeInput(inputId = "roiFrame",
......@@ -407,26 +459,45 @@ server <- function(input, output, session) {
}
})
# Remember input
observe({
rv$inputChoices[["selectedVar"]] <- input$selectedVar
rv$inputChoices[["colsOnHover"]] <- input$colsOnHover
rv$inputChoices[["colsToHide"]]<- input$colsToHide
rv$inputChoices[["groupLabels"]] <- input$groupLabels
rv$inputChoices[["roiX"]] <- input$roiX
rv$inputChoices[["roiY"]] <- input$roiY
rv$inputChoices[["roiFrame"]] <- input$roiFrame
# rv$inputChoices[["imgRoot"]] <- parseDirPath(roots, input$imgRoot)
rv$inputChoices[["fileCol1"]] <- input$fileCol1
rv$inputChoices[["fileCol2"]] <- input$fileCol2
rv$inputChoices[["normalize.img1"]] <- input$normalize.img1
rv$inputChoices[["normalize.img2"]] <- input$normalize.img2
})
## Save current choices to a file
output$saveConfigFile <- downloadHandler(
filename = function() {
data.file <- tools::file_path_sans_ext(basename(input$datafile$name))
paste0("IDE-saved_input_choices-", data.file, "-", Sys.Date(), ".rds") },
content = function(file) {
## Collect current choices
rv$inputChoices[["imgRoot"]] <- parseDirPath(roots, input$imgRoot)
settings <- list("selectedVar" = input$selectedVar, "colsOnHover" = input$colsOnHover,
"colsToHide" = input$colsToHide, "groupLabels" = input$groupLabels, "roiX" = input$roiX,
"roiY" = input$roiY, "roiFrame" = input$roiFrame, "imgRoot" = rv$inputChoices[["imgRoot"]],
"fileCol1" = input$fileCol1, "fileCol2" = input$fileCol2,
"normalize.img1" = input$normalize.img1, "normalize.img2" = input$normalize.img2)
saveRDS(settings, file)
isolate({
## Collect current choices
rv$inputChoices[["imgRoot"]] <- parseDirPath(roots, input$imgRoot)
settings <- list("selectedVar" = input$selectedVar, "colsOnHover" = input$colsOnHover,
"colsToHide" = input$colsToHide, "groupLabels" = input$groupLabels, "roiX" = input$roiX,
"roiY" = input$roiY, "roiFrame" = input$roiFrame, "imgRoot" = rv$inputChoices[["imgRoot"]],
"fileCol1" = input$fileCol1, "fileCol2" = input$fileCol2,
"normalize.img1" = input$normalize.img1, "normalize.img2" = input$normalize.img2)
saveRDS(settings, file)
})
}
)
## Restore input choices from file
observeEvent(input$readConfigFile, {
req(rv$data)
## Read saved choices from file
settings <- readRDS(file = input$readConfigFile$datapath)
for(field in inputChoices.params) {
......@@ -447,16 +518,6 @@ server <- function(input, output, session) {
updateCheckboxInput(session = session, inputId = "normalize.img2", value = rv$inputChoices[["normalize.img2"]])
})
# Vector of user input names (i.e. inputId) that we may want to restore from file
# Values are stored in rv$inputChoices
inputChoices.params <- c("selectedVar", "colsOnHover", "colsToHide", "groupLabels", "roiX", "roiY",
"roiFrame", "imgRoot", "fileCol1", "fileCol2", "normalize.img1", "normalize.img2")
rv <- reactiveValues(inputChoices = setNames(vector("list", length(inputChoices.params)),inputChoices.params),
data = NULL, currentRows = NULL, selectedRows = NULL, clusters = NULL, imgRoot = NULL,
imgPath1 = NULL, imgPath2 = NULL, pixelPosition = NULL, selectedFrame = NULL,
metadataImg1 = NULL, metadataImg2 = NULL, colsToHide = NULL, colsOnHover = NULL,
annotationCol = NULL, annotationLabels = NULL)
#################
## Explore tab ##
#################
......@@ -642,8 +703,8 @@ server <- function(input, output, session) {
## Interactions with the plot
observe({
req(rv$data)
isolate({
req(rv$data)
df <- rv$data
selectedCols <- c(NULL, NULL)
if(length(input$selectedVar) == 1) {
......@@ -932,6 +993,8 @@ server <- function(input, output, session) {
clickPosition <- data.frame(t(c(input$pixelPosition)))
roiData <- rv$data[,c(input$roiX, input$roiY)]
}
message(str(clickPosition))
message(str(roiData))
nn <- nn2(roiData,
clickPosition,
k = k,
......@@ -945,9 +1008,9 @@ server <- function(input, output, session) {
}
})
#################
## Annotate tab #
#################
##################
## Annotate tab ##
##################
## Select annotations column
output$annotationColumn <- renderUI({
......@@ -1012,6 +1075,97 @@ server <- function(input, output, session) {
}
})
##################################
## Dimensionality reduction tab ##
##################################
## Select features for input to dimensionality reduction method
output$featuresToReduce <- renderUI({
selectizeInput(inputId = "featuresToReduce",
label = "Dimensionality reduction will be applied to these variables",
multiple = TRUE,
choices = names(rv$data))
})
## Select dimensionality reduction method
output$dimReductionMethod <- renderUI({
selectizeInput(inputId = "dimReductionMethod",
label = "Select dimensionality reduction method to apply",
multiple = FALSE,
choices = c("", "PCA", "UMAP"))
})
## Show parameter input relevant to the selected method
output$dimReductionParams <- renderUI({
if(!is.null(input$dimReductionMethod) && input$dimReductionMethod != "") {
if(input$dimReductionMethod == 'PCA') {
"No parameter required."
} else if(input$dimReductionMethod == 'UMAP') {
tags$div(
numericInput("UMAP.n_neighbours", "Number of neighbours to use", 15, min = 1, max = NA),
numericInput("UMAP.min_dist", "Minimum distance between embedded points", 0.01, min = NA, max = NA)
)
}
}
})
observeEvent(input$select.numeric.cols,{
if(input$select.numeric.cols) {
num.cols <- colnames(Filter(is.numeric, rv$data))
num.cols <- num.cols[num.cols != 'id' & num.cols != 'idx']
updateSelectizeInput(session = session, inputId = "featuresToReduce", selected = num.cols)
} else {
updateSelectizeInput(session = session, inputId = "featuresToReduce", selected = "")
}
})
## Apply dimensionality reduction
## then use the new dimensions for plotting and switch to the explore tab
observeEvent(input$dimReductionButton,{
isolate({
if(length(input$featuresToReduce)<2) {
showNotification("You need to select at least 2 variables/columns.", type = "error")
} else if(!any(unlist(lapply(rv$data[,input$featuresToReduce], is.numeric)))) {
showNotification("Non-numeric variables/columns selected.", type = "error")
} else if(!is.null(input$dimReductionMethod) && input$dimReductionMethod != "") {
tmp <- rv$data[,input$featuresToReduce]
# Remove rows with NAs and infinite values
tmp <- tmp[is.finite(rowSums(tmp)),]
show_modal_spinner(text = "It looks like this is going to take a while. Please wait...",
spin = "orbit")
if(input$dimReductionMethod == 'PCA') {
pca <- prcomp(tmp[,input$featuresToReduce], rank = 2, retx = TRUE)
tmp <- predict(pca, newdata = rv$data[,input$featuresToReduce])
if(all(c("PCA.PC1", "PCA.PC2") %in% colnames(rv$data))) {
rv$data$PCA.PC1 <- tmp[,1]
rv$data$PCA.PC2 <- tmp[,2]
} else {
rv$data <- cbind(rv$data, tmp)
colnames(rv$data)[c((ncol(rv$data)-1),ncol(rv$data))] <- c("PCA.PC1", "PCA.PC2")
}
rv$inputChoices[["selectedVar"]] <- c("PCA.PC1", "PCA.PC2")
} else if(input$dimReductionMethod == 'UMAP') {
u <- as.data.frame(umap(tmp,
scale = TRUE,
n_neighbors = input$UMAP.n_neighbours,
min_dist = input$UMAP.min_dist,
n_components = 2))
if(!all(c("UMAP.X1", "UMAP.X2") %in% colnames(rv$data))) {
rv$data$UMAP.X1 <- NA
rv$data$UMAP.X2 <- NA
}
rv$data[rownames(tmp),]$UMAP.X1 <- u[,1]
rv$data[rownames(tmp),]$UMAP.X2 <- u[,2]
rv$inputChoices[["selectedVar"]] <- c("UMAP.X1", "UMAP.X2")
}
remove_modal_spinner()
updateSelectizeInput(session = session, inputId = "selectedVar",
selected = rv$inputChoices[["selectedVar"]],
choices = colnames(rv$data))
updateTabsetPanel(session, "menu", selected = "explore")
}
}) # End isolate()
})
## Stop the app when browser tab is closed
## Not used with Docker container
# session$onSessionEnded(stopApp)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment