#' filterfeat UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal bridgeeters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
#' @import shinyjs
mod_filterfeat_ui <- function(id){
ns <- NS(id)
tagList(
# wellPanel(width = 12, h3('filterfeat check'), br(), verbatimTextOutput(ns('check'))),
fluidRow(
column(
width = 12,
h1('Filter Features'),
tags$div(
"It may be desirable to perform analysis on a subset of features (e.g. sequences) if certain taxa are considered contamination, or are no longer relevant to the current research question.",
br(),br(),
tags$em(
tags$b("NB:"), "Filtering sequences based on sequence quality and minimum count threshold has already been performed during quality control processing of the dataset. Filtering features at this stage should only be done if you have additional reasoning for omitting certain sequences or features"),
br())
) # end column 1 description text
), # end fluidRow
fluidRow(
# filter menu controls------------------------------------------------
wellPanel(id=ns('filt_param'),
fluidRow(
column(
width=3,
radioButtons(ns('asv_select_prompt'),
"Features to exclude from analysis:",
choices = c('Use all features' = 'all',
'Filter features' = 'some'),
selected = 'all'),
hidden(div(
id = ns('asv_filter_options_div'),
radioButtons(
ns('asv_filter_options'), 'Filter features by:',
choices = c('read count' = 'asv_by_count',
'selection' = 'asv_by_select'),
selected = "asv_by_count")
)) # end hidden div filter options
), # end left column of wellPanel
hidden(div(
id = ns('asv_count_div'),
column(
width = 9,
tags$b('Filter features based on read count threshold'),
fluidRow(
column(
width = 6, br(),
radioButtons(
ns('cutoff_method'), 'Set filter cutoff by:',
c('Read count' = 'abs_count',
'Read count as percent of sample' = 'percent_sample',
'Read count as percent of dataset' = 'percent_total'),
selected = 'abs_count')
),
column(
width = 6, br(),
tags$div('min: 0', br(),
'max:',
textOutput(ns('cutoff_max'), inline = TRUE)),
br(),
uiOutput(ns('asv_cutoff_ui')),
uiOutput(ns('prevalence_ui'))
)
) # need fluid row to get columns in wellPanel
) # end right column of wellPanel
)), # end asv_count_div hidden div
column(
width = 12,
div(
style="display:inline-block;",
withBusyIndicatorUI(
actionButton(ns('submit_asv'), "Filter features"))
),
div(
style="display:inline-block;",
withBusyIndicatorUI(
actionButton(ns('clear_asv'),
tags$div(title = "Reset feature filtering",
icon("undo-alt"))
)
)
)
) # end column for submit/clear button
) # end fluidRow in wellPanel
) # end wellPanel
), # end fluidRow
hidden(div(
id = ns('asv_hist_div'),
fluidRow(
column(
width = 6,
p("There are three methods by which sequences can be filtered. For all three methods, the cut-off threshold is taken into consideration with the prevalence of sequences across the samples*."), br(),
p("1) 'Read count' sets the filter threshold at a specific read count, such that a given sequence must be observed greater than or equal to the cut-off count."),
p("2) 'Percent of sample total' looks at read counts as abundances relative to the sample total. This is useful for when you want to keep features that make up at least x% in your samples."),
p("3) 'Percent of dataset total' looks at read counts as abundances relative to the dataset total. This is useful for when you want to keep features that make up at least x% in your dataset."), br(),
p("*Sequence prevalence is calculated as the number of samples in which sequence abundance is greater than or equal to the cut-off threshold.")
), # end left side column 6
column(
width = 6,
tabsetPanel(
type = "tabs",
tabPanel("Prevalence",
plotlyOutput(ns('hist_prev_plot')) %>%
shinycssloaders::withSpinner()),
tabPanel("Read count",
tags$p("default view shows first 10 bins. Double click to zoom out and see full plot area."),
plotlyOutput(ns('hist_readcount_plot')) %>%
shinycssloaders::withSpinner()),
tabPanel("% of Sample",
tags$p("default view shows first 15 bins. Double click to zoom out and see full plot area."),
plotlyOutput(ns('hist_samptot_plot')) %>%
shinycssloaders::withSpinner()),
tabPanel("% of Data set",
tags$p("default view shows first 20 bins. Double click to zoom out and see full plot area."),
plotlyOutput(ns('hist_datatot_plot')) %>%
shinycssloaders::withSpinner())
) # end tabsetPanel
) # end rightside column 6
) # end fluidRow
)), # end hidden div asv_hist_div
hidden(div(
id = ns('asv_select_div'),
fluidRow(
h3('Filter features based on selection'),
p("Select the features that you wish to", strong("exclude"),"from subsequent analyses. You can filter the rows using the search fields at the top of each column, or using the search bar at the top right corner of the table. Multiple rows can be selected at once by clicking the first row, then holding the shift button while clicking the last row. Click 'Filter features' to apply changes."), br(),
DT::dataTableOutput(ns('asv_table_select')) %>%
shinycssloaders::withSpinner()
) # end fluidRow
)), # end asv_select_div
hidden(div(
id = ns('prev_filter_div'),
fluidRow(
column(
width=7,
tabsetPanel(
type = "tabs",
tabPanel("Aggregated view",
plotlyOutput(ns('prev_agg_plot')) %>%
shinycssloaders::withSpinner()),
tabPanel("Expanded view",
plotlyOutput(ns('prev_read_plot')) %>%
shinycssloaders::withSpinner())
)
),
column(
width = 5,
uiOutput(ns('secondary_filter_ui')) %>%
shinycssloaders::withSpinner()
)
) # end fluidRow
)), # end prev_filter_div hidden div
fluidRow(
uiOutput(ns('secondary_check_ui'))
),
hidden(div(
id = ns('preview_asv_div'),
fluidRow(
h3('Features included in analysis'),
DT::dataTableOutput(ns('preview_asv')) %>%
shinycssloaders::withSpinner()
) # end fluidRow
)) # end hidden div preview asv div
) # end taglist
}
#' filterfeat Server Function
#'
#' @param input,output,session Internal bridgeeters for {shiny}.
#' @param bridge reactiveValues. contains objects to be passed from outer module
#'
#' @noRd
mod_filterfeat_server <- function(input, output, session, bridge){
ns <- session$ns
# unpack data from parent module----------------------------------------------
met <- reactive(bridge$work_db$met)
asv <- reactive(bridge$work_db$asv)
tax <- reactive(bridge$work_db$tax)
wip <- reactive(asv() %>% gather('sampleID','read_count', -featureID))
# control UI based on filter method--------------------------------------
observeEvent(input$asv_select_prompt, {
toggle("asv_filter_options_div",
condition = input$asv_select_prompt == 'some')
})
observe({
# by read count
toggle('asv_hist_div',
condition = input$asv_select_prompt == 'some' &
grepl('asv_by_count', input$asv_filter_options))
toggle(id = 'asv_count_div',
condition = input$asv_select_prompt == 'some' &
grepl('asv_by_count',input$asv_filter_options))
# by selected ASV
toggle(id = 'asv_select_div',
condition = input$asv_select_prompt == 'some' &
grepl('asv_by_select', input$asv_filter_options))
})
observeEvent(input$submit_asv, {
show("preview_asv_div")
toggle(id = 'prev_filter_div',
condition = input$asv_select_prompt == 'some' &
grepl('asv_by_count', input$asv_filter_options))
})
# ui outputs for asv filter---------------------------------------------------
# ui for prevalence threshold
output$prevalence_ui <- renderUI({
nsample <- length(unique(wip()$sampleID))
default <- round(nsample * 0.05)
if(default < 1) default <- 1
numericInput(ns('prevalence'),
"Feature prevalence (# of samples):",
min = 1, max = nsample, value = default)
})
# ui for cut-off threshold
ui_entry <- reactive({
switch(
input$cutoff_method,
abs_count = list(label = 'Read count cut-off:',
max_cutoff = max(wip()$read_count),
step = 2,
default_value = 1,
msg = 'Keeping N_KEEP/TOT_FEAT (REL_FEAT%) features with read counts >= REPLACE2 in >= REPLACE3/TOT_SAMP (REL_SAMP%) samples'),
percent_sample = list(label = 'Read count cut-off (% of sample total):',
max_cutoff = 100,
step = 0.002,
default_value = 0.001,
msg = 'Keeping N_KEEP/TOT_FEAT (REL_FEAT%) features with read counts >= REPLACE2% of sample total read count in >= REPLACE3/TOT_SAMP (REL_SAMP%) samples'),
percent_total = list(label = 'Read count cut-off (% of dataset total):',
max_cutoff = 100,
step = 0.0002,
default_value = 0.0001,
msg = 'Keeping N_KEEP/TOT_FEAT (REL_FEAT%) features with read counts >= REPLACE2% of dataset total read count in >= REPLACE3/TOT_SAMP (REL_SAMP%) samples')
)
})
output$asv_cutoff_ui <- renderUI({
numericInput(ns('asv_cutoff'), label = ui_entry()$label,
value = ui_entry()$default_value, step = ui_entry()$step,
min = 0, max = ui_entry()$max_cutoff)
})
output$cutoff_max <- renderText({
ui_entry()$max_cutoff
})
asv_table_select <- reactive({
tax() %>%
left_join(asv(), 'featureID') %>%
select(-Taxon, -sequence) %>%
arrange(Kingdom, Phylum, Class, Order, Family, Genus, Species)
})
# by selecting ASVs
output$asv_table_select <- DT::renderDataTable(server = FALSE, {
DT::datatable(asv_table_select(), filter = 'top',
rownames = FALSE,
options = list(
pageLength = 15,
scrollX = TRUE,
dom = 'lfrtip',
filter = 'top'))
})
# # check
# output$check <- renderPrint({
# })
# prepare asv dataframe-------------------------------------------------------
asv_mat <- reactive({
as.data.frame(asv()) %>%
column_to_rownames('featureID')
})
# get sample prevalence for features
prev_data <- reactive({
# convert asv counts to binary
binary <- (asv_mat() != 0) * 1 # true means present
rowSums(binary)
})
# relative abundance based on sample total
relab_samptot <- reactive({
# convert to relative abundance
apply(asv_mat(), 2, function(x) x/sum(x))
})
relab_datatot <- reactive({
data_total <- sum(asv_mat())
asv_mat() / data_total
})
# generate histograms to help picking read count and prevalence cutoffs-------
hist_prev_pdata <- reactive({
enframe(prev_data(), 'featureID','prevalence')
})
hist_samptot_pdata <- reactive({
as.data.frame(relab_samptot()) %>%
rownames_to_column('featureID') %>%
gather('sampleID', 'relab_samptot', -featureID)
})
hist_datatot_pdata <- reactive({
as.data.frame(relab_datatot()) %>%
rownames_to_column('featureID') %>%
gather('sampleID', 'relab_datatot', -featureID)
})
vline <- function(x = 0, color = "darkred") {
list(
type = "line",
y0 = 0,
y1 = 1,
yref = "paper",
x0 = x,
x1 = x,
line = list(color = color, linetype='dashed')
)
}
# render histogram outputs
output$hist_prev_plot <- renderPlotly({
plot_ly(nbinsx=nrow(met())) %>%
add_histogram(x=hist_prev_pdata()$prevalence) %>%
layout(shapes=list(vline(input$prevalence)),
bargap=0.1,
xaxis = list(title = "Prevalence (# of samples)"),
yaxis = list(title = 'Number of features'))
# ggplotly(hist_prev_plot())
})
output$hist_readcount_plot <- renderPlotly({
# set default zoom to first 10 bins
out <- plot_ly(nbinsx=ceiling(max(wip()$read_count)/2)) %>%
add_histogram(x=wip()$read_count) %>%
layout(bargap=0.1,
xaxis=list(range=c(0,20),
title = "Read Count (bin size = 1)"),
yaxis = list(title = 'Number of features'))
if(input$cutoff_method == 'abs_count') {
out <- out %>%
layout(shapes=list(vline(input$asv_cutoff)),
xaxis=list(title = "Read Count (bin size = 1)"),
yaxis = list(title = 'Number of features'))
}
out
# ggplotly(hist_readcount_plot())
})
output$hist_samptot_plot <- renderPlotly({
# set default zoom to first 10 bins
out <- plot_ly(nbinsx=1000) %>%
add_histogram(x=hist_samptot_pdata()$relab_samptot) %>%
layout(bargap=0.1,
xaxis=list(range=c(0,0.015),
title = "Relative abundance (bin size = 1000)"),
yaxis = list(title = 'Number of features'))
if(input$cutoff_method == 'percent_sample') {
out <- out %>%
layout(shapes=list(vline(input$asv_cutoff)),
xaxis = list(title = "Relative abundance (bin size = 0.001%)"),
yaxis = list(title = 'Number of features'))
}
out
# ggplotly(hist_samptot_plot())
})
output$hist_datatot_plot <- renderPlotly({
# set default zoom to first 10 bins
out <- plot_ly(nbinsx=1000) %>%
add_histogram(x=hist_datatot_pdata()$relab_datatot) %>%
layout(bargap=0.1,
xaxis=list(range=c(0,0.001),
title = "Relative abundance (bin size = 0.00005%)"),
yaxis = list(title = 'Number of features'))
if(input$cutoff_method == 'percent_total') {
out <- out %>%
layout(shapes=list(vline(input$asv_cutoff)),
xaxis = list(title = "Relative abundance (bin size = 1000)"),
yaxis = list(title = 'Number of features'))
}
out
#ggplotly(hist_datatot_plot())
})
working_asv <- reactive({
if(input$asv_select_prompt == 'some') {
dataset_total <- sum(wip()$read_count)
out <- wip() %>%
# calculate relative abundance as dataset total
mutate(ds_rel_abund = read_count / dataset_total * 100) %>%
# calculate relative abundance as sample total
group_by(sampleID) %>%
mutate(sample_total = sum(read_count)) %>%
group_by(sampleID, featureID) %>%
mutate(samp_rel_abund = read_count / sample_total * 100) %>%
group_by(featureID) %>%
mutate(prev_observed = sum(read_count >= input$asv_cutoff)) %>%
ungroup()
out
}
else {
wip()
}
})
# define ASVs to keep---------------------------------------------------------
calculate_keep <- eventReactive(input$submit_asv, {
if(input$asv_select_prompt == 'some') {
if(input$asv_filter_options == 'asv_by_count') {
out <- switch(
input$cutoff_method,
# count cut-off
abs_count = asv_mat()[rowSums(asv_mat() >= input$asv_cutoff) >= input$prevalence,],
# cut-off based on percent of sample total
percent_sample = relab_samptot()[rowSums(relab_samptot() >= input$asv_cutoff) >= input$prevalence,],
# cut-off based on percent of dataset total
percent_total = relab_datatot()[rowSums(relab_datatot() >= input$asv_cutoff) >= input$prevalence,]
)
}
# filter ASV based on selection-------------------------------------------
if(input$asv_filter_options == 'asv_by_select') {
req(input$asv_table_select_rows_selected)
out <- asv_table_select() %>%
slice(-c(input$asv_table_select_rows_selected)) %>%
column_to_rownames('featureID')
}
} else {
out <- asv_mat()
}
rownames(out)
})
filter_result <- reactiveValues(to_keep = NULL, to_remove = NULL)
observe({
req(calculate_keep())
filter_result$to_keep <- calculate_keep()
featID <- rownames(asv_mat())
filter_result$asv_remove <- featID[!featID %in% calculate_keep()]
})
observeEvent(input$clear_asv, {
reset('filt_param')
hide('prev_filter_div')
filter_result$to_keep <- NULL
filter_result$asv_remove <- NULL
selectRows(dataTableProxy('asv_table_select'), NULL)
})
# show ASVs removed-----------------------------------------------------------
asv_cutoff_msg <- eventReactive(input$submit_asv, {
req(filter_result$to_keep)
validate(need(input$asv_select_prompt == 'some',
"No filtering performed"),
need(!is.null(filter_result$to_keep),
"No filtering performed"))
req(input$cutoff_method, input$prevalence, input$asv_cutoff)
tot_feat <- wip() %>% filter(read_count > 0)
tot_feat <- length(unique(tot_feat$featureID))
rel_feat <- length(filter_result$to_keep) / tot_feat * 100
rel_feat <- round(rel_feat, 1)
tot_samp <- length(unique(met()$sampleID))
rel_samp <- as.numeric(input$prevalence) / tot_samp * 100
rel_samp <- round(rel_samp, 1)
out <- gsub("N_KEEP", as.character(length(filter_result$to_keep)),
ui_entry()$msg)
out <- gsub("TOT_FEAT", as.character(tot_feat), out)
out <- gsub("REL_FEAT", as.character(rel_feat), out)
out <- gsub("REL_FEAT", as.character(rel_feat), out)
out <- gsub('REPLACE2', as.character(input$asv_cutoff), out)
out <- gsub("REPLACE3", as.character(input$prevalence), out)
out <- gsub("TOT_SAMP", as.character(tot_samp), out)
out <- gsub("REL_SAMP", as.character(rel_samp), out)
})
# giving preview on read and prevalence
prev_agg_plot <- eventReactive(input$submit_asv, {
req(filter_result$to_keep)
validate(need(input$asv_select_prompt == 'some',
"Using all features"),
need(!is.null(filter_result$to_keep), "No filtering performed"))
scaleFUN <- function(x) sprintf("%.0f", x)
if(input$cutoff_method == 'abs_count') {
pdata <- wip() %>%
group_by(featureID) %>%
summarise(y = mean(read_count))
ylab <- 'Mean Read count'
}
if(input$cutoff_method == 'percent_total') {
pdata <- hist_datatot_pdata() %>%
group_by(featureID) %>%
summarise(y = mean(relab_datatot))
ylab <- 'Mean Relative abundance\n(% of total reads)'
}
if(input$cutoff_method == 'percent_sample') {
pdata <- hist_samptot_pdata() %>%
group_by(featureID) %>%
summarise(y = mean(relab_samptot))
ylab <- 'Mean Relative abundance\n(% of sample)'
}
pdata <- pdata %>%
left_join(hist_prev_pdata(), 'featureID') %>%
mutate(colour = ifelse(featureID %in% filter_result$to_keep,
'to keep', 'to remove'))
p <- ggplot(pdata, aes(x = prevalence, y = y, colour = colour)) +
geom_point(aes(text=sprintf("featureID: %s", featureID)),
alpha = 0.5, size = 2) +
xlab('ASV prevalence (# of samples)') +
ylab(ylab) +
scale_x_continuous(labels = scaleFUN, limits = c(0, nrow(met()))) +
scale_y_continuous(trans = 'log10') +
theme_bw(12) +
theme(legend.position = 'bottom')
p
})
output$prev_agg_plot <- renderPlotly({
ggplotly(prev_agg_plot()) %>%
layout(legend = list(orientation = "h", x = -0.5, y = 1.2))
})
prev_read_plot <- eventReactive(input$submit_asv, {
req(filter_result$to_keep)
validate(need(input$asv_select_prompt == 'some',
"Using all features"),
need(!is.null(filter_result$to_keep), "No filtering performed"))
scaleFUN <- function(x) sprintf("%.0f", x)
if(input$cutoff_method == 'abs_count') {
pdata <- wip() %>%
rename(y = 'read_count')
ylab <- 'Read count'
}
if(input$cutoff_method == 'percent_total') {
pdata <- hist_datatot_pdata() %>%
rename(y = 'relab_datatot')
ylab <- 'Relative abundance\n(% of total reads)'
}
if(input$cutoff_method == 'percent_sample') {
pdata <- hist_samptot_pdata() %>%
rename(y = 'relab_samptot')
ylab <- 'Mean Relative abundance\n(% of sample)'
}
pdata <- pdata %>%
left_join(hist_prev_pdata(), 'featureID') %>%
mutate(colour = ifelse(featureID %in% filter_result$to_keep,
'to keep', 'to remove'))
p <- ggplot(pdata, aes(x = prevalence, y = y, colour = colour)) +
geom_point(aes(text=sprintf("featureID: %s<br>sampleID: %s",
featureID, sampleID)),
alpha = 0.5, size = 2) +
xlab('ASV prevalence (# of samples)') +
ylab(ylab) +
scale_x_continuous(labels = scaleFUN, limits = c(0, nrow(met()))) +
scale_y_continuous(trans = 'log10') +
theme_bw(12) +
theme(legend.position = 'bottom')
})
output$prev_read_plot <- renderPlotly({
ggplotly(prev_read_plot()) %>%
layout(legend = list(orientation = "h", x = -0.5, y = -1))
})
# filter ASVs based on set cutoff/selection-----------------------------------
wip_filtered <- reactiveVal()
withBusyIndicatorServer('submit_asv', 'filterfeat_ui_1', {
observeEvent(input$submit_asv, {
req(filter_result$to_keep)
entry <- wip() %>%
filter(featureID %in% filter_result$to_keep)
wip_filtered(entry)
})
})
# secondary check for samples with no reads-----------------------------------
sample_total <- reactive({
wip_filtered() %>%
group_by(sampleID) %>%
summarise(sample_total = sum(read_count))
})
asv_total <- reactive({
wip_filtered() %>%
group_by(featureID) %>%
summarise(asv_total = sum(read_count))
})
secondary_check_sample <- reactive({
any(sample_total()$sample_total == 0)
})
secondary_check_asv <- reactive({
any(asv_total()$asv_total == 0)
})
# identify empty samples
empty_sample <- reactive({
out <- sample_total() %>%
filter(sample_total == 0)
out$sampleID
})
n_empty_sample <- reactive({length(empty_sample())})
# identify empty asvs
empty_asv <- reactive({
out <- asv_total() %>%
filter(asv_total == 0)
out$featureID
})
output$secondary_filter_ui <- renderUI({
req(filter_result$asv_remove)
validate(need(!is.null(filter_result$to_keep), "No filtering performed"))
wellPanel(
tags$b(asv_cutoff_msg()),
br(),
tags$b(sprintf("Removing %s Features", length(filter_result$asv_remove))),
br(),br(),
tags$b(sprintf("%s samples contained 0 reads after ASV filtering. The following samples have been removed:", length(empty_sample()))),
br(),
HTML(paste(empty_sample(), collapse = '<br/>')),
br(),
tags$b(sprintf("%s asvs contained 0 reads in all samples after ASV filtering. The following asvs have been removed:", length(empty_asv()))),
br(),
HTML(paste(empty_asv(), collapse = '<br/>'))
)
})
# update asv_filtered
asv_filtered <- reactive({
withBusyIndicatorServer('submit_asv', "setup_ui_1", {
if(secondary_check_sample()) {
wip_filtered() %>%
filter(!sampleID %in% empty_sample())
}
else if(secondary_check_asv()) {
wip_filtered() %>%
filter(!featureID %in% empty_asv())
}
else {
wip_filtered()
}
})
})
# update met
met_filtered <- eventReactive(input$submit_asv, {
if(secondary_check_sample()) {
met() %>%
filter(!sampleID %in% empty_sample())
}
else {
met()
}
})
output$preview_asv <- DT::renderDataTable(server = FALSE, {
validate(need(!is.null(filter_result$to_keep), "No filtering performed"))
out <- tax() %>%
right_join(asv_filtered() %>%
spread(sampleID, read_count), 'featureID') %>%
select(-Taxon, -sequence) %>%
arrange(Kingdom, Phylum, Class, Order, Family, Genus, Species)
DT::datatable(out, extensions = 'Buttons',
rownames = FALSE,
options = list(
pageLength = 30,
scrollX = TRUE,
dom = 'Blfrtip',
buttons = c('copy','csv'),
fixedColumns=list(leftColumns = 2)
))
})
# add filtered tables to bridge reactive-------------------------------------
cross_mod <- reactiveValues()
observe({
cross_mod$filtered <- list(met = met_filtered(),
asv = asv_filtered() %>%
spread(sampleID, read_count),
tax = tax() %>%
filter(featureID %in% asv_filtered()$featureID))
})
observe({
cross_mod$params <- list(
asv_cutoff_msg = asv_cutoff_msg(),
to_keep = filter_result$to_keep,
asv_remove = filter_result$asv_remove,
prev_agg_plot = prev_agg_plot(),
prev_read_plot = prev_read_plot(),
empty_sample = empty_sample(),
empty_asv = empty_asv()
)
})
return(cross_mod)
}
## To be copied in the UI
# mod_filterfeat_ui("filterfeat_ui_1")
## To be copied in the server
# callModule(mod_filterfeat_server, "filterfeat_ui_1")
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.