Skip to content

GitLab

Commit caf05f3b authored by Jean-Karim Heriche's avatar Jean-Karim Heriche
Browse files
Options

Started work on feature selection.

parent fe04eea5
Hide whitespace changes
Inline Side-by-side
Showing with 139 additions and 57 deletions
R/annotate.R
View file @ caf05f3b
......@@ -9,22 +9,21 @@
############### UI ##################
ui_annotate <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box( width = 4,
title = "Annotation column", solidHeader = TRUE, status = "primary",
## Select column to hold annotations
uiOutput(ns("annotationColumn")),
),
box( width = 4,
title = "Annotation labels", solidHeader = TRUE, status = "primary",
## Enter annotation labels
uiOutput(ns("annotationLabels"))
),
actionButton(ns("annotateButton"), "Apply", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
) # End column
) # End fluidRow
column(12,
box( width = 4,
title = "Annotation column", solidHeader = TRUE, status = "primary",
## Select column to hold annotations
uiOutput(ns("annotationColumn")),
),
box( width = 4,
title = "Annotation labels", solidHeader = TRUE, status = "primary",
## Enter annotation labels
uiOutput(ns("annotationLabels"))
),
actionButton(ns("annotateButton"), "Apply", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
) # End column
} # End Function
......
R/dim_reduction.R
View file @ caf05f3b
......@@ -10,24 +10,22 @@
ui_dimensionality_reduction <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box( width = 3,
title = "Columns to consider", solidHeader = TRUE, status = "primary",
uiOutput(ns("featuresToReduce"))
),
box( width = 3,
title = "Algorithm", solidHeader = TRUE, status = "primary",
uiOutput(ns("dimReductionMethod"))),
box(width = 3,
title = "Parameters", solidHeader = TRUE, status = "primary",
uiOutput(ns("dimReductionParams"))),
actionButton(ns("dimReductionButton"), "Apply", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
) #End column
) # End fluidRow
column(12,
box( width = 3,
title = "Features to consider", solidHeader = TRUE, status = "primary",
uiOutput(ns("featuresToReduce"))
),
box( width = 3,
title = "Algorithm", solidHeader = TRUE, status = "primary",
uiOutput(ns("dimReductionMethod"))),
box(width = 3,
title = "Parameters", solidHeader = TRUE, status = "primary",
uiOutput(ns("dimReductionParams"))),
actionButton(ns("dimReductionButton"), "Apply", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
) #End column
} # End ui_dimensionality_reduction()
......@@ -51,16 +49,16 @@ dimensionality_reduction_server <- function(input, output, session, rv, session_
checkboxInput(ns(idtext), text, check)
) # End tagList
}) # End RenderUI
} # End dimensionality_reduction_server
}
DR_col("featuresToReduce", "Dimensionality reduction will be applied to these features", TRUE, names(rv$data) , "check" , "Select all numeric variables", FALSE)
# Select all numeric variables but exclude variables used only by the app (i.e. not in the input data)
observeEvent(input$check,{
if(input$check){
# Get names of numric columns
# Get names of numeric columns
numeric.cols <- colnames(Filter(is.numeric, rv$data))
# Remove non-data variables
numeric.cols <- numeric.cols[numeric.cols != 'id' & numeric.cols != 'idx']
numeric.cols <- numeric.cols[numeric.cols != 'ide.id' & numeric.cols != 'ide.idx']
updateSelectizeInput(session, inputId = "featuresToReduce", selected = numeric.cols)
}
if(!input$check){
......@@ -83,7 +81,6 @@ dimensionality_reduction_server <- function(input, output, session, rv, session_
output$dimReductionParams <- renderUI({
if(input$dimReductionMethod== "UMAP") {
tagList(
tags$div(tags$b("Distance measure to use")),
numericInput(ns("UMAP.n_neighbours"), "n_neighbors:", 15, min = 1, max = NA),
numericInput(ns("UMAP.min_dist"), "min_dist:", 0.01, min = NA, max = NA)
)
......
R/explore_plate_view.R
View file @ caf05f3b
......@@ -47,7 +47,7 @@ plate_view_server <- function(input, output, session, rv) {
"1536" = c(nb.rows = 32, nb.cols = 48)
)
# Use the first selected plate since this is the one we'll eventuually draw
nb.wells <- length(unique(plateData[plateData[, rv$plateCol] == selectedPlates[1],rv$wellCol]))
nb.wells <- length(unique(plateData[plateData[, rv$plateCol] == selectedPlates[1], rv$wellCol]))
plateSize <- min(plate.sizes[nb.wells/plate.sizes<=1])
validate(need(plateSize>=4 && plateSize<=1536, "Unrecognized plate size/format."))
nb.rows <- plate.formats[[as.character(plateSize)]]["nb.rows"]
......@@ -55,11 +55,18 @@ plate_view_server <- function(input, output, session, rv) {
nb.cols <- plate.formats[[as.character(plateSize)]]["nb.cols"]
col.labels <- 1:nb.cols
plateData <- cbind(plateData[, c("ide.id", rv$plateCol, rv$wellCol,rv$fieldCol, rv$treatCol, rv$selectedVar[1]), drop = FALSE], rows = NA, cols = NA)
# Match well index to row/col coordinates
for(i in 1:nrow(plateData)) {
idx <- plateData[i, rv$wellCol]
plateData[i, "rows"] <- row.labels[((idx-1) %/% nb.cols)+1]
plateData[i, "cols"] <- ((idx-1) %% nb.cols)+1
if(all(grepl("^[A-Za-z]", plateData[, rv$wellCol]))) { # assume we have row/col coordinates
plateData[, "rows"] <- gsub('\\d','', plateData[, rv$wellCol])
plateData[, "cols"] <- gsub('\\D','', plateData[, rv$wellCol])
} else if(all(!grepl("\\D", plateData[, rv$wellCol]))) { # all numeric, assume we have well indices
# Match well index to row/col coordinates
for(i in 1:nrow(plateData)) {
idx <- plateData[i, rv$wellCol]
plateData[i, "rows"] <- row.labels[((idx-1) %/% nb.cols)+1]
plateData[i, "cols"] <- ((idx-1) %% nb.cols)+1
}
} else {
showNotification("Unrecognized well identifier", type = "error")
}
plateData$rows <- factor(plateData$rows)
plateData$rows <- factor(plateData$rows, rev(levels(plateData$rows)))
......
R/explore_table.R
View file @ caf05f3b
......@@ -97,7 +97,6 @@ explore_table_server <- function(input, output, session, rv) {
rv$selectedFrame <- rv$data[rv$selectedRows, rv$roiFrame]
}
}
print("Table clicked")
updateFilters()
})
......
R/feature_selection.R
View file @ caf05f3b
......@@ -8,23 +8,103 @@
ui_feature_selection <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box(id="box_alert", width= 6,
title = "Feature selection", solidHeader = TRUE, status = "primary",
tags$div(style = "line-height: 2",
tags$b("Feature selection is not implemented yet. Please come back later or consider contributing code to the app."),
)
) # End box
) # End column
) # End fluidRow
column(12,
box( width = 3,
title = "Features to consider", solidHeader = TRUE, status = "primary",
uiOutput(ns("featuresToProcess"))
),
box( width = 3,
title = "Target annotation column", solidHeader = TRUE, status = "primary",
uiOutput(ns("targetCol"))
),
# box(width = 3,
# title = "Parameters", solidHeader = TRUE, status = "primary",
# uiOutput(ns("featSelectionParams"))),
actionButton(ns("featSelectionButton"), "Start", icon("check"),
style="color: #fff; background-color: #3C8DBC; border-color: #3C8DBC")
) #End column
} # End ui_cluster()
feature_selection_server <- function(input, output, session) {
feature_selection_server <- function(input, output, session, rv, session_parent) {
req(rv$data)
ns <- session$ns
## Select input variables
## Allow to select all variables of numerical type as it may be more user-friendly to deselect a few variables
## instead of selecting many one by one.
output$featuresToProcess <- renderUI({
tagList(
selectizeInput(inputId = ns("featuresToProcess"),
label = "Feature selection will be applied to these features",
multiple = TRUE,
choices = names(rv$data)),
checkboxInput(ns("check"), "Select all numeric variables", FALSE)
) # End tagList
}) # End RenderUI
output$targetCol <- renderUI({
tagList(
selectizeInput(inputId = ns("targetCol"),
label = "Select column containing target annotations",
multiple = FALSE,
choices = names(rv$data))
)
})
# Select all numeric variables but exclude variables used only by the app (i.e. not in the input data)
observeEvent(input$check,{
if(input$check){
# Get names of numeric columns
numeric.cols <- colnames(Filter(is.numeric, rv$data))
# Remove non-data variables
numeric.cols <- numeric.cols[numeric.cols != 'ide.id' & numeric.cols != 'ide.idx']
updateSelectizeInput(session, inputId = "featuresToProcess", selected = numeric.cols)
}
if(!input$check){
updateSelectizeInput(session, inputId = "featuresToProcess", selected = "")
}
})
####################################
## Feature selection with XGBoost ##
####################################
action_button_feature_selection <- function(){
shinyjs::disable("featSelectionButton")
req(rv$data)
tmp <- rv$data[,input$featuresToProcess]
# Remove rows with NAs and infinite values
tmp <- tmp[is.finite(rowSums(tmp)),]
remove_modal_spinner()
shinyjs::enable("featSelectionButton")
}
# Run action function on button click
onclick("featSelectionButton", Check_variable(action_button_feature_selection()))
#TODO
# Check that we have at least two columns selected and they they are numeric
# then start processing
Check_variable <- function(buttonaction){
if(length(input$featuresToProcess)<2) {
showNotification("You need to select at least 2 variables/columns.", type = "error")
} else if(!any(unlist(lapply(rv$data[,input$featuresToProcess], is.numeric)))) {
showNotification("Non-numeric variables/columns selected.", type = "error")
}
else{
show_modal_spinner(text = "It looks like this is going to take a while. Please wait...",
spin = "orbit")
buttonaction
}
}
}
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