utils.R
In NACHO: NanoString Quality Control Dashboard

`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

panelInputUI <- function(id, label, ..., sidebar = NULL) {
  ns <- shiny::NS(id)

  contents <- list(...)

  contents_grid <- switch(
    as.character(length(contents)),
    "1" = {
      list(
        shiny::fluidRow(shiny::column(
          width = 12,
          align = "center",
          contents[[1]]
        ))
      )
    },
    "2" = {
      list(
        shiny::fluidRow(
          shiny::column(width = 6, align = "center", contents[[1]]),
          shiny::column(width = 6, align = "center", contents[[2]])
        )
      )
    },
    "3" = {
      list(
        shiny::fluidRow(
          shiny::column(width = 6, align = "center", contents[[1]]),
          shiny::column(width = 6, align = "center", contents[[2]])
        ),
        shiny::fluidRow(
          style = "padding-top: 1em;",
          shiny::column(width = 12, align = "center", contents[[3]])
        )
      )
    },
    "4" = {
      list(
        shiny::fluidRow(
          shiny::column(width = 6, align = "center", contents[[1]]),
          shiny::column(width = 6, align = "center", contents[[2]])
        ),
        shiny::fluidRow(
          style = "padding-top: 1em;",
          shiny::column(width = 6, align = "center", contents[[3]]),
          shiny::column(width = 6, align = "center", contents[[4]])
        )
      )
    },
    list(shiny::fluidRow())
  )

  if (is.null(sidebar)) {
    shiny::tabPanel(label, value = ns("tab"), contents_grid)
  } else {
    shiny::tabPanel(
      label,
      value = ns("tab"),
      shiny::sidebarLayout(
        shiny::sidebarPanel(
          width = 3,
          shiny::tags$div(align = "center", sidebar)
        ),
        shiny::mainPanel(width = 9, contents_grid)
      )
    )
  }
}

card <- function(title, body) {
  shiny::tags$div(
    class = paste0("card border-dark"),
    shiny::tags$div(class = "card-header", align = "center", title),
    shiny::tags$div(class = "card-body", align = "center", body)
  )
}

plotInputUI <- function(label = NULL, ...) {
  id <- tolower(gsub("\\b(\\pL)\\pL|.", "\\U\\1", label, perl = TRUE))
  ns <- shiny::NS(id)
  card(
    title = {
      shiny::tags$h4(
        label,
        align = "center",
        shinyWidgets::dropdownButton(
          shiny::uiOutput(ns("plot_ui")),
          circle = TRUE,
          status = "danger",
          size = "sm",
          icon = shiny::icon("gear"),
          width = "800px",
          inline = TRUE,
          tooltip = shinyWidgets::tooltipOptions(
            title = "Click to see inputs!"
          ),
          ...
        )
      )
    },
    body = shiny::plotOutput(ns("plot"), height = "350px")
  )
}

plotInput <- function(id, nacho) {
  shiny::moduleServer(id = id, module = function(input, output, session) {
    ns <- session$ns
    font_size <- 80
    output$plot_ui <- shiny::renderUI({
      shiny::fluidRow(
        shiny::column(
          width = 6,
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              12,
              align = "center",
              shiny::selectInput(
                ns("group_colour"),
                shiny::tags$span(
                  "Grouping Variable",
                  shiny::helpText("(Colour)")
                ),
                selected = shiny::isolate(input$group_colour) %||%
                  "CartridgeID",
                choices = unique(c(
                  "CartridgeID",
                  "Date",
                  "ID",
                  "ScannerID",
                  "StagePosition",
                  names(nacho[["nacho"]])
                ))
              )
            )
          ),
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              6,
              align = "center",
              shiny::radioButtons(
                ns("show_levels"),
                shiny::tags$span("Show Levels", shiny::helpText("(Legend)")),
                choiceNames = list("No", "Yes"),
                choiceValues = list(FALSE, TRUE),
                selected = shiny::isolate(input$show_levels) %||% TRUE,
                inline = TRUE
              )
            ),
            shiny::column(
              6,
              align = "center",
              shiny::radioButtons(
                ns("show_outliers"),
                shiny::tags$span("Show Outliers", shiny::helpText("(Point)")),
                choiceNames = list("No", "Yes"),
                choiceValues = list(FALSE, TRUE),
                selected = shiny::isolate(input$show_outliers) %||% TRUE,
                inline = TRUE
              )
            )
          ),
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              6,
              align = "center",
              shiny::radioButtons(
                inputId = ns("show_outliers_labels"),
                label = shiny::tags$span(
                  "Outliers' Label",
                  shiny::helpText("(Text)")
                ),
                choiceNames = list("No", "Yes"),
                choiceValues = list(FALSE, TRUE),
                selected = shiny::isolate(input$show_outliers_labels) %||%
                  FALSE,
                inline = TRUE
              )
            ),
            shiny::column(
              6,
              align = "center",
              shiny::numericInput(
                inputId = ns("outliers_point_size"),
                label = shiny::tags$span(
                  "Outliers Point Size",
                  shiny::helpText("(Factor x Point Size)")
                ),
                value = shiny::isolate(input$outliers_point_size) %||% 1,
                min = 1,
                max = 3,
                step = 0.1
              )
            )
          ),
          shiny::fluidRow(
            shiny::column(
              12,
              align = "center",
              shiny::uiOutput(ns("outliers_labels"))
            )
          )
        ),
        shiny::column(
          width = 6,
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              6,
              align = "center",
              shiny::numericInput(
                ns("font_size"),
                shiny::tags$span("Font Size", shiny::helpText("(pt)")),
                value = shiny::isolate(input$font_size) %||% 16
              )
            ),
            shiny::column(
              6,
              align = "center",
              shiny::numericInput(
                ns("point_size"),
                shiny::tags$span("Point Size", shiny::helpText("(mm)")),
                value = shiny::isolate(input$point_size) %||% 1,
                min = 0,
                max = 4,
                step = 0.5
              )
            )
          ),
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              4,
              align = "center",
              shiny::numericInput(
                ns("plot_width"),
                shiny::tags$span("Width", shiny::helpText("(cm)")),
                value = shiny::isolate(input$plot_width) %||% 16
              )
            ),
            shiny::column(
              4,
              align = "center",
              shiny::numericInput(
                ns("plot_height"),
                shiny::tags$span("Height", shiny::helpText("(cm)")),
                value = shiny::isolate(input$plot_height) %||% 12
              )
            ),
            shiny::column(
              4,
              align = "center",
              shiny::numericInput(
                ns("plot_dpi"),
                shiny::tags$span("DPI", shiny::helpText("(Default: 120)")),
                value = shiny::isolate(input$plot_dpi) %||% 120
              )
            )
          ),
          shiny::fluidRow(
            style = paste0("font-size: ", font_size, "%;"),
            shiny::column(
              12,
              align = "center",
              style = "padding-top: 2em;",
              shiny::downloadButton(ns("plot_download"), label = "Download")
            )
          )
        )
      )
    })

    output$outliers_labels <- shiny::renderUI({
      if (shiny::req(input[["show_outliers_labels"]])) {
        shiny::selectInput(
          ns("outliers_labels"),
          NULL,
          choices = colnames(nacho$nacho),
          selected = nacho$access
        )
      }
    })

    plot <- shiny::reactive({
      autoplot_values <- c(
        "bd" = "BD",
        "fov" = "FoV",
        "pcl" = "PCL",
        "lod" = "LoD",
        "pp" = "Positive",
        "np" = "Negative",
        "hgp" = "Housekeeping",
        "cpe" = "PN",
        "acvbd" = "ACBD",
        "acvmc" = "ACMC",
        "pca" = "PCA",
        "pcai" = "PCAi",
        "pfvnf" = "PFNF",
        "hgf" = "HF",
        "nr" = "NORM"
      )
      x_metrics <- unname(autoplot_values[id])
      p <- NACHO::autoplot(
        x = x_metrics,
        object = nacho,
        colour = input[["group_colour"]] %||% "CartridgeID",
        size = input[["point_size"]] %||% 1,
        show_legend = as.logical(input[["show_levels"]] %||% TRUE),
        show_outliers = as.logical(input[["show_outliers"]] %||% TRUE),
        outliers_factor = input[["outliers_point_size"]] %||% 1,
        outliers_labels = if (
          as.logical(input[["show_outliers_labels"]] %||% FALSE)
        ) {
          input[["outliers_labels"]]
        } else {
          NULL
        }
      )
      p +
        ggplot2::theme_minimal(base_size = input[["font_size"]] %||% 16) +
        ggplot2::theme(
          panel.grid.major.x = p$theme$panel.grid.major.x,
          panel.grid.minor.x = p$theme$panel.grid.major.x,
          axis.text.x = p$theme$axis.text.x
        )
    })

    output$plot <- shiny::renderPlot(plot())

    output$plot_download <- shiny::downloadHandler(
      filename = function() {
        autoplot_values <- c(
          "bd" = "BD",
          "fov" = "FoV",
          "pcl" = "PCL",
          "lod" = "LoD",
          "pp" = "Positive",
          "np" = "Negative",
          "hgp" = "Housekeeping",
          "cpe" = "PN",
          "acvbd" = "ACBD",
          "acvmc" = "ACMC",
          "pca" = "PCA",
          "pcai" = "PCAi",
          "pfvnf" = "PFNF",
          "hgf" = "HF",
          "nr" = "NORM"
        )
        x_metrics <- unname(autoplot_values[id])
        paste0(x_metrics, ".png")
      },
      content = function(file) {
        ggplot2::ggsave(
          filename = file,
          plot = plot(),
          width = input[["plot_width"]],
          height = input[["plot_height"]],
          units = "cm",
          dpi = input[["plot_dpi"]]
        )
      }
    )
  })
}

bd_range <- function(instrument) {
  switch(
    instrument,
    "MAX/FLEX" = c(0.1, 2.25),
    "SPRINT" = c(0.1, 1.8)
  )
}

is_zip_upload <- function(name, type) {
  type %in%
    c("application/zip", "application/x-zip-compressed") ||
    grepl("\\.zip$", name, ignore.case = TRUE)
}

about_pages <- c(
  "Binding Density" = "bd",
  "Field of View" = "fov",
  "Positive Control Linearity" = "pcl",
  "Limit of Detection" = "lod",
  "Positive Factor" = "pf",
  "Housekeeping Genes Factor" = "hgf"
)

include_about <- function(name) {
  about <- readLines(
    file.path("www", paste0("about-", name, ".md")),
    encoding = "UTF-8"
  )
  shiny::HTML(markdown::mark(text = about, output = NULL))
}