Nothing
#' Generate the sample select panel of the shiny app
#' @description These are the UI and server components of the sample selection
#' panel of the shiny app. It is generated by including 'SampleSelect' in the
#' panels.default argument of \code{\link{generateShinyApp}}.
#' @inheritParams DEpanel
#' @param modality the modality, needs to be passed when used within another
#' shiny module for namespacing reasons
#' @return The UI and Server components of the shiny module, that can be used
#' within the UI and Server definitions of a shiny app.
#' @name sampleSelectPanel
NULL
#' @rdname sampleSelectPanel
#' @export
sampleSelectPanelUI <- function(id, metadata, show = TRUE){
ns <- NS(id)
if(show){
tabPanel(
'Sample select',
actionButton(ns('goSamples'), label = 'Use the selected samples!',
width = "100%", class = "btn-primary btn-lg"),
fluidRow(
column(2, checkboxInput(ns("selectAll"), label = "Select all", value = TRUE)),
column(2, checkboxInput(ns("deselectAll"), label = "Deselect all", value = FALSE)),
column(2, style = "padding-top: 10px;", 'Select using metadata column:'),
column(2, style = "padding-top: 5px;",
selectInput(ns('condition'), NULL, colnames(metadata),
selected = colnames(metadata)[ncol(metadata)])),
column(4, style = "padding-top: 10px;",
checkboxGroupInput(ns("selectMeta"), label = NULL, inline = TRUE,
choices = unique(metadata[[ncol(metadata)]]),
selected = unique(metadata[[ncol(metadata)]]))),
),
DT::dataTableOutput(ns('tbl'))
)
}else{
NULL
}
}
#' @rdname sampleSelectPanel
#' @export
sampleSelectPanelServer <- function(id, expression.matrix, metadata, modality = "RNA"){
ns <- NS(c(modality, id))
# check whether inputs (other than id) are reactive or not
stopifnot({
!is.reactive(expression.matrix)
!is.reactive(metadata)
})
moduleServer(id, function(input, output, session){
# create a character vector of shiny inputs
shinyInput = function(FUN, len, ID, value, ...) {
if (length(value) == 1) value <- rep(value, len)
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(ns(paste0(ID, i)), label = NULL, value = value[i]))
}
inputs
}
# obtain the values of inputs
shinyValue = function(ID, len) {
unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(ID, i)]]
if (is.null(value)) TRUE else value
}))
}
observe({
updateCheckboxInput(
session = session,
inputId = "selectAll",
value = FALSE
)
}) %>%
bindEvent(shinyValue('cb_', n), input[["condition"]],
input[["deselectAll"]], input[["selectMeta"]])
observe({
updateCheckboxInput(
session = session,
inputId = "deselectAll",
value = FALSE
)
}) %>%
bindEvent(shinyValue('cb_', n), input[["condition"]], input[["selectMeta"]])
observe({
updateCheckboxGroupInput(
session = session,
inputId = "selectMeta",
choices = unique(metadata[[input[["condition"]]]]),
selected = NULL,
inline = TRUE
)
}) %>%
bindEvent(shinyValue('cb_', n), input[["condition"]])
observe({
if (input[['goSamples']] != 0){
if (!identical(colnames(expression.matrix[,shinyValue('cb_', n)]), colnames(filteredInputs()$expression.matrix))){
shinyjs::enable("goSamples")
}
} else {
if (!all(shinyValue('cb_', n))){
shinyjs::enable("goSamples")
}
}
}) %>%
bindEvent(shinyValue('cb_', n))
n <- nrow(metadata)
df = cbind(
data.frame(selected = shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px')),
metadata
)
loopData = reactive({
if(input[["selectAll"]]){
df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = TRUE, width='1px')
}else if(input[["deselectAll"]]){
df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = FALSE, width='1px')
}else if(length(input[["selectMeta"]]) > 0){
df$selected <<- shinyInput(
checkboxInput, n, 'cb_', width='1px',
value = shinyValue('cb_', n) | metadata[[input[["condition"]]]] %in% input[["selectMeta"]]
)
}else{
df$selected <<- shinyInput(checkboxInput, n, 'cb_', value = shinyValue('cb_', n), width='1px')
}
df
})
tbl <- DT::renderDataTable(
isolate(loopData()),
escape = FALSE,
selection = 'none',
options = list(
dom = 't', paging = FALSE, ordering = FALSE,
preDrawCallback = DT::JS('function() { Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = DT::JS('function() { Shiny.bindAll(this.api().table().node()); } ')
))
output[["tbl"]] = tbl
proxy = DT::dataTableProxy('tbl')
observe({
DT::replaceData(proxy, loopData(), resetPaging = FALSE)
})
filteredInputs <- reactive({
shinyjs::disable("goSamples")
list("expression.matrix" = expression.matrix[, shinyValue('cb_', n)],
"metadata" = metadata[shinyValue('cb_', n), ])
}) %>%
bindEvent(input[["goSamples"]], ignoreNULL = FALSE)
return(filteredInputs)
})
}
sampleSelectPanelApp <- function(){
expression.matrix.preproc <- as.matrix(utils::read.csv(
system.file("extdata", "expression_matrix_preprocessed.csv", package = "bulkAnalyseR"),
row.names = 1
))
metadata <- data.frame(
srr = colnames(expression.matrix.preproc),
timepoint = rep(c("0h", "12h", "36h"), each = 2)
)
shinyApp(
ui = fluidPage(sampleSelectPanelUI('SampleSelect')),
server = function(input, output, session){
sampleSelectPanelServer('SampleSelect', expression.matrix.preproc, metadata)
}
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.