inst/shiny/shiny_server/server_coverage.R
In matdoering/openPrimeRui: Shiny Application for Multiplex PCR Primer Design and Analysis
#########
# Shiny server functionalities relating to primer coverage
##########
primerViewObserverGroup <- observeEvent(current.seqs(), {
# update coverage group selector when templates are available
if (length(current.seqs()) != 0) {
groups <- unique(current.seqs()$Group)
updateSelectInput(session, "selected_group_coverage", choices = c("all", groups))
}
})
primerViewObserver <- observe({
# update input$selected_primer for coverage tab
cur.table <- NULL
if (input$set_meta_selector == "all") {
if (length(rv_primers$evaluated_primers) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
return()
}
cur.table <- rv_primers$evaluated_primers
} else if (input$set_meta_selector == "filtered") {
cur.table <- current.filtered.primers()
if (length(cur.table) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
return()
}
} else if (input$set_meta_selector == "optimized") {
cur.table <- optimal.primers()
if (length(cur.table) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
validate(need(FALSE, "Please compute the optimized data set first."))
return()
}
} else {
updateSelectInput(session, "selected_primer", choices = "")
validate(need(FALSE, "No valid primer set selected."))
return()
}
template.df <- current.seqs()
if (length(cur.table) != 0 && nrow(cur.table) != 0 && "primer_coverage" %in% colnames(cur.table)) {
cov.seqs <- sapply(strsplit(cur.table$Covered_Seqs, split = ","), function(x) match(as.numeric(x), template.df$Identifier))
groups <- sapply(seq_along(cov.seqs), function(x) unique(template.df$Group[cov.seqs[[x]]]))
if (length(input$selected_group_coverage) == 0 || any(c("", "all") %in% input$selected_group_coverage)) {
sel <- seq_len(nrow(cur.table))
} else {
sel <- which(sapply(groups, function(x) input$selected_group_coverage %in% x))
}
cur.table <- cur.table[sel,]
updateSelectInput(session, "selected_primer", choices = cur.table$ID)
}
})
coverage.statistics <- reactive({
# overview of coverage information
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# stats for expected coverage:
cvg.stats.exp <- openPrimeR:::get_cvg_stats(data, template.data)
if (length(cvg.stats.exp) != 0 && nrow(cvg.stats.exp) != 0) {
cvg.stats.exp <- cbind(cvg.stats.exp, Coverage_Definition = "Expected_Coverage")
}
# stats for text identity coverage:
cvg.stats.txt <- openPrimeR:::get_cvg_stats(data, template.data,
allowed.mismatches = 0, cvg.definition = "basic")
if (length(cvg.stats.txt) != 0 && nrow(cvg.stats.txt) != 0) {
cvg.stats.txt <- cbind(cvg.stats.txt, Coverage_Definition = "Identity_Coverage")
}
cvg.stats <- rbind(cvg.stats.exp, cvg.stats.txt)
return(cvg.stats)
})
coverage.statistics.mismatches <- reactive({
# overview of coverage information for different mismatch settings
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# stats for expected coverage:
mm.range <- seq(0, input$allowed_mismatches)
mm.stats <- vector("list", length(mm.range))
for (i in seq_along(mm.range)) {
cvg.stats <- openPrimeR:::get_cvg_stats(data, template.data,
allowed.mismatches = mm.range[i])
cvg.stats <- cbind(cvg.stats, "MaxMismatches" = mm.range[i])
mm.stats[[i]] <- cvg.stats
}
cvg.string <- sapply(mm.stats, function(x) paste0(round(x[x$Group == "Total", "Coverage_Ratio"] * 100, 1), "%"))
mm.stats <- do.call(rbind, mm.stats)
# update the selector for max mismatches:
labels <- paste0(mm.range, " mismatches (", cvg.string, " coverage)")
opts <- mm.range
names(opts) <- labels
updateSelectInput(session, "allowed_mm_cvg_stats", choices = opts)
return(mm.stats)
})
#basic_string_cvg <- reactive({
## basic coverage according to string complementarity with 0 mismatches
#data <- switch(input$set_meta_selector,
#"all" = rv_primers$evaluated_primers,
#"filtered" = current.filtered.primers(),
#"optimized" = optimal.primers())
#template.data <- switch(input$set_meta_selector,
#"all" = rv_templates$cvg_all,
#"filtered" = rv_templates$cvg_filtered,
#"optimized" = rv_templates$cvg_optimized)
#validate(need(data, "No primer coverage available."))
#validate(need(template.data, "No templates available."))
#cvg <- openPrimeR::get_cvg_ratio(data, template.data, allowed.mismatches = 0, cvg.definition = "basic")
#return(cvg)
#})
output$cvg_stats <- DT::renderDataTable({
# table with coverage stats
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# select the coverage definition for template coverage table:
selected.cvg.def <- input$selected_cvg_def_stats
stats <- coverage.statistics()
if (length(stats) != 0) {
stats <- stats[stats$Coverage_Definition == selected.cvg.def,]
stats <- stats[, c("Group", "Coverage", "Coverage_fw", "Coverage_rev")]
}
return(DT::datatable(stats,
rownames = FALSE, options = list(dom = "pt"), # dom = pt -> show pages and table
caption = paste("The number of covered sequences per group of templates.",
"If the coverage definition is set to 'Expected Coverage', ",
"coverage is computed using the extended coverage criteria",
"and (possibly) allowing for multiple mismatches.",
"If, however, the coverage definition is set to",
"'Identity Coverage', only coverage events where the primers",
"are perfectly complementary to the templates are considered.")))
})
output$cvg_stats_mismatches <- DT::renderDataTable({
# table with template coverage stats
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# select the coverage definition for template coverage table:
allowed.mm <- input$allowed_mm_cvg_stats
stats <- coverage.statistics.mismatches()
if (allowed.mm == "") {
# nothing to select
return(NULL)
} else {
# convert from string to numeric
allowed.mm <- as.numeric(allowed.mm)
}
if (length(stats) != 0) {
stats <- stats[stats$MaxMismatches == allowed.mm,]
stats <- stats[, c("Group", "Coverage", "Coverage_fw", "Coverage_rev")]
}
return(DT::datatable(stats,
rownames = FALSE, options = list(dom = "pt"), # dom = pt -> show pages and table
caption = paste("The number of sequences that are expected to be",
"covered by primers when allowing for a certain number",
"of mismatches.")))
})
output$CoverageTotal <- renderUI({
# output text giving an overview of coverage/Tm Delta
if (length(coverage.statistics()) == 0) {
return(NULL)
}
stats <- coverage.statistics()
#selected.group <- input$selected_group_coverage
selected.group <- NULL # no dependence on selected.group -> don't want to show multiple texts, just show coverage text for all templates.
if (length(stats) != 0) {
cvg.stats.exp <- stats[stats$Coverage_Definition == "Expected_Coverage",]
cvg.stats.ident <- stats[stats$Coverage_Definition == "Identity_Coverage",]
cvg.text.ident <- paste("<li>",
openPrimeR:::create.cvg.text(cvg.stats.ident, selected.group, "Identity Coverage"),
"</li>", sep = "")
cvg.text.exp <- paste("<li>",
openPrimeR:::create.cvg.text(cvg.stats.exp, selected.group, "Expected Coverage"),
"</li>", sep = "")
} else {
cvg.text.ident <- ""
cvg.text.exp <- ""
}
text <- HTML(paste("<h3><ul>",
cvg.text.exp,
cvg.text.ident,
"</ul></h3>", sep = ""))
return(text)
})
output$ConstraintsTotal <- renderUI({
Tm.info <- cur.Tm.info()
if (length(Tm.info) != 0) {
Tm.text <- paste("<li>", openPrimeRui:::create.Tm.text(Tm.info$Tm_range, Tm.info$Tm_diff), "</li>", sep = "")
} else {
Tm.text <- ""
}
annealing.text <- ""
annealing.temps <- annealing.temperature()
if (length(annealing.temps) != 0) {
opt <- ifelse(input$automatic_annealing_temp == "active", "recommended", "user-defined")
annealing.text <- paste0("<li>The ", opt, " annealing temperature is ", min(annealing.temps), "℃.</li>")
}
text <- HTML(paste("<h3><ul>",
Tm.text,
annealing.text,
"</ul></h3>", sep = ""))
#print(text)
return(text)
})
primer_plot_height <- reactive({
# height of the primer view plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- current.seqs()
if (length(primer.df) == 0 || length(template.df) == 0) {
return(0)
}
id <- NULL
if (length(input$selected_primer) == 0 || input$selected_primer == "") { # no ID given -> plot all
id <- primer.df$Identifier
} else {
id <- primer.df$Identifier[match(input$selected_primer, primer.df$ID)] # match from primer identifier to ID
}
m <- match(id, primer.df$Identifier)
primer.df <- primer.df[m, ]
show.group <- input$selected_group_coverage
if (!is.null(show.group) && !"all" %in% show.group) {
lex.id <- which(template.df$Group %in% show.group)
template.df <- template.df[lex.id,]
}
if ("primer_coverage" %in% colnames(primer.df)) {
n1 <- sum(primer.df$primer_coverage) # nbr of coverage events to show
} else {
n1 <- 0
}
n2 <- nrow(template.df) # nbr of templates to show
n <- n1 + n2
height <- openPrimeR:::get.plot.height(n, px.per.n = 30)
return(height)
})
primer_plot_width <- reactive({
# width of the primer view plot
myData <- current.seqs()
if (length(myData) == 0) {
return(1200)
}
n <- max(nchar(myData$Sequence))
width <- openPrimeR:::get.plot.height(n, px.per.n = 2)
return(width)
})
output$primer_plot <- renderPlot({
# data for the primer view plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df, "The selected primer data set cannot be plotted, because no primer coverage is available in the selected set."))
validate(need(nrow(primer.df) !=0, "The selected primer data set cannot be plotted, because no primers are available."))
validate(need(current.seqs(), "No template sequences are available for plotting yet."))
show.group <- input$selected_group_coverage
template.df <- current.seqs()
id <- NULL
if (length(input$selected_primer) == 0 || input$selected_primer == "") { # no ID given -> plot all
id <- primer.df$Identifier
} else {
id <- primer.df$Identifier[match(input$selected_primer, primer.df$ID)] # match from primer identifier to ID
}
if (!is.null(show.group) && !"all" %in% show.group) {
lex.id <- which(template.df$Group %in% show.group)
template.df <- template.df[lex.id,]
}
validate(need(template.df, "No template sequences avaialable."))
# check whether selected primers have any cvg?
m <- match(id, primer.df$Identifier)
validate(need(any(primer.df[m, "primer_coverage"] != 0), "Selected primers do not cover any template sequences."))
selected.group <- "all" # was 'input$selected_group' before
relation <- input$primer_plot_rel
region.names <- NULL
# change region names if we have immuno data
if (input$template_scenario == "supplied" && input$selected_supplied_templates == "immunological") {
openPrimeR:::plot_primer(primer.df, template.df, id, relation, region.names = c("Leader", "Variable region"))
} else {
openPrimeR:::plot_primer(primer.df, template.df, id, relation)
}
}, width = primer_plot_width, height=primer_plot_height, units="px")
cvg.group.plot.dim <- reactive({
# dimension of template coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(template.df) == 0 || length(primer.df) == 0) {
#print("templates unknown for group plot dimension ...")
return(list("width" = 800, "height" = 800))
}
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
template.df <- template.df[idx,]
}
# base width on number of groups
nbr.groups <- length(unique(template.df$Group))
#nbr.primers <- nrow(primer.df)
width <- openPrimeR:::get.plot.height(nbr.groups, 40, 500)
# increase height with number of templates per group
max.nbr.templates.per.group <- max(table(template.df$Group))
height <- openPrimeR:::get.plot.height(max.nbr.templates.per.group, 1, 500)
out <- list("width" = width, "height" = height)
return(out)
})
primer.cvg.plot.dim <- reactive({
# dimension of template coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(template.df) == 0 || length(primer.df) == 0) {
#print("templates unknown for group plot dimension ...")
return(list("width" = 800, "height" = 800))
}
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
template.df <- template.df[idx,]
}
# base width on number of groups
nbr.groups <- length(unique(template.df$Group))
nbr.primers <- nrow(primer.df)
width <- openPrimeR:::get.plot.height(nbr.groups*nbr.primers, 10, 500) # 2nd value is the width of each bar
# increase height with number of templates per group
height <- 500
out <- list("width" = width, "height" = height)
return(out)
})
cvg.group.plot.width <- reactive({
# width for group coverage plot
if (length(cvg.group.plot.dim()) == 0) {
return(NULL)
}
return(cvg.group.plot.dim()$width)
})
cvg.group.plot.height <- reactive({
# height for group coverage plot
if (length(cvg.group.plot.dim()) == 0) {
return(NULL)
}
return(cvg.group.plot.dim()$height)
})
output$Coverage_Group <- renderPlot({
# group coverage plot
lex.sel <- input$selected_group_coverage
primer.data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
openPrimeR:::plot_template_cvg(primer.data, template.data, groups = lex.sel)
}, width = cvg.group.plot.width, height = cvg.group.plot.height)
output$coverage_primer_per_group_ui <- renderUI({
# ui output of group coverage; prevents overplotting for multiple plot elements on one page
plotOutput("Coverage_Group", width = paste0(cvg.group.plot.width(), "px"),
height = paste0(cvg.group.plot.height(), "px"))
})
cvg.stats.primer <- reactive({
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
cvg.stats <- openPrimeR:::get_cvg_stats_primer(data, template.data)$cvg_per_group
return(cvg.stats)
})
cvg.stats.primer.mismatches <- reactive({
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
cvg.stats <- openPrimeR:::get_cvg_stats_primer(data, template.data)$cvg_per_nbr_mismatches
return(cvg.stats)
})
output$primer_cvg_stats<- DT::renderDataTable({
# table with coverage stats for primers (covered templates by group)
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.df, "No primer coverage available."))
validate(need(template.df, "No templates available."))
return(DT::datatable(cvg.stats.primer(),
caption = paste("The number of covered template sequences for every primer.",
"Each column indicates the number of covered templates",
"per group of template sequences."),
rownames = FALSE, options = list(dom = "pt"))) # dom = pt -> show pages and table
})
output$primer_cvg_stats_mismatch <- DT::renderDataTable({
# table with coverage stats wrt mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.df, "No primer coverage available."))
validate(need(template.df, "No templates available."))
return(DT::datatable(cvg.stats.primer.mismatches(),
caption = paste("The number of covered template sequences for every primer.",
"Columns with numeric identifiers give the number of coverage events",
"that occur with the indicated number of mismatches."),
rownames = FALSE, options = list(dom = "pt"))) # dom = pt -> show pages and table
})
output$template_coverage_mismatch_ui <- renderUI({
# important: set size of plot here to prevent overlap in the UI
plotOutput("template_coverage_mismatch",
width = cvg.template.mismatch.width(),
height = cvg.template.mismatch.height())
})
cvg.template.mismatch.nfacets <- reactive({
# decide on the number of facet columns to show
px.width <- cvg.group.plot.dim()$width # unfacetted plot
nfacets <- 2
if (px.width > 1000) {
# only show 1 column if plot is too wide for typical screens
nfacets <- 1
}
return(nfacets)
})
cvg.template.mismatch.width <- reactive({
# width of template coverage plot, stratified by mismatches
# just multiply by two (two facet columns)
plot.width <- cvg.group.plot.width() * cvg.template.mismatch.nfacets()
return(plot.width)
})
cvg.template.mismatch.height <- reactive({
# height: at which nbr of mismatches do we have maxed the coverage?
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(primer.df) == 0 || length(template.df) == 0 || !"primer_coverage" %in% colnames(primer.df)) {
return(1200)
}
# select template subset
# TODO: should store selected primers/templates as react expressions -> not necessary to have duplicated code for every function that uses this
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
excluded.seqs <- setdiff(template.df$Identifier[seq_len(nrow(template.df))], template.df$Identifier[idx])
template.df <- template.df[idx,]
primer.df <- openPrimeR:::evaluate.diff.primer.cvg(primer.df, excluded.seqs, template.df)
}
# scale height of plot by max nbr of mismatches of any primer
max.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df)
max.mm <- max(as.numeric(unlist(strsplit(c(primer.df$Nbr_of_mismatches_fw, primer.df$Nbr_of_mismatches_rev), split = ","))))
for (i in seq(0, max.mm - 1)) {
cur.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df, allowed.mismatches = i)
if (cur.cvg == max.cvg) {
max.mm <- i
break
}
}
height <- openPrimeR:::get.plot.height(ceiling(max.mm + 1) / cvg.template.mismatch.nfacets(), 200, 600)
return(height)
})
output$template_coverage_mismatch <- renderPlot({
# plot of template coverage with consideration of mismatch setting
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
groups <- input$selected_group_coverage
openPrimeR:::plot_template_cvg_mismatches(primer.df, template.df,
groups = groups,
nfacets = cvg.template.mismatch.nfacets())
})
cvg.primer.group.width <- reactive({
# width of individual primer plot
if (length(primer.cvg.plot.dim()) == 0) {
return(NULL)
}
width <- primer.cvg.plot.dim()$width
return(width)
})
cvg.primer.group.height <- reactive({
# height of individual primer plot
if (length(primer.cvg.plot.dim()) == 0) {
return(NULL)
}
height <- primer.cvg.plot.dim()$height
return(height)
})
Coverage_Primer_mismatches_nfacets <- reactive({
# nbr of facets for the primer mismatch plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(primer.df) == 0) {
return(3)
}
nfacets <- 3
if (nrow(primer.df) > 10) {
nfacets <- 2
}
if (nrow(primer.df) > 30) {
nfacets <- 1
}
return(nfacets)
})
Coverage_Primer_mismatches_width <- reactive({
# width of primer mismatch coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(primer.df) == 0) {
return(1200)
}
# base width on number of primers and number of facets used
width <- openPrimeR:::get.plot.height(nrow(primer.df) * Coverage_Primer_mismatches_nfacets(), 15, 800)
return(width)
})
Coverage_Primer_mismatches_height <- reactive({
# height of template coverage plot, stratified by mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(primer.df) == 0 || length(template.df) == 0 || !"primer_coverage" %in% colnames(primer.df)) {
return(1200)
}
# select template subset
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
excluded.seqs <- setdiff(template.df$Identifier[seq_len(nrow(template.df))], template.df$Identifier[idx])
template.df <- template.df[idx,]
primer.df <- openPrimeR:::evaluate.diff.primer.cvg(primer.df, excluded.seqs, template.df)
}
# scale height of plot by max nbr of mismatches of any primer
max.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df)
max.mm <- max(as.numeric(unlist(strsplit(c(primer.df$Nbr_of_mismatches_fw, primer.df$Nbr_of_mismatches_rev), split = ","))))
for (i in seq(0, max.mm - 1)) {
cur.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df, allowed.mismatches = i)
if (cur.cvg == max.cvg) {
max.mm <- i
break
}
}
height <- openPrimeR:::get.plot.height(ceiling(max.mm + 1) / Coverage_Primer_mismatches_nfacets(), 200, 600)
return(height)
})
output$Coverage_Primer_mismatches_ui <- renderUI({
# important: set size of plot here to prevent overlap in the UI
# TOOD: set width and height
plotOutput("Coverage_Primer_mismatches",
width = paste0(Coverage_Primer_mismatches_width(), "px"),
height = paste0(Coverage_Primer_mismatches_height(), "px"))
})
output$Coverage_Primer_mismatches <- renderPlot({
# individual primer coverage plot: mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
groups <- input$selected_group_coverage
openPrimeR:::plot_primer_cvg_mismatches(primer.df, template.df,
groups = groups,
nfacets = Coverage_Primer_mismatches_nfacets())
})
output$Coverage_Primer_ui <- renderUI({
# width shall be defined by groups * primers
# ui output of individual primer coverage plot
plotOutput("Coverage_Primer", width = paste0(cvg.primer.group.width(), "px"), height = paste0(cvg.primer.group.height(), "px"))
})
output$Coverage_Primer <- renderPlot({
# individual primer coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
openPrimeR:::plot_primer_cvg(primer.df, template.df, groups = input$selected_group_coverage)
})#, width = cvg.primer.group.width, height = cvg.primer.group.height)
output$coverage_primer_groups_ui <- renderUI({
# ui output of individual primer coverage plot
plotOutput("Coverage_Primer")#, width = paste0(cvg.primer.group.width(), "px"), height = paste0(cvg.primer.group.height(), "px"))
})
output$primer_binding_regions <- renderPlot({
# plot of primer binding regions
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(data, "Please compute the primer coverage first."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "Please make sure the templates are present."))
lex.sel <- input$selected_group_coverage
if (length(template.df) == 0 || length(data) == 0) {
return(NULL)
}
# why select a subset beforehand?
relation <- input$primer_location_plot_rel
# change annotation of regions for immuno data
if (input$template_scenario == "supplied" && input$selected_supplied_templates == "immunological") {
openPrimeR:::plot_primer_binding_regions(data, template.df, relation = relation, group = lex.sel,
region.names = c("Leader", "Variable region"))
} else {
openPrimeR:::plot_primer_binding_regions(data, template.df, relation = relation, group = lex.sel)
}
})
mismatch.table.fw <- reactive({
# table with mismatch data for fw primers
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df$primer_coverage, "Mismatch data (fw) is not available since primer coverage has not been computed yet."))
validate(need(template.df, "Mismatch data (fw) is not available since no templates are available."))
table <- openPrimeR:::compute.mismatch.table(primer.df, template.df, "fw")
validate(need(table, "No primers (fw) binding with mismatches found."))
return(table)
})
mismatch.table.rev <- reactive({
# table with mismatch data for rev primers
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df, "Mismatch data (rev) is not available since primer coverage has not been computed yet."))
validate(need(template.df, "Mismatch data (rev) is not available since no templates are available."))
table <- openPrimeR:::compute.mismatch.table(primer.df, template.df, "rev")
validate(need(table, "No primers (rev) binding with mismatches found."))
return(table)
})
display.mismatch.table <- reactive({
# the currently selected mismatch table
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df, "No primers available."))
validate(need(template.df, "No templates available."))
withProgress(message = 'Rendering mismatch table ...', value = 0, {
if (input$selected_primer_set_mismatches_direction == "fw") {
table <- mismatch.table.fw()
} else {
table <- mismatch.table.rev()
}
})
return(openPrimeRui:::view.mismatch.table(table))
})
output$mismatch_table <- DT::renderDataTable(
# shows the currently selected mismatch table
DT::datatable(
display.mismatch.table(),
, escape=FALSE,
caption = "Overview of all primers binding with mismatches. The input template sequences (top rows) as well as the amplicons resulting from mismatch primers (bottom rows) are displayed in their nucleotide and amino-acid sequence."
, options = list(), rownames=FALSE
))
cur.Tm.info <- reactive({
# current maximal difference in primer Tm's
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(data) == 0 || !"melting_temp" %in% colnames(data)) {
return(NULL)
}
Tm.range <- c(min(data$melting_temp), max(data$melting_temp))
max.diff <- Tm.range[2] - Tm.range[1]
Tm.info <- list("Tm_range" = Tm.range, "Tm_diff" = max.diff)
return(Tm.info)
})
matdoering/openPrimeRui documentation built on Aug. 15, 2020, 2:37 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#########
# Shiny server functionalities relating to primer coverage
##########
primerViewObserverGroup <- observeEvent(current.seqs(), {
# update coverage group selector when templates are available
if (length(current.seqs()) != 0) {
groups <- unique(current.seqs()$Group)
updateSelectInput(session, "selected_group_coverage", choices = c("all", groups))
}
})
primerViewObserver <- observe({
# update input$selected_primer for coverage tab
cur.table <- NULL
if (input$set_meta_selector == "all") {
if (length(rv_primers$evaluated_primers) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
return()
}
cur.table <- rv_primers$evaluated_primers
} else if (input$set_meta_selector == "filtered") {
cur.table <- current.filtered.primers()
if (length(cur.table) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
return()
}
} else if (input$set_meta_selector == "optimized") {
cur.table <- optimal.primers()
if (length(cur.table) == 0) {
updateSelectInput(session, "selected_primer", choices = "")
validate(need(FALSE, "Please compute the optimized data set first."))
return()
}
} else {
updateSelectInput(session, "selected_primer", choices = "")
validate(need(FALSE, "No valid primer set selected."))
return()
}
template.df <- current.seqs()
if (length(cur.table) != 0 && nrow(cur.table) != 0 && "primer_coverage" %in% colnames(cur.table)) {
cov.seqs <- sapply(strsplit(cur.table$Covered_Seqs, split = ","), function(x) match(as.numeric(x), template.df$Identifier))
groups <- sapply(seq_along(cov.seqs), function(x) unique(template.df$Group[cov.seqs[[x]]]))
if (length(input$selected_group_coverage) == 0 || any(c("", "all") %in% input$selected_group_coverage)) {
sel <- seq_len(nrow(cur.table))
} else {
sel <- which(sapply(groups, function(x) input$selected_group_coverage %in% x))
}
cur.table <- cur.table[sel,]
updateSelectInput(session, "selected_primer", choices = cur.table$ID)
}
})
coverage.statistics <- reactive({
# overview of coverage information
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# stats for expected coverage:
cvg.stats.exp <- openPrimeR:::get_cvg_stats(data, template.data)
if (length(cvg.stats.exp) != 0 && nrow(cvg.stats.exp) != 0) {
cvg.stats.exp <- cbind(cvg.stats.exp, Coverage_Definition = "Expected_Coverage")
}
# stats for text identity coverage:
cvg.stats.txt <- openPrimeR:::get_cvg_stats(data, template.data,
allowed.mismatches = 0, cvg.definition = "basic")
if (length(cvg.stats.txt) != 0 && nrow(cvg.stats.txt) != 0) {
cvg.stats.txt <- cbind(cvg.stats.txt, Coverage_Definition = "Identity_Coverage")
}
cvg.stats <- rbind(cvg.stats.exp, cvg.stats.txt)
return(cvg.stats)
})
coverage.statistics.mismatches <- reactive({
# overview of coverage information for different mismatch settings
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# stats for expected coverage:
mm.range <- seq(0, input$allowed_mismatches)
mm.stats <- vector("list", length(mm.range))
for (i in seq_along(mm.range)) {
cvg.stats <- openPrimeR:::get_cvg_stats(data, template.data,
allowed.mismatches = mm.range[i])
cvg.stats <- cbind(cvg.stats, "MaxMismatches" = mm.range[i])
mm.stats[[i]] <- cvg.stats
}
cvg.string <- sapply(mm.stats, function(x) paste0(round(x[x$Group == "Total", "Coverage_Ratio"] * 100, 1), "%"))
mm.stats <- do.call(rbind, mm.stats)
# update the selector for max mismatches:
labels <- paste0(mm.range, " mismatches (", cvg.string, " coverage)")
opts <- mm.range
names(opts) <- labels
updateSelectInput(session, "allowed_mm_cvg_stats", choices = opts)
return(mm.stats)
})
#basic_string_cvg <- reactive({
## basic coverage according to string complementarity with 0 mismatches
#data <- switch(input$set_meta_selector,
#"all" = rv_primers$evaluated_primers,
#"filtered" = current.filtered.primers(),
#"optimized" = optimal.primers())
#template.data <- switch(input$set_meta_selector,
#"all" = rv_templates$cvg_all,
#"filtered" = rv_templates$cvg_filtered,
#"optimized" = rv_templates$cvg_optimized)
#validate(need(data, "No primer coverage available."))
#validate(need(template.data, "No templates available."))
#cvg <- openPrimeR::get_cvg_ratio(data, template.data, allowed.mismatches = 0, cvg.definition = "basic")
#return(cvg)
#})
output$cvg_stats <- DT::renderDataTable({
# table with coverage stats
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# select the coverage definition for template coverage table:
selected.cvg.def <- input$selected_cvg_def_stats
stats <- coverage.statistics()
if (length(stats) != 0) {
stats <- stats[stats$Coverage_Definition == selected.cvg.def,]
stats <- stats[, c("Group", "Coverage", "Coverage_fw", "Coverage_rev")]
}
return(DT::datatable(stats,
rownames = FALSE, options = list(dom = "pt"), # dom = pt -> show pages and table
caption = paste("The number of covered sequences per group of templates.",
"If the coverage definition is set to 'Expected Coverage', ",
"coverage is computed using the extended coverage criteria",
"and (possibly) allowing for multiple mismatches.",
"If, however, the coverage definition is set to",
"'Identity Coverage', only coverage events where the primers",
"are perfectly complementary to the templates are considered.")))
})
output$cvg_stats_mismatches <- DT::renderDataTable({
# table with template coverage stats
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
# select the coverage definition for template coverage table:
allowed.mm <- input$allowed_mm_cvg_stats
stats <- coverage.statistics.mismatches()
if (allowed.mm == "") {
# nothing to select
return(NULL)
} else {
# convert from string to numeric
allowed.mm <- as.numeric(allowed.mm)
}
if (length(stats) != 0) {
stats <- stats[stats$MaxMismatches == allowed.mm,]
stats <- stats[, c("Group", "Coverage", "Coverage_fw", "Coverage_rev")]
}
return(DT::datatable(stats,
rownames = FALSE, options = list(dom = "pt"), # dom = pt -> show pages and table
caption = paste("The number of sequences that are expected to be",
"covered by primers when allowing for a certain number",
"of mismatches.")))
})
output$CoverageTotal <- renderUI({
# output text giving an overview of coverage/Tm Delta
if (length(coverage.statistics()) == 0) {
return(NULL)
}
stats <- coverage.statistics()
#selected.group <- input$selected_group_coverage
selected.group <- NULL # no dependence on selected.group -> don't want to show multiple texts, just show coverage text for all templates.
if (length(stats) != 0) {
cvg.stats.exp <- stats[stats$Coverage_Definition == "Expected_Coverage",]
cvg.stats.ident <- stats[stats$Coverage_Definition == "Identity_Coverage",]
cvg.text.ident <- paste("<li>",
openPrimeR:::create.cvg.text(cvg.stats.ident, selected.group, "Identity Coverage"),
"</li>", sep = "")
cvg.text.exp <- paste("<li>",
openPrimeR:::create.cvg.text(cvg.stats.exp, selected.group, "Expected Coverage"),
"</li>", sep = "")
} else {
cvg.text.ident <- ""
cvg.text.exp <- ""
}
text <- HTML(paste("<h3><ul>",
cvg.text.exp,
cvg.text.ident,
"</ul></h3>", sep = ""))
return(text)
})
output$ConstraintsTotal <- renderUI({
Tm.info <- cur.Tm.info()
if (length(Tm.info) != 0) {
Tm.text <- paste("<li>", openPrimeRui:::create.Tm.text(Tm.info$Tm_range, Tm.info$Tm_diff), "</li>", sep = "")
} else {
Tm.text <- ""
}
annealing.text <- ""
annealing.temps <- annealing.temperature()
if (length(annealing.temps) != 0) {
opt <- ifelse(input$automatic_annealing_temp == "active", "recommended", "user-defined")
annealing.text <- paste0("<li>The ", opt, " annealing temperature is ", min(annealing.temps), "℃.</li>")
}
text <- HTML(paste("<h3><ul>",
Tm.text,
annealing.text,
"</ul></h3>", sep = ""))
#print(text)
return(text)
})
primer_plot_height <- reactive({
# height of the primer view plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- current.seqs()
if (length(primer.df) == 0 || length(template.df) == 0) {
return(0)
}
id <- NULL
if (length(input$selected_primer) == 0 || input$selected_primer == "") { # no ID given -> plot all
id <- primer.df$Identifier
} else {
id <- primer.df$Identifier[match(input$selected_primer, primer.df$ID)] # match from primer identifier to ID
}
m <- match(id, primer.df$Identifier)
primer.df <- primer.df[m, ]
show.group <- input$selected_group_coverage
if (!is.null(show.group) && !"all" %in% show.group) {
lex.id <- which(template.df$Group %in% show.group)
template.df <- template.df[lex.id,]
}
if ("primer_coverage" %in% colnames(primer.df)) {
n1 <- sum(primer.df$primer_coverage) # nbr of coverage events to show
} else {
n1 <- 0
}
n2 <- nrow(template.df) # nbr of templates to show
n <- n1 + n2
height <- openPrimeR:::get.plot.height(n, px.per.n = 30)
return(height)
})
primer_plot_width <- reactive({
# width of the primer view plot
myData <- current.seqs()
if (length(myData) == 0) {
return(1200)
}
n <- max(nchar(myData$Sequence))
width <- openPrimeR:::get.plot.height(n, px.per.n = 2)
return(width)
})
output$primer_plot <- renderPlot({
# data for the primer view plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df, "The selected primer data set cannot be plotted, because no primer coverage is available in the selected set."))
validate(need(nrow(primer.df) !=0, "The selected primer data set cannot be plotted, because no primers are available."))
validate(need(current.seqs(), "No template sequences are available for plotting yet."))
show.group <- input$selected_group_coverage
template.df <- current.seqs()
id <- NULL
if (length(input$selected_primer) == 0 || input$selected_primer == "") { # no ID given -> plot all
id <- primer.df$Identifier
} else {
id <- primer.df$Identifier[match(input$selected_primer, primer.df$ID)] # match from primer identifier to ID
}
if (!is.null(show.group) && !"all" %in% show.group) {
lex.id <- which(template.df$Group %in% show.group)
template.df <- template.df[lex.id,]
}
validate(need(template.df, "No template sequences avaialable."))
# check whether selected primers have any cvg?
m <- match(id, primer.df$Identifier)
validate(need(any(primer.df[m, "primer_coverage"] != 0), "Selected primers do not cover any template sequences."))
selected.group <- "all" # was 'input$selected_group' before
relation <- input$primer_plot_rel
region.names <- NULL
# change region names if we have immuno data
if (input$template_scenario == "supplied" && input$selected_supplied_templates == "immunological") {
openPrimeR:::plot_primer(primer.df, template.df, id, relation, region.names = c("Leader", "Variable region"))
} else {
openPrimeR:::plot_primer(primer.df, template.df, id, relation)
}
}, width = primer_plot_width, height=primer_plot_height, units="px")
cvg.group.plot.dim <- reactive({
# dimension of template coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(template.df) == 0 || length(primer.df) == 0) {
#print("templates unknown for group plot dimension ...")
return(list("width" = 800, "height" = 800))
}
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
template.df <- template.df[idx,]
}
# base width on number of groups
nbr.groups <- length(unique(template.df$Group))
#nbr.primers <- nrow(primer.df)
width <- openPrimeR:::get.plot.height(nbr.groups, 40, 500)
# increase height with number of templates per group
max.nbr.templates.per.group <- max(table(template.df$Group))
height <- openPrimeR:::get.plot.height(max.nbr.templates.per.group, 1, 500)
out <- list("width" = width, "height" = height)
return(out)
})
primer.cvg.plot.dim <- reactive({
# dimension of template coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(template.df) == 0 || length(primer.df) == 0) {
#print("templates unknown for group plot dimension ...")
return(list("width" = 800, "height" = 800))
}
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
template.df <- template.df[idx,]
}
# base width on number of groups
nbr.groups <- length(unique(template.df$Group))
nbr.primers <- nrow(primer.df)
width <- openPrimeR:::get.plot.height(nbr.groups*nbr.primers, 10, 500) # 2nd value is the width of each bar
# increase height with number of templates per group
height <- 500
out <- list("width" = width, "height" = height)
return(out)
})
cvg.group.plot.width <- reactive({
# width for group coverage plot
if (length(cvg.group.plot.dim()) == 0) {
return(NULL)
}
return(cvg.group.plot.dim()$width)
})
cvg.group.plot.height <- reactive({
# height for group coverage plot
if (length(cvg.group.plot.dim()) == 0) {
return(NULL)
}
return(cvg.group.plot.dim()$height)
})
output$Coverage_Group <- renderPlot({
# group coverage plot
lex.sel <- input$selected_group_coverage
primer.data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
openPrimeR:::plot_template_cvg(primer.data, template.data, groups = lex.sel)
}, width = cvg.group.plot.width, height = cvg.group.plot.height)
output$coverage_primer_per_group_ui <- renderUI({
# ui output of group coverage; prevents overplotting for multiple plot elements on one page
plotOutput("Coverage_Group", width = paste0(cvg.group.plot.width(), "px"),
height = paste0(cvg.group.plot.height(), "px"))
})
cvg.stats.primer <- reactive({
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
cvg.stats <- openPrimeR:::get_cvg_stats_primer(data, template.data)$cvg_per_group
return(cvg.stats)
})
cvg.stats.primer.mismatches <- reactive({
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.data <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(data, "No primer coverage available."))
validate(need(template.data, "No templates available."))
cvg.stats <- openPrimeR:::get_cvg_stats_primer(data, template.data)$cvg_per_nbr_mismatches
return(cvg.stats)
})
output$primer_cvg_stats<- DT::renderDataTable({
# table with coverage stats for primers (covered templates by group)
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.df, "No primer coverage available."))
validate(need(template.df, "No templates available."))
return(DT::datatable(cvg.stats.primer(),
caption = paste("The number of covered template sequences for every primer.",
"Each column indicates the number of covered templates",
"per group of template sequences."),
rownames = FALSE, options = list(dom = "pt"))) # dom = pt -> show pages and table
})
output$primer_cvg_stats_mismatch <- DT::renderDataTable({
# table with coverage stats wrt mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(primer.df, "No primer coverage available."))
validate(need(template.df, "No templates available."))
return(DT::datatable(cvg.stats.primer.mismatches(),
caption = paste("The number of covered template sequences for every primer.",
"Columns with numeric identifiers give the number of coverage events",
"that occur with the indicated number of mismatches."),
rownames = FALSE, options = list(dom = "pt"))) # dom = pt -> show pages and table
})
output$template_coverage_mismatch_ui <- renderUI({
# important: set size of plot here to prevent overlap in the UI
plotOutput("template_coverage_mismatch",
width = cvg.template.mismatch.width(),
height = cvg.template.mismatch.height())
})
cvg.template.mismatch.nfacets <- reactive({
# decide on the number of facet columns to show
px.width <- cvg.group.plot.dim()$width # unfacetted plot
nfacets <- 2
if (px.width > 1000) {
# only show 1 column if plot is too wide for typical screens
nfacets <- 1
}
return(nfacets)
})
cvg.template.mismatch.width <- reactive({
# width of template coverage plot, stratified by mismatches
# just multiply by two (two facet columns)
plot.width <- cvg.group.plot.width() * cvg.template.mismatch.nfacets()
return(plot.width)
})
cvg.template.mismatch.height <- reactive({
# height: at which nbr of mismatches do we have maxed the coverage?
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(primer.df) == 0 || length(template.df) == 0 || !"primer_coverage" %in% colnames(primer.df)) {
return(1200)
}
# select template subset
# TODO: should store selected primers/templates as react expressions -> not necessary to have duplicated code for every function that uses this
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
excluded.seqs <- setdiff(template.df$Identifier[seq_len(nrow(template.df))], template.df$Identifier[idx])
template.df <- template.df[idx,]
primer.df <- openPrimeR:::evaluate.diff.primer.cvg(primer.df, excluded.seqs, template.df)
}
# scale height of plot by max nbr of mismatches of any primer
max.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df)
max.mm <- max(as.numeric(unlist(strsplit(c(primer.df$Nbr_of_mismatches_fw, primer.df$Nbr_of_mismatches_rev), split = ","))))
for (i in seq(0, max.mm - 1)) {
cur.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df, allowed.mismatches = i)
if (cur.cvg == max.cvg) {
max.mm <- i
break
}
}
height <- openPrimeR:::get.plot.height(ceiling(max.mm + 1) / cvg.template.mismatch.nfacets(), 200, 600)
return(height)
})
output$template_coverage_mismatch <- renderPlot({
# plot of template coverage with consideration of mismatch setting
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
groups <- input$selected_group_coverage
openPrimeR:::plot_template_cvg_mismatches(primer.df, template.df,
groups = groups,
nfacets = cvg.template.mismatch.nfacets())
})
cvg.primer.group.width <- reactive({
# width of individual primer plot
if (length(primer.cvg.plot.dim()) == 0) {
return(NULL)
}
width <- primer.cvg.plot.dim()$width
return(width)
})
cvg.primer.group.height <- reactive({
# height of individual primer plot
if (length(primer.cvg.plot.dim()) == 0) {
return(NULL)
}
height <- primer.cvg.plot.dim()$height
return(height)
})
Coverage_Primer_mismatches_nfacets <- reactive({
# nbr of facets for the primer mismatch plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(primer.df) == 0) {
return(3)
}
nfacets <- 3
if (nrow(primer.df) > 10) {
nfacets <- 2
}
if (nrow(primer.df) > 30) {
nfacets <- 1
}
return(nfacets)
})
Coverage_Primer_mismatches_width <- reactive({
# width of primer mismatch coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(primer.df) == 0) {
return(1200)
}
# base width on number of primers and number of facets used
width <- openPrimeR:::get.plot.height(nrow(primer.df) * Coverage_Primer_mismatches_nfacets(), 15, 800)
return(width)
})
Coverage_Primer_mismatches_height <- reactive({
# height of template coverage plot, stratified by mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
if (length(primer.df) == 0 || length(template.df) == 0 || !"primer_coverage" %in% colnames(primer.df)) {
return(1200)
}
# select template subset
lex.sel <- input$selected_group_coverage
if (!is.null(lex.sel) && !"all" %in% lex.sel) { # select subset
idx <- which(template.df$Group %in% lex.sel)
excluded.seqs <- setdiff(template.df$Identifier[seq_len(nrow(template.df))], template.df$Identifier[idx])
template.df <- template.df[idx,]
primer.df <- openPrimeR:::evaluate.diff.primer.cvg(primer.df, excluded.seqs, template.df)
}
# scale height of plot by max nbr of mismatches of any primer
max.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df)
max.mm <- max(as.numeric(unlist(strsplit(c(primer.df$Nbr_of_mismatches_fw, primer.df$Nbr_of_mismatches_rev), split = ","))))
for (i in seq(0, max.mm - 1)) {
cur.cvg <- openPrimeR:::get_cvg_ratio(primer.df, template.df, allowed.mismatches = i)
if (cur.cvg == max.cvg) {
max.mm <- i
break
}
}
height <- openPrimeR:::get.plot.height(ceiling(max.mm + 1) / Coverage_Primer_mismatches_nfacets(), 200, 600)
return(height)
})
output$Coverage_Primer_mismatches_ui <- renderUI({
# important: set size of plot here to prevent overlap in the UI
# TOOD: set width and height
plotOutput("Coverage_Primer_mismatches",
width = paste0(Coverage_Primer_mismatches_width(), "px"),
height = paste0(Coverage_Primer_mismatches_height(), "px"))
})
output$Coverage_Primer_mismatches <- renderPlot({
# individual primer coverage plot: mismatches
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
groups <- input$selected_group_coverage
openPrimeR:::plot_primer_cvg_mismatches(primer.df, template.df,
groups = groups,
nfacets = Coverage_Primer_mismatches_nfacets())
})
output$Coverage_Primer_ui <- renderUI({
# width shall be defined by groups * primers
# ui output of individual primer coverage plot
plotOutput("Coverage_Primer", width = paste0(cvg.primer.group.width(), "px"), height = paste0(cvg.primer.group.height(), "px"))
})
output$Coverage_Primer <- renderPlot({
# individual primer coverage plot
primer.df <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(primer.df$primer_coverage, "Primer coverage has not been computed yet."))
validate(need(any(primer.df$primer_coverage != 0), "The primers do not cover any of the templates."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "The template data set is not available."))
openPrimeR:::plot_primer_cvg(primer.df, template.df, groups = input$selected_group_coverage)
})#, width = cvg.primer.group.width, height = cvg.primer.group.height)
output$coverage_primer_groups_ui <- renderUI({
# ui output of individual primer coverage plot
plotOutput("Coverage_Primer")#, width = paste0(cvg.primer.group.width(), "px"), height = paste0(cvg.primer.group.height(), "px"))
})
output$primer_binding_regions <- renderPlot({
# plot of primer binding regions
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
validate(need(data, "Please compute the primer coverage first."))
template.df <- switch(input$set_meta_selector,
"all" = rv_templates$cvg_all,
"filtered" = rv_templates$cvg_filtered,
"optimized" = rv_templates$cvg_optimized)
validate(need(template.df, "Please make sure the templates are present."))
lex.sel <- input$selected_group_coverage
if (length(template.df) == 0 || length(data) == 0) {
return(NULL)
}
# why select a subset beforehand?
relation <- input$primer_location_plot_rel
# change annotation of regions for immuno data
if (input$template_scenario == "supplied" && input$selected_supplied_templates == "immunological") {
openPrimeR:::plot_primer_binding_regions(data, template.df, relation = relation, group = lex.sel,
region.names = c("Leader", "Variable region"))
} else {
openPrimeR:::plot_primer_binding_regions(data, template.df, relation = relation, group = lex.sel)
}
})
mismatch.table.fw <- reactive({
# table with mismatch data for fw primers
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df$primer_coverage, "Mismatch data (fw) is not available since primer coverage has not been computed yet."))
validate(need(template.df, "Mismatch data (fw) is not available since no templates are available."))
table <- openPrimeR:::compute.mismatch.table(primer.df, template.df, "fw")
validate(need(table, "No primers (fw) binding with mismatches found."))
return(table)
})
mismatch.table.rev <- reactive({
# table with mismatch data for rev primers
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df, "Mismatch data (rev) is not available since primer coverage has not been computed yet."))
validate(need(template.df, "Mismatch data (rev) is not available since no templates are available."))
table <- openPrimeR:::compute.mismatch.table(primer.df, template.df, "rev")
validate(need(table, "No primers (rev) binding with mismatches found."))
return(table)
})
display.mismatch.table <- reactive({
# the currently selected mismatch table
if (input$set_meta_selector == "all") {
primer.df <- rv_primers$evaluated_primers
template.df <- rv_templates$cvg_all
} else if (input$set_meta_selector == "filtered") {
primer.df <- current.filtered.primers()
template.df <- rv_templates$cvg_filtered
} else if (input$set_meta_selector == "optimized") {
primer.df <- optimal.primers()
template.df <- rv_templates$cvg_optimized
} else {
return(NULL)
}
validate(need(primer.df, "No primers available."))
validate(need(template.df, "No templates available."))
withProgress(message = 'Rendering mismatch table ...', value = 0, {
if (input$selected_primer_set_mismatches_direction == "fw") {
table <- mismatch.table.fw()
} else {
table <- mismatch.table.rev()
}
})
return(openPrimeRui:::view.mismatch.table(table))
})
output$mismatch_table <- DT::renderDataTable(
# shows the currently selected mismatch table
DT::datatable(
display.mismatch.table(),
, escape=FALSE,
caption = "Overview of all primers binding with mismatches. The input template sequences (top rows) as well as the amplicons resulting from mismatch primers (bottom rows) are displayed in their nucleotide and amino-acid sequence."
, options = list(), rownames=FALSE
))
cur.Tm.info <- reactive({
# current maximal difference in primer Tm's
data <- switch(input$set_meta_selector,
"all" = rv_primers$evaluated_primers,
"filtered" = current.filtered.primers(),
"optimized" = optimal.primers())
if (length(data) == 0 || !"melting_temp" %in% colnames(data)) {
return(NULL)
}
Tm.range <- c(min(data$melting_temp), max(data$melting_temp))
max.diff <- Tm.range[2] - Tm.range[1]
Tm.info <- list("Tm_range" = Tm.range, "Tm_diff" = max.diff)
return(Tm.info)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.