#' Shiny setup for DOQTL selection
#'
#' Shiny module for phenotype selection, with interfaces \code{shinySetupInput} and \code{shinySetupUI}.
#'
#' @param id identifier for shiny reactive
#' @param pheno_typer,peaks_tbl,pmap_obj,analyses_tbl,cov_df,projects_info reactive arguments
#'
#' @author Brian S Yandell, \email{brian.yandell@@wisc.edu}
#' @keywords utilities
#'
#' @return No return value; called for side effects.
#'
#' @export
#' @importFrom gdata humanReadable
#' @importFrom dplyr arrange desc distinct filter mutate one_of select
#' @importFrom tidyr unite
#' @importFrom shiny moduleServer NS reactive req
#' radioButtons selectInput
#' dataTableOutput textOutput uiOutput
#' renderDataTable renderText renderUI
#' observeEvent
#' strong tagList
shinySetup <- function(id, pheno_typer, peaks_tbl, pmap_obj, analyses_tbl,
cov_df, projects_info) {
shiny::moduleServer(id, function(input, output, session) {
ns <- session$ns
project_info <- shinyProject("project", projects_info)
# Select phenotype dataset
pheno_group <- shiny::reactive({
shiny::req(project_info())
sort(unique(shiny::req(analyses_tbl())$pheno_group))
}, label = "pheno_group")
pheno_type <- shiny::reactive({
shiny::req(project_info())
phe_gp <- shiny::req(input$pheno_group)
analyses_group <-
dplyr::filter(
shiny::req(analyses_tbl()),
pheno_group %in% phe_gp)
sort(unique(analyses_group$pheno_type))
})
output$pheno_group <- shiny::renderUI({
shiny::req(choices <- pheno_group())
if(is.null(selected <- input$pheno_group)) {
selected <- choices[1]
}
shiny::selectInput(ns("pheno_group"), "",
choices = as.list(choices),
selected = selected,
multiple = TRUE)
})
output$dataset <- shiny::renderUI({
shiny::req(project_info())
choices <- c("all", shiny::req(pheno_type()))
if(is.null(selected <- input$dataset))
selected <- NULL
shiny::selectInput(ns("dataset"), "Phenotype Set",
choices = as.list(choices),
selected = selected,
multiple = TRUE)
})
## Set up analyses data frame.
analyses_set <- shiny::reactive({
shiny::req(project_info(), analyses_tbl())
set_analyses(input$dataset, input$pheno_group, analyses_tbl())
})
# Restrict peaks to region.
peaks_df <- shiny::reactive({
shiny::req(project_info(), analyses_set(), peaks_tbl())
chr_id <- shiny::req(win_par$chr_id)
peak_Mbp <- shiny::req(win_par$peak_Mbp)
window_Mbp <- shiny::req(win_par$window_Mbp)
peaks_in_pos(analyses_set(), peaks_tbl(),
shiny::isTruthy(input$filter),
chr_id, peak_Mbp, window_Mbp)
})
output$filter <- shiny::renderUI({
shiny::checkboxInput(ns("filter"),
paste0("Peak on chr ", win_par$chr_id, " in ",
paste(win_par$peak_Mbp + c(-1,1) * win_par$window_Mbp,
collapse = "-"), "?"),
TRUE)
})
# Pick phenotype names
output$pheno_names <- shiny::renderUI({
shiny::req(project_info(), win_par$chr_id, win_par$peak_Mbp, win_par$window_Mbp)
out <- select_phenames(input$pheno_names, peaks_df(), win_par$local,
win_par$chr_id, win_par$peak_Mbp, win_par$window_Mbp)
shiny::selectInput(ns("pheno_names"), out$label,
choices = out$choices,
selected = out$selected,
multiple = TRUE)
})
## Locate Peak.
win_par <- shinyPeaks("shinypeaks", input, pheno_type, peaks_tbl, pmap_obj,
project_info)
chr_pos <- shiny::reactive({
shiny::req(project_info())
make_chr_pos(win_par$chr_id,
win_par$peak_Mbp, win_par$window_Mbp)
})
output$chr_pos <- shiny::renderText({
paste0("Region: ", chr_pos(), "Mbp")
})
output$num_pheno <- shiny::renderText({
shiny::req(project_info())
num_pheno(character(), analyses_tbl())
})
output$version <- shiny::renderText({
versions()
})
shiny::observeEvent(project_info(), {
output$num_pheno <- shiny::renderText({
num_pheno(input$pheno_names, analyses_tbl())
})
shiny::req(win_par$chr_id, win_par$peak_Mbp, win_par$window_Mbp)
out <- select_phenames("none", peaks_df(), win_par$local,
win_par$chr_id, win_par$peak_Mbp, win_par$window_Mbp)
updateSelectInput(session, "pheno_names", out$label,
choices = out$choices, selected = "none")
})
shiny::observeEvent(input$pheno_names, {
output$num_pheno <- shiny::renderText({
num_pheno(input$pheno_names, analyses_tbl())
})
})
## Use window as input to shinyPhenos.
shinyPhenos("phenos", input, win_par, peaks_df, analyses_tbl, cov_df, project_info)
## Setup input logic.
output$project_name <- renderUI({
shiny::strong(paste("Project:",
shiny::req(project_info()$project),
"\n"))
})
output$project_name2 <- renderUI({
shiny::strong(paste("Project:",
shiny::req(project_info()$project),
"\n"))
})
output$title <- shiny::renderUI({
switch(shiny::req(input$radio),
Region = {
shiny::tagList(
shinyProjectUI(ns("project")),
shiny::strong(shiny::req(input$radio)))
},
Phenotypes = {
shiny::tagList(
shiny::uiOutput(ns("project_name2")),
shiny::strong(shiny::req(input$radio)))
})
})
output$sidebar_setup <- shiny::renderUI({
switch(shiny::req(input$radio),
Phenotypes = shiny::tagList(
shiny::uiOutput(ns("filter")),
shinyPhenosUI(ns("phenos"))),
Region = shinyPeaksInput(ns("shinypeaks")))
})
output$sidebar_hot <- shiny::renderUI({
switch(shiny::req(input$radio),
Region = shinyPeaksUI(ns("shinypeaks")))
})
output$main_setup <- shiny::renderUI({
switch(shiny::req(input$radio),
Phenotypes = shinyPhenosOutput(ns("phenos")),
Region = shinyPeaksOutput(ns("shinypeaks")))
})
output$radio <- shiny::renderUI({
shiny::radioButtons(ns("radio"), NULL,
c("Region", "Phenotypes"),
input$radio,
inline=TRUE)
})
## Return.
shiny::reactive({
list(project_info = project_info(),
pheno_names = input$pheno_names,
win_par = win_par)
})
})
}
shinySetupInput <- function(id) {
ns <- shiny::NS(id)
shiny::tagList(
shiny::uiOutput(ns("project_name")),
shiny::textOutput(ns("num_pheno")),
shiny::uiOutput(ns("chr_pos"))
)
}
shinySetupUI <- function(id) {
ns <- shiny::NS(id)
shiny::tagList(
sidebarPanel(
shiny::uiOutput(ns("title")),
shiny::uiOutput(ns("radio")),
shiny::uiOutput(ns("sidebar_setup")),
shiny::uiOutput(ns("pheno_names")),
shiny::uiOutput(ns("pheno_group")),
shiny::uiOutput(ns("dataset")),
shiny::uiOutput(ns("sidebar_hot")),
shiny::uiOutput(ns("version"))
),
mainPanel(shiny::uiOutput(ns("main_setup")))
)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.