Nothing
#' Create a PCR plate input control
#'
#' Create an input control for representing PCR plate and dynamically selecting
#' wells inside it.
#'
#' @usage pcrPlateInput(inputId,
#' label = NULL,
#' plateDescription,
#' pcrFormat = pcrFormatType$new(8, 12, labelFormatType$new("ABC"),
#' labelFormatType$new("123")),
#' selection = NULL,
#' highlighting = NULL,
#' wellLabelTemplate = "{{sample}}",
#' onHoverWellTextTemplate = "{{position}}\u000A{{sample}}\u000A{{targets}}",
#' wellClassTemplate = NULL,
#' wellStyleTemplate = NULL,
#' wellGroupTemplate = "{{sample}}-{{targets}}",
#' cssFile = system.file("/css/pcrPlateInputStyle.css",
#' package = "shinyMolBio"),
#' cssText = NULL,
#' legend = NULL,
#' interactive = TRUE)
#'
#' @param inputId The \code{input} slot that will be used to access the selected
#' wells positions.
#' @param label Display label for the control, or \code{NULL} for no label.
#' @param plateDescription Plate description - basicly output from \code{RDML
#' AsTable()} function.
#' @param pcrFormat PCR plate parametrs. Should be \code{pcrFormatType}.
#' @param selection Set preselected wells (e.g. \code{c("A01", "A02")} or \code{c(1, 2)})
#' @param highlighting Set highlighted wells (e.g. \code{c("A01", "A02")} or \code{c(1, 2)})
#' @param wellLabelTemplate Template of the well label.
#' @param onHoverWellTextTemplate Template of the text on hover.
#' @param wellClassTemplate Template of the well class (css class).
#' @param wellStyleTemplate Template of the well style (css).
#' @param wellGroupTemplate Template of the well group for selecting.
#' @param cssFile Path to the css styles file.
#' @param cssText CSS styles as text.
#' @param legend Plate legend (any HTML content).
#' @param interactive Should be this \code{pcrPlate} interactive or not.
#' @return A PCR plate control that can be added to a UI definition.
#'
#' @author Konstantin A. Blagodatskikh <k.blag@@yandex.ru>
#' @keywords PCR RDML Shiny Input
#' @import RDML shiny dplyr stringr checkmate
#' @importFrom purrr map
#' @importFrom whisker whisker.render
#'
#' @family input elements
#' @seealso \code{\link{updatePcrPlateInput}}
#'
#' @examples
#' ## Only run examples in interactive R sessions
#' library(RDML)
#' if (interactive()) {
#' ui <- fluidPage(
#' pcrPlateInput("plate1",
#' "Plate 1",
#' RDML$new(system.file("/extdata/stepone_std.rdml", package = "RDML"))$AsTable(),
#' pcrFormatType$new(8,12,labelFormatType$new("ABC"),
#' labelFormatType$new("123"))),
#' verbatimTextOutput("selected")
#' )
#' server <- function(input, output) {
#' output$selected <- renderText({ input$plate1 })
#' }
#' shinyApp(ui, server)
#' }
#' @export
pcrPlateInput <- function(inputId,
label = NULL,
plateDescription,
pcrFormat = pcrFormatType$new(8, 12, labelFormatType$new("ABC"), labelFormatType$new("123")),
selection = NULL,
highlighting = NULL,
wellLabelTemplate = "{{sample}}",
onHoverWellTextTemplate = "{{position}}\u000A{{sample}}\u000A{{targets}}",
wellClassTemplate = NULL,
wellStyleTemplate = NULL,
wellGroupTemplate = "{{sample}}-{{targets}}",
cssFile = system.file("/css/pcrPlateInputStyle.css",
package = "shinyMolBio"),
cssText = NULL,
legend = NULL,
interactive = TRUE) {
assertString(inputId)
assertString(label, null.ok = TRUE)
assertDataFrame(plateDescription)
assertClass(pcrFormat, "pcrFormatType")
assert(checkNull(selection),
checkNumeric(selection),
checkCharacter(selection))
assert(checkNull(highlighting),
checkNumeric(highlighting),
checkCharacter(highlighting))
assertString(wellLabelTemplate, null.ok = TRUE)
assertString(onHoverWellTextTemplate, null.ok = TRUE)
assertString(wellClassTemplate, null.ok = TRUE)
assertString(wellStyleTemplate, null.ok = TRUE)
assertString(wellGroupTemplate, null.ok = TRUE)
assertString(cssFile)
assertString(cssText, null.ok = TRUE)
assert(checkNull(legend),
checkClass(legend, "shiny.tag"))
assertFlag(interactive)
ns <- NS(inputId)
plateDescription <- plateDescription %>%
group_by(.data$position) %>%
mutate(targets = paste(.data$target, collapse = "; "),
target.dyeIds = paste(.data$target.dyeId, collapse = "; ")) %>%
distinct(.data$react.id, .keep_all = TRUE)
selectionColumn <- {
if (is.numeric(selection))
"react.id"
else
"position"
}
highlightingColumn <- {
if (is.numeric(highlighting))
"react.id"
else
"position"
}
plateDescription[, "selection"] <- ""
plateDescription[plateDescription[[selectionColumn]] %in% selection,
"selection"] <- " selected-well"
plateDescription[, "highlighting"] <- ""
plateDescription[plateDescription[[highlightingColumn]] %in% highlighting,
"highlighting"] <- " highlighted-well"
htmlPlate <-
sprintf(paste0('<table id="', ns("pcrPlateTbl"),
'" class="pcr-plate-tbl',
{
if (interactive)
' interactive'
},
'"><thead><tr><th id="', ns("toggleall"),
'" class="toggle-all"></th>%s</tr></thead>',
'<tbody>%s</tbody></table>'
# ,'<script>addOnClick("', ns("pcrPlateTbl"),'");</script>'
),
map(1:pcrFormat$columns,
function(col) {
sprintf("<th id='%s'>%s</th>",
ns(sprintf("col_%02i", col)),
col)}) %>%
paste(collapse = ""),
map(LETTERS[1:pcrFormat$rows],
function(row){
sprintf("<tr><th id='%s' class='%s'>%s</th>%s</tr>",
ns(sprintf("row_%s", row)),
{
if (as.integer(charToRaw(row)) %% 2 == 0) "even-row"
else "odd-row"
},
row,
map(1:pcrFormat$columns,
function(col) {
well <- sprintf("%s%02i", row, col)
trow <-
filter(plateDescription, .data$position == well)
if (!length(trow$fdata.name))
return("<td class='empty-well'></td>")
# paste0(
sprintf("<td id='%s' title='%s' group='%s' class='%s%s%s' style='%s'>%s</td>",
trow$position,
whisker.render(onHoverWellTextTemplate,
trow),
gsub(pattern = "[[:punct:]]",
whisker.render(wellGroupTemplate, trow),
replacement = ""),
whisker.render(wellClassTemplate,
trow),
trow$selection,
trow$highlighting,
whisker.render(wellStyleTemplate,
trow),
whisker.render(wellLabelTemplate,
trow)
)
}) %>%
paste(collapse = ""))
}) %>%
paste(collapse = "")) %>%
HTML()
css <- tags$style(type = "text/css",
paste0(whisker.render(
suppressWarnings(readLines(cssFile, warn = FALSE, encoding = "UTF-8")) %>%
paste0( collapse = ""),
list(id = inputId)
),
whisker.render(cssText, list(id = inputId))
)
)
tagList(
if (interactive) {
tags$head(
singleton(
includeScript(system.file("/js/pcrPlate-input-bindings.js", package = "shinyMolBio"))
),
singleton(css)
)
} else {
css
},
div(id = inputId, class = "pcr-plate",
tags$label(label, `for` = inputId),
htmlPlate,
legend
)
)
}
#' Change the value of a PCR plate input control on the client
#'
#' Change the value of a PCR plate input control on the client
#'
#' @param session The \code{session} object passed to function given to \code{shinyServer}.
#' @param inputId The id of the \code{input} object.
#' @param label The label to set for the input object.
#' @param selection The positions of the wells to be selected.
#' @param highlighting The positions of the wells to be highlighted.
#'
#' @author Konstantin A. Blagodatskikh <k.blag@@yandex.ru>
#' @keywords PCR RDML Shiny Input
#' @export
#' @examples
#' ## Only run examples in interactive R sessions
#' library(RDML)
#' if (interactive()) {
#' ui <- fluidPage(
#' pcrPlateInput("plate1",
#' "Plate 1",
#' RDML$new(system.file("/extdata/stepone_std.rdml", package = "RDML"))$AsTable(),
#' pcrFormatType$new(8,12,labelFormatType$new("ABC"),
#' labelFormatType$new("123"))),
#' verbatimTextOutput("selected"),
#' actionButton("selectWellBtn",
#' "Select Well A01-A03")
#' )
#' server <- function(input, output, session) {
#' output$selected <- renderText({ input$plate1 })
#'
#' observeEvent(
#' input$selectWellBtn,
#' {
#' updatePcrPlateInput(session,
#' "plate1",
#' selection = c("A01", "A02", "A03"))
#' })
#' }
#' shinyApp(ui, server)
#' }
updatePcrPlateInput <- function(session, inputId,
label = NULL,
selection = NULL,
highlighting = NULL) {
assertClass(session, "ShinySession")
assertString(inputId)
assertString(label, null.ok = TRUE)
assert(checkNull(selection),
checkNumeric(selection),
checkCharacter(selection))
assert(checkNull(highlighting),
checkNumeric(highlighting),
checkCharacter(highlighting))
message <- .dropNulls(list(label = label,
selection = selection,
highlighting = highlighting))
session$sendInputMessage(inputId, message)
}
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.