diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..828acac --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,49 @@ +Package: wilson +Type: Package +Title: WIlsON Webbased Interactive Omics visualizatioN +Version: 1.0.0 +Authors@R: c( + person("Hendrik", "Schultheis", email = "hendrik.schultheis@mpi-bn.mpg.de", role = c("aut", "cre")), + person("Jens", "Preussner", email = "jens.preussner@mpi-bn.mpg.de", role = "aut"), + person("Looso", "Mario", email = "mario.looso@mpi-bn.mpg.de", role = "aut")) +Description: This package provides modules for webbased tools that use plot based strategies to visualize and analyze multi-omics data. + WIlsON utilizes the Rshiny and Plotly frameworks to provide a user friendly dashboard for interactive plotting. +URL: https://github.molgen.mpg.de/loosolab/wilson +BugReports: https://github.molgen.mpg.de/loosolab/wilson/issues +License: MIT + file LICENSE +Encoding: UTF-8 +LazyData: true +Imports: shiny, + data.table, + ggplot2, + plotly, + scales, + shinydashboard, + DT, + colourpicker, + RColorBrewer, + shinyjs, + viridis, + rje, + grDevices, + grid, + plyr, + circlize, + ComplexHeatmap, + stats, + gplots, + reshape, + rintrojs, + Kmisc, + webshot, + RJSONIO, + ggrepel (>= 0.6.12), + DESeq2, + rjson, + FactoMineR, + factoextra, + heatmaply, + shinyBS, + shinythemes +RoxygenNote: 6.0.1 +biocViews: diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..ffa70fb --- /dev/null +++ b/LICENSE @@ -0,0 +1,2 @@ +YEAR: 2017 +COPYRIGHT HOLDER: Mario Looso, Hendrik Schultheis and Jens Preussner diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..4da3252 --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,37 @@ +# Generated by roxygen2: do not edit by hand + +export(and) +export(andUI) +export(colorPicker) +export(colorPicker2) +export(colorPicker2UI) +export(colorPickerUI) +export(columnSelector) +export(columnSelectorUI) +export(featureSelector) +export(featureSelectorUI) +export(geneView) +export(geneViewUI) +export(global_cor_heatmap) +export(global_cor_heatmapUI) +export(heatmap) +export(heatmapUI) +export(label) +export(labelUI) +export(limit) +export(limitUI) +export(marker) +export(markerUI) +export(orNumeric) +export(orNumericUI) +export(orTextual) +export(orTextualUI) +export(parse_MaxQuant) +export(parser) +export(pca) +export(pcaUI) +export(scatterPlot) +export(scatterPlotUI) +export(transformation) +export(transformationUI) +import(data.table) diff --git a/R/and.R b/R/and.R new file mode 100644 index 0000000..22f9b31 --- /dev/null +++ b/R/and.R @@ -0,0 +1,287 @@ +#' AND module UI representation +#' +#' The AND module connects filtering and selection across multiple columns of a data.frame. Columns of class boolean, character or factor will be represented as textual ORs, numeric columns as numerical OR. +#' +#' @param id The ID of the modules namespace. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +andUI <- function(id) { + ns <- shiny::NS(id) + + ret <- shiny::uiOutput(ns("and")) + + shiny::tagList(ret) +} + +#' AND module server logic +#' +#' This function evaluates output from multiple OR modules by combining with a logical and. +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param data The input data.frame for which selection should be provided. Evaluates an OR module for each column (Supports reactive). +#' @param show.elements A Vector of column names determining which OR modules are shown. Defaults to names(data). (Supports reactive) +#' @param element.grouping Group features in boxes. (Data.table: first column = columnnames, second column = groupnames) (Supports reactive) +#' @param column.labels Additional labels for the columns, defaults to \code{names(data)}. +#' @param delimiter A single character, or a vector indicating how column values are delimited. (Fills vector sequentially if needed)(Supports reactive) +#' @param multiple Whether or not textual ORs should allow multiple selections. (Fills vector sequentially if needed)(Supports reactive) +#' @param contains Whether or not textual ORs are initialized as textInput checking entries for given string. (Fills vector sequentially if needed)(Supports reactive) +#' @param ranged Whether or not numeric ORs are ranged. (Fills vector sequentially if needed)(Supports reactive) +#' @param step Set numeric ORs slider steps. (Fills vector sequentially if needed)(Supports reactive) +#' @param reset Reactive which will cause a UI reset on change. +#' +#' @return A reactive containing named list with a boolean vector of length \code{nrow(data)} (bool), indicating whether an observation is selected or not and a vector of Strings showing the used filter (text). +#' +#' @export +and <- function(input, output, session, data, show.elements = NULL, element.grouping = NULL, column.labels = NULL, delimiter = NULL, multiple = TRUE, contains = FALSE, ranged = FALSE, step = 100, reset = NULL) { + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data() + }else{ + data + } + }) + + # handle reactive show.elements + show.elements.r <- shiny::reactive({ + if(shiny::is.reactive(show.elements)) { + show.elements <- show.elements() + } else { + show.elements <- show.elements + } + if(is.null(show.elements)) { + show.elements <- names(data.r()) + } + + return(show.elements) + }) + + #handle reactive grouping + element.grouping.r <- shiny::reactive({ + if(shiny::is.reactive(element.grouping)){ + element.grouping() + }else{ + element.grouping + } + }) + + parameter <- shiny::reactive({ + #get column labels + if(is.null(column.labels)){ + column.labels <- names(data.r()) + }else{ + column.labels <- column.labels + } + #fill multiple if vector is too small + if(shiny::is.reactive(multiple)) { + multiple <- multiple() + } + if (length(multiple) < ncol(data.r())) { + multiple <- rep(multiple, length.out = ncol(data.r())) + } + #fill contains if vector is too small + if(shiny::is.reactive(contains)) { + contains <- contains() + } + if (length(contains) < ncol(data.r())) { + contains <- rep(contains, length.out = ncol(data.r())) + } + #fill ranged if vector is too small + if(shiny::is.reactive(ranged)) { + ranged <- ranged() + } + if (length(ranged) < ncol(data.r())) { + ranged <- rep(ranged, length.out = ncol(data.r())) + } + #fill delimiter if vector is too small + if(shiny::is.reactive(delimiter)) { + delimiter <- delimiter() + } + if (length(delimiter) < ncol(data.r()) & !is.null(delimiter)) { + delimiter <- rep(delimiter, length.out = ncol(data.r())) + } + #fill step if vector is too small + if(shiny::is.reactive(step)) { + step <- step() + } + if (length(step) < ncol(data.r()) & !is.null(step)) { + step <- rep(step, length.out = ncol(data.r())) + } + + return(list(column.labels = column.labels, multiple = multiple, contains = contains, ranged = ranged, delimiter = delimiter, step = step)) + }) + + output$and <- shiny::renderUI({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0, message = "Render orModules:") + + # select data based on show.elements + data <- data.r()[, show.elements.r(), with = FALSE] + + step <- ncol(data) + + if(!is.null(element.grouping.r())){ + # only group shown data + element.grouping <- element.grouping.r()[element.grouping.r()[[1]] %in% show.elements.r()] + + grouping <- tapply(element.grouping[[1]], element.grouping[[2]], function(x){x}) + # keep grouping order + grouping <- grouping[unique(element.grouping[[2]])] + + return <- lapply(1:length(grouping), function(i){ + group <- lapply(unlist(grouping[i]), function(x){ + progress$inc(step, detail = x) + + if(is.numeric(data[[x]])){ + ui <- orNumericUI(id = session$ns(paste0("orN-", make.names(x)))) + }else{ + ui <- orTextualUI(id = session$ns(paste0("orT-", make.names(x)))) + } + + if(length(ui) < 4){ #orTextual + shiny::tagList(shiny::fluidRow( + shiny::column(width = 4, ui[1]), + shiny::column(width = 3, ui[2]), + shiny::column(width = 1, offset = 4, ui[3]) + )) + }else{ #orNumeric + shiny::tagList(shiny::fluidRow( + shiny::column(width = 4, ui[1]), + shiny::column(width = 1, ui[2]), + shiny::column(width = 6, ui[3]), + shiny::column(width = 1, ui[4]) + )) + } + + }) + + shiny::tagList(shinydashboard::box(width = 12, collapsible = TRUE, collapsed = TRUE, title = names(grouping[i]), shiny::tagList(group))) + }) + }else{ + return <- lapply(1:ncol(data), function(x) { + progress$inc(step, detail = names(data)[x]) + if (is.numeric(data[[x]])) { + ui <- orNumericUI(id = session$ns(paste0("orN-", make.names(names(data)[x])))) + + } else{ + ui <- orTextualUI(id = session$ns(paste0("orT-", make.names(names(data)[x])))) + } + + if(length(ui) < 4){ #orTextual + shiny::tagList(shiny::fluidRow( + shiny::column(width = 4, ui[1]), + shiny::column(width = 3, ui[2]), + shiny::column(width = 1, offset = 4, ui[3]) + )) + }else{ #orNumeric + shiny::tagList(shiny::fluidRow( + shiny::column(width = 4, ui[1]), + shiny::column(width = 1, ui[2]), + shiny::column(width = 6, ui[3]), + shiny::column(width = 1, ui[4]) + )) + } + }) + } + + #initialize new modules + modules() + + shiny::tagList(return) + }) + + # initialize or modules + # returns a vector containing modules + modules <- shiny::reactive({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0, message = "Filtering Module:") + step <- ncol(data.r()) + + lapply(1:ncol(data.r()), function(x) { + progress$inc(step, detail = names(data.r())[x]) + if (is.numeric(data.r()[[x]])) { + if (parameter()$ranged[x]) { + shiny::callModule( + module = orNumeric, + id = paste0("orN-", make.names(names(data.r())[x])), + choices = data.r()[[x]], + value = c(floor(min(data.r()[[x]], na.rm = TRUE)), ceiling(max(data.r()[[x]], na.rm = TRUE))), + label = parameter()$column.labels[x], + step = parameter()$step[x], + min. = floor(min(data.r()[[x]], na.rm = TRUE)), + max. = ceiling(max(data.r()[[x]], na.rm = TRUE)), + reset = reset + ) + } else{ + shiny::callModule( + module = orNumeric, + id = paste0("orN-", make.names(names(data.r())[x])), + choices = data.r()[[x]], + value = mean(data.r()[[x]], na.rm = TRUE), + label = parameter()$column.labels[x], + step = parameter()$step[x], + min. = floor(min(data.r()[[x]], na.rm = TRUE)), + max. = ceiling(max(data.r()[[x]], na.rm = TRUE)), + reset = reset + ) + } + } else{ + shiny::callModule( + module = orTextual, + id = paste0("orT-", make.names(names(data.r())[x])), + choices = data.r()[[x]], + label = parameter()$column.labels[x], + delimiter = parameter()$delimiter[x], + multiple = parameter()$multiple[x], + contains = parameter()$contains[x], + reset = reset + ) + } + }) + }) + + selection <- shiny::reactive({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0, message = "Apply Filter") + + or.modules <- modules() + + step <- 0.9 / length(or.modules) + #OR modules selection + or.selection.bool <- sapply(or.modules, function(x) { + progress$inc(step, detail = x()$label) + x()$bool + }) + or.selection.text <- sapply(or.modules, function(x) { + if(shiny::isTruthy(x()$text)){ + return(paste0(x()$label, ": ", paste(x()$text, collapse = ","), collapse = "")) + } + }) + + #cast to matrix if sapply returns vector + if(is.vector(or.selection.bool)){ + or.selection.bool <- t(as.matrix(or.selection.bool)) + } + + #selected rows (and selection) + and.selection.bool <- apply(or.selection.bool, 1, all) + + or.selection.text <- unlist(or.selection.text) + + progress$set(1) + + return(list(bool = and.selection.bool, text = unlist(or.selection.text))) + }) + + return(selection) +} diff --git a/R/colorPicker.R b/R/colorPicker.R new file mode 100644 index 0000000..4e3b372 --- /dev/null +++ b/R/colorPicker.R @@ -0,0 +1,66 @@ +#' colorPicker module UI representation +#' +#' The functions creates HTML tag definitions of its representation based on the parameters supplied. +#' Currently, two UI can be created for the user to choose either (a) colors from a given color scheme, or (b) choose one or more single colors. +#' +#' @param id The ID of the modules namespace. +#' @param label Either a character vector of length one with the label for the color scheme dropdown, or a character vector containing labels of the single colors. +#' @param choices A character vector with choices for the color scheme dropdown. See \code{\link[shiny]{selectInput}}. +#' @param selected.choice The initially selected value(s) of the dropdown. If NULL (default), the first value of schemes will be taken. +#' @param show.reverse Logical, whether or not to show the reverse switch. +#' @param show.transparency Logical, whether or not to show the transparency slider. +#' @param single.colors Logical, whether or not to make a single color chooser. (Only if length(label) == 1 needed) +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @section Single color mode: +#' If one or more single colors can be chosen, the UI element names are prefix by \emph{color} followed by \code{make.names} ouput of \code{label}. +#' +#' @section To do: +#' Replace ordinary textInput for single colors by a real colorPicker, e.g. from https://github.com/daattali/colourpicker +#' +#' @export +colorPickerUI <- function(id, label = "Color scheme", choices = c("Blues", "Greens", "Greys", "Oranges", "Purples", "Reds"), selected.choice = NULL, show.reverse = TRUE, show.transparency = TRUE, single.colors = FALSE) { + ns <- shiny::NS(id) + + if(is.null(selected.choice)) { + selected.choice <- choices[[1]] + } + + if(length(label) == 1 & !single.colors) { + ret <- list(shiny::selectInput(ns("scheme"), label = label, choices = choices, selected = selected.choice)) + + if(show.reverse) { + ret <- c(ret, list(shiny::checkboxInput(ns("reverse"), label = "Reverse scheme"))) + } + } else { + ret <- list() + for(name in make.names(label)) { + ret <- c(ret, list(colourpicker::colourInput(ns(paste0("color", name)), name, value = "red"))) + } + } + + if(show.transparency) { + ret <- c(ret, list(shiny::sliderInput(ns("transparency"), label = "Transparency", min = 0, max = 1, value = 1))) + } + shiny::tagList(ret) +} + +#' colorPicker module server logic +#' +#' Provides server logic for the colorPicker module. +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' +#' @return The \code{input} object. +#' +#' @section To do: +#' Implement transparency calculation in case of one or more single colors. +#' +#' @export +colorPicker <- function(input, output, session) { + return(input) +} + diff --git a/R/colorPicker2.R b/R/colorPicker2.R new file mode 100644 index 0000000..48ba1f2 --- /dev/null +++ b/R/colorPicker2.R @@ -0,0 +1,262 @@ +#' colorPicker2 module UI representation +#' +#' The functions creates HTML tag definitions of its representation based on the parameters supplied. +#' Currently, two UI can be created for the user to choose either (a) colors from a given color scheme, or (b) choose one or more single colors. +#' +#' @param id The ID of the modules namespace. +#' @param label Either a character vector of length one with the label for the color scheme dropdown, or a character vector containing labels of the single colors. +#' @param custom Boolean if TRUE custom colors can be selected (Default = FALSE). +#' @param multiple Boolean value, if set to TRUE custom colorpalettes can be made. Only if custom = TRUE (Default = FALSE). +#' @param show.reverse Logical, whether or not to show the reverse switch (Default = TRUE). +#' @param show.scaleoptions Logical, whether or not to show color scaling option winorize (Default = TRUE). +#' @param show.transparency Logical, whether or not to show the transparency slider (Default = TRUE). +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +colorPicker2UI <- function(id, label = "Color scheme", custom = FALSE, multiple = FALSE, show.reverse = TRUE, show.scaleoptions = TRUE, show.transparency = TRUE) { + ns <- shiny::NS(id) + + if(custom){ + ret <- list(colourpicker::colourInput(ns("picker"), label = NULL, value = "red")) + + if(multiple){ + ret <- list( + shinyjs::useShinyjs(), + shinyBS::tipify(shiny::textInput(ns("palette"), label = NULL, value = "red,blue", placeholder = "e.g. black,#3c8dbc"), title = "Comma delimited colors (hex or name)", placement = "right"), + ret, + shiny::actionButton(ns("add"), "add", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "reset", style = "color: #fff; background-color: #3c8dbc") + ) + } + + ret <- list(shiny::tags$b(label), ret) + }else{ + ret <- list(shiny::tags$b(label), shiny::uiOutput(ns("palette"))) + } + + if(!custom | custom & multiple){ + if(show.reverse) { + ret <- c(ret, list(shiny::checkboxInput(ns("reverse"), label = "Reverse scheme"))) + } + if(show.scaleoptions) { + ret <- c(ret, limitUI(ns("winsorize"), label = "Winsorize to upper/lower")) + } + if(show.transparency) { + ret <- c(ret, list(shiny::sliderInput(ns("transparency"), label = "Transparency", min = 0, max = 1, value = 1))) + } + } + + shiny::tagList(ret) +} + +#' colorPicker2 module server logic +#' +#' Provides server logic for the colorPicker2 module. +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param num.colors Define length of colorpalette vector (Default = 256). +#' @param distribution Decide which palettes are selectable. One or more of list("sequential", "diverging", "categorical"). Defaults to "all" (Supports reactive). +#' @param winsorize Numeric vector of two. Dynamicly change lower and upper limit (supports reactive). Defaults to NULL. +#' @param selected Set the default selected palette. +#' +#' @details A custom colorpalette's return will be NULL if there is something wrong with it. +#' @details equalize will be returned as FALSE if not selected. +#' +#' @return Reactive containing list(palette = c(colors), name = palette_name, transparency = Integer, reverse = Boolean, winsorize = NULL or a two-component vector containing lower and upper limits). +#' +#' @export +colorPicker2 <- function(input, output, session, num.colors = 256, distribution = "all", winsorize = NULL, selected = NULL) { + Sequential <- sequentialPalettes(num.colors) + Diverging <- divergingPalettes(num.colors) + Categorical <- categoricalPalettes(num.colors) + + shinyjs::reset("reverse") + shinyjs::reset("transparency") + + #handle reactive distribution + distribution.r <- shiny::reactive({ + if(shiny::is.reactive(distribution)){ + distribution() + }else{ + distribution + } + }) + + if(!is.null(winsorize)) { + # handle reactive winsorize + winsorize.r <- shiny::reactive({ + if(shiny::is.reactive(winsorize)) { + winsorize() + } else { + winsorize + } + }) + } + limits <- shiny::callModule(limit, "winsorize", lower = if(!is.null(winsorize)){shiny::reactive(winsorize.r()[1])}, upper = if(!is.null(winsorize)){shiny::reactive(winsorize.r()[2])}) + + output$palette <- shiny::renderUI({ + choices <- list() + + if("sequential" %in% distribution.r()) choices <- append(choices, list(Sequential = names(Sequential))) + if("diverging" %in% distribution.r()) choices <- append(choices, list(Diverging = names(Diverging))) + if("categorical" %in% distribution.r()) choices <- append(choices, list(Categorical = names(Categorical))) + if(length(distribution.r()) == 1 && distribution.r() == "all") { + choices <- list(Sequential = names(Sequential), Diverging = names(Diverging), Categorical = names(Categorical)) + } + + shiny::selectInput(session$ns("palette"), label = NULL, choices = choices, selected = selected) + }) + + shiny::observeEvent(input$add, { + pal <- ifelse(input$palette == "", input$picker, paste(input$palette, input$picker, sep = ",")) + + shiny::updateTextInput(session, "palette", value = pal) + }) + + shiny::observeEvent(input$reset, { + shiny::updateTextInput(session, "palette", value = "") + }) + + #create custom colorpalette + custom <- shiny::reactive({ + #returns TRUE if String is a valid color + isColor <- function(x){ + res <- try(grDevices::col2rgb(x),silent=TRUE) + return(!"try-error"%in%class(res)) + } + + pal <- unlist(strsplit(input$palette, split = ",", fixed = TRUE)) + + if(length(pal) != 0){ + valid <- unlist(lapply(pal, isColor)) + if(!all(valid)){ + shiny::showNotification(id = session$ns("notification"), shiny::HTML(paste("ColorPicker
Found invalid colors: ", paste(pal[!valid], collapse = ", "))), duration = NULL, type = "warning") + pal <- NULL + }else{ + shiny::removeNotification(id = session$ns("notification")) + pal <- grDevices::colorRampPalette(pal)(num.colors) + } + }else{ + shiny::showNotification(id = session$ns("notification"), shiny::HTML("ColorPicker
Warning no colors selected!"), duration = NULL, type = "warning") + pal <- NULL + } + + return(pal) + }) + + output <- shiny::reactive({ + if(is.null(input$palette)){ + #custom single color + pal <- input$picker + }else{ + #predefined palettes + if(is.null(shiny::isolate(input$picker))){ + #get palette + if(input$palette %in% names(Sequential)){ + pal <- Sequential[[input$palette]] + }else if(input$palette %in% names(Diverging)){ + pal <- Diverging[[input$palette]] + }else { + pal <- Categorical[[input$palette]] + } + }else{ + #custom palettes (multiple colors) + pal <- custom() + } + #reverse palette + if(!is.null(input$reverse)){ + if(input$reverse){ + pal <- rev(pal) + } + } + } + + winsorize <- NULL + if(!is.null(limits())) { + winsorize <- c(limits()$lower, limits()$upper) + } + + list( + palette = pal, + name = input$palette, + transparency = input$transparency, + reverse = input$reverse, + winsorize = winsorize + ) + }) + + return(output) +} + +#' Function to generate sequential (one-sided) color palettes (e.g. for expression, enrichment) +#' +#' @param n Number of colors to generate +#' +#' @return A data.table with (named) color palettes of length n +#' +sequentialPalettes <- function(n) { + Heat <- grDevices::colorRampPalette(rev(RColorBrewer::brewer.pal(9, "YlOrRd")))(n) + Viridis <- viridis::viridis(n) + Magma <- viridis::magma(n) + Inferno <- viridis::inferno(n) + Plasma <- viridis::plasma(n) + YlGnBu <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "YlGnBu"))(n) + Blues <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "Blues"))(n) + Reds <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "Reds"))(n) + Cubehelix <- rje::cubeHelix(n) + + BkOrYl <- grDevices::colorRampPalette(c("black", "orange", "yellow"))(n) #one-sided (0 .. x): go enrichment + GnBu <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "GnBu"))(n) #one-sided (0 .. x): expression + PuBuGn <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "PuBuGn"))(n) #one-sided (0 .. x): expression + BuGnYlRd <- grDevices::colorRampPalette(c("#000041", "#0000CB", "#0081FF", "#02DA81", "#80FE1A", "#FDEE02", "#FFAB00", "#FF3300"))(n) #one-sided (0 .. x): expression, ~=spectral + + data.table::data.table(Heat, Viridis, Magma, Inferno, Plasma, YlGnBu, Blues, Reds, Cubehelix, BkOrYl, PuBuGn) +} + +#' Function to generate diverging (two-sided) color palettes (e.g. for log2fc, zscore) +#' +#' @param n Number of colors to generate +#' +#' @return A data.table with (named) color palettes of length n +#' +divergingPalettes <- function(n) { + BuWtRd <- grDevices::colorRampPalette(c("royalblue4", "steelblue4", "white", "indianred", "firebrick4"))(n) + RdBkGr <- gplots::redgreen(n) + RdYlGr <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdYlGn"))(n) + YlWtPu <- grDevices::colorRampPalette(c("gold", "white", "white", "mediumpurple4"))(n) #two-sided (-1 .. +1): correlation + Spectral <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "Spectral"))(n) + + BuYlGn <- grDevices::colorRampPalette(c("dodgerblue4", "cadetblue1", "yellow", "darkolivegreen1", "darkgreen"))(n) #two-sided (-x .. +x): fold-change + TqWtRd <- grDevices::colorRampPalette(c("darkslategray", "darkturquoise", "cornsilk", "indianred3", "red3"))(n) #two-sided (-x .. +x): fold-change + YlGyRd <- grDevices::colorRampPalette(c("yellow", "grey25", "red"))(n) #two-sided (-x .. +x): fold-change + RdBu <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "RdBu"))(n) #two-sided (-x .. +x): fold-change + GnWtRd <- grDevices::colorRampPalette(c("chartreuse3", "white", "firebrick1"))(n) #two-sided (-x .. +x): fold-change + RdYlBu <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdYlBu"))(n) #two-sided (-x .. +x): fold-change + RdGy <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "RdGy"))(n) #two-sided (-x .. +x): fold-change + PuOr <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(11, "PuOr"))(n) #two-sided (-x .. +x): fold-change + + data.table::data.table(BuWtRd, Spectral, RdBkGr, YlWtPu, BuYlGn, GnWtRd, RdGy, PuOr) +} + +#' Function to generate categorical (qualitative) color palettes +#' +#' @param n Number of colors to generate +#' +#' @return A data.table with (named) color palettes of length n +#' +categoricalPalettes <- function(n) { + Accent <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(8, "Accent"))(n) + Dark2 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(8, "Dark2"))(n) + Paired <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Paired"))(n) + Pastel1 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "Pastel1"))(n) + Pastel2 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(8, "Pastel2"))(n) + Set1 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(9, "Set1"))(n) + Set2 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(8, "Set2"))(n) + Set3 <- grDevices::colorRampPalette(RColorBrewer::brewer.pal(12, "Set3"))(n) + + data.table::data.table(Accent, Dark2, Paired, Pastel1, Pastel2, Set1, Set2, Set3) +} + diff --git a/R/columnSelector.R b/R/columnSelector.R new file mode 100644 index 0000000..a06320c --- /dev/null +++ b/R/columnSelector.R @@ -0,0 +1,159 @@ +#' columnSelector module UI representation +#' +#' @param id The ID of the modules namespace. +#' @param label Boolean value; if true include a text input field with the desired axis label (this should be preset with the headline of the column) +#' @param title String which is displayed as module title. (Default = NULL) +#' +#' @return A list from \code{\link[shiny]{tag}} with the UI elements. +#' +#' @export +columnSelectorUI <- function(id, label = F, title = NULL) { + #create namespace + ns <- shiny::NS(id) + + shiny::tagList( + shiny::tags$b(title), + shiny::HTML(""), + shiny::uiOutput(ns("out")), + {if(label) shiny::uiOutput(ns("showLabel"))} + ) +} + +#' columnSelector module server logic +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param type.columns data.table: (Supports reactive) +#' column1 = columnnames (id) +#' column2 = type (datalevel) +#' column3 = label (optional, used instead of id) +#' column4 = sub_label (optional, added to id/ label) +#' @param type The type (contrast/group/sample of the type dropdown menu, selected in step 1 (upper dropdown). Defaults to unique(type.columns[,2]) (Supports reactive) +#' @param columnTypeLabel Changes the label of the first UI element +#' @param labelLabel Change label above label text input. +#' @param multiple Boolean value whether multiple values can be selected in second selector. (Default = TRUE) +#' @param none If TRUE adds "None to secondSelector and select is. (Default = FALSE) +#' @param sep Used to seperate labels on multi value selection. +#' @param suffix Added to label only on multiple = FALSE (supports reactive). Also uses sep as seperator. +#' +#' @return Returns the input. As named list: names("type", "selectedColumns", "label") +#' +#' @export +columnSelector <- function(input, output, session, type.columns, type = NULL, columnTypeLabel = "Type of Column", labelLabel = "Label", multiple = TRUE, none = FALSE, sep = ", ", suffix = NULL) { + #handle reactive input + type.columns.r <- shiny::reactive({ + if(shiny::is.reactive(type.columns)){ + type.columns() + }else{ + type.columns + } + }) + type.r <- shiny::reactive({ + if(!is.null(type)){ + if(shiny::is.reactive(type)){ + type() + }else{ + type + } + }else{ + unique(type.columns.r()[[2]]) + } + }) + suffix.r <- shiny::reactive({ + if(shiny::is.reactive(suffix)) { + suffix() + } else { + suffix + } + }) + + output$out <- shiny::renderUI({ + if(none){ + choices <- c("None", type.columns.r()[type.columns.r()[[2]] %in% type.r()[1]][[1]]) + }else{ + choices <- type.columns.r()[type.columns.r()[[2]] %in% type.r()[1]][[1]] + } + columnSelectLabel = "Select individual column" + if(multiple) { + columnSelectLabel = paste0(columnSelectLabel, "(s)") + } + shiny::tagList( + shiny::selectInput(session$ns("select.type"), label = columnTypeLabel, choices = type.r(), selected = type.r()[1], multiple = FALSE), + shiny::selectizeInput(session$ns("select.column"), label = columnSelectLabel, choices = choices, multiple = multiple) + ) + }) + + #show label textInput + output$showLabel <- shiny::renderUI({ + shiny::textInput(session$ns("select.label"), label = labelLabel) + }) + + # make label + create_label <- shiny::reactive({ + if(ncol(type.columns.r()) > 2) { + label_id <- input$select.column + label_label <- type.columns.r()[type.columns.r()[[1]] %in% input$select.column][[3]] + + # replace id with label + label <- ifelse(label_label == "", label_id, label_label) + + if(ncol(type.columns.r()) > 3) { + label <- paste(label, type.columns.r()[type.columns.r()[[1]] %in% input$select.column][[4]]) + } + } else { + label <- input$select.column + } + + label <- paste(label, collapse = sep) + + return(label) + }) + + # update label + shiny::observe({ + input$select.column + suffix.r() + + shiny::isolate({ + if(!is.null(input$select.label)) { + if(!multiple && !is.null(suffix.r())) { + value <- paste(create_label(), suffix.r(), sep = sep) + } else { + value <- create_label() + } + shiny::updateTextInput(session = session, inputId = "select.label", value = value) + } + }) + }) + + #show columns based on selected type + shiny::observe({ + if(none){ + columns <- c("None", type.columns.r()[type.columns.r()[[2]] %in% input$select.type][[1]]) + }else{ + columns <- type.columns.r()[type.columns.r()[[2]] %in% input$select.type][[1]] + } + + shiny::updateSelectizeInput(session = session, inputId = "select.column", choices = columns) + }) + + out.type <- shiny::reactive(input$select.type) + out.selectedColumns <- shiny::reactive(ifelse(input$select.column == "None", "", input$select.column)) + out.label <- shiny::reactive({ + if(is.null(input$select.label)) { + label <- create_label() + } else { + label <- input$select.label + } + + if(multiple) { + label <- unlist(strsplit(label, split = sep, fixed = TRUE)) + } + + return(label) + }) + + return(list(type = out.type, selectedColumns = out.selectedColumns, label = out.label)) + +} diff --git a/R/featureSelector.R b/R/featureSelector.R new file mode 100644 index 0000000..0bce69f --- /dev/null +++ b/R/featureSelector.R @@ -0,0 +1,356 @@ +#' featureSelector module UI representation +#' +#' @param id The ID of the modules namespace +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}} +#' +#' @export +featureSelectorUI <- function(id){ + ns <- shiny::NS(id) + + shiny::tagList( + shiny::fluidPage( + rintrojs::introjsUI(), + shiny::fluidRow( + shinydashboard::box(width = 12, collapsible = TRUE, + shiny::div(id = ns("guide_table"), + DT::dataTableOutput(ns("table")), + shiny::br(), + shiny::uiOutput(ns("row_select")) + ) + ) + ), + shiny::fluidRow( + shinydashboard::box(width = 12, + shiny::fluidRow( + shiny::column(width = 12, + shiny::div(id = ns("guide_buttons"), + shiny::actionButton(ns("select"), "Select", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "Reset", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")) + ) + + ) + ), + shiny::div(id = ns("guide_and"), + shiny::br(), + shiny::uiOutput(ns("and.container")) + ) + ) + ) + ) + ) +} + +#' featureSelector module server logic +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param data data.table from which to select (Supports reactive). +#' @param features List of features (i.e. columnnames) the and module will show (Defaults to names(data))(Supports reactive). +#' @param feature.grouping Display features seperated in boxes. (Data.table: first column = columnnames, second column = groupnames) (Supports reactive) +#' @param delimiter A single character, or a vector indicating how column values are delimited. (Fills vector sequentially if needed)(Supports reactive) +#' @param multiple Whether or not textual ORs should allow multiple selections. (Fills vector sequentially if needed)(Supports reactive) +#' @param contains Whether or not textual ORs are initialized as textInput checking entries for given string. (Fills vector sequentially if needed)(Supports reactive) +#' @param ranged Whether or not numeric ORs are ranged. (Fills vector sequentially if needed)(Supports reactive) +#' @param step Set numeric ORs slider steps. (Fills vector sequentially if needed)(Supports reactive) +#' @param truncate Truncate datatable entries at x characters (Default = 30). +#' @param selection.default Decide whether everything or nothing is selected on default (no filters applied). Either "all" or "none" (Default = "all"). +#' +#' @details Keep in mind that the order of features is the order in which delimiter, multiple, contains, ranged and step are evaluated. +#' +#' @return Reactive containing names list: Selected data as reactive containing data.table (data). Used filter to select data (filter). +#' +#' @export +featureSelector <- function(input, output, session, data, features = NULL, feature.grouping = NULL, delimiter = "|", multiple = TRUE, contains = FALSE, ranged = TRUE, step = 100, truncate = 30, selection.default = "all"){ + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data.table::copy(data()) + }else{ + data.table::copy(data) + } + }) + + #handle reactive features + features.r <- shiny::reactive({ + if(is.null(features)){ + names(data.r()) + }else{ + if(shiny::is.reactive(features)){ + if(is.null(features())){ + names(data.r()) + }else{ + features() + } + }else{ + features + } + } + }) + + #handle reactive grouping + feature.grouping.r <- shiny::reactive({ + if(shiny::is.reactive(feature.grouping)){ + feature.grouping() + }else{ + feature.grouping + } + }) + + and_selected <- shiny::callModule(and, "and", data = data.r, show.elements = features.r, element.grouping = feature.grouping.r, delimiter = delimiter, multiple = multiple, contains = contains, ranged = ranged, step = step, reset = shiny::reactive(input$reset)) + row_selector <- shiny::callModule(orNumeric, "row_selector", choices = choices, value = value_wrapper, label = "Select TopX features:", stepsize = 1) + + # row_selector choices + choices <- shiny::reactive({ + if(nrow(data_output()$data) > 0) { + c(1:nrow(data_output()$data)) + } else { + c(0, 0) + } + }) + + # row_selector value; saves last values + value <- shiny::reactiveVal(value = NULL) + + # select all if no values stored + value_wrapper <- shiny::reactive({ + if(is.null(value())) { + value(c(min(choices()), max(choices()))) + } + + value() + }) + + # safe row_selector value + shiny::observeEvent(input$select, { + if(shiny::isTruthy(input$table_rows_selected)) { + if(grepl("outer", row_selector()$text)) { # accomodate for outer selection + diff <- setdiff(input$table_rows_all, input$table_rows_selected) + value(c(min(diff), max(diff))) + } else { + value(c(min(input$table_rows_selected), max(input$table_rows_selected))) + } + } else { + value(NULL) + } + }) + # reset row_selector value on data change + shiny::observeEvent(data.r(), { + value(NULL) + }) + + # reset row_selector + shiny::observeEvent(input$reset, { + value(NULL) + row_selector <<- shiny::callModule(orNumeric, "row_selector", choices = choices, value = value_wrapper, label = "Select TopX features:", stepsize = 1) + }) + + #Fetch reactive guide for this module + guide <- featureSelectorGuide(session, !is.null(feature.grouping)) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide(), scrollToElement = FALSE)) + }) + + output$and.container <- shiny::renderUI({ + andUI(session$ns("and")) + }) + + output$row_select <- shiny::renderUI({ + ui <- orNumericUI(session$ns("row_selector")) + + shiny::tagList( + shiny::fluidRow( + shiny::column( + width = 4, + shiny::column( + width = 5, + ui[1] + ), + shiny::column( + width = 1, + #added css so that padding won't be added everytime (sums up) modal is shown + shiny::tags$style(type="text/css", "body {padding-right: 0px !important;}"), + shiny::actionLink(session$ns("infobutton"), label = NULL, icon = shiny::icon("question-circle")) + ) + ), + shiny::column( + width = 1, + ui[2] + ), + shiny::column( + width = 7, + ui[3] + ) + ) + ) + }) + + # row selector info + shiny::observeEvent(input$infobutton, { + title <- "Select TopX features" + content <- "Subset the TopX features from the currently selected candidates." + + shiny::showModal( + shiny::modalDialog( + title = title, + footer = shiny::modalButton("close"), + easyClose = TRUE, + size = "s", + content + ) + ) + }) + + # access data table information + proxy <- DT::dataTableProxy(session$ns("table")) + + # select rows via row_selector + shiny::observe({ + shiny::req(row_selector()$bool, input$table_rows_all) + + row_order <- input$table_rows_all + + # don't select whole table + if(any(row_selector()$bool == FALSE) & length(row_selector()$bool) == length(row_order)) { + DT::selectRows(proxy, row_order[row_selector()$bool]) + } else { + # delete selection + DT::selectRows(proxy, list()) + } + }) + + output$table <- DT::renderDataTable(options = list(pageLength = 5, scrollX = TRUE, deferRender = TRUE, processing = FALSE, #deferRender = only render visible part of table + columnDefs = list(list( + targets = "_all", + render = DT::JS( + "function(data, type, row) {", + paste("var length =", truncate), + "return typeof data !== 'number' && type === 'display' && data.length > length ?", + "'' + data.substr(0, length) + '...' : data;", + "}" + ) + )) + ), { + data_output()$data + }) + + # first filter (and) whole set in table + select <- shiny::eventReactive(eventExpr = input$select, { + data <- data.r()[and_selected()$bool] + }) + + # second filter (highlighted rows) selected via click and/ or 'select rows' ui + result <- shiny::reactive({ + # create subset + if(!is.null(input$table_rows_selected)) { + data <- data_output()$data[input$table_rows_selected] + } else if(!is.null(input$table_rows_all)) { + data <- data_output()$data[input$table_rows_all] + } else { + data <- data_output()$data + } + + # expand filter + filter <- data_output()$filter + + # number of rows selected + if(!is.null(input$table_rows_selected)) { + filter <- append(filter, after = 1, + values = paste("Selected:", length(input$table_rows_selected)) + ) + } + + #TODO add order information to filter + + # search text + if(!is.null(input$table_search)) { + if(nchar(input$table_search) > 0) { + hits <- ifelse(is.null(input$table_rows_all), 0, length(input$table_rows_all)) + filter <- append(filter, after = 1, + values = paste("Search:", paste0("'", input$table_search, "'"), paste0("(Hits: ", hits, ")")) + ) + } + } + + return(list(data = data, filter = filter)) + }) + + # store change + data_change <- shiny::reactiveVal(value = 0) + + # return on file change unprocessed table + data_output <- shiny::reactive({ + if(data_change() == 0) { + if(selection.default == "all") { + data <- data.r() + } else if(selection.default == "none") { + data <- data.r()[FALSE] + } + + # create filter text + filter <- paste("Result:" , nrow(data), "hits") + } else if(data_change() == 1) { + data <- select() + + # create filter text + filter <- c(paste("Result:", nrow(data), "hits"), "", shiny::isolate(and_selected()$text)) + } + + return(list(data = data , filter = filter)) + }) + + # observe most recent change + shiny::observe({ + data.r() + data_change(0) + }) + shiny::observe({ + select() + data_change(1) + }) + + return(result) +} + +#' featureSelector module guide +#' +#' @param session The shiny session +#' @param grouping Logical if Text for grouping should be displayed (Default = FALSE). +#' +#' @return A shiny reactive that contains the texts for the guide steps. +#' +featureSelectorGuide <- function(session, grouping = FALSE) { + steps <- list( + "guide_and" = paste0("

Selectors

+ The selectors are presented row-wise, so that each line represents a seperate selector.
+ Each one operates on a single column of the dataset defined by the columnname on the left side.
+ Basically there are two different types of selectors: one for numeric values and one for text.
+ For further information on how to use any of those close this guide and click on one of the infobuttons ", shiny::icon("question-circle"), "."), + "guide_and" = "

Set filter

+ As mentioned before each selector is connected to a specific column.
+ So in order to apply a filter and create a specific subset adjust the selectors as needed.
+ The sum of those adjustments will be the filter used in the next step.", + "guide_buttons" = "

Apply filter

+ After the filter is set as intended, click on 'select' to filter the dataset, or click on 'reset' to delete the current filter.", + "guide_table" = "

Further limit dataset

+ Once the filter is successfully applied the remaining data is shown in this table.
+
+ The table along with the slider provides the following possibilities:
+ reorder: Change the row order ascending/descending by clicking on the respective column name.
+ text search: Use the field on the top right for text search.
+ select rows: Either use the slider or directly click on rows to select only certain rows in the table." + ) + + if(grouping) { + steps <- append(steps, + list("guide_and" = "

Grouping

+ These boxes contain several selectors each.
+ Expand/ Collapse them with a click on the '+'/ '-' on the right side.
+ Please expand now one or more of those boxes."), + 0) + } + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/function.R b/R/function.R new file mode 100644 index 0000000..74e30f7 --- /dev/null +++ b/R/function.R @@ -0,0 +1,1140 @@ +#' Method for scatter plot creation +#' +#' @param data data.table containing plot data +#' column 1: id +#' column 2, 3(, 4): x, y(, z) +#' @param transparency Set point transparency. See \code{\link[ggplot2]{geom_point}}. +#' @param pointsize Set point size. See \code{\link[ggplot2]{geom_point}}. +#' @param labelsize Set label size. See \code{\link[ggplot2]{geom_text}}. +#' @param colors Vector of colors used for color palette +#' @param x_label Label x-Axis +#' @param y_label Label Y-Axis +#' @param z_label Label Z-Axis +#' @param density Boolean value, perform 2d density estimate. +#' @param line Boolean value, add reference line. +#' @param categorized Z-Axis (if exists) as categories. +#' @param highlight.data data.table containing data to highlight. +#' @param highlight.labels Vector of labels used for highlighted data. +#' @param highlight.color String with hexadecimal color-code. +#' @param xlim Numeric vector of two setting min and max limit of x-axis. See \code{\link[ggplot2]{lims}}. +#' @param ylim Numeric vector of two setting min and max limit of y-axis. See \code{\link[ggplot2]{lims}}. +#' @param colorbar.limits Vector with min, max values for colorbar (Default = NULL). +#' @param width Set plot width in cm (Default = "auto"). +#' @param height Set plot height in cm (Default = "auto"). +#' @param ppi Pixel per inch (default = 72). +#' @param plot.method Whether the plot should be 'interactive' or 'static' (Default = 'static'). +#' +#' @details Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +#' +#' @import data.table +#' +#' @return Returns list(plot = ggplotly/ ggplot, width, height, ppi, exceed_size). +create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize = 3, colors = NULL, x_label = "", y_label = "", z_label = "", density = T, line = T, categorized = F, highlight.data = NULL, highlight.labels = NULL, highlight.color = "#FF0000", xlim = NULL, ylim = NULL, colorbar.limits = NULL, width = "auto", height = "auto", ppi = 72, plot.method = "static"){ + ########## prepare data ########## + #set labelnames if needed + x_label <- ifelse(nchar(x_label), x_label, names(data)[2]) + y_label <- ifelse(nchar(y_label), y_label, names(data)[3]) + if(ncol(data) >= 4){ z_label <- ifelse(nchar(z_label), z_label, names(data)[4])} + + # make column names unqiue to prevent overwrite + columnnames <- names(data) + names(data) <- make.unique(columnnames) + if(!is.null(highlight.data)) { + columnnames.highlight <- names(highlight.data) + names(highlight.data) <- make.unique(columnnames.highlight) + } + + # get intern columnnames + x_head <- names(data)[2] + y_head <- names(data)[3] + if(ncol(data) >= 4){ z_head <- names(data)[4]} + + #delete rows where both 0 or at least one NA + rows.to.keep.data <- which(as.logical((data[,2] != 0) + (data[,3] != 0))) + data <- data[rows.to.keep.data] + if(!is.null(highlight.data)){ + rows.to.keep.high <- which(as.logical((highlight.data[,2] != 0) + (highlight.data[,3 != 0]))) + highlight.data <- highlight.data[rows.to.keep.high] + } + + #delete labels accordingly + if(is.null(highlight.data)){ + highlight.labels <- highlight.labels[rows.to.keep.data] + }else{ + highlight.labels <- highlight.labels[rows.to.keep.high] + } + + ########## assemble plot ########## + theme1 <- ggplot2::theme ( #no gray background or helper lines + plot.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.line.x = ggplot2::element_line(size=.3), + axis.line.y = ggplot2::element_line(size=.3), + axis.title.x = ggplot2::element_text(face="bold", color="black", size=10), + axis.title.y = ggplot2::element_text(face="bold", color="black", size=10), + plot.title = ggplot2::element_text(face="bold", color="black", size=12) + # legend.background = element_rect(color = "red") #border color + # legend.key = element_rect("green") #not working! + ) + + ###z-axis exists? + if(ncol(data) >= 4){ + plot <- ggplot2::ggplot(data = data) + + ###scatter with color axis + if(categorized == FALSE){ + plot <- plot + + ###color_gradient + ggplot2::scale_color_gradientn(colors = colors, name = z_label, limits = colorbar.limits, oob = scales::squish) + + ###scatter with categories + }else if(categorized == TRUE){ + #change categorized column to factor + data <- data[, (z_head) := as.factor(data[[z_head]])] + + ###categorized plot + plot <- plot + + + ggplot2::scale_color_manual ( + #labels = data[,z_head], + values = grDevices::colorRampPalette(colors)(length(unique(data[[z_head]]))), #get color for each value, + #breaks = , + drop=FALSE, #to avoid dropping empty factors + name = z_label + # guide=guide_legend(title="sdsds" ) #legend for points + ) + } + #set names + plot <- plot + ggplot2::aes_(x = as.name(x_head), y = as.name(y_head), color = as.name(z_head)) + }else{ + plot <- ggplot2::ggplot(data = data, ggplot2::aes_(x = as.name(x_head),y = as.name(y_head))) + } + + if(density == TRUE){ + ### kernel density + #plot$layers <- c(stat_density2d(geom="tile", aes(fill=..density..^0.25), n=200, contour=FALSE,) + aes_(fill=as.name(var)), plot$layers)#n=resolution; density less sparse + plot <- plot + ggplot2::stat_density2d(geom="tile", ggplot2::aes(fill=..density..^0.25), n=200, contour=FALSE) + + plot <- plot + ggplot2::scale_fill_gradient(low="white", high="black") + + #guides(fill=FALSE) + #remove density legend + + ggplot2::labs(fill="Density") + } + + if(line == TRUE){ + ### diagonal line + plot <- plot + ggplot2::geom_abline(intercept=0, slope=1) + } + + plot <- plot + + ggplot2::xlab(x_label) + #axis labels + ggplot2::ylab(y_label) + + # interactive points with hovertexts + if(plot.method == "interactive") { + #set hovertext + if(ncol(data) >=4){ + hovertext <- paste0("
", data[[1]], + "
", x_label, ": ", data[[x_head]], + "
", y_label, ": ", data[[y_head]], + "
", z_label, ": ", data[[z_head]]) + }else{ + hovertext <- paste0("
", data[[1]], + "
", x_label, ": ", data[[x_head]], + "
", y_label, ": ", data[[y_head]]) + } + + #set points + plot <- plot + ggplot2::geom_point(size=pointsize, alpha=transparency, ggplot2::aes(text = hovertext)) + + if(!is.null(highlight.data)){ + #set highlighted hovertext + if(ncol(data) >=4){ + hovertext.high <- paste0("
", highlight.data[[1]], + "
", x_label, ": ", highlight.data[[x_head]], + "
", y_label, ": ", highlight.data[[y_head]], + "
", z_label, ": ", highlight.data[[z_head]]) + }else{ + hovertext.high <- paste0("
", highlight.data[[1]], + "
", x_label, ": ", highlight.data[[x_head]], + "
", y_label, ": ", highlight.data[[y_head]]) + } + + #set highlighted points + plot <- plot + ggplot2::geom_point(size = pointsize, alpha = transparency, inherit.aes = TRUE, data = highlight.data, color = highlight.color, show.legend = FALSE, ggplot2::aes(text = hovertext.high)) + } + # static points without hovertexts + } else if(plot.method == "static") { + seed <- Sys.getpid() + Sys.time() + # set points + plot <- plot + ggplot2::geom_point(size = pointsize, alpha = transparency) + + # set highlighted points + if(!is.null(highlight.data)) { + plot <- plot + ggplot2::geom_point(size = pointsize, alpha = transparency, inherit.aes = TRUE, data = highlight.data, color = highlight.color, show.legend = FALSE) + + # set repelling point labels + if(!is.null(highlight.labels)) { + plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, alpha = 0.5, seed = seed) + plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, seed = seed) + } + # set repelling labels (for only highlighted points shown) + } else if(!is.null(highlight.labels) & length(highlight.labels) == nrow(data)) { + plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, alpha = 0.5, seed = seed) + plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, seed = seed) + } + } + + #set axis limits + if(!is.null(xlim)){ + plot <- plot + ggplot2::xlim(xlim) + } + if(!is.null(ylim)){ + plot <- plot + ggplot2::ylim(ylim) + } + + plot <- plot + theme1 + + + + #estimate legend width + legend.width <- 0 + legend.padding <- 20 # 10 on both sides + legend.thickness <- 30 + if(density){ + legend.width <- nchar("Density") + } + if(ncol(data) > 3){ + legend.width <- ifelse(legend.width > nchar(z_label), legend.width, nchar(z_label)) + } + if(density | ncol(data) > 3){ + #estimate tickwidth + min.tick <- nchar(as.character(min(data[[3]], na.rm = TRUE))) * 8.75 + max.tick <- nchar(as.character(max(data[[3]], na.rm = TRUE))) * 8.75 + legend.thickness <- legend.thickness + ifelse(min.tick < max.tick, max.tick, min.tick) + + legend.width <- legend.width * 8.75 + legend.width <- ifelse(legend.width > legend.thickness, legend.width, legend.thickness) + legend.padding + } + + #set width/ height + if(width == "auto"){ + # cm to px + width <- 28 * (ppi / 2.54) + legend.width + } else { + width <- width * (ppi / 2.54) + } + if(height == "auto"){ + # cm to px + height <- 28 * (ppi / 2.54) + } else { + height <- height * (ppi / 2.54) + } + + # size exceeded? + exceed_size <- FALSE + limit <- 500 * (ppi / 2.54) + if(width > limit) { + exceed_size <- TRUE + width <- limit + } + if(height > limit) { + exceed_size <- TRUE + height <- limit + } + + if(plot.method == "interactive") { + plot <- plotly::ggplotly(plot, width = width + legend.width, height = height, tooltip = "text") + + # add labels with arrows + if(!is.null(highlight.labels)) { + if(!is.null(highlight.data)) { + plot <- plotly::add_annotations(p = plot, x = highlight.data[[x_head]], y = highlight.data[[y_head]], text = highlight.labels, standoff = pointsize, font = list(size = labelsize), bgcolor = 'rgba(255, 255, 255, 0.5)') + } else if(nrow(data) == length(highlight.labels)) { + plot <- plotly::add_annotations(p = plot, x = data[[x_head]], y = data[[y_head]], text = highlight.labels, standoff = pointsize, font = list(size = labelsize), bgcolor = 'rgba(255, 255, 255, 0.5)') + } + } + } + + # pixel to cm + width <- width / (ppi / 2.54) + height <- height / (ppi / 2.54) + + + return(list(plot = plot, width = width, height = height, ppi = ppi, exceed_size = exceed_size)) +} + +#' Method for pca creation. +#' +#' @param data data.table from which the plot is created (First column will be handled as rownames if not numeric). +#' @param dimensionA Number of dimension displayed on X-Axis. +#' @param dimensionB Number of dimension displayed on Y-Axis. +#' @param dimensions Number of dimesions to create. +#' @param on.columns Boolean perform pca on columns or rows. +#' @param labels Boolean show labels. +#' @param custom.labels Vector of custom labels. Will replace columnnames. +#' @param pointsize Size of the data points. +#' @param labelsize Size of texts inside plot (default = 3). +#' @param width Set the width of the plot in cm (default = 28). +#' @param height Set the height of the plot in cm (default = 28). +#' @param ppi Pixel per inch (default = 72). +#' +#' @details If width and height are the same axis ratio will be set to one (quadratic plot). +#' @details Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +#' +#' @import data.table +#' +#' @return A named list(plot = ggplot object, data = pca.data, width = width of plot (cm), height = height of plot (cm), ppi = pixel per inch, exceed_size = Boolean whether width/ height exceeded max). +create_pca <- function(data, dimensionA = 1, dimensionB = 2, dimensions = 6, on.columns = TRUE, labels = FALSE, custom.labels = NULL, pointsize = 2, labelsize = 3, width = 28, height = 28, ppi = 72) { + requireNamespace("FactoMineR", quietly = TRUE) + requireNamespace("factoextra", quietly = TRUE) + + # prepare data ------------------------------------------------------------ + # set custom labels + if(!is.null(custom.labels)) { + if(!is.numeric(data[[1]])) { + colnames(data)[-1] <- custom.labels + } else { + colnames(data) <- custom.labels + } + } + + #remove rows with NA + data <- stats::na.omit(data) + + #check for rownames + if(!is.numeric(data[[1]])){ + rownames <- data[[1]] + data[, 1 := NULL] + }else{ + rownames <- NULL + } + + #transpose + if(on.columns){ + data_t <- t(data) + if(!is.null(rownames)){ + colnames(data_t) <- rownames + } + }else{ + data_t <- as.matrix(data) + if(!is.null(rownames)){ + rownames(data_t) <- rownames + } + } + + #check if PCA possible + if(ncol(data_t) < 3){ + stop(paste("PCA requires at least 3 elements. Found:", ncol(data_t))) + } + + #remove constant rows (=genes with the same value for all samples) + data_t <- data_t[, apply(data_t, 2, function(x) min(x, na.rm = TRUE) != max(x, na.rm = TRUE))] + + pca <- FactoMineR::PCA(data_t, scale.unit = TRUE, ncp = dimensions, graph = FALSE) + + # plot -------------------------------------------------------------------- + theme1 <- ggplot2::theme ( #no gray background or helper lines + plot.background = ggplot2::element_blank(), + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + panel.border = ggplot2::element_blank(), + panel.background = ggplot2::element_blank(), + axis.line.x = ggplot2::element_line(size=.3), + axis.line.y = ggplot2::element_line(size=.3), + axis.title.x = ggplot2::element_text(color="black", size=11), + axis.title.y = ggplot2::element_text(color="black", size=11), + #plot.title = element_text(color="black", size=12), + plot.title = ggplot2::element_blank(), + legend.title= ggplot2::element_blank(), + text= ggplot2::element_text(size = 12) #size for all (legend?) labels + #legend.key = element_rect(fill="white") + ) + + pca_plot <- factoextra::fviz_pca_ind(pca, axes = c(dimensionA, dimensionB), invisible = "none", pointsize = pointsize, label = "none", axes.linetype = "blank", repel = FALSE) + pca_plot <- pca_plot + theme1 + + if(labels) { + pca_plot <- pca_plot + ggrepel::geom_text_repel( + data = data.frame(pca$ind$coord), + mapping = ggplot2::aes_(x = pca$ind$coord[, dimensionA], y = pca$ind$coord[, dimensionB], label = rownames(pca$ind$coord)), + segment.color = "gray65", + size = labelsize, + force = 2, + max.iter = 10000, + point.padding = grid::unit(0.1, "lines") + ) + } + + #ensure quadratic plot + # if(width == height){ + # pca_plot <- pca_plot + ggplot2::coord_fixed(ratio = 1) + # } + + # size exceeded? + exceed_size <- FALSE + if(width > 500) { + exceed_size <- TRUE + width <- 500 + } + if(height > 500) { + exceed_size <- TRUE + height <- 500 + } + + return(list(plot = pca_plot, data = pca, width = width, height = height, ppi = ppi, exceed_size = exceed_size)) +} + +#' Method for heatmap creation +#' +#' @param data data.table containing plot data. First column contains row labels. +#' @param unitlabel label of the colorbar +#' @param row.label Logical whether or not to show row labels. +#' @param row.custom.label Vector of custom row labels. +#' @param column.label Logical whether or not to show column labels. +#' @param column.custom.label Vector of custom column labels. +#' @param clustering How to apply clustering on data. c("none", "both", "column", "row") +#' @param clustdist Which cluster distance to use. See \code{\link[heatmaply]{heatmapr}}. +#' @param clustmethod Which cluster method to use. See \code{\link[heatmaply]{heatmapr}}. +#' @param colors Vector of colors used for color palette. +#' @param winsorize.colors NULL or a vector of length two, giving the values of colorbar ends (default = NULL). +#' @param plot.method Choose which method is used for plotting. Either "plotly" or "complexHeatmap" (Default = "complexHeatmap"). +#' @param width Set width of plot in cm (Default = "auto"). +#' @param height Set height of plot in cm (Default = "auto"). +#' @param ppi Pixel per inch (default = 72). +#' +#' @details Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +#' +#' @return Returns list(plot = complexHeatmap/ plotly object, width = width in cm, height = height in cm, ppi = pixel per inch, exceed_size = Boolean whether width/ height exceeded max) depending on plot.method. +create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label = NULL, column.label=T, column.custom.label = NULL, clustering='none', clustdist='auto', clustmethod='auto', colors=NULL, winsorize.colors = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72) { + requireNamespace("heatmaply", quietly = TRUE) + requireNamespace("ComplexHeatmap", quietly = TRUE) + requireNamespace("grDevices", quietly = TRUE) + requireNamespace("circlize", quietly = TRUE) + + #row label + if(!is.null(row.custom.label)) { + row.label.strings <- row.custom.label + } else { + row.label.strings <- data[[1]] + } + + # column label + if(!is.null(column.custom.label)) { + column.label.strings <- column.custom.label + } else { + column.label.strings <- names(data)[-1] + } + + # cm to pixel + if(is.numeric(width)) { + width <- width * (ppi / 2.54) + } + if(is.numeric(height)) { + height <- height * (ppi / 2.54) + } + + # plot -------------------------------------------------------------------- + if(plot.method == "interactive"){ + #estimate label sizes + #row label + rowlabel_size <- ifelse(row.label, max(nchar(data[[1]]), na.rm = TRUE) * 8, 0) + #column label + collabel_size <- ifelse(column.label, (2 + log2(max(nchar(names(data)), na.rm = TRUE))^2) * 10, 0) + #legend + legend <- nchar(unitlabel) * 10 + legend <- ifelse(legend < 90, 90, legend) + #plot size + #auto_width <- 20 * (ncol(data) - 1) + rowlabel_size + legend + auto_height <- 10 * nrow(data) + collabel_size + + #data + plot <- heatmaply::heatmapr(data[, -1], + labRow = row.label.strings, + labCol = column.label.strings, + hclust_method = clustmethod, + dist_method = clustdist, + dendrogram = clustering, + distfun = factoextra::get_dist + #width = width, #not working + #height = height + ) + + #layout + plot <- heatmaply::heatmaply(plot, + plot_method = "ggplot", + scale_fill_gradient_fun = ggplot2::scale_fill_gradientn(colors = colors, name = unitlabel, limits = winsorize.colors, oob = scales::squish) + ) + + plot <- plotly::layout(plot, autosize = ifelse(width == "auto", TRUE, FALSE), margin = list(l = rowlabel_size, r = legend, b = collabel_size)) + + # decide which sizes should be used + if(width == "auto") { + width <- 0 + # } else if(width <= auto_width) { + # width <- auto_width + } + if(height == "auto") { + height <- auto_height + } + + # size exceeded? + exceed_size <- FALSE + limit <- 500 * (ppi / 2.54) + if(width > limit) { + exceed_size <- TRUE + width <- limit + } + if(height > limit) { + exceed_size <- TRUE + height <- limit + } + + plot$x$layout$width <- width + plot$x$layout$height <- height + + #address correct axis + if(clustering == "both" || clustering == "column"){ + plot <- plotly::layout(plot, xaxis = list(showticklabels = column.label), + yaxis2 = list(showticklabels = row.label) + ) + }else if(clustering == "row" || clustering == "none"){ + plot <- plotly::layout(plot, xaxis = list(showticklabels = column.label), + yaxis = list(showticklabels = row.label) + ) + } + + #don't show dendrogram ticks + if(clustering == "row"){ + plot <- plotly::layout(plot, xaxis2 = list(showticklabels = FALSE) + ) + }else if(clustering == "column"){ + plot <- plotly::layout(plot, yaxis = list(showticklabels = FALSE) + ) + } + + # pixel to cm + width <- width / (ppi / 2.54) + height <- height / (ppi / 2.54) + + plot <- list(plot = plot, width = width, height = height, ppi = ppi, exceed_size = exceed_size) + }else if(plot.method == "static"){ + + #clustering + if (clustering=='none') { + cluster_rows=F + cluster_columns=F + } else if (clustering=='row') { + cluster_rows=T + cluster_columns=F + } else if (clustering=='column') { + cluster_rows=F + cluster_columns=T + } else if (clustering=='both') { + cluster_rows=T + cluster_columns=T + } + + # + # Create new colour brakepoints in case of winsorizing + # + if(!is.null(winsorize.colors)) { + breaks <- seq(winsorize.colors[1], winsorize.colors[2], length = length(colors)) + colors <- circlize::colorRamp2(breaks, colors) + } + + #convert data to data.frame so rownames can be used for annotation + prep.data <- as.data.frame(data[, -1]) + + row.names(prep.data) <- row.label.strings + colnames(prep.data) <- column.label.strings + + plot <- ComplexHeatmap::Heatmap( + prep.data, + name = unitlabel, + col = colors, + cluster_rows = cluster_rows, + cluster_columns = cluster_columns, + clustering_distance_rows = clustdist, + clustering_distance_columns = clustdist, + clustering_method_rows = clustmethod, + clustering_method_columns = clustmethod, + show_row_names = row.label, + show_column_names = column.label, + row_names_side = "left", + row_dend_side = "right", + row_dend_width = grid::unit(1, "inches"), + column_dend_height = grid::unit(1, "inches"), + row_names_max_width = grid::unit(8, "inches"), + column_names_max_height = grid::unit(4, "inches"), + row_names_gp = grid::gpar(fontsize = 12), + column_names_gp = grid::gpar(fontsize = 12), + column_title_gp = grid::gpar(fontsize = 10, units = "in"), + heatmap_legend_param = list( + color_bar = "continuous", + legend_direction = "horizontal" + ) + ) + + #width/ height calculation + col_names_maxlength_label_width=max(sapply(colnames(prep.data), graphics::strwidth, units="in", font=12)) #longest column label when plotted in inches + col_names_maxlength_label_height=max(sapply(colnames(prep.data), graphics::strheight, units="in", font=12)) #highest column label when plotted in inches + row_names_maxlength_label_width=max(sapply(rownames(prep.data), graphics::strwidth, units="in", font=12)) #longest row label when plotted in inches + row_names_maxlength_label_height=max(sapply(rownames(prep.data), graphics::strheight, units="in", font=12)) #highest row label when plotted in inches + + # width + if(row.label){ + auto_width <- row_names_maxlength_label_width + 0.3 #width buffer: labels + small whitespaces + }else{ + auto_width <- 0.3 #no labels + } + + if(cluster_rows) auto_width <- auto_width + 1 #width buffer: dendrogram + small whitespaces between viewports + + auto_width <- ncol(prep.data) * (col_names_maxlength_label_height + 0.08) + auto_width #readable rowlabels + # inch to px + auto_width <- auto_width * ppi + + # height + auto_height <- 0.2 + 0.5 + (5 * row_names_maxlength_label_height) #height buffer: small whitespaces + color legend + 2 title rows(+whitespace) + + if(column.label) auto_height <- auto_height + col_names_maxlength_label_width + if(cluster_columns) auto_height <- auto_height + 1 + + auto_height <- auto_height + nrow(prep.data) * (row_names_maxlength_label_height + 0.06) + # inch to px + auto_height <- auto_height * ppi + + # use auto sizes + if(height == "auto") { + height <- auto_height + } + if(width == "auto") { + width <- auto_width + } + + # pixel to cm + width <- width / (ppi / 2.54) + height <- height / (ppi / 2.54) + + # size exceeded? + exceed_size <- FALSE + if(width > 500) { + exceed_size <- TRUE + width <- 500 + } + if(height > 500) { + exceed_size <- TRUE + height <- 500 + } + + plot <- list(plot = plot, width = width, height = height, ppi = ppi, exceed_size = exceed_size) + } + + return(plot) +} + +#' Method for geneView creation +#' +#' @param data data.table containing plot data +#' @param grouping data.table metadata containing: +#' column1 : key +#' column2 : factor1 +#' @param plot.type String specifing which plot type is used c("box", "line", "violin", "bar"). +#' @param facet.target Target to plot on x-Axis c("gene", "condition"). +#' @param facet.cols Number of plots per row. +#' @param colors Vector of colors used for color palette +#' @param ylabel Label of the y-axis (default = NULL). +#' @param ylimits Vector defining scale of y-axis (default = NULL). +#' @param gene.label Vector of labels used instead of gene names (default = NULL). +#' @param plot.method Choose which method used for plotting. Either "static" or "interactive" (Default = "static"). +#' @param width Set the width of the plot in cm (default = "auto"). +#' @param height Set the height of the plot in cm (default = "auto"). +#' @param ppi Pixel per inch (default = 72). +#' +#' @details Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +#' +#' @import data.table +#' +#' @return Returns depending on plot.method list(plot = ggplot/ plotly object, width = width in cm, height = height in cm, ppi = pixel per inch, exceed_size = Boolean). +create_geneview <- function(data, grouping, plot.type = "line", facet.target = "gene", facet.cols = 2, colors = NULL, ylabel = NULL, ylimits = NULL, gene.label = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72){ + #grouping + #group by factor if existing (fill with key if empty) + grouping[grouping[[2]] == "", 2 := grouping[grouping[[2]] == "", 1]] + + genes <- nrow(data) #number of genes (rows in matrix) + conditions <- length(unique(grouping[[2]])) #number of conditions (columns in matrix) + + ################### + # Combine and transform dataframes + ################### + #detach ids from data/ replace with gene.label + if(is.null(gene.label)) { + data_id <- data[[1]] + } else { + data_id <- gene.label + } + data <- data[, sapply(data, is.numeric), with = FALSE] + + data_cols <- names(data) + data <- data.table::transpose(data) #switch columns <> rows + + #place former colnames in cols + data$cols <- data_cols + data.table::setcolorder(data, c("cols", colnames(data)[1:ncol(data)-1])) + #reattach ids as colnames + names(data)[2:ncol(data)] <- data_id + + names(grouping)[1:2] <- c("cols", "condition") #add header for condition + data <- data[grouping, on = c(names(grouping)[1])] #merge dataframes by rownames + names(data)[1] <- "sample" #change Row.names to sample + data[, sample := NULL] #completely remove sample column again + #order conditions in plot according to grouping (instead of alphabetic) + data[, condition := factor(condition, levels = unique(condition))] + + data <- data.table::melt(data, id.vars = "condition") + + ################### + # Choose color palette + ################### + if (facet.target == "gene") { #facet = gene + num_colors <- conditions + } + if (facet.target == "condition") { #facet = condition + num_colors <- genes + } + + + if (is.null(colors)) { + color_fill_grayscale="grey75" #color to use for filling geoms in grayscale mode + colors <- rep(color_fill_grayscale,num_colors) + }else{ + colors <- grDevices::colorRampPalette(colors)(num_colors) + } + + ################### + # Function to get standard error for error bars (box, bar, violin) + ################### + get.se <- function(y){ + se <- stats::sd(y) / sqrt(length(y)) + mu <- mean(y) + data.frame(ymin = mu-se, y = y, ymax = mu+se) + } + + ################### + # Function to collapse the dataframe to the mean and the standard deviation/error before plotting (ONLY used for line plot) + ################### + + # data : a data frame + # varname : the name of a column containing the variable to be summarized + # groupnames : vector of column names to be used as grouping variables + data_summary <- function(data, varname, groupnames){ + summary_func <- function(x, col){ + c( + mean = mean(x[[col]], na.rm=TRUE), + sd = stats::sd(x[[col]], na.rm=TRUE), + se = stats::sd(x[[col]], na.rm=TRUE) / sqrt(length(x[[col]])) + ) + } + data_sum <- plyr::ddply(data, groupnames, .fun=summary_func, varname) + data_sum <- reshape::rename(data_sum, c("mean" = varname)) + return(data_sum) + } + if (plot.type == "line") { + data = data_summary(data, varname = "value", groupnames = c("condition", "variable")) #collapse the dataframe to the mean and the standard deviation for line plot + } + + if (plot.type == "box" || plot.type == "violin" || plot.type == "bar" || plot.type == "line") { + ################### + # Set common parameters for all plots + ################### + + # plot -------------------------------------------------------------------- + + theme1 <- ggplot2::theme( #no gray background or helper lines + panel.grid.major = ggplot2::element_blank(), + panel.grid.minor = ggplot2::element_blank(), + axis.text.x = ggplot2::element_text(angle = 90, hjust = 1, vjust = 1), #x-axis sample lables = 90 degrees + strip.background = ggplot2::element_blank(), + panel.border = ggplot2::element_rect(colour = "black"), + legend.position = "none", #remove legend + legend.title = ggplot2::element_blank(), + axis.title.x = ggplot2::element_blank(), + text = ggplot2::element_text(family = "mono", size = 15) + + #axis.line.x = element_line(size = .3), + #axis.line.y = element_line(size = .3), + #panel.background = element_blank(), + #axis.title.y = element_text(face = "bold", color = "black", size = 10), + #plot.title = element_text(face = "bold", color = "black", size = 12), + #axis.text.x = element_text(angle = 90, hjust = 1) #x-axis sample lables = vertical + ) + + matrixplot <- ggplot2::ggplot(data, ggplot2::aes(y = value)) + + matrixplot <- matrixplot + + ggplot2::theme_bw() + theme1 + + ggplot2::ylab(ylabel) + + ggplot2::xlab("") + + ggplot2::scale_fill_manual(values = colors) + + ggplot2::scale_color_manual(values = colors) + + ################### + # Handle facetting and special parameters for line plot (no facetting, etc.) + ################### + + if (facet.target == "gene") { #facet = gene + matrixplot = matrixplot + ggplot2::aes(x = condition, fill = condition) + + if (plot.type == "line") { #line plot: no facetting, different size algorithm + matrixplot <- matrixplot + ggplot2::aes(x = variable, colour = condition, group = condition, fill = NULL) + matrixplot <- matrixplot + ggplot2::scale_x_discrete(expand = c(0.05, 0.05)) #expand to reduce the whitespace inside the plot (left/right) + } else { + #compute number of rows to get facet.cols columns (works better with plotly) + rows <- ceiling(length(levels(data$variable)) / facet.cols) + + matrixplot <- matrixplot + ggplot2::facet_wrap(~variable, nrow = rows, scales = "free_x") + } + } + if (facet.target == "condition") { #facet = condition + matrixplot <- matrixplot + ggplot2::aes(x = variable, fill = variable) + + if (plot.type == "line") { #line plot: no facetting, different size algorithm + matrixplot <- matrixplot + ggplot2::aes(x = condition, colour = variable, group = variable, fill = NULL) + matrixplot <- matrixplot + ggplot2::scale_x_discrete(expand = c(0.05,0.05)) #expand to reduce the whitespace inside the plot (left/right) + } else { + #compute number of rows to get facet.cols columns (works better with plotly) + rows <- ceiling(length(levels(data$condition)) / facet.cols) + + matrixplot <- matrixplot + ggplot2::facet_wrap(~condition, nrow = rows, scales = "free_x") + } + } + + ################### + # Further handle plot types + ################### + + if (plot.type == "box") { #plot type: box + matrixplot <- matrixplot + ggplot2::geom_boxplot(position = ggplot2::position_dodge(1)) + matrixplot <- matrixplot + ggplot2::stat_boxplot(geom = 'errorbar', size = 0.2, width = 0.5) #add horizontal line for errorbar + #matrixplot <- matrixplot + stat_summary(fun.data = get.se, geom = "errorbar", width = 0.2) #error bar of standard error + } + if (plot.type == "violin") { #plot type: violin + matrixplot <- matrixplot + ggplot2::geom_violin() + #matrixplot <- matrixplot + stat_summary(fun.y = "median", geom = "point") #add median dot + #matrixplot <- matrixplot + stat_summary(fun.data = get.se, geom = "errorbar", width = 0.2, position = position_dodge()) #error bar of standard error + } + if (plot.type == "bar") { #plot type: box + matrixplot <- matrixplot + ggplot2::stat_summary(fun.y = mean, geom = "bar", position = "dodge") #bar plot of the mean (color=condition) + matrixplot <- matrixplot + ggplot2::stat_summary(fun.data = get.se, geom = "errorbar", size = 0.2, width = 0.2, position = ggplot2::position_dodge()) #error bar of standard error + } + if (plot.type == "line") { + matrixplot <- matrixplot + ggplot2::theme(legend.position = "right") + #matrixplot <- matrixplot + geom_errorbar(aes(ymin = value-sd, ymax = value + sd), width = 0.05) #error bar = standard deviation + matrixplot <- matrixplot + ggplot2::geom_errorbar(ggplot2::aes(ymin = value - se, ymax = value + se), size = 0.2, width = 0.05) #error bar = standard error + matrixplot <- matrixplot + ggplot2::geom_line() + ggplot2::geom_point() #bar plot of the mean (color=condition) + #set hovertext + matrixplot <- matrixplot + ggplot2::aes(text = paste("ID: ", data$variable, "\n", + "Condition: ", data$condition, "\n", + "Value: ", data$value + )) + } + + # set y-axis ticks + y_ticks <- pretty(data[["value"]]) + if(length(data[["value"]]) != 1) { + if(!is.null(ylimits)) { + y_ticks <- pretty(ylimits) + } + + matrixplot <- matrixplot + ggplot2::scale_y_continuous(breaks = y_ticks, limits = ylimits) + } else { + # change yaxis limits + if(!is.null(ylimits)) { + matrixplot <- matrixplot + ggplot2::ylim(ylimits) + } + } + } + + #get names of columns / rows + if(plot.type == "line"){ + if(facet.target == "gene"){ + column.names <- data[["variable"]] + legend.names <- data[["condition"]] + }else{ + column.names <- data[["condition"]] + legend.names <- data[["variable"]] + } + }else{ + if(facet.target == "condition"){ + column.names <- data[["variable"]] + title.names <- data[["condition"]] + }else{ + column.names <- data[["condition"]] + title.names <- data[["variable"]] + } + } + + #dynamic plot in inches + + #calculate cex for better strwidth calculation + ccex <- function(x){ + 2.3 - (x * log(1 + 1/x)) + } + + ###width estimation + yaxis_label_height <- graphics::strheight(ylabel, units = "inches") + if(length(data[["value"]]) == 1 && floor(data[["value"]]) == data[["value"]]) { + # adds three characters '.05'; account for single integer value plots + value <- data[["value"]] + 0.05 + } else { + value <- y_ticks + } + yaxis_tick_width <- max(graphics::strwidth(value, units = "inches"), na.rm = TRUE) + xaxis_tick_height <- max(graphics::strheight(column.names, units = "inches", cex = 2), na.rm = TRUE) * length(levels(column.names)) + ###height estimation + xaxis_tick_width <- max(graphics::strwidth(column.names, units = "inches", cex = ccex(max(nchar(levels(column.names))))), na.rm = TRUE) + + if(plot.type == "line"){ + ###width estimation + max_chars <- max(nchar(levels(legend.names)), na.rm = TRUE) + legend_width <- max(graphics::strwidth(legend.names, units = "inches", cex = ccex(max_chars)), na.rm = TRUE) + legend_columns <- 1 + (length(levels(legend.names))-1) %/% 20 + + auto_width <- 0.25 + yaxis_label_height + yaxis_tick_width + xaxis_tick_height + ((legend_width + 0.5) * legend_columns) + + ###height estimation + plot_height <- 4 + + #top margin to prevent legend cut off + top <- 0 + if(plot.method == "static"){ + margin.multiplier <- ceiling(length(levels(legend.names)) / legend_columns) + margin.multiplier <- ifelse(margin.multiplier < 17, 0, margin.multiplier - 17) + + top <- 0.1 * margin.multiplier + matrixplot <- matrixplot + ggplot2::theme(plot.margin = grid::unit(c(top + 0.1, 0, 0, 0), "inches")) + } + + auto_height <- plot_height + xaxis_tick_width + top + }else{ + ###width estimation + max_chars <- max(nchar(levels(title.names)), na.rm = TRUE) + + title_width <- max(graphics::strwidth(title.names, units = "inches", cex = ccex(max_chars)), na.rm = TRUE) + # prevent cut off for small titles + title.chars <- sum(nchar(levels(title.names))) + if(facet.cols == 1 && max(nchar(levels(title.names))) <= 20) { + title_width <- title_width + (-log10(max(nchar(levels(title.names)))) + 1.6) / 3 + } else if(title.chars <= 20) { + title_width <- title_width + (-log10(title.chars) + 1.4) / 3 + } + #TODO margin between plots (not really needed) + plots_per_row <- ceiling(length(levels(title.names))/ rows) + + auto_width <- yaxis_label_height + yaxis_tick_width + (ifelse(title_width > xaxis_tick_height, title_width, xaxis_tick_height) * plots_per_row) + + ###height estimation + title_height <- max(graphics::strheight(title.names, units = "inches", cex = 2), na.rm = TRUE) + plot_height <- 2 + + + auto_height <- (title_height + plot_height + xaxis_tick_width) * rows + } + + # size inch -> cm + auto_width <- auto_width * 2.54 + auto_height <- auto_height * 2.54 + + # use greater/ automatic sizes + if(width == "auto") { + width <- auto_width + } + if(height == "auto") { + height <- auto_height + } + + # size exceeded? + exceed_size <- FALSE + if(width > 500) { + exceed_size <- TRUE + width <- 500 + } + if(height > 500) { + exceed_size <- TRUE + height <- 500 + } + + # plotly ------------------------------------------------------------------ + if(plot.method == "interactive"){ + matrixplotly <- plotly::ggplotly( + tooltip = "text", + matrixplot, + width = width * (ppi / 2.54), + height = height * (ppi / 2.54) + ) + + plotly::layout(matrixplotly, autosize = FALSE) + + return(list(plot = matrixplotly, width = width, height = height, ppi = ppi, exceed_size = exceed_size)) + }else{ + return(list(plot = matrixplot, width = width, height = height, ppi = ppi, exceed_size = exceed_size)) + } +} + +#' Method to get equalized min/max values from vector +#' +#' @param values Numeric vector or table +#' +#' @return Vector with c(min, max). +equalize <- function(values){ + if(is.vector(values)){ + min <- abs(min(values, na.rm = TRUE)) + max <- abs(max(values, na.rm = TRUE)) + }else{ + min <- abs(min(apply(values, 2, function(x) {min(x, na.rm = TRUE)}))) + max <- abs(max(apply(values, 2, function(x) {max(x, na.rm = TRUE)}))) + } + + if(min > max){ + result <- min + }else{ + result <- max + } + + return(c(-1 * result, result)) +} + +#' Function to search data for selection +#' +#' @param input Vector length one (single) or two (ranged) containing numeric values for selection. +#' @param choices Vector on which input values are applied. +#' @param options Vector on how the input and choices should be compared. It can contain: single = c("=", "<", ">") or ranged = c("inner", "outer"). +#' @param min. Minimum value that can be selected on slider (defaults to min(choices)). +#' @param max. Maximum value that can be selected on slider (defaults to max(choices)). +#' +#' @return Returns a logical vector with the length of choices, where every matched position is TRUE. +searchData <- function(input, choices, options = c("=", "<", ">"), min. = min(choices, na.rm = TRUE), max. = max(choices, na.rm = TRUE)) { + #don't apply if no options selected + if(is.null(options)){ + return(rep(TRUE, length(choices))) + } + + if(length(input) > 1){ + #don't compare if everything is selected + if(options == "inner" & input[1] == min. & input[2] == max.){ + return(rep(TRUE, length(choices))) + } + + selection <- vapply(choices, FUN.VALUE = logical(1), function(x) { + # NA & NaN == FALSE + if(is.na(x) | is.nan(x)){ + return(FALSE) + } + + #range + if("inner" == options){ + if(x >= input[1] & x <= input[2]) return(TRUE) + } + if("outer" == options){ + if(x < input[1] | x > input[2]) return(TRUE) + } + + return(FALSE) + }) + }else{ + selection <- vapply(choices, FUN.VALUE = logical(1), function(x) { + # NA & NaN == FALSE + if(is.na(x) | is.nan(x)){ + return(FALSE) + } + + #single point + if(any("=" == options)){ + if(x == input) return(TRUE) + } + if(any("<" == options)){ + if(x < input) return(TRUE) + } + if(any(">" == options)){ + if(x > input) return(TRUE) + } + + return(FALSE) + }) + } + + return(selection) +} + +#' Function used for downloading. +#' Creates a zip container containing plot in png, pdf and user input in json format. +#' Use inside \code{\link[shiny]{downloadHandler}} content function. +#' +#' @param file See \code{\link[shiny]{downloadHandler}} content parameter. +#' @param filename See \code{\link[shiny]{downloadHandler}}. +#' @param plot Plot to download. +#' @param width in centimeter. +#' @param height in centimeter. +#' @param ppi pixel per inch. Defaults to 72. +#' @param ui List of user inputs. Will be converted to Javascript Object Notation. See \code{\link[RJSONIO]{toJSON}} +#' +#' @return See \code{\link[utils]{zip}}. +download <- function(file, filename, plot, width, height, ppi = 72, ui = NULL) { + # cut off file extension + name <- sub("(.*)\\..*$", replacement = "\\1", filename) + + # create tempfile names + plot_file_pdf <- tempfile(pattern = name, fileext = ".pdf") + plot_file_png <- tempfile(pattern = name, fileext = ".png") + if(!is.null(ui)) { + selection_file <- tempfile(pattern = "selection", fileext = ".json") + } else { + selection_file <- NULL + } + + # save plots depending on given plot object + if(ggplot2::is.ggplot(plot)) { + # ggplot + + ggplot2::ggsave(plot_file_pdf, plot = plot, width = width, height = height, units = "cm", device = "pdf") + ggplot2::ggsave(plot_file_png, plot = plot, width = width, height = height, units = "cm", device = "png", dpi = ppi) + } else if(class(plot)[1] == "plotly") { + # plotly + # change working directory temporary so mounted drives are not a problem + wd <- getwd() + setwd(tempdir()) + plotly::export(p = plot, file = plot_file_pdf) + plotly::export(p = plot, file = plot_file_png) + setwd(wd) + } else if(class(plot) == "Heatmap") { # TODO: find better way to check for complexHeatmap object + # complexHeatmap + grDevices::pdf(plot_file_pdf, width = width / 2.54, height = height / 2.54) # cm to inch + ComplexHeatmap::draw(plot, heatmap_legend_side = "bottom") + grDevices::dev.off() + grDevices::png(plot_file_png, width = width, height = height, units = "cm", res = ppi) + ComplexHeatmap::draw(plot, heatmap_legend_side = "bottom") + grDevices::dev.off() + } + + # vector with files to zip + files <- c(plot_file_pdf, plot_file_png) + + # save user input + if(!is.null(selection_file)) { + # make key = value pair using value of name variable + ui_list <- list() + ui_list[[name]] <- ui + + json <- RJSONIO::toJSON(ui_list, pretty = TRUE) + write(json, file = selection_file) + + files <- c(files, selection_file) + } + + # create zip file + utils::zip(zipfile = file, files = files, flags = "-j") # discard file path +} diff --git a/R/geneView.R b/R/geneView.R new file mode 100644 index 0000000..7ce41c8 --- /dev/null +++ b/R/geneView.R @@ -0,0 +1,429 @@ +#' geneView's module UI representation +#' +#' @param id The ID of the modules namespace. +#' @param plot.columns Initial value of plot column slider. Integer value between 1 and 7 (Default = 3). +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +geneViewUI <- function(id, plot.columns = 3){ + ns <- shiny::NS(id) + + shiny::tagList( + rintrojs::introjsUI(), + shinyjs::useShinyjs(), + shiny::fluidPage( + shiny::fluidRow( + shinydashboard::box( + width = 12, + shiny::div(style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center", + shiny::uiOutput(ns("geneView")) + ) + ) + ), + shiny::fluidRow( + shinydashboard::box( + width = 12, + collapsible = TRUE, + shiny::fluidRow( + shiny::column( + width = 3, + + shiny::div(id = ns("guide_geneSelection"), + shiny::HTML(""), + shiny::uiOutput(ns("genes"))), + shiny::div(id = ns("guide_genelabel"), + labelUI(ns("labeller"))) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_columnSelection"), + columnSelectorUI(ns("selector"), title = "Grouping:"), + shiny::selectInput(ns("groupby"), label = "by", choices = c("gene", "condition")) + ) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_type"), + shiny::selectInput(ns("plotType"), label = "Type of Plot", choices = c("box", "line", "violin", "bar"), selected = "line")), + shiny::div(id = ns("guide_transformation"), + transformationUI(id = ns("transform"), choices = list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore")), + shiny::textInput(ns("label"), label = "Y-Axis Label")), + shiny::div(id = ns("guide_limit"), + limitUI(id = ns("limit"), label = "Y-Axis Limit")) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_color"), + colorPicker2UI(id = ns("color"), show.transparency = FALSE, show.scaleoptions = FALSE)), + shiny::div(id = ns("guide_plotColumns"), + shiny::sliderInput(ns("plotColumns"), label = "Plot Columns", min = 1, max = 7, value = plot.columns, step = 1)) + ) + ), + shiny::fluidRow( + shiny::column( + width = 12, + shiny::div(id = ns("guide_buttons"), + shiny::actionButton(ns("plot"), "Plot", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "Reset", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")), + shiny::downloadButton(outputId = ns("download"), label = "Download") + ) + ) + ) + ) + ) + ) + ) +} +#' geneView's module server logic +#' +#' Provides server logic for the geneView module. +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param data data.table: +#' column1 : ids +#' column2 : symbol (data used for selection) +#' column3-n : data +#' @param metadata data.table: +#' column1: ids +#' column2: factor1 (conditions) +#' column3: level (condition type) +#' @param level Vector containing data levels to select from (default: unique(metadata[["level"]])). +#' @param plot.method Choose which method is used for plotting. Either "static" or "interactive" (Default = "static"). +#' @param custom.label Data.table used for creating custom labels (supports reactive). +#' @param label.sep Seperator used for label merging (Default = ", "). +#' @param width Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param height Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param ppi Pixel per inch. Defaults to 72 and supports reactive. +#' +#' @details Width/ height/ ppi less or equal to default will use default value. +#' @details Ppi less or equal to zero will use default. +#' +#' @return Reactive containing data.table used for plotting. +#' +#' @export + +geneView <- function(input, output, session, data, metadata, level = NULL, plot.method = "static", custom.label = NULL, label.sep = ", ", width = "auto", height = "auto", ppi = 72){ + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data.table::copy(data()) + }else{ + data.table::copy(data) + } + }) + metadata.r <- shiny::reactive({ + if(shiny::is.reactive(metadata)){ + metadata() + }else{ + metadata + } + }) + level.r <- shiny::reactive({ + if(is.null(level)){ + metadata[[3]] + }else if(shiny::is.reactive(level)){ + level() + }else{ + level + } + }) + # handle reactive sizes + size <- shiny::reactive({ + width <- ifelse(shiny::is.reactive(width), width(), width) + height <- ifelse(shiny::is.reactive(height), height(), height) + ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi) + + if(!is.numeric(width) || width <= 0) { + width <- "auto" + } + if(!is.numeric(height) || height <= 0) { + height <- "auto" + } + if(!is.numeric(ppi) || ppi <= 0) { + ppi <- 72 + } + + list(width = width, + height = height, + ppi = ppi) + }) + + #Fetch the reactive guide for this module + guide <- geneViewGuide(session, label = !is.null(custom.label)) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide())) + }) + + shiny::observeEvent(input$reset, { + shinyjs::reset("genes") + shinyjs::reset("plotType") + shinyjs::reset("groupby") + shinyjs::reset("plotColumns") + colorPicker <<- shiny::callModule(colorPicker2, "color", distribution = "all", selected = "Dark2") + transform <<- shiny::callModule(transformation, "transform", shiny::reactive(as.matrix(data.r()[, selector$selectedColumns(), with = FALSE]))) + selector <<- shiny::callModule(columnSelector, "selector", type.columns = shiny::reactive(metadata.r()[level %in% level.r(), c(1, 3)]), columnTypeLabel = "Select Columns") + if(!is.null(custom.label)) { + custom_label <<- shiny::callModule(label, "labeller", data = custom.label, sep = label.sep) + } + limiter <<- shiny::callModule(limit, "limit", lower = shiny::reactive(get_limits()[1]), upper = shiny::reactive(get_limits()[2])) + }) + + get_limits <- shiny::reactive({ + equalize(result.data()$data[, c(-1, -2)]) + }) + + colorPicker <- shiny::callModule(colorPicker2, "color", distribution = "all", selected = "Dark2") + transform <- shiny::callModule(transformation, "transform", shiny::reactive(as.matrix(data.r()[, selector$selectedColumns(), with = FALSE]))) + selector <- shiny::callModule(columnSelector, "selector", type.columns = shiny::reactive(metadata.r()[level %in% level.r(), c(1, 3)]), columnTypeLabel = "Select Columns") + if(!is.null(custom.label)) { + custom_label <- shiny::callModule(label, "labeller", data = custom.label, sep = label.sep) + } + limiter <- shiny::callModule(limit, "limit", lower = shiny::reactive(get_limits()[1]), upper = shiny::reactive(get_limits()[2])) + + output$genes <- shiny::renderUI({ + output <- shiny::selectizeInput(session$ns("genes"), label = "Select Genes", choices = NULL, multiple = TRUE) + #only fetch needed data (calculation on server-side) + shiny::updateSelectizeInput(session, "genes", choices = unique(data.r()[[2]]), server = TRUE) + + return(output) + }) + + output$level <- shiny::renderUI({ + shiny::selectInput(session$ns("level"), label = "Data level", choices = unique(level.r())) + }) + + shiny::observe({ + shiny::updateTextInput(session = session, inputId = "label", value = transform$method()) + }) + + #notification + shiny::observe({ + shiny::req(input$genes) + + if(length(input$genes) > 50){ + shiny::showNotification( + paste("Caution! You selected", length(input$genes), "genes. This may take a while to compute."), + duration = 5, + type = "warning", + id = "warning", + closeButton = FALSE + ) + }else{ + shiny::removeNotification("warning") + } + }) + + # warning if plot size exceeds limits + shiny::observe({ + if(plot()$exceed_size) { + shiny::showNotification( + ui = "Width and/ or height exceed limit. Using 500 cm instead.", + id = "limit", + type = "warning" + ) + } else { + shiny::removeNotification("limit") + } + }) + + result.data <- shiny::eventReactive(input$plot, { + result <- data.table::data.table(data.r()[, c(1, 2)], data.table::as.data.table(transform$data())) + + # label selected? + if(!is.null(custom.label)) { + # drop not selected + label <- custom_label()$label[which(result[[2]] %in% input$genes)] + } else { + label <- NULL + } + + result <- result[result[[2]] %in% input$genes] + + return(list(data = result, label = label)) + }) + + # disable downloadButton on init + shinyjs::disable("download") + + plot <- shiny::eventReactive(input$plot, { + # enable downloadButton + shinyjs::enable("download") + + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0, message = "Computing data") + + processed.data <- data.table::copy(result.data()$data) + + #extract symbol + processed.data <- processed.data[, -2] + + progress$set(0.33, message = "Calculating plot") + + #plot + plot <- create_geneview( + data = processed.data, + grouping = metadata.r()[level == selector$type() & key %in% selector$selectedColumns(), c(1, 2)], + plot.type = input$plotType, + facet.target = input$groupby, + facet.cols = input$plotColumns, + colors = colorPicker()$palette, + ylabel = input$label, + gene.label = result.data()$label, + ylimits = unlist(unname(limiter())), + plot.method = plot.method, + width = size()$width, + height = size()$height, + ppi = size()$ppi + ) + + progress$set(1, detail = "Return plot") + return(plot) + }) + + #enable plot button only if plot possible + shiny::observe({ + if(is.null(input$genes) | length(selector$selectedColumns()) < 1){ + shinyjs::disable("plot") + }else if(input$plotType == "violin"){ + factor1.levels <- metadata.r()[level == selector$type() & key %in% selector$selectedColumns() & factor1 != ""][, .N, keyby = factor1][["N"]] + + if(input$groupby == "condition"){ + #every level >= 3 times + factor1.levels <- ifelse(length(factor1.levels) > 0, factor1.levels, FALSE) + if(all(factor1.levels >= 3)){ + shinyjs::enable("plot") + }else{ + shinyjs::disable("plot") + } + }else if(input$groupby == "gene"){ + #at least one level >= 3 times + if(any(factor1.levels >= 3)){ + shinyjs::enable("plot") + }else{ + shinyjs::disable("plot") + } + } + }else{ + shinyjs::enable("plot") + } + }) + + output$geneView <- shiny::renderUI({ + if(plot.method == "interactive"){ + plotly::plotlyOutput(session$ns("interactive")) + }else if (plot.method == "static"){ + shiny::plotOutput(session$ns("static")) + } + }) + + if(plot.method == "interactive") { + output$interactive <- plotly::renderPlotly({ + #progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(message = "Rendering plot", value = 0) + + plot <- plot()$plot + + progress$set(value = 1) + return(plot) + }) + } else if(plot.method == "static") { + output$static <- shiny::renderPlot( + width = shiny::reactive(plot()$width * (plot()$ppi / 2.54)), + height = shiny::reactive(plot()$height * (plot()$ppi / 2.54)), + { + #progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(message = "Rendering plot", value = 0.3) + + plot <- plot()$plot + + progress$set(value = 1) + return(plot) + }) + } + + output$download <- shiny::downloadHandler(filename = "geneView.zip", + content = function(file) { + download(file = file, filename = "geneView.zip", plot = plot()$plot, width = plot()$width, height = plot()$height, ppi = plot()$ppi, ui = user_input()) + }) + + + user_input <- shiny::reactive({ + # format data + data <- list( + genes = input$genes, + columns = list(type = selector$type(), selectedColumns = selector$selectedColumns()), + groupby = input$groupby + ) + + # format options + if(!is.null(custom.label)) { + label <- custom_label()$selected + } else { + label <- NULL + } + options <- list( + plot_type = input$plotType, + transformation = transform$method(), + yaxis_label = input$label, + yaxis_limit = limiter(), + plot_column = input$plotColumns, + colors = list(scheme = colorPicker()$name, reverse = colorPicker()$reverse), + custom_label = label + ) + + # merge all + all <- list(data = data, options = options) + }) + + return(shiny::reactive(result.data()$data)) +} + +#' geneView module guide +#' +#' @param session The shiny session +#' @param label Boolean to show custom label step. +#' +#' @return A shiny reactive that contains the texts for the Guide steps. +#' +geneViewGuide <- function(session, label = FALSE) { + steps <- list( + "guide_geneSelection" = "

Gene selection

+ Select genes to be displayed.", + "guide_columnSelection" = "

Column selection

+ First select a column type for visualization, then select individual columns from all columns of the chosen type.
+ After that choose a factor by which the given subset is grouped. E.g. 'condition' will generate a plot for each condition or uses the conditions as x-axis ticks, based on the choosen plot type.", + "guide_type" = "

Plot type

+ Choose the preferred type of plot that will be rendered.", + "guide_transformation" = "

Data transformation

+ Pick a transformation that you want to apply to your data or leave it as 'None' if no transformation is needed.
+ The y-axis label will be changed according to transformation but can also be custom if wanted.", + "guide_limit" = "

Y-axis limit

+ Use upper/ lower limit to customize the axis limits.", + "guide_color" = "

Color palettes

+ Based on the selected data's distribution, one can choose between sequential, categorical or diverging color palettes.
+ The selected palette can additionally be reversed.", + "guide_plotColumns" = "

Plots per column

+ Select how many plots are displayed in each row or in other words how many columns are used. + This slider doesn't affect line plots as they are consisting of only one plot.", + "guide_buttons" = "

Create the plot

+ As a final step, a click on the 'Plot' button will render the plot, while a click on the 'Reset' button will reset the parameters to default." + ) + + if(label) { + steps <- append(steps, values = list("guide_genelabel" = "

Custom label

+ Select one or more columns to be used as a label instead of the names above."), + after = 1) + } + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/global_cor_heatmap.R b/R/global_cor_heatmap.R new file mode 100644 index 0000000..4ea4aea --- /dev/null +++ b/R/global_cor_heatmap.R @@ -0,0 +1,460 @@ +#' global correlation heatmap module UI representation +#' +#' @param id The ID of the modules namespace. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}} +#' +#' @export +global_cor_heatmapUI <- function(id) { + ns <- shiny::NS(id) + + shiny::tagList( + shiny::fluidPage( + # load additional functionality (e.g. guide, disable ui) + rintrojs::introjsUI(), + shinyjs::useShinyjs(), + # plot space + shiny::fluidRow( + shinydashboard::box( + width = 12, + shiny::div( + style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center", + shiny::uiOutput(ns("cor_heatmap")) + ) + ) + ), + # module options + shiny::fluidRow( + shinydashboard::box( + width = 12, + collapsible = TRUE, + shiny::fluidRow( + shiny::column( + width = 3, + shiny::div( + id = ns("guide_selection"), + columnSelectorUI(id = ns("select")) + ) + ), + shiny::column( + width = 3, + shiny::div( + id = ns("guide_calculate"), + shiny::selectInput( + inputId = ns("calc"), + label = "Calculate", + choices = c("distance", "correlation") + ), + shiny::selectInput( + inputId = ns("calc_method"), + label = "Calculation method", + choices = c("euclidean", "maximum", "manhattan", "canberra", "minkowski") + ) + ), + shiny::div( + id = ns("guide_cluster"), + shiny::selectInput( + inputId = ns("distance"), + label = "Cluster distance", + choices = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "pearson", "spearman", "kendall"), + multiple = FALSE + ), + shiny::selectInput( + inputId = ns("method"), + label = "Cluster method", + choices = c("average", "ward.D", "ward.D2", "single", "complete", "mcquitty"), + multiple = FALSE + ) + ) + ), + shiny::column( + width = 3, + shiny::div( + id = ns("guide_transformation"), + transformationUI(id = ns("transform"), choices = list(`None` = "raw", `regularized log` = "rlog")) + ), + shiny::div( + id = ns("guide_coloring"), + shiny::selectInput( + inputId = ns("distribution"), + label = "Data distribution", + choices = c("Sequential", "Diverging"), + multiple = FALSE + ), + colorPicker2UI( + id = ns("color"), + show.transparency = FALSE + ) + ) + ), + shiny::column( + width = 3, + shiny::div( + id = ns("guide_options"), + shiny::textInput( + inputId = ns("label"), + label = "Unit label", placeholder = "Enter unit..." + ), + shiny::checkboxInput( + inputId = ns("row_label"), + label = "Row label", + value = TRUE + ), + shiny::checkboxInput( + inputId = ns("column_label"), + label = "Column label", + value = TRUE + ) + ) + ) + ), + shiny::fluidRow( + shiny::column( + width = 12, + shiny::div( + id = ns("guide_buttons"), + shiny::actionButton( + inputId = ns("plot"), + label = "Plot", + style = "color: #fff; background-color: #3c8dbc" + ), + shiny::actionButton( + inputId = ns("reset"), + label = "Reset", + style = "color: #fff; background-color: #3c8dbc" + ), + shiny::actionButton( + inputId = ns("guide"), + label = "Launch guide", + style = "color: #fff; background-color: #3c8dbc", + icon = shiny::icon("question-circle") + ), + shiny::downloadButton( + outputId = ns("download"), + label = "Download" + ) + ) + ) + ) + ) + ) + ) + ) +} + +#' global correlation heatmap module server logic +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param data data.table data visualized in plot (supports reactive). +#' @param types data.table: (supports reactive) +#' column1: colnames of data +#' column2: corresponding column type +#' column3 = label (optional, used instead of id) +#' column4 = sub_label (optional, added to id/ label) +#' @param plot.method Choose which method is used for plotting. Either "static" or "interactive" (Default = "static"). +#' @param width Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param height Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param ppi Pixel per inch. Defaults to 72 and supports reactive. +#' +#' +#' +#' @return Reactive containing data used for plotting. +#' +#' @export +global_cor_heatmap <- function(input, output, session, data, types, plot.method = "static", width = "auto", height = "auto", ppi = 72) { + # load module ------------------------------------------------------------- + # handle reactive data + data_r <- shiny::reactive({ + if(shiny::is.reactive(data)) { + data <- data.table::copy(data()) + }else { + data <- data.table::copy(data) + } + + return(data) + }) + # handle reactive sizes + size <- shiny::reactive({ + width <- ifelse(shiny::is.reactive(width), width(), width) + height <- ifelse(shiny::is.reactive(height), height(), height) + ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi) + + if(!is.numeric(width) || width <= 0) { + width <- "auto" + } + if(!is.numeric(height) || height <= 0) { + if(plot.method == "interactive") { + height <- 28 + }else { + height <- "auto" + } + } + if(!is.numeric(ppi) || ppi <= 0) { + ppi <- 72 + } + + list(width = width, + height = height, + ppi = ppi) + }) + + # load internal modules + columns <- shiny::callModule(columnSelector, "select", type.columns = types, columnTypeLabel = "Column types to choose from") + transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(data_r()[, columns$selectedColumns(), with = FALSE]))) + colorPicker <- shiny::callModule(colorPicker2, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1]))) + + # load dynamic ui + if(plot.method == "static") { + output$cor_heatmap <- shiny::renderUI({ + shiny::plotOutput(outputId = session$ns("static")) + }) + }else if(plot.method == "interactive") { + output$cor_heatmap <- shiny::renderUI({ + plotly::plotlyOutput(outputId = session$ns("interactive")) + }) + } + + # functionality ----------------------------------------------------------- + # reset ui + shiny::observeEvent(input$reset, { + shinyjs::reset("calc") + shinyjs::reset("calc_method") + shinyjs::reset("distance") + shinyjs::reset("method") + shinyjs::reset("distribution") + shinyjs::reset("label") + shinyjs::reset("row_label") + shinyjs::reset("column_label") + columns <<- shiny::callModule(columnSelector, "select", type.columns = types, columnTypeLabel = "Column types to choose from") + transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(data_r()[, columns$selectedColumns(), with = FALSE]))) + colorPicker <<- shiny::callModule(colorPicker2, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1]))) + }) + + # warning if plot size exceeds limits + shiny::observe({ + if(plot()$exceed_size) { + shiny::showNotification( + ui = "Width and/ or height exceed limit. Using 500 cm instead.", + id = "limit", + type = "warning" + ) + } else { + shiny::removeNotification("limit") + } + }) + + # fetch the reactive guide for this module + guide <- global_cor_heatmap_guide(session) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide())) + }) + + # enable/ disable plot button + shiny::observe({ + if(length(columns$selectedColumns()) <= 1) { + shinyjs::disable("plot") + }else { + shinyjs::enable("plot") + } + }) + + # automatic unitlabel + shiny::observe({ + shiny::updateTextInput(session = session, inputId = "label", value = transform$method()) + }) + + # show right methods + shiny::observe({ + if(input$calc == "distance") { + shiny::updateSelectInput(session = session, inputId = "calc_method", + choices = c("euclidean", "maximum", "manhattan", "canberra", "minkowski")) + }else if(input$calc == "correlation") { + shiny::updateSelectInput(session = session, inputId = "calc_method", choices = c("spearman", "pearson", "kendall")) + } + }) + + # plotting ---------------------------------------------------------------- + # preprocess data + result_data <- shiny::eventReactive(input$plot, { + # progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Compute data") + + # process data + processed_data <- data.table::as.data.table(transform$data()) + processed_data <- processed_data[, columns$selectedColumns(), with = FALSE] + processed_data <- data.table::data.table(data_r()[, 1], processed_data) + + # corellate data + if(input$calc == "distance") { + processed_data <- data.table::as.data.table(as.matrix(stats::dist(t(processed_data[, -1]), method = input$calc_method)), keep.rownames = "Names") + }else if(input$calc == "correlation") { + processed_data <- data.table::as.data.table(stats::cor(processed_data[, -1], method = input$calc_method), keep.rownames = "Names") + } + + # update progress indicator + progress$set(1) + + return(processed_data) + }) + + # disable downloadButton on init + shinyjs::disable("download") + + # build plot object + plot <- shiny::eventReactive(input$plot, { + # enable downloadButton + shinyjs::enable("download") + + # progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Building plot") + + # check if rlog failed + if(is.null(attr(transform$data(), "betaPriorVar")) && is.null(attr(transform$data(), "intercept")) && transform$method() == "rlog") { + shiny::showNotification("Regularized log failed (dispersion within 2 orders of magnitude)! Performing log2 instead.", + duration = 5, + type = "warning") + + if(input$label == "rlog") { + unitlabel <- "log2" + shiny::updateTextInput(session = session, inputId = "label", value = unitlabel) + } else { + unitlabel <- input$label + } + } else { + unitlabel <- input$label + } + + # call create/ building function + plot <- create_heatmap( + data = result_data(), + unitlabel = unitlabel, + row.label = input$row_label, + row.custom.label = make.unique(columns$label()), + column.label = input$column_label, + column.custom.label = make.unique(columns$label()), + clustering = "both", + clustdist = input$distance, + clustmethod = input$method, + colors = colorPicker()$palette, + width = size()$width, + height = size()$height, + ppi = size()$ppi, + plot.method = plot.method, + winsorize.colors = colorPicker()$winsorize + ) + + # update progress indicator + progress$set(1) + + return(plot) + }) + + # render plot + if(plot.method == "static") { + output$static <- shiny::renderPlot( + width = shiny::reactive(plot()$width * (plot()$ppi / 2.54)), + height = shiny::reactive(plot()$height * (plot()$ppi / 2.54)), + { + # progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Rendering plot") + + # get plot + plot <- plot()$plot + + # update progress indicator + progress$set(1) + + # draw plot + return(ComplexHeatmap::draw(plot, heatmap_legend_side = "bottom")) + } + ) + }else if(plot.method == "interactive") { + output$interactive <- plotly::renderPlotly({ + # progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Rendering plot") + + plot <- plot()$plot + + # update progress indicator + progress$set(1) + + return(plot) + }) + } + + output$download <- shiny::downloadHandler(filename = "global_correlation_heatmap.zip", + content = function(file) { + download(file = file, filename = "global_correlation_heatmap.zip", plot = plot()$plot, width = plot()$width, height = plot()$height, ppi = plot()$ppi, ui = user_input()) + }) + + user_input <- shiny::reactive({ + # format selection + selection <- list(type = columns$type(), selectedColumns = columns$selectedColumns()) + + # format calculation + calculation <- list( + calculate = input$calc, + method = input$calc_method + ) + + # format clustering + clustering <- list( + distance = input$distance, + method = input$method + ) + + # format options + options <- list( + transformation = transform$method(), + color = list(distribution = input$distribution, scheme = colorPicker()$name, reverse = colorPicker()$reverse, winsorize = colorPicker()$winsorize), + unit_label = input$label, + row_label = input$row_label, + column_label = input$column_label + ) + + # merge all + all <- list(selection = selection, calculation = calculation, clustering = clustering, options = options) + }) + + # return plotting data + return(result_data) +} + +#' global correlation heatmap module guide +#' +#' @param session The shiny session +#' +#' @return A shiny reactive that contains the texts for the Guide steps. +#' +global_cor_heatmap_guide <- function(session) { + steps <- list( + "guide_selection" = "

Data selection

+ Select a column type for visualisation, then select individual columns from all columns of the chosen type.", + "guide_calculate" = "

Apply calculation

+ Either apply a distance function or correlate the data. Also choose which method should be used in order to do so.", + "guide_cluster" = "

Row & Column clustering

+ Select a clustering distance and method.", + "guide_transformation" = "

Data transformation

+ Pick a transformation that you want to apply to your data or leave it as 'None' if no transformation is needed.", + "guide_coloring" = "

Color palettes

+ Based on the selected data distribution, available color palettes are either sequential or diverging.
+ The selected palette can additionally be reversed.
+ Set the limits of the color palette with 'Winsorize to upper/lower'. Out of bounds values will be mapped to the nearest color.", + "guide_options" = "

Additional options

+ You can set a label for the color legend that describes the underlying data unit. Furthermore, you can enable/disable row and column labels.", + "guide_buttons" = "

Create the plot

+ As a final step click, a click on the Plot button will render the plot, while a click on the reset button will reset the parameters to default." + ) + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/heatmap.R b/R/heatmap.R new file mode 100644 index 0000000..c21cf92 --- /dev/null +++ b/R/heatmap.R @@ -0,0 +1,415 @@ +#' heatmap module UI representation +#' +#' @param id The ID of the modules namespace. +#' @param row.label Boolean Value set initial Value for rowlabel checkbox (Default = TRUE). +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +heatmapUI <- function(id, row.label = TRUE) { + ns <- shiny::NS(id) + + shiny::tagList(shiny::fluidPage( + rintrojs::introjsUI(), + shinyjs::useShinyjs(), + shiny::fluidRow(shinydashboard::box(width = 12, + shiny::div(style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center", + shiny::uiOutput(ns("heatmap"))))), + shiny::fluidRow( + shinydashboard::box( + width = 12, + collapsible = TRUE, + shiny::fluidRow( + shiny::column( + width = 3, + shiny::div(id = ns("guide_selection"), + columnSelectorUI(id = ns("select")))), + shiny::column( + width = 3, + shiny::div(id = ns("guide_cluster"), + shiny::selectInput( + ns("clustering"), + label = "Choose clustering", + choices = c("columns and rows" = "both", "only columns" = "column", "only rows" = "row", "no clustering" = "none"), + multiple = FALSE + ), + shiny::selectInput( + ns("cluster.distance"), + label = "Cluster distance", + choices = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "pearson", "spearman", "kendall"), + multiple = FALSE + ), + shiny::selectInput( + ns("cluster.method"), + label = "Cluster method", + choices = c("average", "ward.D", "ward.D2", "single", "complete", "mcquitty"), + multiple = FALSE)) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_transformation"), + transformationUI(id = ns("transform"), choices = list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore"), transposeOptions = TRUE) + ), + shiny::div(id = ns("guide_coloring"), + shiny::selectInput( + ns("distribution"), + label = "Data distribution", + choices = c("Sequential", "Diverging"), + multiple = FALSE + ), + colorPicker2UI(ns("color"), show.transparency = FALSE) + ) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_options"), + shiny::textInput(ns("label"), label = "Unit label", placeholder = "Enter unit..."), + shiny::checkboxInput(ns("row.label"), label = "Row label", value = row.label), + labelUI(ns("labeller")), + shiny::checkboxInput(ns("column.label"), label = "Column label", value = TRUE) + ) + ) + ), + shiny::fluidRow( + shiny::column( + width = 12, + shiny::div(id = ns("guide_buttons"), + shiny::actionButton(ns("plot"), "Plot", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "Reset", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")), + shiny::downloadButton(outputId = ns("download"), label = "Download") + ) + ) + ) + ) + ) + )) +} + +#' heatmap module server logic +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param data data.table data visualized in plot (Supports reactive). +#' @param types data.table: (Supports reactive) +#' column1: colnames of data +#' column2: corresponding column typ +#' column3: label (optional, used instead of id) +#' column4: sub_label (optional, added to id/ label) +#' @param plot.method Choose which method is used for plotting. Either "static" or "interactive" (Default = "static"). +#' @param custom.row.label Data.table used for creating custom labels (supports reactive). +#' @param label.sep Seperator used for label merging (Default = ", "). +#' @param width Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param height Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param ppi Pixel per inch. Defaults to 72 and supports reactive. +#' +#' @return Reactive containing data used for plotting. +#' +#' @export +heatmap <- function(input, output, session, data, types, plot.method = "static", custom.row.label = NULL, label.sep = ", ", width = "auto", height = "auto", ppi = 72) { + # cluster limitation + static <- 11000 + interactive <- 3000 + + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data <- data.table::copy(data()) + }else{ + data <- data.table::copy(data) + } + }) + # handle reactive sizes + size <- shiny::reactive({ + width <- ifelse(shiny::is.reactive(width), width(), width) + height <- ifelse(shiny::is.reactive(height), height(), height) + ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi) + + if(!is.numeric(width) || width <= 0) { + width <- "auto" + } + if(!is.numeric(height) || height <= 0) { + if(plot.method == "interactive") { + height <- 28 + }else { + height <- "auto" + } + } + if(!is.numeric(ppi) || ppi <= 0) { + ppi <- 72 + } + + list(width = width, + height = height, + ppi = ppi) + }) + + # Fetch the reactive guide for this module + guide <- heatmapGuide(session, !is.null(custom.row.label)) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide())) + }) + + #notification + shiny::observe({ + shiny::req(data.r()) + + if(length(columns$selectedColumns()) > 0){ + if(input$clustering != "none") { # clustering + if(plot.method == "static" && nrow(data.r()) > static) { # cluster limitation (static) + shiny::showNotification( + paste("Clustering limited to", static, "genes! Please disable clustering or select less genes."), + duration = NULL, + type = "error", + id = session$ns("notification"), + closeButton = FALSE + ) + } else if(plot.method == "interactive" && nrow(data.r()) > interactive) { # cluster limitation (interactive) + shiny::showNotification( + paste("Clustering limited to", interactive, "genes! Please disable clustering or select less genes."), + duration = NULL, + type = "error", + id = session$ns("notification"), + closeButton = FALSE + ) + } else { + shiny::removeNotification(session$ns("notification")) + } + } else if(nrow(data.r()) > 200) { # computation warning + shiny::showNotification( + paste("Caution! You selected", nrow(data.r()), "genes. This will take a while to compute."), + duration = 5, + type = "warning", + id = session$ns("notification"), + closeButton = FALSE + ) + } else { + shiny::removeNotification(session$ns("notification")) + } + }else{ + shiny::removeNotification(session$ns("notification")) + } + }) + + # warning if plot size exceeds limits + shiny::observe({ + if(plot()$exceed_size) { + shiny::showNotification( + ui = "Width and/ or height exceed limit. Using 500 cm instead.", + id = "limit", + type = "warning" + ) + } else { + shiny::removeNotification("limit") + } + }) + + #reset ui + shiny::observeEvent(input$reset, { + shinyjs::reset("cluster.distance") + shinyjs::reset("cluster.method") + shinyjs::reset("clustering") + shinyjs::reset("distribution") + shinyjs::reset("label") + shinyjs::reset("row.label") + shinyjs::reset("column.label") + columns <<- shiny::callModule(columnSelector, "select", type.columns = types, columnTypeLabel = "Column types to choose from") + transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(data.r()[, columns$selectedColumns(), with = FALSE]))) + colorPicker <<- shiny::callModule(colorPicker2, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(transform$data()))) + if(!is.null(custom.row.label)) { + custom_label <<- shiny::callModule(label, "labeller", data = custom.row.label, label = "Select row label", sep = label.sep, disable = shiny::reactive(!input$row.label)) + } + }) + + columns <- shiny::callModule(columnSelector, "select", type.columns = types, columnTypeLabel = "Column types to choose from") + transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(data.r()[, columns$selectedColumns(), with = FALSE]))) + colorPicker <- shiny::callModule(colorPicker2, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(transform$data()))) + if(!is.null(custom.row.label)) { + custom_label <- shiny::callModule(label, "labeller", data = custom.row.label, label = "Select row label", sep = label.sep, disable = shiny::reactive(!input$row.label)) + } + + result.data <- shiny::eventReactive(input$plot, { + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Compute data") + + processed_data <- data.table::as.data.table(transform$data()) + + processed_data <- data.table::data.table(data.r()[, 1], processed_data) + + progress$set(1) + return(processed_data) + }) + + # disable downloadButton on init + shinyjs::disable("download") + + plot <- shiny::eventReactive(input$plot, { + # enable downloadButton + shinyjs::enable("download") + + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Compute plot") + + colors <- colorPicker()$palette + + if(!is.null(custom.row.label)) { + label <- custom_label()$label + } else { + label <- NULL + } + + plot <- create_heatmap( + data = result.data(), + unitlabel = input$label, + row.label = input$row.label, + row.custom.label = label, + column.label = input$column.label, + column.custom.label = make.unique(columns$label()), + clustering = input$clustering, + clustdist = input$cluster.distance, + clustmethod = input$cluster.method, + colors = colors, + width = size()$width, + height = size()$height, + ppi = size()$ppi, + plot.method = plot.method, + winsorize.colors = colorPicker()$winsorize + ) + progress$set(1) + + return(plot) + }) + + #render choosen plotUI + if(plot.method == "interactive"){ + output$heatmap <- shiny::renderUI({ + plotly::plotlyOutput(session$ns("interactive")) + }) + + output$interactive <- plotly::renderPlotly({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Render plot") + + plot <- plot()$plot + + progress$set(1) + + return(plot) + }) + }else{ + output$heatmap <- shiny::renderUI({ + shiny::plotOutput(session$ns("static")) + }) + + output$static <- shiny::renderPlot( + width = shiny::reactive(plot()$width * (plot()$ppi / 2.54)), + height = shiny::reactive(plot()$height * (plot()$ppi / 2.54)), + { + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Render plot") + + plot <- plot()$plot + + progress$set(1) + return(ComplexHeatmap::draw(plot, heatmap_legend_side = "bottom")) + }) + } + + output$download <- shiny::downloadHandler(filename = "heatmap.zip", + content = function(file) { + download(file = file, filename = "heatmap.zip", plot = plot()$plot, width = plot()$width, height = plot()$height, ppi = plot()$ppi, ui = user_input()) + }) + + + user_input <- shiny::reactive({ + # format selection + selection <- list(type = columns$type(), selectedColumns = columns$selectedColumns()) + + # format clustering + clustering <- list( + clustering = input$clustering, + distance = input$cluster.distance, + method = input$cluster.method + ) + + # format options + options <- list( + transformation = list(method = transform$method(), applied = transform$transpose()), + color = list(distribution = input$distribution, scheme = colorPicker()$name, reverse = colorPicker()$reverse, winsorize = colorPicker()$winsorize), + unit_label = input$label, + row_label = input$row.label, + custom_row_label = custom_label()$selected, + column_label = input$column.label + ) + + # merge all + all <- list(selection = selection, clustering = clustering, options = options) + }) + + #enable/ disable plot button + shiny::observe({ + if(length(columns$selectedColumns()) <= 0){ # columns selected + shinyjs::disable("plot") + } else { + # clustering + if(input$clustering != "none") { + if(plot.method == "static" && nrow(data.r()) > static || plot.method == "interactive" && nrow(data.r()) > interactive) { + shinyjs::disable("plot") + } else { + shinyjs::enable("plot") + } + } else { + shinyjs::enable("plot") + } + } + }) + + # automatic unitlabel + shiny::observe({ + shiny::updateTextInput(session = session, inputId = "label", value = transform$method()) + }) + + return(result.data) +} + +#' heatmap module guide +#' +#' @param session The shiny session +#' @param custom.row.label Boolean. Show additional info. Default = FALSE. +#' +#' @return A shiny reactive that contains the texts for the Guide steps. +#' +heatmapGuide <- function(session, custom.row.label = FALSE) { + steps <- list( + "guide_selection" = "

Data selection

+ Select a column type for visualization, then select individual columns based on the chosen type.", + "guide_cluster" = "

Row/Column clustering

+ Choose where the clustering is applied, then select a clustering distance and method.", + "guide_transformation" = "

Data transformation

+ Pick a transformation that you want to apply to your data or leave it as 'None' if no transformation is needed.
+ In case of the Z-score transformation, you can additionally choose to apply it to either rows or columns.", + "guide_coloring" = "

Color palettes

+ Based on the selected data distribution, available color palettes are either sequential or diverging.
+ The selected palette can additionally be reversed.
+ Set the limits of the color palette with 'Winsorize to upper/lower'. Out of bounds values will be mapped to the nearest color.", + "guide_options" = "

Additional options

+ You can set a label for the color legend that describes the underlying data unit. Furthermore, you can enable/disable row and column labels.", + "guide_buttons" = "

Create the plot

+ As a final step click, a click on the 'Plot' button will render the plot, while a click on the 'Reset' button will reset the parameters to default." + ) + + if(custom.row.label) { + steps[["guide_options"]] <- paste(steps[["guide_options"]], "Use the input to generate custom row-labels. The selected columns will be merged and used as label.") + } + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/label.R b/R/label.R new file mode 100644 index 0000000..64817e3 --- /dev/null +++ b/R/label.R @@ -0,0 +1,71 @@ +#' label module UI representation +#' +#' @param id The ID of the modules namespace +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}} +#' +#' @export +labelUI <- function(id){ + ns <- shiny::NS(id) + + shiny::tagList( + shiny::uiOutput(outputId = ns("label_container")) + ) +} + +#' label module server logic +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param data Data.table used for label creation. Column names will be used for selection. (supports reactive) +#' @param label Set label of selectizeInput. +#' @param multiple Allow multiple selection which will be merged with sep (default = TRUE). +#' @param sep Seperator used to collapse selection (default = ", "). +#' @param unique Make labels unique. Defaults to TRUE. See \code{\link[base]{make.unique}}. +#' @param unique_sep Seperator used for unique (default = "_"). Should differ from sep. +#' @param disable Reactive containing boolean. To disable/ enable module. +#' +#' @return Reactive containing list(label = vector of strings or NULL on empty selection, selected = user input). +#' +#' @export +label <- function(input, output, session, data, label = "Select label columns", multiple = TRUE, sep = ", ", unique = TRUE, unique_sep = "_", disable = NULL){ + # handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)) { + data() + } else { + data + } + }) + + output$label_container <- shiny::renderUI({ + # first choice = "" so no selection for multiple = F is possible + shiny::selectizeInput(inputId = session$ns("label_creator"), label = label, choices = c("", names(data.r())), selected = "", multiple = multiple, options = list(placeholder = "None")) + }) + + # disable/ enable module + if(!is.null(disable)) { + shiny::observe({ + if(disable()) { + shinyjs::disable("label_creator") + } else { + shinyjs::enable("label_creator") + } + }) + } + + shiny::reactive({ + if(!shiny::isTruthy(input$label_creator) || !is.null(disable) && disable()) return(NULL) + + # merge selected rows to vector of strings + custom_label <- data.r()[, do.call(paste, c(... = .SD, sep = sep)), .SDcols = input$label_creator] + + # make unique labels + if(unique) { + custom_label <- make.unique(custom_label, sep = unique_sep) + } + + list(label = custom_label, selected = input$label_creator) + }) +} diff --git a/R/limit.R b/R/limit.R new file mode 100644 index 0000000..9b3e436 --- /dev/null +++ b/R/limit.R @@ -0,0 +1,88 @@ +#' limit module UI representation +#' +#' @param id The ID of the modules namespace +#' @param label Set the modules label. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}} +#' +#' @export +limitUI <- function(id, label = "Limit"){ + ns <- shiny::NS(id) + + shiny::tagList( + list(shinyjs::useShinyjs(), shiny::checkboxInput(inputId = ns("enable"), label = label, value = FALSE)), + shiny::fluidRow(shiny::column(shiny::numericInput(ns("lowerLimit"), label = "Lower limit", value = -2), width = 6), + shiny::column(shiny::numericInput(ns("upperLimit"), label = "Upper limit", value = 2), width = 6)) + ) +} + +#' limit module server logic +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param lower Set lower limit (supports reactive). +#' @param upper Set upper limit (supports reactive). +#' +#' @return Reactive containing: list(lower, upper). +#' +#' @export +limit <- function(input, output, session, lower = NULL, upper = NULL){ + # evaluate reactive parameter + lower.r <- shiny::reactive({ + if(shiny::is.reactive(lower)) { + lower() + } else { + lower + } + }) + + upper.r <- shiny::reactive({ + if(shiny::is.reactive(upper)) { + upper() + } else { + upper + } + }) + + # update ui + shiny::observe({ + if(!is.null(input$enable) && input$enable) { + shiny::isolate(shiny::updateNumericInput(session = session, inputId = "lowerLimit", value = lower.r())) + } + }) + + shiny::observe({ + if(!is.null(input$enable) && input$enable) { + shiny::isolate(shiny::updateNumericInput(session = session, inputId = "upperLimit", value = upper.r())) + } + }) + + shiny::observe({ + # lowerLimit = smaller than upper + shiny::updateNumericInput(session = session, inputId = "lowerLimit", max = input$upperLimit - 1) + # upperLimit = greater than lower + shiny::updateNumericInput(session = session, inputId = "upperLimit", min = input$lowerLimit + 1) + }) + + # enable ui if checkbox checked + shiny::observeEvent(input$enable, { + if(input$enable) { + shinyjs::enable("lowerLimit") + shinyjs::enable("upperLimit") + } else { + shinyjs::disable("lowerLimit") + shinyjs::disable("upperLimit") + } + }) + + # return values + shiny::reactive({ + if(!is.null(input$enable) && !input$enable) { + NULL + } else { + list(lower = input$lowerLimit, + upper = input$upperLimit) + } + }) +} diff --git a/R/marker.R b/R/marker.R new file mode 100644 index 0000000..359c332 --- /dev/null +++ b/R/marker.R @@ -0,0 +1,47 @@ +#' marker module UI representation +#' +#' @param id The ID of the modules namespace +#' @param label Set label of first element. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}} +#' +#' @export +markerUI <- function(id, label = "Highlight/ Label Selected Features"){ + ns <- shiny::NS(id) + + shiny::tagList( + shiny::selectInput(ns("highlight"), label = label, choices = c("Disabled", "Highlight", "Exclusive")), + colorPicker2UI(ns("color"), label = "Color", custom = TRUE), + labelUI(ns("label")) + + ) +} + +#' marker module server logic +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param highlight.labels Data.table from which labels are provided (Supports reactive). +#' +#' @return A reactive which contains a named list (highlight, color, labelColumn, label). +#' +#' @export +marker <- function(input, output, session, highlight.labels){ + highlight.labels.r <- shiny::reactive({ + if(shiny::is.reactive(highlight.labels)){ + highlight.labels() + }else{ + highlight.labels + } + }) + + color <- shiny::callModule(colorPicker2, "color") + labeller <- shiny::callModule(label, "label", data = shiny::reactive(highlight.labels.r()), unique = FALSE) + + shiny::reactive({ + shiny::req(input$highlight, color()$palette) + + list(highlight = input$highlight, color = color()$palette, labelColumn = labeller()$selected, label = labeller()$label) + }) +} diff --git a/R/orNumeric.R b/R/orNumeric.R new file mode 100644 index 0000000..6b801dc --- /dev/null +++ b/R/orNumeric.R @@ -0,0 +1,351 @@ +#' orNumeric module UI representation +#' +#' This module allows to select value/range inputs from a \code{\link[shiny]{sliderInput}} element. +#' The functions creates HTML tag definitions of its representation based on the parameters supplied. +#' +#' @param id The ID of the modules namespace. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +orNumericUI <- function(id){ + ns <- shiny::NS(id) + + shiny::tagList( + shiny::tagList(shinyjs::useShinyjs(), shiny::uiOutput(ns("label"))), + shiny::uiOutput(ns("options")), + shiny::uiOutput(ns("slider")), + shiny::uiOutput(ns("info")) + ) +} + +#' orNumeric module server logic +#' +#' Provides server logic for the orNumeric module. +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param choices A list or a numeric vector with the possible choices offered in the UI. See \code{\link[shiny]{sliderInput}} (Supports reactive). +#' @param value Initial value of the slider. Creates a ranged slider if numeric vector of two given (Supports reactive). +#' @param label Label of the entire module. +#' @param step Number of steps on interval (Default = 100). +#' @param stepsize Value defining interval size of the slider. Will be used instead of step (Default = NULL). +#' @param min. Minimum value that can be selected on slider (defaults to min(choices)) (Supports reactive). +#' @param max. Maximum value that can be selected on slider (defaults to max(choices)) (Supports reactive). +#' @param label.slider A character vector of length one with the label for the \code{\link[shiny]{sliderInput}}. +#' @param zoomable Boolean to enable zooming. Redefine the sliders range. Defaults to TRUE. +#' @param reset A reactive which will trigger a module reset on change. +#' +#' @return Returns a reactive containing a named list with the label, the selected choices as a character vector (text) and a boolean vector of length \code{length(choices)} (bool), indicating whether a item has been chosen. If no item has been chosen, the return is \code{TRUE} for items. +#' +#' @export +orNumeric <- function(input, output, session, choices, value, label = "Column", step = 100, stepsize = NULL, min. = shiny::reactive(min(choices.r(), na.rm = TRUE)), max. = shiny::reactive(max(choices.r(), na.rm = TRUE)), label.slider = NULL, zoomable = TRUE, reset = NULL){ + choices.r <- shiny::reactive({ + if(shiny::is.reactive(choices)) { + choices() + } else { + choices + } + }) + + value.r <- shiny::reactive({ + if(shiny::is.reactive(value)) { + value() + } else { + value + } + }) + + min.r <- shiny::reactive({ + if(shiny::is.reactive(min.)) { + min.() + } else { + min. + } + }) + + max.r <- shiny::reactive({ + if(shiny::is.reactive(max.)) { + max.() + } else { + max. + } + }) + + output$label <- shiny::renderUI({ + shiny::tags$b(label) + }) + + output$options <- shiny::renderUI({ + if(shiny::isolate(length(value.r()) > 1)){ + shiny::radioButtons(inputId = session$ns("options"), label = NULL, inline = FALSE, + choices = list("inner", "outer")) + }else{ + shiny::selectInput(inputId = session$ns("options"), label = NULL, + choices = c("=", "<", ">"), + selected = NULL, + multiple = TRUE) + } + }) + + css <- shiny::reactive({ + # range slider? + if(length(value.r()) > 1) { + shiny::req(input$options) + # span.irs-bar = range between points (inner) + # span.irs-line = range outside of points (outer) + # span.irs-slider.from = left point + # span.irs-slider.to = right point + # span.irs-from = text above left point + # span.irs-to = text above right point + # span.irs-min = left text above slider + # span.irs-max = right text above slider + # span.irs-single = joined texts above points + + # inner css + if(input$options == "inner") { + css <- shiny::HTML(paste0("") + # outer css + }else if(input$options == "outer") { + css <- shiny::HTML(paste0("") + } + #single slider + }else { + # span.irs-min = left text above slider + # span.irs-max = right text above slider + # span.irs-single = text above point + # span.irs-slider.single = point + # span.irs-bar = bar left side of point + # span.irs-bar-edge = left edge of bar + # span.irs-line = bar right side of point + + # default for < + less <- shiny::HTML(paste0("" + + if(any("<" == input$options)) { + less <- shiny::HTML(paste0("" + } + shiny::HTML(less, equal, greater) + } + }) + + # insert style for slider + shiny::observe({ + # re-insert css if slider is re-rendered + min.r() + max.r() + + # escape . to get valid css selector + # TODO better validation + selector <- gsub(pattern = ".", replacement = "\\.", x = session$ns("slider-style"), fixed = TRUE) + selector2 <- gsub(pattern = ".", replacement = "\\.", x = session$ns("slider"), fixed = TRUE) + + if(length(value.r()) > 1) shiny::req(input$options) + shiny::removeUI( + selector = paste0("#", selector) + ) + + shiny::insertUI( + selector = paste0("#", selector2), + where = "afterBegin", + ui = css() + ) + }) + + output$slider <- shiny::renderUI({ + min. <- min.r() + max. <- max.r() + value <- value.r() + + interval <- ifelse(is.null(stepsize), abs(min. - max.) / step, stepsize) + + out <- shiny::tagList( + shiny::fluidRow( + if(zoomable) shiny::column(width = 3, shiny::numericInput(session$ns("minVal"), min = min., max = max., value = min., label = NULL, width = "100%")), + shiny::column(width = ifelse(zoomable, 6, 12), shiny::sliderInput(session$ns("slider"), label = label.slider, min = min., max = max., value = value, step = interval, width = "100%", round = FALSE)), + if(zoomable) shiny::column(width = 3, shiny::numericInput(session$ns("maxVal"), min = min., max = max., value = max., label = NULL, width = "100%")) + ) + ) + + return(out) + }) + + if(shiny::is.reactive(reset)) { + shiny::observeEvent(reset(), { + # require rendered UI + shiny::req(input$slider) + + shinyjs::reset("minVal") + shinyjs::reset("maxVal") + shinyjs::reset("options") + + min. <- min.r() + max. <- max.r() + value <- value.r() + interval <- ifelse(is.null(stepsize), abs(min. - max.) / step, stepsize) + shiny::updateSliderInput(session = session, inputId = "slider", value = value, min = min., max = max., step = interval) # shinyjs::reset("slider") won't reset value if not in current range + }) + } + + if(zoomable){ + #zoomable slider + shiny::observe({ + shiny::req(input$minVal, input$maxVal) + + interval <- ifelse(is.null(stepsize), abs(input$minVal - input$maxVal) / step, stepsize) + shiny::updateSliderInput(session, inputId = "slider", min = input$minVal, max = input$maxVal, step = interval) + }) + + #only useful values + shiny::observe({ + shiny::req(input$minVal, input$maxVal) + + shiny::updateNumericInput(session, inputId = "minVal", max = input$maxVal) + shiny::updateNumericInput(session, inputId = "maxVal", min = input$minVal) + }) + } + + + output$info <- shiny::renderUI({ + shiny::tagList( + #added css so that padding won't be added everytime (sums up) modal is shown + shiny::tags$style(type="text/css", "body {padding-right: 0px !important;}"), + shiny::actionLink(session$ns("infobutton"), label = NULL, icon = shiny::icon("question-circle")) + ) + }) + + #show right info + shiny::observeEvent(input$infobutton, { + if(length(value.r()) > 1){ + #ranged slider + title <- "Numeric" + content <- shiny::HTML("Use the slider to selected the desired range. Choose either 'inner' or 'outer' for the values in- or outside the range.") + }else{ + #single slider + title <- "Numeric" + content <- shiny::HTML("Select one or more operations (\"<\", \">\", \"=\")
Use slider to set value on which operations will be performed.
E.g. If you choose \"<\" \"=\" 5 every value smaller or equal will be selected.") + } + + if(zoomable){ + content <- shiny::HTML(content, paste("
Use the numberfields on each side of the slider to set it's min/max value, allowing for a more precise selection. As the slider will always attempt to have", step, "steps.")) + path <- "wilson_www/orNumeric_help.png" + if(length(value.r()) > 1) content <- shiny::tagList(content, shiny::div(shiny::img(src = path, width = "90%"))) + } + + shiny::showModal( + shiny::modalDialog( + title = title, + footer = shiny::modalButton("close"), + easyClose = TRUE, + size = "l", + content + ) + ) + }) + + selected <- shiny::reactive({ + searchData(input = input$slider, choices = choices.r(), options = input$options, min. = min.r(), max. = max.r()) + }) + + out <- shiny::reactive({ + value <- value.r() + + text <- "" + + # ranged: return text if not in default selection; single: return if options are selected + if(length(value) > 1) { + if(shiny::isTruthy(input$slider) & shiny::isTruthy(input$options)) { + if(!(input$slider[1] == min.r() & input$slider[2] == max.r() & input$options == "inner")) { + text <- paste(input$options, paste(input$slider, collapse = "-")) + } + } + } else { + if(shiny::isTruthy(input$options)){ + text <- paste(paste(input$options, collapse = " "), input$slider) + } + } + + list( + label = label, + bool = selected(), + text = text + ) + }) + + return(out) +} diff --git a/R/orTextual.R b/R/orTextual.R new file mode 100644 index 0000000..a51e073 --- /dev/null +++ b/R/orTextual.R @@ -0,0 +1,124 @@ +#' orTextual module UI representation +#' +#' This module allows to select (multiple) inputs from a \code{\link[shiny]{selectInput}} element. +#' The functions creates HTML tag definitions of its representation based on the parameters supplied. +#' +#' @param id The ID of the modules namespace. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +orTextualUI <- function(id){ + ns <- shiny::NS(id) + + shiny::tagList( + shiny::tagList(shinyjs::useShinyjs(), shiny::uiOutput(ns("label"))), + shiny::uiOutput(ns("select")), + shiny::uiOutput(ns("info")) + ) +} + +#' orTextual module server logic +#' +#' Provides server logic for the orTextual module. +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param choices A list or a character vector with the possible choices offered in the UI. See \code{\link[shiny]{selectInput}}. +#' @param selected The initially selected value. See \code{\link[shiny]{selectInput}}. +#' @param label A character vector of length one with the label for the \code{\link[shiny]{selectInput}}. +#' @param delimiter A single character indicating if and how items are delimited (default: \code{NULL} indicates no delimitation). Only if contains = FALSE. +#' @param multiple Whether or not selection of multiple items is allowed. +#' @param contains Logical variable. If TRUE shows module as a textsearch input. +#' @param reset A reactive which will trigger a module reset on change. +#' +#' @return Returns a reactive containing a named list with the label, the selected choices as a character vector (text) and a boolean vector of length \code{length(choices)} (bool), indicating whether a item has been chosen. If no item has been chosen, the return is \code{TRUE} for items. +#' +#' @export +orTextual <- function(input, output, session, choices, selected = NULL, label = "Column", delimiter = NULL, multiple = TRUE, contains = FALSE, reset = NULL){ + raw.choices <- choices + + #delimit choices + if(!is.null(delimiter) & contains == FALSE){ + choices <- unlist(strsplit(choices, split = delimiter, fixed = TRUE)) + } + + output$label <- shiny::renderUI({ + shiny::tags$b(label) + }) + + output$select <- shiny::renderUI({ + if(contains){ + ui <- shiny::textInput(session$ns("column"), label = NULL) + }else{ + ui <- shiny::selectizeInput(session$ns("column"), label = NULL, choices = NULL, multiple = multiple, selected = NULL) + #only fetch needed data (calculation on server-side) + shiny::updateSelectizeInput(session, "column", choices = unique(choices), selected = selected, server = TRUE) + } + + return(ui) + }) + + output$info <- shiny::renderUI({ + shiny::tagList( + #added css so that padding won't be added everytime (sums up) modal is shown + shiny::tags$style(type="text/css", "body {padding-right: 0px !important;}"), + shiny::actionLink(session$ns("infobutton"), label = NULL, icon = shiny::icon("question-circle")) + ) + }) + + if(shiny::is.reactive(reset)) { + shiny::observeEvent(reset(), { + if(is.null(selected)){ + shinyjs::reset("column") + }else{ + shiny::updateSelectizeInput(session, "column", selected = selected) + } + }) + } + + #show right info + shiny::observeEvent(input$infobutton, { + if(contains){ + title <- "Textsearch" + content <- shiny::HTML("Enter some text which will be used for textsearch.") + }else{ + title <- "Text" + content <- shiny::HTML("Select one or multiple values to filter.") + } + + shiny::showModal( + shiny::modalDialog( + title = title, + footer = shiny::modalButton("close"), + easyClose = TRUE, + content + ) + ) + }) + + selected.choices <- shiny::reactive({ + if(!is.null(input$column)){ + #escape all regex symbols + esc.choices <- paste0("\\Q", input$column, "\\E") + + if(contains | !is.null(delimiter)){ + result <- grepl(pattern = paste0(esc.choices, paste0("($|", delimiter, ")"), collapse = "|"), raw.choices, perl = TRUE) + }else{ + result <- grepl(pattern = paste0("^(", esc.choices, ")$", collapse = "|"), raw.choices, perl = TRUE) + } + + #set all TRUE if nothing selected + if(is.null(input$column) | input$column[1] == "" & !all(result)){ + result <- !result + } + + return(result) + }else{ + return(!logical(length = length(raw.choices))) + } + }) + + return(shiny::reactive(list(label = label, bool = selected.choices(), text = input$column))) +} diff --git a/R/parser.R b/R/parser.R new file mode 100644 index 0000000..5367f3c --- /dev/null +++ b/R/parser.R @@ -0,0 +1,419 @@ + + +#' Converting MaxQuant Output file proteinGroups.txt to CLARION format +#' by creating a headline of metadata for each column +#' +#' List with columns of reduced version (see config.json file) +#' If you only want the samples of a specific keyword write: column;exp +#' For example: +#' You got: +#' Intensity +#' Intensity 'experiment_name' +#' Do you want both add "Intensity" to the list. +#' Do you only want the sample add "Intensity;exp" to the list +#' Anything else like 'Intensity;ex' or 'Intesity;' results in writing both. +#' Only works if there are samples of that type. If not, column does not show up in file +#' +#' @author Rene Wiegandt +#' @param proteinGroups_in path of proteinGroup.txt file +#' @param summary_in path of belonging summary.txt file +#' @param outfile path of full CLARION output file +#' @param outfile_reduced path of reduced CLARION output file +#' @param config path of config file (containing information about metadata) +#' @param delimiter delimiter (Default = ;) +#' @param format pre-header information about format (optional) +#' @param version pre-header information about version (optional) +#' @param experiment_id pre-header information about experiment id (optional) +#' +#' @export +parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduced, config = system.file("extdata", "parser_MaxQuant_config.json", package = "wilson"), delimiter = ";", format = NULL, version = NULL, experiment_id = NULL){ + if(missing(proteinGroups_in)){ + stop("The proteinGroups file was not given") + } + if(missing(summary_in)){ + stop("The summary file was not given") + } + if(missing(outfile)){ + stop("The output file was not given") + } + if(missing(outfile_reduced)){ + stop("The output_reduced file was not given") + } + + # parsers json config file + # @param config path of config file + # @return data.table with metadata + get_meta_from_config <- function(meta_config){ + dr <- lapply(meta_config$meta, function(r){ + data.table::data.table("col_name" = r$col_name, + "level" = r$level, + "type" = r$type, + "label" = r$label, + "sublabel" = r$sublabel + ) + }) + meta <- do.call('rbind', dr) + } + + + # Get the type of the sample + # Cutting of the experiment name and checking in given lists if left column name is in one of those lists + # Depending on in which list it is returns the type + # @param exp_name experiment name + + # @param scores,ratios,category,ary vectors with Strings + # @return String type of given column + get_sample_type <- function(name, scores, ratios, prob, category, ary){ + + name_split <- strsplit(name, " ") + if(grepl("[[:digit:]]{1,2}",utils::tail(name_split[[1]],1))){ + name <- paste(utils::head(name_split[[1]], -1), collapse = ' ') + } + if(name %in% scores){ return("score") } + if(name %in% ratios){ return("ratio") } + if(name %in% prob){ return("probability")} + if(name %in% category){ return("category") } + if(name %in% ary){ return("array") } + + return("unknown") + } + + + # Get the level of the sample column + # Checking for keywords inside of the column name + # Each keyword is given one level + # @param col_head column head + # @return String level of given column + get_sample_level <- function(col_head, isSample, full_list){ + # Get the level of all 'sample' columns. + # Default: level <- "sample" + if(grepl("Ratio", col_head, perl = TRUE)){ + if (grepl("type", col_head, perl = TRUE)){ return("feature") } + return("contrast") + } + if (grepl("type", col_head, perl = TRUE)){ return("feature") } + if(grepl("Fraction [[:digit:]]{1,2}", col_head, perl = TRUE)){ return("condition") } + if(isSample){ return("sample") } + if(col_head %in% full_list){ return("contrast") } + return("unknown") + } + + + # Get label and sublabel of remaining columns + # remaining columns <- columns which are not in meta or a sample column + # @param col_head column head + # @return list with label and sublabel + get_remaining_labeling <- function(col_head){ + col_head_split = strsplit(col_head, " ") + if(length(col_head_split) > 1){ + sublabel <- col_head_split[[1]][length(col_head_split[[1]])] + if(grepl(sublabel, "[%]", fixed = TRUE)){ + label <- paste(utils::head(col_head_split[[1]], -2), collapse = ' ') + sublabel <- paste(utils::tail(col_head_split[[1]], 2), collapse = ' ') + } else { + label <- paste(utils::head(col_head_split[[1]], -1), collapse = ' ') + sublabel <- col_head_split[[1]][length(col_head_split[[1]])] + } + return(list(label, sublabel)) + } + return(list(col_head, "")) + } + + + # Get list of all column names with experiment name, which are in the reduced version + # @param meta_full data table with metadata + # @param reduced_list raw list of all columns of every quantification method, which need to in the reduced version + # @param exp_names list of experiment names + # @param col_names list of all column names + # @return list: 1 <- list of all reduced column names, 2 <- columns which are in the raw list but not in the final list + get_reduced_version <- function(meta_full, reduced_list, exp_names, col_names){ + red_split <- strsplit(reduced_list, ";") + red_exp_list <- unlist(lapply(red_split, function(split_name){ + # if length == 2 entry of reduced list is column_name;exp + # only adding column_name + experiment name to the list + if(length(split_name) == 2){ + red_col_name <- lapply(exp_names, function(exp_name){ + rcn <- paste(split_name[1],exp_name) + # special case for Sequence Coverage exp_name [%] + if(!(rcn %in% col_names) && (paste(rcn,"[%]") %in% col_names)){ + rcn <- paste(rcn,"[%]") + } + return(rcn) + }) + } else { + # adding both column name + experiment_name and column name without experiment name to list + red_col_name <- lapply(1:(length(exp_names)+1), function(i){ + if(i <= length(exp_names)){ + if(paste(split_name,exp_names[i]) %in% col_names){ + return(paste(split_name,exp_names[i])) + } + } else { + return(split_name) + } + }) + } + })) + overlap <- setdiff(red_exp_list, col_names) + red_exp_list <- red_exp_list[!(red_exp_list %in% overlap)] + return(list(red_exp_list,overlap)) + } + + + # writing clarion file + # @param meta data table with meta data + # @param out output file + # @param format format + # @param version version number + # @param exp_id experiment id + # @param pGroups data table protein groups file + write_clarion_file <- function(meta, out, format, version, exp_id, pGroups, delimiter){ + to_append = FALSE + if(!missing(format)){ + write(paste0("!format=",format),file=out, append = to_append) + to_append = TRUE + } + if(!missing(version)){ + write(paste0("!version=",version),file=out, append = to_append) + to_append = TRUE + } + if(!missing(exp_id)){ + write(paste0("!experiment_id=",exp_id),file=out, append = to_append) + to_append = TRUE + } + write(paste0("!delimiter=",delimiter),file=out, append=to_append) + write("#key\tfactor1\tlevel\ttype\tlabel\tsub_label",file=out, append=TRUE) + data.table::fwrite(meta, file=out, sep = "\t", append=TRUE, col.names=FALSE, quote= FALSE) + data.table::fwrite(pGroups, file=out, sep = "\t", append=TRUE, col.names = TRUE, quote= FALSE) + } + + # reading files in data tables + proteinGroups <- data.table::fread(proteinGroups_in, header = TRUE, quote='') + summary_file <- data.table::fread(summary_in, header = TRUE) + meta_config <- rjson::fromJSON(file = config) + + # getting experiment names + exp_names <- (unique(summary_file[Experiment != "",Experiment])) + + meta <- get_meta_from_config(meta_config = meta_config) + + sample_scores <- meta_config$type_scores + sample_ratios <- meta_config$type_ratios + sample_probability <- meta_config$type_probability + + sample_category <- meta_config$type_category + sample_ary <- meta_config$type_array + reduced_list <- meta_config$reduced_list + full_sample_list <- c(sample_scores, sample_ratios, sample_probability, sample_category, sample_ary) + + # get column names + col_names <- colnames(proteinGroups) + + # delete rows from meta, which are not in col_names + meta_trim <- meta[col_name %in% col_names] + + # get metadata for each sample column + # append rows to data table with metadata + samples_list <- lapply(col_names, function(col_head){ + + unlist(lapply(exp_names, function(name){ + name_brackets <- paste0("\\Q", name) + exp_regex <- paste0("\\Q ", name) + sample_description <- strsplit(col_head, exp_regex) + if(length(grep(name_brackets, col_head, perl = TRUE)) == 1 ){ # Does column name contains experiment name? + de<-data.table::data.table("col_name" = c(col_head), + "level" = c(get_sample_level(col_head = col_head,isSample = TRUE, full_list = full_sample_list)), + "type" = c(get_sample_type(name = sample_description[[1]][1], scores = sample_scores, + ratios = sample_ratios, prob = sample_probability, category = sample_category, + ary = sample_ary)), + "label" = c(name), + "sublabel" = c(trimws(gsub(name_brackets, '', col_head), "r")) + ) + return(de) + } + })) + + }) + samples <- do.call('rbind', Filter(Negate(is.null), samples_list)) + meta_half <- rbind(meta_trim, samples) + + # get metadata for each remaining column(columsn which are specific for a certain quantification methode) + # append rows to data table with metadata + remaining_list <- lapply(col_names, function(col_head){ + if(!(col_head %in% meta_half[["col_name"]])){ + label_sublabel <- get_remaining_labeling(col_head = col_head) + de2<-data.table::data.table("col_name" = c(col_head), + "level" =c(get_sample_level(col_head = col_head,isSample = FALSE, full_list = full_sample_list)), + "type" = c(get_sample_type(name = col_head, scores = sample_scores, ratios = sample_ratios, + prob = sample_probability, category = sample_category, ary = sample_ary)), + "label" = c(label_sublabel[1]), + "sublabel" = c(label_sublabel[2]) + ) + return(de2) + } + }) + remaining <- do.call('rbind', Filter(Negate(is.null), remaining_list)) + meta_full <- rbind(meta_half, remaining) + meta_full$col_name <- sub("^","#",meta_full$col_name) + + # add column factor 1 and reorder the columns + meta_full$factor1 <- "" + meta_full <- meta_full[, c("col_name", "factor1", "level", "type", "label", "sublabel")] + + # get data.table with reduced metadata + reduced <- get_reduced_version(meta_full = meta_full,reduced_list = reduced_list, + exp_names = exp_names, col_names = col_names) + meta_reduced <- meta_full[meta_full$col_name %in% sub("^","#",reduced[[1]]),] + + # if there are unknown columns the user gets a warning with all unknown columns + # unknown columns wont be writen in the meta data header + if(nrow(meta_full[level == "unknown"]) > 0){ + meta_warn <- gsub("#","",meta_full[level == "unknown",col_name]) + warning("Following columns are unknown and have been removed (Check JSON config file: 'meta'): ", paste(meta_warn, collapse=", ")) + meta_full <- meta_full[level != "unknown"] + } + + # if there are unknown column types the user gets a warning with all columns with unknown type + # columns with unknown types wont be writen in the meta data header + if(nrow(meta_full[type == "unknown"]) > 0){ + meta_warn <- gsub("#","",meta_full[type == "unknown",col_name]) + warning("Due to unknown type follwing columns were removed (Check JSON config file: 'type_X'): ", paste(meta_warn, collapse=", ")) + meta_full <- meta_full[type != "unknown"] + } + + # writing advanced CLARION file + write_clarion_file(meta = meta_full, out = outfile, format = format, + version = version, exp_id = experiment_id, pGroups = proteinGroups, delimiter = delimiter) + + #writing reduced CLARION file + write_clarion_file(meta = meta_reduced, out = outfile_reduced, format = format, + version = version, exp_id = experiment_id, pGroups = proteinGroups, delimiter = delimiter) +} + +#' Method to parse input file. +#' +#' @param file Path to file that needs parsing. +#' @param dec The decimal separator. See \code{\link[data.table]{fread}}. +#' +#' @return named list containing list(header = list(), metadata = data.table, data = data.table) +#' +#' @import data.table +#' +#' @export +parser <- function(file, dec = ".") { + message(paste("Parsing file:", file)) + + #number of rows for each part + file.lines <- Kmisc::readlines(file) + num.header <- length(grep("^!", file.lines)) + num.metadata <- length(grep("^#", file.lines)) + + ###parse header + header <- data.table::fread(input = file, fill = TRUE, header = FALSE, dec = dec, nrows = num.header, integer64 = "double") + #cut of leading ! + header <- as.list(gsub("^!", "", header[[1]])) + #make named list + header.names <- gsub("=.*$", "", header, perl = TRUE) + header <- as.list(gsub("^.*?=", "", header, perl = TRUE)) + names(header) <- header.names + + ###parse metadata + metadata <- data.table::fread(input = file, skip = num.header, header = FALSE, nrows = num.metadata, fill = TRUE, dec = dec, integer64 = "double") + #cut off leading # + metadata[, names(metadata)[1] := gsub("^#", "", metadata[[1]])] + #set first line as header + names(metadata) <- as.character(metadata[1]) + + # remove empty columns + metadata <- metadata[, which(unlist(lapply(metadata, function(x) !all(is.na(x) || x == "")))), with = FALSE] + + #check for unexpected columns + accepted_columns <- c("key", "factor\\d+", "level", "type", "label", "sub_label") + regex <- paste0(paste0("^", accepted_columns, "$"), collapse = "|") + invalid <- grep(regex, names(metadata), invert = TRUE, perl = TRUE) + if(length(invalid) > 0){ + warning(paste("Metadata: Unexpected columnames detected: ", paste0(names(metadata)[invalid], collapse = ", "))) + } + # check mandatory columns + check_columns <- c("key", "level") + mandatory <- check_columns %in% names(metadata) + if(!all(mandatory)) { + stop(paste0("Metadata: Mandatory column(s) are missing! ", paste0(check_columns[!mandatory], collapse = ", "))) + } + + #delete first line + metadata <- metadata[-1] + # duplicated keys? + meta_duplicants <- duplicated(metadata[["key"]]) + if(any(meta_duplicants)) { + stop(paste0("Metadata: Duplicate(s) in key detected! The following keys occur more than once: ", paste0(unique(metadata[["key"]][meta_duplicants]), collapse = ", "))) + } + + # check levels + known_level <- c("feature", "sample", "condition", "contrast") + unknown_level <- metadata[!level %in% known_level][["level"]] + if(length(unknown_level) > 0) { + warning(paste0("Metadata: Unkown level found: ", paste0(unknown_level, collapse = ", "))) + } + # check if type fits corresponding level + if(is.element("type", names(metadata))) { + # if type contains array delimiter mandatory + if(is.element("array", metadata[["type"]])) { + if(!is.element("delimiter", names(header))) { + stop("Found array but no delimiter! Multi-value fields require delimiter (in header) and type (in metadata).") + } + } + # feature + feature_types <- c("unique_id", "name", "category", "array") + # sample, condition, contrast + samp_cond_cont_types <- c("score", "ratio", "probability", "array") + + keys <- metadata[level == "feature" & !type %in% feature_types][["key"]] + keys <- append(keys, metadata[level %in% c("sample", "condition", "contrast") & !type %in% samp_cond_cont_types][["key"]]) + + # unique_id defined? + if(!is.element("unique_id", metadata[["type"]])) { + stop("Metadata: No unique_id found in type! Please define an unique_id.") + } + + if(length(keys) > 0) { + warning(paste0("Metadata: Level doesn't match type: ", paste0(keys, collapse = ", "))) + } + } + + ###parse data + # check for inconsistency + col_data <- data.table::fread(input = file, header = TRUE, skip = num.header + num.metadata, fill = FALSE, nrows = 0, dec = dec, integer64 = "double") + col_names <- names(col_data) + missing_refs <- setdiff(col_names, metadata[[1]]) + missing_cols <- setdiff(metadata[[1]], col_names) + if(length(missing_refs) > 0) { + warning(paste0("Metadata rows and data columns differ! Following rows are missing in metadata: ", paste(missing_refs, collapse = ", "))) + } + if(length(missing_cols) > 0) { + warning(paste0("Metadata rows and data columns differ! Following columns are not definded in data: ", paste(missing_refs, collapse = ", "))) + } + # duplicated columnnames? + data_duplicants <- duplicated(col_names) + if(any(data_duplicants)) { + stop(paste0("Data: Duplicated column name(s) detected! The following names are duplicated: ", paste0(unique(col_names[data_duplicants]), collapse = ", "))) + } + + data <- data.table::fread(input = file, header = TRUE, skip = num.header + num.metadata, fill = FALSE, dec = dec, integer64 = "double") + + # unexpected columntypes?; sample, condition & contrast numeric? + if(is.element("type", names(metadata))) { + columns <- metadata[level %in% c("sample", "condition", "contrast") & type != "array"][["key"]] + } else { + columns <- metadata[level %in% c("sample", "condition", "contrast")][["key"]] + } + not_num_cols <- names(data[, columns, with = FALSE][, which(!sapply(data[, columns, with = FALSE], is.numeric))]) + if(length(not_num_cols) > 0) { + stop(paste0("Column(s): ", paste0(not_num_cols, collapse = ", "), " not numeric! Probably wrong decimal separator.")) + } + + data.table::setindexv(metadata, names(metadata)[1]) + data.table::setindexv(data, names(data)[1]) + + return(list(header = header, metadata = metadata, data = data)) +} + diff --git a/R/pca.R b/R/pca.R new file mode 100644 index 0000000..b50a544 --- /dev/null +++ b/R/pca.R @@ -0,0 +1,334 @@ +#' pca module UI representation +#' +#' @param id The ID of the modules namespace. +#' @param show.label Set initial value of show label checkbox (Default = TRUE). +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +pcaUI <- function(id, show.label = TRUE) { + ns <- shiny::NS(id) + + shiny::tagList(shiny::fluidPage( + rintrojs::introjsUI(), + shinyjs::useShinyjs(), + shiny::fluidRow(shinydashboard::box( + width = 12, + shiny::div(style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center", + shiny::plotOutput(outputId = ns("pca")) + ) + )), + shiny::fluidRow( + shinydashboard::box( + width = 12, + collapsible = TRUE, + shiny::fluidRow( + shiny::column( + width = 4, + shiny::div(id = ns("guide_selection"), + columnSelectorUI(ns("select")), + shiny::checkboxInput(ns("label"), label = "show label", value = show.label) + ) + ), + shiny::column( + width = 4, + shiny::div(id = ns("guide_dimensions"), + shiny::numericInput(ns("dimA"), label = "PCA dimension (x-axis)", min = 1, max = 6, step = 1, value = 1), + shiny::numericInput(ns("dimB"), label = "PCA dimension (y-axis)", min = 1, max = 6, step = 1, value = 2) + ) + ), + shiny::column( + width = 4, + shiny::div(id = ns("guide_pointsize"), + shiny::sliderInput(ns("pointsize"),label = "Point size", min = 0.1, max = 10, value = 2), + shiny::sliderInput(ns("labelsize"), label = "Label size", min = 1, max = 20, value = 5, round = TRUE) + ) + ) + ), + shiny::fluidRow(shiny::column( + width = 12, + shiny::div(id = ns("guide_buttons"), + shiny::actionButton(ns("plot"), "Plot", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "Reset", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")), + shiny::downloadButton(outputId = ns("download"), label = "Download") + ) + + )) + + ) + ) + )) +} + +#' pca module server logic +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param data data.table data visualized in plot. (Supports Reactive) +#' @param types data.table: (Supports reactive) +#' column1: colnames of data +#' column2: corresponding column typ +#' column3: label (optional, used instead of id) +#' column4: sub_label (optional, added to id/ label) +#' @param levels Levels from which data is selected (Defaults to unique(metadata[["level"]])). (Supports Reactive) +#' @param entryLabel Define additional columns added to each entry (Default = NULL). Use a vector containing the desired columnnames e.g. c("column1", "column2"). +#' @param width Width of the plot in cm. Defaults to 28 and supports reactive. +#' @param height Height of the plot in cm. Defaults to 28 and supports reactive. +#' @param ppi Pixel per inch. Defaults to 72 and supports reactive. +#' +#' @details Width/ height/ ppi less or equal to zero will use default value. +#' +#' @return A reactive containing list with dimensions. +#' +#' @import data.table +#' +#' @export +pca <- function(input, output, session, data, types, levels = NULL, entryLabel = NULL, width = 28, height = 28, ppi = 72) { + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data <- data.table::copy(data()) + }else{ + data <- data.table::copy(data) + } + #merge columns for additional label info + if(!is.null(entryLabel)){ + data[, 1 := apply(data[, c(names(data)[1], entryLabel), with = FALSE], 1, paste, collapse = ", ")] + names(data)[1] <- paste(names(data)[1], paste(entryLabel, collapse = ", "), sep = ", ") + } + + return(data) + }) + types.r <- shiny::reactive({ + if(shiny::is.reactive(types)){ + types() + }else{ + types + } + }) + levels.r <- shiny::reactive({ + if(is.null(levels)){ + metadata.r()[["level"]] + }else{ + if(shiny::is.reactive(levels)){ + levels() + }else{ + levels + } + } + }) + # handle reactive sizes + size <- shiny::reactive({ + width <- ifelse(shiny::is.reactive(width), width(), width) + height <- ifelse(shiny::is.reactive(height), height(), height) + ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi) + + if(!is.numeric(width) | width <= 0) { + width <- 28 + } + if(!is.numeric(height) | height <= 0) { + height <- 28 + } + if(!is.numeric(ppi) | ppi <= 0) { + ppi <- 72 + } + + list(width = width, + height = height, + ppi = ppi) + }) + + + guide <- pcaGuide(session) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide())) + }) + + #reset ui + shiny::observeEvent(input$reset, { + shinyjs::reset("label") + shinyjs::reset("dimA") + shinyjs::reset("dimB") + shinyjs::reset("pointsize") + shinyjs::reset("labelsize") + columnSelect <<- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(types.r()[level %in% levels.r(), c("key", "level"), with = FALSE]), columnTypeLabel = "Column types to choose from") + }) + + columnSelect <- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(types.r()[level %in% levels.r(), c("key", "level"), with = FALSE]), columnTypeLabel = "Column types to choose from") + + output$datalevel <- shiny::renderUI({ + shiny::selectInput(session$ns("select"), label = "select data level", choices = unique(levels.r())) + }) + + #update dimension inputs + shiny::observe({ + col.num <- length(columnSelect$selectedColumns()) + if(col.num < 3 | nrow(data.r()) < 3 | is.na(input$dimA) | is.na(input$dimB)){ + shinyjs::disable("plot") + + # show warning if not enough selected + if(col.num > 0) { + shiny::showNotification( + ui = "Not enough columns selected! At least 3 needed for plotting.", + id = "warning", + type = "warning" + ) + }else { + shiny::removeNotification("warning") + } + + }else{ + shiny::removeNotification("warning") + shinyjs::enable("plot") + + if(col.num <= input$dimA){ + valueA <- col.num - 1 + }else{ + valueA <- input$dimA + } + if(col.num <= input$dimB){ + valueB <- col.num - 1 + }else{ + valueB <- input$dimB + } + shiny::updateNumericInput(inputId = "dimA", session = session, max = col.num - 1, value = valueA) + shiny::updateNumericInput(inputId = "dimB", session = session, max = col.num - 1, value = valueB) + } + }) + + # warning if plot size exceeds limits + shiny::observe({ + if(computed.data()$exceed_size) { + shiny::showNotification( + ui = "Width and/ or height exceed limit. Using 500 cm instead.", + id = "limit", + type = "warning" + ) + } else { + shiny::removeNotification("limit") + } + }) + + selected <- shiny::reactive({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Select data") + + selected <- data.r()[, c(names(data.r())[1], columnSelect$selectedColumns()), with = FALSE] + + progress$set(1) + + return(selected) + }) + + # disable downloadButton on init + shinyjs::disable("download") + + computed.data <- shiny::eventReactive(input$plot, { + # enable downloadButton + shinyjs::enable("download") + + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Render plot") + + plot <- create_pca( + data = selected(), + dimensionA = input$dimA, + dimensionB = input$dimB, + dimensions = length(columnSelect$selectedColumns()) - 1, + pointsize = input$pointsize, + labelsize = input$labelsize, + labels = input$label, + custom.labels = columnSelect$label(), + on.columns = TRUE, + width = size()$width, + height = size()$height, + ppi = size()$ppi + ) + + progress$set(1) + + return(plot) + }) + + # get width in pixel + plot_width <- shiny::reactive({ + width <- computed.data()$width * (computed.data()$ppi / 2.54) + ifelse(width < 50, 50, width) + }) + + # get height in pixel + plot_height <- shiny::reactive({ + height <- computed.data()$height * (computed.data()$ppi / 2.54) + ifelse(height < 50, 50, height) + }) + + output$pca <- shiny::renderPlot( + width = plot_width, + height = plot_height, + { + computed.data()$plot + }) + + #group data by dimension + reorganized.data <- shiny::reactive({ + sapply(colnames(computed.data()$data$var$coord), USE.NAMES = TRUE, simplify = FALSE, function(dim) { + sapply(computed.data()$data$var, function(table) { + table[, dim] + }) + }) + }) + + output$download <- shiny::downloadHandler(filename = "pca.zip", + content = function(file) { + download(file = file, filename = "pca.zip", plot = computed.data()$plot, width = plot_width() / (computed.data()$ppi / 2.54), height = plot_height() / (computed.data()$ppi / 2.54), ppi = computed.data()$ppi, ui = user_input()) + }) + + user_input <- shiny::reactive({ + # format selection + selection <- list( + data = list(type = columnSelect$type(), selectedColumns = columnSelect$selectedColumns()), + dimensions = list(xaxis = input$dimA, yaxis = input$dimB) + ) + + # format options + options <- list( + show_label = input$label, + pointsize = input$pointsize, + labelsize = input$labelsize + ) + + # merge all + all <- list(selection = selection, options = options) + }) + + return(reorganized.data) +} + +#' pca module guide +#' +#' @param session The shiny session +#' +#' @return A shiny reactive that contains the texts for the Guide steps. +#' +pcaGuide <- function(session) { + steps <- list( + "guide_selection" = "

Data selection

+ Select a column type for visualization, then select individual columns based on the chosen type.
+ At least three individual columns need to be selected for PCA.", + "guide_dimensions" = "

PCA dimensions

+ Choose which PCA dimensions are shown on the x-axis and y-axis.
+ The number of PCA dimensions available for visualization is one less than the number of selected columns in the previous step.", + "guide_pointsize" = "

Additional options

+ You can increase or decrease the point size by dragging the slider to the right or to the left. The same goes for the label size and it's respecting slider.", + "guide_buttons" = "

Create the plot

+ As a final step, a click on the 'Plot' button will render the plot, while a click on the 'Reset' button will reset the parameters to default." + ) + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/scatterPlot.R b/R/scatterPlot.R new file mode 100644 index 0000000..1fc2a8b --- /dev/null +++ b/R/scatterPlot.R @@ -0,0 +1,472 @@ +#' scatterPlot module UI representation +#' +#' @param id The ID of the modules namespace. +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +scatterPlotUI <- function(id) { + ns <- shiny::NS(id) + + shiny::tagList(shiny::fluidPage( + shiny::fluidRow(shinydashboard::box( + width = 12, + shiny::div(style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center", + shiny::uiOutput(outputId = ns("scatter")) + ) + )), + shiny::fluidRow( + rintrojs::introjsUI(), + shinyjs::useShinyjs(), + shinydashboard::box( + width = 12, + shiny::fluidRow( + shiny::column( + width = 3, + shiny::div(id = ns("guide_xaxis"), + columnSelectorUI( + id = ns("xaxis"), + title = "Data on x-axis", + label = T + ) + ), + shiny::div(id = ns("guide_xaxis_transformation"), + transformationUI(id = ns("transform_x"), label = "Transformation", choices = list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore")) + ), + shiny::div(id = ns("guide_xaxis_limit"), + limitUI(id = ns("xaxis_limit"), label = "Limit axis")) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_yaxis"), + columnSelectorUI( + id = ns("yaxis"), + title = "Data on y-axis", + label = T + ) + ), + shiny::div(id = ns("guide_yaxis_transformation"), + transformationUI(id = ns("transform_y"), label = "Transformation", choices = list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore")) + ), + shiny::div(id = ns("guide_yaxis_limit"), + limitUI(id = ns("yaxis_limit"), label = "Limit axis")) + + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_zaxis"), + columnSelectorUI( + id = ns("zaxis"), + title = "Data on z-axis", + label = T + ) + ) + ), + shiny::column( + width = 3, + shiny::div(id = ns("guide_color"), + colorPicker2UI(id = ns("color")) + ), + shiny::div(id = ns("guide_pointsize"), + shiny::sliderInput( + ns("pointsize"), + "Point Size", + min = 0.1, + max = 10, + value = 0.4 + ), + shiny::sliderInput( + ns("labelsize"), + "Label Size", + min = 1, + max = 20, + value = 5, + round = TRUE + ) + ), + shiny::div(id = ns("guide_options"), + shiny::HTML("Additional options"), + shiny::checkboxInput(ns("density"), "Add 2D kernel density estimate", value = FALSE), + shiny::checkboxInput(ns("line"), "Add reference line", value = TRUE) + ) + ) + ), + shiny::fluidRow(shiny::column( + width = 12, + shiny::div(id = ns("guide_buttons"), + shiny::actionButton(ns("plot"), "Plot", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("reset"), "Reset", style = "color: #fff; background-color: #3c8dbc"), + shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")), + shiny::downloadButton(outputId = ns("download"), label = "Download") + ) + )) + ) + ) + )) +} + +#' scatterPlot module server logic +#' +#' @param input Shiny's input object +#' @param output Shiny's output object +#' @param session Shiny's session object +#' @param data data.table data visualized in plot (Supports reactive). +#' @param types data.table: (Supports reactive) +#' column1: colnames of data +#' column2: corresponding column type +#' column3: label (optional, used instead of id) +#' column4: sub_label (optional, added to id/ label) +#' @param features data.table of the features to mark (first column = id) +#' @param markerReac reactive containing inputs of marker module. +#' @param plot.method Choose to rather render a 'interactive' or 'static' plot. Defaults to 'static'. +#' @param width Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param height Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive. +#' @param ppi Pixel per inch. Defaults to 72 and supports reactive. +#' +#' @return Returns reactive containing data used for plot. +#' +#' @details Make sure to have the same columnnames in data and features. +#' +#' @export +scatterPlot <- function(input, output, session, data, types, features = NULL, markerReac = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72) { + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data <- data.table::copy(data()) + }else{ + data <- data.table::copy(data) + } + + return(data) + }) + #handle reactive features + features.r <- shiny::reactive({ + if(shiny::is.reactive(features)){ + features <- features() + }else{ + features <- features + } + + return(features) + }) + # handle reactive sizes + size <- shiny::reactive({ + width <- ifelse(shiny::is.reactive(width), width(), width) + height <- ifelse(shiny::is.reactive(height), height(), height) + ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi) + + if(!is.numeric(width) || width <= 0) { + width <- "auto" + } + if(!is.numeric(height) || height <= 0) { + height <- "auto" + } + if(!is.numeric(ppi) || ppi <= 0) { + ppi <- 72 + } + + list(width = width, + height = height, + ppi = ppi) + }) + + #Fetch the reactive guide for this module + guide <- scatterPlotGuide(session, !is.null(markerReac)) + shiny::observeEvent(input$guide, { + rintrojs::introjs(session, options = list(steps = guide())) + }) + + data_x <- shiny::reactive(as.matrix(data.r()[, xaxis$selectedColumn(), with = FALSE])) + data_y <- shiny::reactive(as.matrix(data.r()[, yaxis$selectedColumn(), with = FALSE])) + + #reset ui + shiny::observeEvent(input$reset, { + shinyjs::reset("density") + shinyjs::reset("line") + shinyjs::reset("pointsize") + shinyjs::reset("labelsize") + xaxis <<- shiny::callModule(columnSelector, "xaxis", type.columns = types, columnTypeLabel = "Column type to choose from", labelLabel = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_x$method())) + yaxis <<- shiny::callModule(columnSelector, "yaxis", type.columns = types, columnTypeLabel = "Column type to choose from", labelLabel = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_y$method())) + zaxis <<- shiny::callModule(columnSelector, "zaxis", type.columns = types, columnTypeLabel = "Column type to choose from", multiple = FALSE, none = TRUE) + colorPicker <<- shiny::callModule(colorPicker2, "color", distribution = list("sequential", "diverging"), winsorize = winsorize) + transform_x <<- shiny::callModule(transformation, "transform_x", data = data_x) + transform_y <<- shiny::callModule(transformation, "transform_y", data = data_y) + limit_x <<- shiny::callModule(limit, "xaxis_limit", lower = shiny::reactive(get_x_limit()[1]), upper = shiny::reactive(get_x_limit()[2])) + limit_y <<- shiny::callModule(limit, "yaxis_limit", lower = shiny::reactive(get_y_limit()[1]), upper = shiny::reactive(get_y_limit()[2])) + }) + + winsorize <- shiny::reactive({ + if(zaxis$selectedColumn() != "") { + equalize(result.data()$processed.data[, 4]) + } else { + NULL + } + }) + + xaxis <- shiny::callModule(columnSelector, "xaxis", type.columns = types, columnTypeLabel = "Column type to choose from", labelLabel = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_x$method())) + yaxis <- shiny::callModule(columnSelector, "yaxis", type.columns = types, columnTypeLabel = "Column type to choose from", labelLabel = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_y$method())) + zaxis <- shiny::callModule(columnSelector, "zaxis", type.columns = types, columnTypeLabel = "Column type to choose from", labelLabel = "Color label", multiple = FALSE, none = TRUE) + + colorPicker <- shiny::callModule(colorPicker2, "color", distribution = list("sequential", "diverging"), winsorize = winsorize) + transform_x <- shiny::callModule(transformation, "transform_x", data = data_x) + transform_y <- shiny::callModule(transformation, "transform_y", data = data_y) + limit_x <- shiny::callModule(limit, "xaxis_limit", lower = shiny::reactive(result.data()$xlim[1]), upper = shiny::reactive(result.data()$xlim[2])) + limit_y <- shiny::callModule(limit, "yaxis_limit", lower = shiny::reactive(result.data()$ylim[1]), upper = shiny::reactive(result.data()$ylim[2])) + + # select container dependend on plot.method + if(plot.method == "static") { + output$scatter <- shiny::renderUI({ + shiny::plotOutput(outputId = session$ns("static")) + }) + }else if(plot.method == "interactive") { + output$scatter <- shiny::renderUI({ + plotly::plotlyOutput(outputId = session$ns("interactive")) + }) + } + + transformed_data <- shiny::reactive({ + #reassemble after transformation + if(zaxis$selectedColumn() != ""){ + z <- data.table::data.table(data.r()[, zaxis$selectedColumn(), with = FALSE]) + pre.data <- data.table::data.table(transform_x$data(), transform_y$data(), z) + }else{ + pre.data <- data.table::data.table(transform_x$data(), transform_y$data()) + } + + #add rownames/ids + return(data.table::data.table(data.r()[, 1], pre.data)) + }) + + result.data <- shiny::eventReactive(input$plot, { + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0, message = "Computing data") + + result <- list( + processed.data = NULL, + highlight.color = NULL, + highlight.labels = NULL, + highlight.data = NULL, + xlim = NULL, + ylim = NULL + ) + + #get selected data + progress$set(0.3, detail = "transforming") + processed.data <- transformed_data() + progress$set(0.5, detail = "selecting") + + #get axis limits + result$xlim <- c(min(processed.data[, 2], na.rm = TRUE), max(processed.data[, 2], na.rm = TRUE)) + result$ylim <- c(min(processed.data[, 3], na.rm = TRUE), max(processed.data[, 3], na.rm = TRUE)) + + #get highlighted data + if(!is.null(markerReac) & !is.null(features.r())){ + + result$highlight.color <- markerReac()$color + if(markerReac()$highlight != "Disabled" & nrow(features.r()) > 0){ + result$highlight.labels <- markerReac()$label + } + + if(markerReac()$highlight == "Highlight" & nrow(features.r()) > 0){ + #overwrite columnnames because data.table makes unqiue names + result$highlight.data <- processed.data[features.r()[, names(features.r())[1], with = FALSE], on = names(features.r())[1]] + names(result$highlight.data) <- names(processed.data) + #sort out highlighted data + result$processed.data <- processed.data[!result$highlight.data, on = names(result$highlight.data)] + }else if(markerReac()$highlight == "Exclusive" & nrow(features.r()) > 0){ + result$processed.data <- processed.data[features.r()[, names(features.r())[1], with = FALSE], on = names(features.r())[1]] + }else{ + result$processed.data <- processed.data + } + }else{ + result$processed.data <- processed.data + } + + progress$set(1) + return(result) + }) + + #disable downloadbutton on init + shinyjs::disable("download") + + plot <- shiny::eventReactive(input$plot, { + #enable downloadbutton + shinyjs::enable("download") + + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Computing plot") + + colors <- colorPicker()$palette + + if(!is.null(limit_x())) { + xlimit <- unlist(unname(limit_x())) + } else { + xlimit <- result.data()$xlim + } + if(!is.null(limit_y())) { + ylimit <- unlist(unname(limit_y())) + } else { + ylimit <- result.data()$ylim + } + + plot <- create_scatterplot( + data = result.data()$processed.data, + colors = colors, + x_label = xaxis$label(), + y_label = yaxis$label(), + z_label = zaxis$label(), + transparency = colorPicker()$transparency, + pointsize = input$pointsize, + labelsize = input$labelsize, + density = input$density, + line = input$line, + highlight.data = result.data()$highlight.data, + highlight.color = result.data()$highlight.color, + highlight.labels = result.data()$highlight.labels, + xlim = xlimit, + ylim = ylimit, + colorbar.limits = colorPicker()$winsorize, + plot.method = plot.method, + width = size()$width, + height = size()$height, + ppi = size()$ppi + ) + + progress$set(1) + return(plot) + }) + + # warning if plot size exceeds limits + shiny::observe({ + if(plot()$exceed_size) { + shiny::showNotification( + ui = "Width and/ or height exceed limit. Using 500 cm instead.", + id = "limit", + type = "warning" + ) + } else { + shiny::removeNotification("limit") + } + }) + + if(plot.method == "static") { + output$static <- shiny::renderPlot( + width = shiny::reactive(plot()$width * (plot()$ppi / 2.54)), + height = shiny::reactive(plot()$height * (plot()$ppi / 2.54)), + { + plot()$plot + } + ) + } else if(plot.method == "interactive") { + output$interactive <- plotly::renderPlotly({ + #new progress indicator + progress <- shiny::Progress$new() + on.exit(progress$close()) + progress$set(0.2, message = "Render plot") + + plot <- plot()$plot + + progress$set(1) + return(plot) + }) + + } + + output$download <- shiny::downloadHandler(filename = "scatterPlot.zip", + content = function(file) { + download(file = file, filename = "scatterPlot.zip", plot = plot()$plot, width = plot()$width, height = plot()$height, ppi = plot()$ppi, ui = user_input()) + } + ) + + + user_input <- shiny::reactive({ + # format axis + xaxis <- lapply(xaxis, function(x) { x() }) + yaxis <- lapply(yaxis, function(x) { x() }) + zaxis <- lapply(zaxis, function(x) { x() }) + ## transformation + xaxis <- append(xaxis, list(transformation = transform_x$method(), limit = limit_x()), after = length(xaxis)) + yaxis <- append(yaxis, list(transformation = transform_y$method(), limit = limit_y()), after = length(yaxis)) + + axis <- list(xaxis = xaxis, yaxis = yaxis, zaxis = zaxis) + + # format appearance + appearance <- list( + scheme = colorPicker()$name, + reverse = colorPicker()$reverse, + winsorize = colorPicker()$winsorize, + transparency = colorPicker()$transparency, + pointsize = input$pointsize, + labelsize = input$labelsize) + + # format options + options <- list(density = input$density, line = input$line) + + # format marker + marker <- NULL + if(!is.null(markerReac)) { + marker <- markerReac() + } + + #merge all + all <- list(axis = axis, appearance = appearance, options = options, marker = marker) + }) + + return(shiny::reactive({unique(data.table::rbindlist(list(result.data()$processed.data, result.data()$highlight.data)))})) +} + +#' scatterPlot module guide +#' +#' @param session The shiny session +#' @param marker Logical if marker step should be enabled (Default = FALSE). +#' +#' @return A shiny reactive that contains the texts for the Guide steps. +#' +scatterPlotGuide <- function(session, marker = FALSE) { + steps <- list( + "guide_xaxis" = "

Data selection: x-axis

+ Select a column type for visualization, then select an individual column of the chosen type.
+ You can also set a customized label for the axis. If left empty, the column name will be used as default.", + "guide_xaxis_transformation" = "

X-axis transformation

+ Pick a transformation that you want to apply to your data or leave it as 'None' if no transformation is needed.", + "guide_xaxis_limit" = "

X-axis limit

+ Use upper/ lower limit to customize the axis limits.", + "guide_yaxis" = "

Data selection: y-axis

+ Select a column type for visualization, then select an individual column of the chosen type.
+ You can also set a customized label for the axis. If left empty, the column name will be used as default.", + "guide_yaxis_transformation" = "

Y-axis transformation

+ Pick a transformation that you want to apply to your data or leave it as 'None' if no transformation is needed.", + "guide_yaxis_limit" = "

Y-axis limit

+ Use upper/ lower limit to customize the axis limits.", + "guide_zaxis" = "

Data selection: z-axis

+ Select a column type for visualization, then select an individual column of the chosen type. The data from the selected column will be mapped onto a color scale.
+ You can also set a customized label for the color bar. If left empty, the column name will be used as default.", + "guide_color" = "

Color palettes

+ Based on the data distribution, select either a sequential or diverging color palette.
+ Choose the range of the color legend by defining it's upper and lower limits with 'Winsorize to upper/lower'. Be aware that out of bounds values will be mapped to their nearest color.
+ Additionally, color palettes can be reversed and colors can be adjusted in transparency.", + "guide_pointsize" = "

Pointsize/ Labelsize

+ You can increase or decrease the point size by dragging the slider to the right or to the left. The same applies to the label size and it's respecting slider.", + "guide_options" = "

Additional options

+ You can add a 2D kernel density estimate and/or a reference line in the form of y = x to the plot by ticking 'Add 2D kernel density estimate' or 'Add reference line'.
+ Note that the computation of the 2D kernel density estimate might take a while.", + "guide_buttons" = "

Create the plot

+ As a final step, a click on the 'Plot' button will render the plot, while a click on the 'Reset' button will reset the parameters to default." + ) + + #add marker text to guide + if(marker){ + steps <- append(steps, + list("guide_marker" = "

Highlighting

+ If a set of features is selected, it is possible to either 'Highlight' those data points in the selected color or to show them 'Exclusively', omitting all other data points.
+ The label of each selected feature can be chosen from the 'Selected label columns' dropdown list."), + 8 + ) + } + + shiny::reactive(data.frame(element = paste0("#", session$ns(names(steps))), intro = unlist(steps))) +} diff --git a/R/transformation.R b/R/transformation.R new file mode 100644 index 0000000..2b7a87c --- /dev/null +++ b/R/transformation.R @@ -0,0 +1,162 @@ +#' transformation module UI representation +#' +#' This function provides an input to select a transformation method. +#' +#' @param id The ID of the modules namespace. +#' @param label A character vector of length one with the label for the \code{\link[shiny]{selectInput}}. +#' @param selected The initially selected value. See \code{\link[shiny]{selectInput}}. +#' @param choices Named list of available transformations. Possible transformations are list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore", `regularized log` = "rlog") which is also the default. +#' @param transposeOptions Boolean value if transpose radioButtons are shown (Default = FALSE). +#' +#' @return A list with HTML tags from \code{\link[shiny]{tag}}. +#' +#' @export +transformationUI <- function(id, label = "Transformation", selected = "raw", choices = list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore", `regularized log` = "rlog"), transposeOptions = FALSE) { + ns <- shiny::NS(id) + + ret <- list( + shiny::tags$b(label), + #shiny::actionLink(ns("help"), label = NULL, icon = shiny::icon("question-circle")), # removed for now + shiny::selectInput(ns("transform"), + label = NULL, + choices = choices, + selected = selected, + multiple = F)) + if(transposeOptions){ + ret <- list(ret, shinyjs::useShinyjs(), shiny::radioButtons(ns("transpose"), label = NULL, choices = c(`row-wise` = "row", `column-wise` = "column"))) + } + + shiny::tagList(ret) +} + +#' transformation module server logic +#' +#' The module provides several transformations on a numeric data matrix for the user. +#' +#' @param input Shiny's input object. +#' @param output Shiny's output object. +#' @param session Shiny's session object. +#' @param data Numeric matrix on which transformation is performed (column-wise). (Supports reactive) +#' @param transpose Whether the matrix should be transposed to enable row-wise transformation. +#' @param pseudocount Numeric Variable to add a pseudocount to log-based transformations. +#' @param replaceInf Change Infinite to NA, applied after transformation. +#' @param replaceNA Change NA to 0, applied after transformation. +#' +#' @return Namedlist of two containing data and name of the used method. +#' data: Reactive containing the transformed matrix. Infinite values are replaced by NA and NA values are replaced by 0. +#' method: Reactive containing String. +#' transpose: Reactive containing String. +#' +#' @export +transformation <- function(input, output, session, data, transpose = FALSE, pseudocount = 1, replaceInf = TRUE, replaceNA = TRUE) { + #handle reactive data + data.r <- shiny::reactive({ + if(shiny::is.reactive(data)){ + data() + }else{ + data + } + }) + + #reset + shinyjs::reset("transform") + shinyjs::reset("transpose") + + #helptext + # shiny::observeEvent(input$help, { + # title <- "Data transformation" + # content <- shiny::HTML("Choose a method with which the given data is transformed:
") + # + # none <- shiny::HTML("'None' = No transformation will be performed
") + # log2 <- shiny::HTML(paste0("'log2' = A pseudocount of ", pseudocount, " will be added to all values afterwards a logarithm based two is performed.
")) + # `-log2` <- shiny::HTML(paste0("'-log2' = Similar to log2 a pseudocount of ", pseudocount, " will be added to all values afterwards a negated logarithm based two is performed.
")) + # log10 <- shiny::HTML(paste0("'log10' = Adds a pseudocount of ", pseudocount, " and performs a logarithm based ten.
")) + # `-log10` <- shiny::HTML(paste0("'log10' = Similar to log10 adds a pseudocount of ", pseudocount, " and performs a negated logarithm based ten.
")) + # zscore <- shiny::HTML(paste0("'zscore' = Applies a zscore transformation to the data.
")) + # rlog <- shiny::HTML(paste0("'regularized log (rlog)' = Log2 transformation which minimizes differences between samples for rows with small counts, and which normalizes with respect to library size.")) + # + # content <- list(content, none, log2, `-log2`, log10, `-log10`, zscore, rlog, shiny::HTML("
")) + # if(!is.null(input$transpose)){ + # transposeOpt <- shiny::HTML("Use the radioButtons to select whether the transformation should be applied row- or column-wise. Will only be enabled when needed (e.g. zscore).
") + # content <- list(content, transposeOpt) + # } + # if(replaceInf){ + # inf <- shiny::HTML("Every positive or negative Infinite will be replaced with NA after transformation.
") + # content <- list(content, inf) + # } + # if(replaceNA){ + # na <- shiny::HTML("All NA in the dataset will be set to 0 after the transformation is applied.") + # content <- list(content, na) + # } + # + # shiny::showModal( + # shiny::modalDialog( + # title = title, + # footer = shiny::modalButton("close"), + # easyClose = TRUE, + # content + # ) + # ) + # }) + + # try rlog transformation else do log2 + try_rlog <- function(x) { + tryCatch(DESeq2::rlogTransformation(x, blind = TRUE), + error = function(err) { + message("Rlog failed using log2 instead.") + log2(x) + }) + } + + transformed_data <- shiny::reactive({ + data <- data.r() + + if(transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore"){ + data <- t(data) + } + + #transform data + output <- switch(input$transform, + log2 = log2(data + pseudocount), + `-log2` = -log2(data + pseudocount), + log10 = log10(data + pseudocount), + `-log10` = -log10(data + pseudocount), + zscore = scale(data, center = TRUE, scale = TRUE), + rlog = try_rlog(round(data) + pseudocount), + raw = data + ) + + #replace infinite with NA & NA with 0 + if(replaceInf){ + is.na(output) <- sapply(output, is.infinite) + } + if(replaceNA){ + output[is.na(output)] <- 0 + } + + if(transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore"){ + output <- t(output) + } + + return(output) + }) + + #enable transposeOptions only if relevant + shiny::observe({ + if(input$transform == "zscore"){ + shinyjs::enable("transpose") + }else{ + shinyjs::disable("transpose") + } + }) + + method <- shiny::reactive({ + if(input$transform == "zscore") { + paste(input$transform, input$transpose) + } else { + input$transform + } + }) + + return(list(data = transformed_data, method = method, transpose = shiny::reactive(input$transpose))) +} diff --git a/R/zzz.R b/R/zzz.R new file mode 100644 index 0000000..24d61b2 --- /dev/null +++ b/R/zzz.R @@ -0,0 +1,4 @@ +.onLoad <- function(libname = find.package("wilson"), pkgname = "wilson") { + # make server aware of images + shiny::addResourcePath(prefix = "wilson_www", directoryPath = system.file("www", package = "wilson")) +} diff --git a/README.md b/README.md new file mode 100644 index 0000000..9757834 --- /dev/null +++ b/README.md @@ -0,0 +1,40 @@ +# WIlsON: Webbased Interactive Omics visualizatioN - The R Package + +## Abstract +#### Objective +High-throughput (HT) studies of complex biological systems generate a massive amount of so called omics data. The results are typically summarized using spreadsheet like data formats. Visualization of this data is a key aspect of both, the analysis and the understanding of biological systems under investigation. While users have many visualization methods and tools to choose from, the challenge is to properly handle these tools and create clear, meaningful, and integrated visualizations based on pre-processed datasets. + +#### Results +The WIlsON R package employs the R Shiny and Plotly web-based frameworks using a client-server based approach comprising a range of interface and plotting modules. These can be joined to allow a user to select a meaningful combination of parameters for the creation of various plot types (e.g. bar, box, line, scatter, heat). The modular setup of elements assures a concise code base and simplifies maintenance. An app thus created can be mounted on an R Shiny Server or inside R Studio. Data must be supplied server-side using a custom tab-delimited format derived from the SummarizedExperiment format (Clarion) and can principally originate from any analysis (e.g. RNA-Seq, ChIP-Seq, Mass Spectrometry, Microarray) that results in numeric data (e.g. count, score, log2foldchange, zscore, pvalue) attributed to a feature (e.g. gene, transcript, probe, protein). + +#### Conclusions +The WIlsON R package includes a toolbox of R Shiny modules that can be used to construct a wide array of web-interfaces for plotting feature-based data. + +## Availability +All components of the WIlsON R package have been implemented in an integrated web application that is available for download from the Github repository [wilson-apps](https://github.molgen.mpg.de/loosolab/wilson-apps) and can be tested on our [official demonstration server](http://loosolab.mpi-bn.mpg.de/apps/wilson/). + +Get a Docker container [here](https://hub.docker.com/r/loosolab/wilson/). + +Please make sure to check our other projects at http://loosolab.mpi-bn.mpg.de/. + +## Organization and Philosophy +Visualizations are organized hierarchically as Shiny modules, such that larger visualizations are built from small, general, and reusable components. + +### Installation +The module source code is made available as an R package and can be installed locally with + +```r +library(devtools) +install_github("loosolab/wilson", host="github.molgen.mpg.de/api/v3") +``` + +## Data Format +CLARION: generiC fiLe formAt foR quantItative cOmparsions of high throughput screeNs + +CLARION is a data format especially developed to be used with WIlsON, which relies on a tab-delimited table with a metadata header to describe the following columns. Most results derived from a variety of analyses can thus be easily reformatted to become compatible, without having to modify the code of WIlsON for specific experiments. For details considering CLARION please visit the Introduction pages of our [official demonstration server](http://loosolab.mpi-bn.mpg.de/apps/wilson/). + +## How to cite +* Schultheis H, Kuenne C, Preussner J, Wiegandt R, Fust A, Looso M. WIlsON: Webbased Interactive Omics VisualizatioN. Bioinformatics (2017), doi: https://XY + +## License +This project is licensed under the MIT license. diff --git a/exec/and_example.R b/exec/and_example.R new file mode 100644 index 0000000..6b9e494 --- /dev/null +++ b/exec/and_example.R @@ -0,0 +1,47 @@ +library(shiny) +source("../R/and.R") +source("../R/orNumeric.R") +source("../R/orTextual.R") +source("../R/function.R") + +###Test Data +table <- data.table::data.table(w = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 11), + x = c("a,b", "b,c", "c,d", "d,e", "e,f", "f,g", "g,h", "h,i", "j,k", "k,l"), + y = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10), + z = c("a1", "b2", "c3", "d4", "e5", "f6", "g7", "h8", "i9", "j10") + ) +delimiter <- c(NULL, ",", NULL, NULL) +multiple <- c(TRUE) +contains <- c(FALSE) +ranged <- c(TRUE, FALSE, FALSE) +step <- c(NULL) + +ui <- fluidPage( + fluidRow( + selectInput(inputId = "column", label = "columns to select from", choices = names(table), multiple = T), + actionButton(inputId = "reset", label = "Reset") + ), + fluidRow( + andUI(id = "id") + ), + fluidRow( + verbatimTextOutput("id.out") + ) +) + +server <- function(input, output, session) { + data <- reactive({ + table + }) + + mod <-callModule(and, "id", data = data, show.elements = reactive(input$column), delimiter = delimiter, multiple = multiple, contains = contains, ranged = ranged, step = step, selection.default = "all", reset = reactive(input$reset)) + + output$id.out <- renderPrint({ + print(mod()) + print("Filter Data:") + print(data()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/colorPicker2_example.R b/exec/colorPicker2_example.R new file mode 100644 index 0000000..04c2721 --- /dev/null +++ b/exec/colorPicker2_example.R @@ -0,0 +1,33 @@ +library(shiny) +source("../R/colorPicker2.R") + + +ui <- fluidPage( + column(width = 4, + colorPicker2UI("custom.single", custom = TRUE, label = "Single color select"), + verbatimTextOutput("cs.t") + ), + column(width = 4, + colorPicker2UI("custom.multiple", custom = TRUE, multiple = TRUE, label = "Multiple color select/ custom colorpalette"), + verbatimTextOutput("cm.t") + ), + column(width = 4, + colorPicker2UI("defined", label = "predefined palettes", show.scaleoptions = T), + verbatimTextOutput("d.t") + ) + ) + + +server <- function(input, output) { + def <- callModule(colorPicker2, "defined", distribution = "all", num.color = 3) + cs <- callModule(colorPicker2, "custom.single", num.colors = 3) + cm <- callModule(colorPicker2, "custom.multiple", num.colors = 3) + + output$d.t <- renderPrint(def()) + output$cs.t <- renderPrint(cs()) + output$cm.t <- renderPrint(cm()) + +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/colorPicker_example.R b/exec/colorPicker_example.R new file mode 100644 index 0000000..8c70c85 --- /dev/null +++ b/exec/colorPicker_example.R @@ -0,0 +1,15 @@ +library(shiny) +source("../R/colorPicker.R") + + +ui <- fluidPage(colorPickerUI("id")) + +server <- function(input, output) { + mod <- callModule(colorPicker, "id") + + observe(print(mod$scheme)) + +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/columnSelector_example.R b/exec/columnSelector_example.R new file mode 100644 index 0000000..004144b --- /dev/null +++ b/exec/columnSelector_example.R @@ -0,0 +1,47 @@ +library(shiny) +source("../R/columnSelector.R") + +###Test Data +table <- data.table::data.table(names = c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j"), type = c("sample", "codition", "contrast")) + +ui <- fluidPage( + fluidRow( + column(width = 6, + columnSelectorUI(id = "id", label = F, title = "first selector"), + verbatimTextOutput("first") + ), + column(width = 6, + columnSelectorUI(id = "2", label = T, title = "second selector"), + verbatimTextOutput("second") + ) + ) +) + +server <- function(input, output) { +data <- reactive({ + table +}) + +type <- reactive({ + unique(table[[2]])[-1] +}) + + mod <-callModule(columnSelector, "id", type.columns = table, multiple = FALSE, none = TRUE) + mod2 <-callModule(columnSelector, "2", type.columns = data, type = type) + + output$first <- renderPrint({ + print(mod$type()) + print(mod$selectedColumn()) + print(mod$label()) + }) + + output$second <- renderPrint({ + print(mod2$type()) + print(mod2$selectedColumn()) + print(mod2$label()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) + diff --git a/exec/featureSelector_example.R b/exec/featureSelector_example.R new file mode 100644 index 0000000..f699717 --- /dev/null +++ b/exec/featureSelector_example.R @@ -0,0 +1,35 @@ +library(shiny) +library(shinydashboard) +source("../R/and.R") +source("../R/orNumeric.R") +source("../R/orTextual.R") +source("../R/featureSelector.R") +source("../R/function.R") + +# test data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" + +ui <- dashboardPage(header = dashboardHeader(), + sidebar = dashboardSidebar( + selectInput("columns", label = "Features to select from", choices = names(data), multiple = TRUE), + verbatimTextOutput("filter") +), dashboardBody(fluidPage( + featureSelectorUI(id = "id") +))) + + +server <- function(input, output) { + + mod <-callModule(featureSelector, "id", data = data, delimiter = ",", features = reactive(input$columns), feature.grouping = metadata) + + output$filter <- renderText({ + paste(mod()$filter, collapse = "\n") + }) + +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/geneView_example.R b/exec/geneView_example.R new file mode 100644 index 0000000..bddb915 --- /dev/null +++ b/exec/geneView_example.R @@ -0,0 +1,45 @@ + +library(shiny) +library(shinydashboard) +source("../R/function.R") +source("../R/colorPicker2.R") +source("../R/transformation.R") +source("../R/geneView.R") +source("../R/columnSelector.R") +source("../R/label.R") +source("../R/limit.R") + +####Test Data +data <- data.table::data.table(id = rownames(mtcars), names = rownames(mtcars), mtcars) +# create metadata +metadata <- data.table::data.table(names(data), factor1 = rep("", length.out = length(names(data))), level = c(rep("annotation", 2), rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar( + numericInput(inputId = "width", label = "width in cm", value = 0, min = 0), + numericInput(inputId = "height", label = "height in cm", value = 0, min = 0) +), dashboardBody(fluidPage( + geneViewUI("id") +))) + +server <- function(input, output) { + table.r <- reactive({ + data + }) + metadata.r <- reactive({ + metadata + }) + level.r <- reactive({ + metadata[level != "annotation"][["level"]] + }) + + gene <- callModule(geneView, "id", data = table.r, metadata.r, level.r, custom.label = table.r, plot.method = "static", width = reactive(input$width), height = reactive(input$height)) + + observe({ + print(gene()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/global_cor_heatmap_example.R b/exec/global_cor_heatmap_example.R new file mode 100644 index 0000000..361273b --- /dev/null +++ b/exec/global_cor_heatmap_example.R @@ -0,0 +1,37 @@ +library(shiny) +library(shinydashboard) +source("../R/function.R") +source("../R/colorPicker2.R") +source("../R/columnSelector.R") +source("../R/transformation.R") +source("../R/global_cor_heatmap.R") +source("../R/limit.R") + +# test data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" + +ui <- dashboardPage( + header = dashboardHeader(), + sidebar = dashboardSidebar( + numericInput(inputId = "width", label = "width in cm", value = 0, min = 0), + numericInput(inputId = "height", label = "height in cm", value = 0, min = 0) + ), + dashboardBody( + fluidPage( + global_cor_heatmapUI("id") + ) + ) +) + +server <- function(input, output) { + table <- shiny::callModule(global_cor_heatmap, "id", data = data, types = metadata[type %in% c("performance", "design")], plot.method = "static", width = reactive(input$width), height = reactive(input$height)) + + shiny::observe({ + print(table()) + }) +} + +shinyApp(ui = ui, server = server) diff --git a/exec/heatmap_example.R b/exec/heatmap_example.R new file mode 100644 index 0000000..53e083b --- /dev/null +++ b/exec/heatmap_example.R @@ -0,0 +1,43 @@ + +library(shiny) +library(shinydashboard) +source("../R/function.R") +source("../R/colorPicker2.R") +source("../R/columnSelector.R") +source("../R/transformation.R") +source("../R/heatmap.R") +source("../R/label.R") + +####Test Data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + + +ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar( + numericInput(inputId = "width", label = "width in cm", value = 0, min = 0), + numericInput(inputId = "height", label = "height in cm", value = 0, min = 0) +), dashboardBody(fluidPage( + heatmapUI("id") +))) + +server <- function(input, output) { + table <- reactive({ + data + }) + typ <- reactive({ + # without annotation + metadata[ type != "annotation"] + }) + + heat <- callModule(heatmap, "id", data = table, types = typ, plot.method = "static", custom.row.label = table, width = reactive(input$width), height = reactive(input$height)) + + observe({ + print(heat()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/label_example.R b/exec/label_example.R new file mode 100644 index 0000000..d63e1da --- /dev/null +++ b/exec/label_example.R @@ -0,0 +1,28 @@ + +library(shiny) +source("../R/label.R") + +####Test Data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- fluidPage( + labelUI("labeller"), + "Vector of resulting labels:", + verbatimTextOutput("result") +) + +server <- function(input, output) { + + label <- callModule(label, "labeller", data = data[1:3], unique = T, multiple = T) + + output$result <- renderPrint({ + print(label()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/limit_example.R b/exec/limit_example.R new file mode 100644 index 0000000..c68e081 --- /dev/null +++ b/exec/limit_example.R @@ -0,0 +1,29 @@ + +library(shiny) +library(shinyjs) +source("../R/limit.R") + +####Test Data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- fluidPage( + limitUI(id = "limiter", label = "Upper/ Lower Limit"), + verbatimTextOutput("result") + +) + +server <- function(input, output) { + + limit <- callModule(limit, "limiter", lower = 5, upper = 10) + + output$result <- renderPrint({ + print(limit()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/marker_example.R b/exec/marker_example.R new file mode 100644 index 0000000..3894c5b --- /dev/null +++ b/exec/marker_example.R @@ -0,0 +1,27 @@ + +library(shiny) +source("../R/marker.R") +source("../R/colorPicker2.R") +source("../R/label.R") + +####Test Data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), type = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- fluidPage( + markerUI(id = "mark") +) + +server <- function(input, output) { + + marker <-callModule(marker, "mark", highlight.labels = data) + + observe({print(marker()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/orNumeric_example.R b/exec/orNumeric_example.R new file mode 100644 index 0000000..0e9fc24 --- /dev/null +++ b/exec/orNumeric_example.R @@ -0,0 +1,47 @@ + +library(shiny) +source("../R/orNumeric.R") +source("../R/function.R") + +ui <- fluidPage( + selectInput("test", "Select choices vector", choices = c(1, 2)), + verbatimTextOutput("choices"), + actionButton("reset", "reset"), + tags$br(), + column(width = 6, + orNumericUI(id = "ranged"), + verbatimTextOutput("ran.out") + ), + column(width = 6, + orNumericUI(id = "single"), + verbatimTextOutput("sin.out") + ) +) + +server <- function(input, output) { + choices1 <- c(0,1,2,3,4,5,6,7,8,9,10) + choices2 <- c(11, 12, 13, 14, 15, 16, 17, 18, 19, 20) + + choices <- reactive({ + if(input$test == 1) { + choices1 + } else { + choices2 + } + }) + + output$choices <- renderPrint(choices()) + + value <- reactive({ + c(min(choices()), max(choices())) + }) + + single <-callModule(orNumeric, "single", choices = choices, value = 3, label = "Title single", step = 11, zoomable = FALSE, reset = reactive(input$reset)) + ranged <-callModule(orNumeric, "ranged", choices = choices, value = value, label = "Title ranged", stepsize = 1, reset = reactive(input$reset)) + + output$ran.out <- renderPrint(ranged()) + output$sin.out <- renderPrint(single()) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/orTextual_example.R b/exec/orTextual_example.R new file mode 100644 index 0000000..374a163 --- /dev/null +++ b/exec/orTextual_example.R @@ -0,0 +1,35 @@ + +library(shiny) +source("../R/orTextual.R") + +ui <- fluidPage( + h4('choices <- c("test,1,a,v,asd", "a,b,c", "a,b,c", "asd|lkj", "2")'), + column(width = 4, + orTextualUI(id = "contains"), + verbatimTextOutput("co.out") + ), + column(width = 4, + orTextualUI(id = "delimit"), + verbatimTextOutput("del.out") + ), + column(width = 4, + orTextualUI(id = "nodelimit"), + verbatimTextOutput("nodel.out") + ), + actionButton("button", "reset") +) + +server <- function(input, output) { + choices <- c("test,1,a,v,asd", "a,b,c", "a,b,c", "asd|lkj", "2") + + contains <- callModule(orTextual, "contains", choices = choices, label = "contains = TRUE", contains = TRUE, reset = reactive(input$button)) + delimit <- callModule(orTextual, "delimit", choices = choices, label = "delimiter = ','", delimiter = ",", reset = reactive(input$button)) + no.delimit <- callModule(orTextual, "nodelimit", choices = choices, label = "delimiter = NULL, selected = 2, multiple = FALSE", selected = "2", multiple = FALSE, reset = reactive(input$button)) + + output$co.out <- renderPrint(contains()) + output$del.out <- renderPrint(delimit()) + output$nodel.out <- renderPrint(no.delimit()) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/pca_example.R b/exec/pca_example.R new file mode 100644 index 0000000..7cc78af --- /dev/null +++ b/exec/pca_example.R @@ -0,0 +1,27 @@ + +library(shiny) +library(shinydashboard) +source("../R/columnSelector.R") +source("../R/function.R") +source("../R/pca.R") + +#### Test Data +data <- data.table::as.data.table(mtcars, keep.rowname = "id") +# create metadata +metadata <- data.table::data.table(names(data), level = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar( + numericInput(inputId = "width", label = "width in cm", value = 0, min = 0), + numericInput(inputId = "height", label = "height in cm", value = 0, min = 0) +), dashboardBody(fluidPage( + pcaUI("id") +))) + +server <- function(input, output) { + callModule(pca, "id", data = data, types = metadata, levels = metadata[level != "annotation"][["level"]], width = reactive(input$width), height = reactive(input$height)) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/scatterPlot_example.R b/exec/scatterPlot_example.R new file mode 100644 index 0000000..d65489c --- /dev/null +++ b/exec/scatterPlot_example.R @@ -0,0 +1,43 @@ + +library(shiny) +library(shinydashboard) +source("../R/function.R") +source("../R/colorPicker2.R") +source("../R/columnSelector.R") +source("../R/transformation.R") +source("../R/scatterPlot.R") +source("../R/marker.R") +source("../R/limit.R") + +####Test Data +data <- data.table::data.table(id = rownames(mtcars), mtcars) +# create metadata +metadata <- data.table::data.table(names(data), level = c("annotation", rep("performance", 7), rep("design", 4))) +names(metadata)[1] <- "key" +#### + +ui <- dashboardPage(header = dashboardHeader(), + sidebar = dashboardSidebar( + markerUI("marker"), + numericInput(inputId = "width", label = "width in cm", value = 0, min = 0), + numericInput(inputId = "height", label = "height in cm", value = 0, min = 0) + ), + body = dashboardBody( + fluidPage( + scatterPlotUI("id") + ) + ) +) + +server <- function(input, output) { + marker <- callModule(marker, "marker", data) + # highlight all manual cars + plot <- callModule(scatterPlot, "id", data = data, types = metadata[level != "annotation"], features = data[am == 1], markerReac = marker, plot.method = "static", width = reactive(input$width), height = reactive(input$height)) + + observe({ + print(plot()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/exec/transformation_example.R b/exec/transformation_example.R new file mode 100644 index 0000000..693c743 --- /dev/null +++ b/exec/transformation_example.R @@ -0,0 +1,25 @@ + +library(shiny) +source("../R/transformation.R") + +ui <- fluidPage( + transformationUI(id = "id", transposeOptions = TRUE) +) + +server <- function(input, output) { + data_matrix <- matrix( 0:10, ncol = 10) + + data <- reactive({ + data_matrix + }) + + mod <- callModule(transformation, "id", data, transpose = F, pseudocount = 0, replaceInf = T, replaceNA = T) + + observe({ + print(mod$method()) + print(mod$data()) + }) +} + +# Run the application +shinyApp(ui = ui, server = server) diff --git a/inst/extdata/parser_MaxQuant_config.json b/inst/extdata/parser_MaxQuant_config.json new file mode 100644 index 0000000..493fd4c --- /dev/null +++ b/inst/extdata/parser_MaxQuant_config.json @@ -0,0 +1,317 @@ +{ + "meta": [ + { + "col_name": "Protein IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "proteins" + }, + { + "col_name": "Majority protein IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "majority protein" + }, + { + "col_name": "Protein names", + "level": "feature", + "type": "array", + "label": "protein names", + "sublabel": "" + }, + { + "col_name": "Gene names", + "level": "feature", + "type": "array", + "label": "gene names", + "sublabel": "" + }, + { + "col_name": "Fasta headers", + "level": "feature", + "type": "array", + "label": "fasta headers", + "sublabel": "" + }, + { + "col_name": "id", + "level": "feature", + "type": "unique_id", + "label": "unique identifier", + "sublabel": "" + }, + { + "col_name": "Peptide IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "peptide" + }, + { + "col_name": "Mod. peptide IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "mod. peptide" + }, + { + "col_name": "Evidence IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "evidence" + }, + { + "col_name": "MS/MS IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "MS/MS" + }, + { + "col_name": "Mol. weight [kDa]", + "level": "feature", + "type": "category", + "label": "Mol. weight [kDa]", + "sublabel": "" + }, + { + "col_name": "Sequence length", + "level": "feature", + "type": "category", + "label": "length", + "sublabel": "Sequence" + }, + { + "col_name": "Sequence lengths", + "level": "feature", + "type": "array", + "label": "lengths", + "sublabel": "Sequence" + }, + { + "col_name": "Reverse", + "level": "feature", + "type": "category", + "label": "Reverse", + "sublabel": "" + }, + { + "col_name": "Potential contaminant", + "level": "feature", + "type": "category", + "label": "Potential contaminant", + "sublabel": "" + }, + { + "col_name": "Oxidation (M) site IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "Oxidation (M) site" + }, + { + "col_name": "Oxidation (M) site positions", + "level": "feature", + "type": "array", + "label": "positions", + "sublabel": "Oxidation (M) site" + }, + { + "col_name": "Phospho (STY) site IDs", + "level": "feature", + "type": "array", + "label": "IDs", + "sublabel": "Phospho (STY) site" + }, + { + "col_name": "Phospho (STY) site positions", + "level": "feature", + "type": "array", + "label": "positions", + "sublabel": "Phospho (STY) site" + }, + { + "col_name": "Peptide counts (all)", + "level": "condition", + "type": "array", + "label": "counts", + "sublabel": "all peptide" + }, + { + "col_name": "Peptide counts (razor+unique)", + "level": "condition", + "type": "array", + "label": "counts", + "sublabel": "razor+unique peptides" + }, + { + "col_name": "Peptide counts (unique)", + "level": "condition", + "type": "array", + "label": "counts", + "sublabel": "unique peptides" + }, + { + "col_name": "Number of proteins", + "level": "condition", + "type": "score", + "label": "count", + "sublabel": "proteins" + }, + { + "col_name": "Peptides", + "level": "condition", + "type": "score", + "label": "count", + "sublabel": "Peptides" + }, + { + "col_name": "Razor + unique peptides", + "level": "condition", + "type": "score", + "label": "count", + "sublabel": "Razor + unique peptides" + }, + { + "col_name": "Unique peptides", + "level": "condition", + "type": "score", + "label": "count", + "sublabel": "Unique peptides" + }, + { + "col_name": "MS/MS count", + "level": "condition", + "type": "score", + "label": "count", + "sublabel": "MS/MS" + }, + { + "col_name": "Fraction average", + "level": "condition", + "type": "score", + "label": "fraction", + "sublabel": "average" + }, + { + "col_name": "Best MS/MS", + "level": "condition", + "type": "array", + "label": "MS/MS", + "sublabel": "best" + }, + { + "col_name": "Intensity", + "level": "condition", + "type": "score", + "label": "Intensity", + "sublabel": "" + }, + { + "col_name": "Intensity L", + "level": "condition", + "type": "score", + "label": "Intensity", + "sublabel": "L" + }, + { + "col_name": "Intensity M", + "level": "condition", + "type": "score", + "label": "Intensity", + "sublabel": "M" + }, + { + "col_name": "Intensity H", + "level": "condition", + "type": "score", + "label": "Intensity", + "sublabel": "H" + }, + { + "col_name": "Q-value", + "level": "condition", + "type": "probability", + "label": "q-value", + "sublabel": "" + }, + { + "col_name": "Score", + "level": "condition", + "type": "probability", + "label": "score", + "sublabel": "" + }, + { + "col_name": "Unique sequence coverage [%]", + "level": "condition", + "type": "ratio", + "label": "sequence coverage", + "sublabel": "Unique" + }, + { + "col_name": "Unique + razor sequence coverage [%]", + "level": "condition", + "type": "ratio", + "label": "sequence coverage", + "sublabel": "Unique + razor" + }, + { + "col_name": "Sequence coverage [%]", + "level": "condition", + "type": "ratio", + "label": "sequence coverage", + "sublabel": "" + }, + { + "col_name": "Only identified by site", + "level": "feature", + "type": "category", + "label": "identified by site", + "sublabel": "" + }, + { + "col_name": "Peptide is razor", + "level": "condition", + "type": "array", + "label": "peptide", + "sublabel": "is razor" + } + ], + + "type_scores": + ["Peptides", "Razor + unique peptides", "Unique peptides", "Ratio M/L count", "Ratio M/L iso-count", "Ratio H/L count", "Ratio H/L iso-count" , + "Ratio H/M count", "Ratio H/M iso-count", "Intensity", "Intensity L", "Intensity M", "Intensity H", "MS/MS count", "LFQ intensity", "Reporter intensity count", + "Reporter intensity corrected", "Reporter intensity", "Fraction", "iBAQ"], + + "type_ratios": + ["Sequence coverage", "Ratio H/M variability [%]", "Ratio H/M normalized", "Ratio H/M", "Ratio H/L variability [%]", "Ratio H/L normalized", "Ratio H/L", + "Ratio M/L", "Ratio M/L variability [%]", "Ratio M/L normalized"], + + "type_probability":[], + + "type_category": + ["Ratio H/M type", "Ratio H/L type", "Ratio M/L type", "Identification type"], + + "type_array": + [], + + "reduced_list": + ["Protein IDs", "Majority protein IDs", "Protein names", "Gene names", "Fasta headers", + "Peptides;exp", "Razor + unique peptides;exp", "Unique peptides;exp", "Mol. weight [kDa]", + "Sequence length", "Sequence coverage;exp", "Intensity;exp", "Reverse", "Potential contaminant", + "id", "Peptide IDs", "Mod. peptide IDs", "Evidence IDs", "Sequence lengths", "Phospho (STY) site IDs", + "Reporter intensity corrected 0;exp", + "Reporter intensity corrected 1;exp", + "Reporter intensity corrected 2;exp", + "Reporter intensity corrected 3;exp", + "Reporter intensity corrected 4;exp", + "Reporter intensity corrected 5;exp", + "LFQ intensity", + "Intensity L", "Intensity H", "Intensity M", "Ratio M/L normalized;exp", "Ratio H/L normalized;exp", + "Ratio H/M normalized;exp"] +} + diff --git a/inst/www/orNumeric_help.png b/inst/www/orNumeric_help.png new file mode 100644 index 0000000..0282c15 Binary files /dev/null and b/inst/www/orNumeric_help.png differ diff --git a/man/and.Rd b/man/and.Rd new file mode 100644 index 0000000..a94076e --- /dev/null +++ b/man/and.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/and.R +\name{and} +\alias{and} +\title{AND module server logic} +\usage{ +and(input, output, session, data, show.elements = NULL, + element.grouping = NULL, column.labels = NULL, delimiter = NULL, + multiple = TRUE, contains = FALSE, ranged = FALSE, step = 100, + reset = NULL) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{data}{The input data.frame for which selection should be provided. Evaluates an OR module for each column (Supports reactive).} + +\item{show.elements}{A Vector of column names determining which OR modules are shown. Defaults to names(data). (Supports reactive)} + +\item{element.grouping}{Group features in boxes. (Data.table: first column = columnnames, second column = groupnames) (Supports reactive)} + +\item{column.labels}{Additional labels for the columns, defaults to \code{names(data)}.} + +\item{delimiter}{A single character, or a vector indicating how column values are delimited. (Fills vector sequentially if needed)(Supports reactive)} + +\item{multiple}{Whether or not textual ORs should allow multiple selections. (Fills vector sequentially if needed)(Supports reactive)} + +\item{contains}{Whether or not textual ORs are initialized as textInput checking entries for given string. (Fills vector sequentially if needed)(Supports reactive)} + +\item{ranged}{Whether or not numeric ORs are ranged. (Fills vector sequentially if needed)(Supports reactive)} + +\item{step}{Set numeric ORs slider steps. (Fills vector sequentially if needed)(Supports reactive)} + +\item{reset}{Reactive which will cause a UI reset on change.} +} +\value{ +A reactive containing named list with a boolean vector of length \code{nrow(data)} (bool), indicating whether an observation is selected or not and a vector of Strings showing the used filter (text). +} +\description{ +This function evaluates output from multiple OR modules by combining with a logical and. +} diff --git a/man/andUI.Rd b/man/andUI.Rd new file mode 100644 index 0000000..cf2b116 --- /dev/null +++ b/man/andUI.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/and.R +\name{andUI} +\alias{andUI} +\title{AND module UI representation} +\usage{ +andUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +The AND module connects filtering and selection across multiple columns of a data.frame. Columns of class boolean, character or factor will be represented as textual ORs, numeric columns as numerical OR. +} diff --git a/man/categoricalPalettes.Rd b/man/categoricalPalettes.Rd new file mode 100644 index 0000000..da8e4f0 --- /dev/null +++ b/man/categoricalPalettes.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker2.R +\name{categoricalPalettes} +\alias{categoricalPalettes} +\title{Function to generate categorical (qualitative) color palettes} +\usage{ +categoricalPalettes(n) +} +\arguments{ +\item{n}{Number of colors to generate} +} +\value{ +A data.table with (named) color palettes of length n +} +\description{ +Function to generate categorical (qualitative) color palettes +} diff --git a/man/colorPicker.Rd b/man/colorPicker.Rd new file mode 100644 index 0000000..515c07c --- /dev/null +++ b/man/colorPicker.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker.R +\name{colorPicker} +\alias{colorPicker} +\title{colorPicker module server logic} +\usage{ +colorPicker(input, output, session) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} +} +\value{ +The \code{input} object. +} +\description{ +Provides server logic for the colorPicker module. +} +\section{To do}{ + +Implement transparency calculation in case of one or more single colors. +} + diff --git a/man/colorPicker2.Rd b/man/colorPicker2.Rd new file mode 100644 index 0000000..0d87a9d --- /dev/null +++ b/man/colorPicker2.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker2.R +\name{colorPicker2} +\alias{colorPicker2} +\title{colorPicker2 module server logic} +\usage{ +colorPicker2(input, output, session, num.colors = 256, distribution = "all", + winsorize = NULL, selected = NULL) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{num.colors}{Define length of colorpalette vector (Default = 256).} + +\item{distribution}{Decide which palettes are selectable. One or more of list("sequential", "diverging", "categorical"). Defaults to "all" (Supports reactive).} + +\item{winsorize}{Numeric vector of two. Dynamicly change lower and upper limit (supports reactive). Defaults to NULL.} + +\item{selected}{Set the default selected palette.} +} +\value{ +Reactive containing list(palette = c(colors), name = palette_name, transparency = Integer, reverse = Boolean, winsorize = NULL or a two-component vector containing lower and upper limits). +} +\description{ +Provides server logic for the colorPicker2 module. +} +\details{ +A custom colorpalette's return will be NULL if there is something wrong with it. + +equalize will be returned as FALSE if not selected. +} diff --git a/man/colorPicker2UI.Rd b/man/colorPicker2UI.Rd new file mode 100644 index 0000000..576b2d3 --- /dev/null +++ b/man/colorPicker2UI.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker2.R +\name{colorPicker2UI} +\alias{colorPicker2UI} +\title{colorPicker2 module UI representation} +\usage{ +colorPicker2UI(id, label = "Color scheme", custom = FALSE, + multiple = FALSE, show.reverse = TRUE, show.scaleoptions = TRUE, + show.transparency = TRUE) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{label}{Either a character vector of length one with the label for the color scheme dropdown, or a character vector containing labels of the single colors.} + +\item{custom}{Boolean if TRUE custom colors can be selected (Default = FALSE).} + +\item{multiple}{Boolean value, if set to TRUE custom colorpalettes can be made. Only if custom = TRUE (Default = FALSE).} + +\item{show.reverse}{Logical, whether or not to show the reverse switch (Default = TRUE).} + +\item{show.scaleoptions}{Logical, whether or not to show color scaling option winorize (Default = TRUE).} + +\item{show.transparency}{Logical, whether or not to show the transparency slider (Default = TRUE).} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +The functions creates HTML tag definitions of its representation based on the parameters supplied. +Currently, two UI can be created for the user to choose either (a) colors from a given color scheme, or (b) choose one or more single colors. +} diff --git a/man/colorPickerUI.Rd b/man/colorPickerUI.Rd new file mode 100644 index 0000000..13db175 --- /dev/null +++ b/man/colorPickerUI.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker.R +\name{colorPickerUI} +\alias{colorPickerUI} +\title{colorPicker module UI representation} +\usage{ +colorPickerUI(id, label = "Color scheme", choices = c("Blues", "Greens", + "Greys", "Oranges", "Purples", "Reds"), selected.choice = NULL, + show.reverse = TRUE, show.transparency = TRUE, single.colors = FALSE) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{label}{Either a character vector of length one with the label for the color scheme dropdown, or a character vector containing labels of the single colors.} + +\item{choices}{A character vector with choices for the color scheme dropdown. See \code{\link[shiny]{selectInput}}.} + +\item{selected.choice}{The initially selected value(s) of the dropdown. If NULL (default), the first value of schemes will be taken.} + +\item{show.reverse}{Logical, whether or not to show the reverse switch.} + +\item{show.transparency}{Logical, whether or not to show the transparency slider.} + +\item{single.colors}{Logical, whether or not to make a single color chooser. (Only if length(label) == 1 needed)} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +The functions creates HTML tag definitions of its representation based on the parameters supplied. +Currently, two UI can be created for the user to choose either (a) colors from a given color scheme, or (b) choose one or more single colors. +} +\section{Single color mode}{ + +If one or more single colors can be chosen, the UI element names are prefix by \emph{color} followed by \code{make.names} ouput of \code{label}. +} + +\section{To do}{ + +Replace ordinary textInput for single colors by a real colorPicker, e.g. from https://github.com/daattali/colourpicker +} + diff --git a/man/columnSelector.Rd b/man/columnSelector.Rd new file mode 100644 index 0000000..886804c --- /dev/null +++ b/man/columnSelector.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/columnSelector.R +\name{columnSelector} +\alias{columnSelector} +\title{columnSelector module server logic} +\usage{ +columnSelector(input, output, session, type.columns, type = NULL, + columnTypeLabel = "Type of Column", labelLabel = "Label", + multiple = TRUE, none = FALSE, sep = ", ", suffix = NULL) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{type.columns}{data.table: (Supports reactive) +column1 = columnnames (id) +column2 = type (datalevel) +column3 = label (optional, used instead of id) +column4 = sub_label (optional, added to id/ label)} + +\item{type}{The type (contrast/group/sample of the type dropdown menu, selected in step 1 (upper dropdown). Defaults to unique(type.columns[,2]) (Supports reactive)} + +\item{columnTypeLabel}{Changes the label of the first UI element} + +\item{labelLabel}{Change label above label text input.} + +\item{multiple}{Boolean value whether multiple values can be selected in second selector. (Default = TRUE)} + +\item{none}{If TRUE adds "None to secondSelector and select is. (Default = FALSE)} + +\item{sep}{Used to seperate labels on multi value selection.} + +\item{suffix}{Added to label only on multiple = FALSE (supports reactive). Also uses sep as seperator.} +} +\value{ +Returns the input. As named list: names("type", "selectedColumns", "label") +} +\description{ +columnSelector module server logic +} diff --git a/man/columnSelectorUI.Rd b/man/columnSelectorUI.Rd new file mode 100644 index 0000000..a81a734 --- /dev/null +++ b/man/columnSelectorUI.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/columnSelector.R +\name{columnSelectorUI} +\alias{columnSelectorUI} +\title{columnSelector module UI representation} +\usage{ +columnSelectorUI(id, label = F, title = NULL) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{label}{Boolean value; if true include a text input field with the desired axis label (this should be preset with the headline of the column)} + +\item{title}{String which is displayed as module title. (Default = NULL)} +} +\value{ +A list from \code{\link[shiny]{tag}} with the UI elements. +} +\description{ +columnSelector module UI representation +} diff --git a/man/create_geneview.Rd b/man/create_geneview.Rd new file mode 100644 index 0000000..7117b8a --- /dev/null +++ b/man/create_geneview.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{create_geneview} +\alias{create_geneview} +\title{Method for geneView creation} +\usage{ +create_geneview(data, grouping, plot.type = "line", facet.target = "gene", + facet.cols = 2, colors = NULL, ylabel = NULL, ylimits = NULL, + gene.label = NULL, plot.method = "static", width = "auto", + height = "auto", ppi = 72) +} +\arguments{ +\item{data}{data.table containing plot data} + +\item{grouping}{data.table metadata containing: +column1 : key +column2 : factor1} + +\item{plot.type}{String specifing which plot type is used c("box", "line", "violin", "bar").} + +\item{facet.target}{Target to plot on x-Axis c("gene", "condition").} + +\item{facet.cols}{Number of plots per row.} + +\item{colors}{Vector of colors used for color palette} + +\item{ylabel}{Label of the y-axis (default = NULL).} + +\item{ylimits}{Vector defining scale of y-axis (default = NULL).} + +\item{gene.label}{Vector of labels used instead of gene names (default = NULL).} + +\item{plot.method}{Choose which method used for plotting. Either "static" or "interactive" (Default = "static").} + +\item{width}{Set the width of the plot in cm (default = "auto").} + +\item{height}{Set the height of the plot in cm (default = "auto").} + +\item{ppi}{Pixel per inch (default = 72).} +} +\value{ +Returns depending on plot.method list(plot = ggplot/ plotly object, width = width in cm, height = height in cm, ppi = pixel per inch, exceed_size = Boolean). +} +\description{ +Method for geneView creation +} +\details{ +Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +} diff --git a/man/create_heatmap.Rd b/man/create_heatmap.Rd new file mode 100644 index 0000000..e626291 --- /dev/null +++ b/man/create_heatmap.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{create_heatmap} +\alias{create_heatmap} +\title{Method for heatmap creation} +\usage{ +create_heatmap(data, unitlabel = "auto", row.label = T, + row.custom.label = NULL, column.label = T, column.custom.label = NULL, + clustering = "none", clustdist = "auto", clustmethod = "auto", + colors = NULL, winsorize.colors = NULL, plot.method = "static", + width = "auto", height = "auto", ppi = 72) +} +\arguments{ +\item{data}{data.table containing plot data. First column contains row labels.} + +\item{unitlabel}{label of the colorbar} + +\item{row.label}{Logical whether or not to show row labels.} + +\item{row.custom.label}{Vector of custom row labels.} + +\item{column.label}{Logical whether or not to show column labels.} + +\item{column.custom.label}{Vector of custom column labels.} + +\item{clustering}{How to apply clustering on data. c("none", "both", "column", "row")} + +\item{clustdist}{Which cluster distance to use. See \code{\link[heatmaply]{heatmapr}}.} + +\item{clustmethod}{Which cluster method to use. See \code{\link[heatmaply]{heatmapr}}.} + +\item{colors}{Vector of colors used for color palette.} + +\item{winsorize.colors}{NULL or a vector of length two, giving the values of colorbar ends (default = NULL).} + +\item{plot.method}{Choose which method is used for plotting. Either "plotly" or "complexHeatmap" (Default = "complexHeatmap").} + +\item{width}{Set width of plot in cm (Default = "auto").} + +\item{height}{Set height of plot in cm (Default = "auto").} + +\item{ppi}{Pixel per inch (default = 72).} +} +\value{ +Returns list(plot = complexHeatmap/ plotly object, width = width in cm, height = height in cm, ppi = pixel per inch, exceed_size = Boolean whether width/ height exceeded max) depending on plot.method. +} +\description{ +Method for heatmap creation +} +\details{ +Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +} diff --git a/man/create_pca.Rd b/man/create_pca.Rd new file mode 100644 index 0000000..044613d --- /dev/null +++ b/man/create_pca.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{create_pca} +\alias{create_pca} +\title{Method for pca creation.} +\usage{ +create_pca(data, dimensionA = 1, dimensionB = 2, dimensions = 6, + on.columns = TRUE, labels = FALSE, custom.labels = NULL, + pointsize = 2, labelsize = 3, width = 28, height = 28, ppi = 72) +} +\arguments{ +\item{data}{data.table from which the plot is created (First column will be handled as rownames if not numeric).} + +\item{dimensionA}{Number of dimension displayed on X-Axis.} + +\item{dimensionB}{Number of dimension displayed on Y-Axis.} + +\item{dimensions}{Number of dimesions to create.} + +\item{on.columns}{Boolean perform pca on columns or rows.} + +\item{labels}{Boolean show labels.} + +\item{custom.labels}{Vector of custom labels. Will replace columnnames.} + +\item{pointsize}{Size of the data points.} + +\item{labelsize}{Size of texts inside plot (default = 3).} + +\item{width}{Set the width of the plot in cm (default = 28).} + +\item{height}{Set the height of the plot in cm (default = 28).} + +\item{ppi}{Pixel per inch (default = 72).} +} +\value{ +A named list(plot = ggplot object, data = pca.data, width = width of plot (cm), height = height of plot (cm), ppi = pixel per inch, exceed_size = Boolean whether width/ height exceeded max). +} +\description{ +Method for pca creation. +} +\details{ +If width and height are the same axis ratio will be set to one (quadratic plot). + +Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +} diff --git a/man/create_scatterplot.Rd b/man/create_scatterplot.Rd new file mode 100644 index 0000000..8c3985d --- /dev/null +++ b/man/create_scatterplot.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{create_scatterplot} +\alias{create_scatterplot} +\title{Method for scatter plot creation} +\usage{ +create_scatterplot(data, transparency = 1, pointsize = 1, labelsize = 3, + colors = NULL, x_label = "", y_label = "", z_label = "", + density = T, line = T, categorized = F, highlight.data = NULL, + highlight.labels = NULL, highlight.color = "#FF0000", xlim = NULL, + ylim = NULL, colorbar.limits = NULL, width = "auto", height = "auto", + ppi = 72, plot.method = "static") +} +\arguments{ +\item{data}{data.table containing plot data +column 1: id +column 2, 3(, 4): x, y(, z)} + +\item{transparency}{Set point transparency. See \code{\link[ggplot2]{geom_point}}.} + +\item{pointsize}{Set point size. See \code{\link[ggplot2]{geom_point}}.} + +\item{labelsize}{Set label size. See \code{\link[ggplot2]{geom_text}}.} + +\item{colors}{Vector of colors used for color palette} + +\item{x_label}{Label x-Axis} + +\item{y_label}{Label Y-Axis} + +\item{z_label}{Label Z-Axis} + +\item{density}{Boolean value, perform 2d density estimate.} + +\item{line}{Boolean value, add reference line.} + +\item{categorized}{Z-Axis (if exists) as categories.} + +\item{highlight.data}{data.table containing data to highlight.} + +\item{highlight.labels}{Vector of labels used for highlighted data.} + +\item{highlight.color}{String with hexadecimal color-code.} + +\item{xlim}{Numeric vector of two setting min and max limit of x-axis. See \code{\link[ggplot2]{lims}}.} + +\item{ylim}{Numeric vector of two setting min and max limit of y-axis. See \code{\link[ggplot2]{lims}}.} + +\item{colorbar.limits}{Vector with min, max values for colorbar (Default = NULL).} + +\item{width}{Set plot width in cm (Default = "auto").} + +\item{height}{Set plot height in cm (Default = "auto").} + +\item{ppi}{Pixel per inch (default = 72).} + +\item{plot.method}{Whether the plot should be 'interactive' or 'static' (Default = 'static').} +} +\value{ +Returns list(plot = ggplotly/ ggplot, width, height, ppi, exceed_size). +} +\description{ +Method for scatter plot creation +} +\details{ +Width/ height limit = 500. If exceeded default to 500 and issue exceed_size = TRUE. +} diff --git a/man/divergingPalettes.Rd b/man/divergingPalettes.Rd new file mode 100644 index 0000000..8513548 --- /dev/null +++ b/man/divergingPalettes.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker2.R +\name{divergingPalettes} +\alias{divergingPalettes} +\title{Function to generate diverging (two-sided) color palettes (e.g. for log2fc, zscore)} +\usage{ +divergingPalettes(n) +} +\arguments{ +\item{n}{Number of colors to generate} +} +\value{ +A data.table with (named) color palettes of length n +} +\description{ +Function to generate diverging (two-sided) color palettes (e.g. for log2fc, zscore) +} diff --git a/man/download.Rd b/man/download.Rd new file mode 100644 index 0000000..883e190 --- /dev/null +++ b/man/download.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{download} +\alias{download} +\title{Function used for downloading. +Creates a zip container containing plot in png, pdf and user input in json format. +Use inside \code{\link[shiny]{downloadHandler}} content function.} +\usage{ +download(file, filename, plot, width, height, ppi = 72, ui = NULL) +} +\arguments{ +\item{file}{See \code{\link[shiny]{downloadHandler}} content parameter.} + +\item{filename}{See \code{\link[shiny]{downloadHandler}}.} + +\item{plot}{Plot to download.} + +\item{width}{in centimeter.} + +\item{height}{in centimeter.} + +\item{ppi}{pixel per inch. Defaults to 72.} + +\item{ui}{List of user inputs. Will be converted to Javascript Object Notation. See \code{\link[RJSONIO]{toJSON}}} +} +\value{ +See \code{\link[utils]{zip}}. +} +\description{ +Function used for downloading. +Creates a zip container containing plot in png, pdf and user input in json format. +Use inside \code{\link[shiny]{downloadHandler}} content function. +} diff --git a/man/equalize.Rd b/man/equalize.Rd new file mode 100644 index 0000000..a215a82 --- /dev/null +++ b/man/equalize.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{equalize} +\alias{equalize} +\title{Method to get equalized min/max values from vector} +\usage{ +equalize(values) +} +\arguments{ +\item{values}{Numeric vector or table} +} +\value{ +Vector with c(min, max). +} +\description{ +Method to get equalized min/max values from vector +} diff --git a/man/featureSelector.Rd b/man/featureSelector.Rd new file mode 100644 index 0000000..c52d853 --- /dev/null +++ b/man/featureSelector.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/featureSelector.R +\name{featureSelector} +\alias{featureSelector} +\title{featureSelector module server logic} +\usage{ +featureSelector(input, output, session, data, features = NULL, + feature.grouping = NULL, delimiter = "|", multiple = TRUE, + contains = FALSE, ranged = TRUE, step = 100, truncate = 30, + selection.default = "all") +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{data}{data.table from which to select (Supports reactive).} + +\item{features}{List of features (i.e. columnnames) the and module will show (Defaults to names(data))(Supports reactive).} + +\item{feature.grouping}{Display features seperated in boxes. (Data.table: first column = columnnames, second column = groupnames) (Supports reactive)} + +\item{delimiter}{A single character, or a vector indicating how column values are delimited. (Fills vector sequentially if needed)(Supports reactive)} + +\item{multiple}{Whether or not textual ORs should allow multiple selections. (Fills vector sequentially if needed)(Supports reactive)} + +\item{contains}{Whether or not textual ORs are initialized as textInput checking entries for given string. (Fills vector sequentially if needed)(Supports reactive)} + +\item{ranged}{Whether or not numeric ORs are ranged. (Fills vector sequentially if needed)(Supports reactive)} + +\item{step}{Set numeric ORs slider steps. (Fills vector sequentially if needed)(Supports reactive)} + +\item{truncate}{Truncate datatable entries at x characters (Default = 30).} + +\item{selection.default}{Decide whether everything or nothing is selected on default (no filters applied). Either "all" or "none" (Default = "all").} +} +\value{ +Reactive containing names list: Selected data as reactive containing data.table (data). Used filter to select data (filter). +} +\description{ +featureSelector module server logic +} +\details{ +Keep in mind that the order of features is the order in which delimiter, multiple, contains, ranged and step are evaluated. +} diff --git a/man/featureSelectorGuide.Rd b/man/featureSelectorGuide.Rd new file mode 100644 index 0000000..1bdba64 --- /dev/null +++ b/man/featureSelectorGuide.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/featureSelector.R +\name{featureSelectorGuide} +\alias{featureSelectorGuide} +\title{featureSelector module guide} +\usage{ +featureSelectorGuide(session, grouping = FALSE) +} +\arguments{ +\item{session}{The shiny session} + +\item{grouping}{Logical if Text for grouping should be displayed (Default = FALSE).} +} +\value{ +A shiny reactive that contains the texts for the guide steps. +} +\description{ +featureSelector module guide +} diff --git a/man/featureSelectorUI.Rd b/man/featureSelectorUI.Rd new file mode 100644 index 0000000..894b7ea --- /dev/null +++ b/man/featureSelectorUI.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/featureSelector.R +\name{featureSelectorUI} +\alias{featureSelectorUI} +\title{featureSelector module UI representation} +\usage{ +featureSelectorUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}} +} +\description{ +featureSelector module UI representation +} diff --git a/man/geneView.Rd b/man/geneView.Rd new file mode 100644 index 0000000..b33b235 --- /dev/null +++ b/man/geneView.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geneView.R +\name{geneView} +\alias{geneView} +\title{geneView's module server logic} +\usage{ +geneView(input, output, session, data, metadata, level = NULL, + plot.method = "static", custom.label = NULL, label.sep = ", ", + width = "auto", height = "auto", ppi = 72) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{data}{data.table: +column1 : ids +column2 : symbol (data used for selection) +column3-n : data} + +\item{metadata}{data.table: +column1: ids +column2: factor1 (conditions) +column3: level (condition type)} + +\item{level}{Vector containing data levels to select from (default: unique(metadata[["level"]])).} + +\item{plot.method}{Choose which method is used for plotting. Either "static" or "interactive" (Default = "static").} + +\item{custom.label}{Data.table used for creating custom labels (supports reactive).} + +\item{label.sep}{Seperator used for label merging (Default = ", ").} + +\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{height}{Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{ppi}{Pixel per inch. Defaults to 72 and supports reactive.} +} +\value{ +Reactive containing data.table used for plotting. +} +\description{ +Provides server logic for the geneView module. +} +\details{ +Width/ height/ ppi less or equal to default will use default value. + +Ppi less or equal to zero will use default. +} diff --git a/man/geneViewGuide.Rd b/man/geneViewGuide.Rd new file mode 100644 index 0000000..8470d5e --- /dev/null +++ b/man/geneViewGuide.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geneView.R +\name{geneViewGuide} +\alias{geneViewGuide} +\title{geneView module guide} +\usage{ +geneViewGuide(session, label = FALSE) +} +\arguments{ +\item{session}{The shiny session} + +\item{label}{Boolean to show custom label step.} +} +\value{ +A shiny reactive that contains the texts for the Guide steps. +} +\description{ +geneView module guide +} diff --git a/man/geneViewUI.Rd b/man/geneViewUI.Rd new file mode 100644 index 0000000..6db2d3d --- /dev/null +++ b/man/geneViewUI.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/geneView.R +\name{geneViewUI} +\alias{geneViewUI} +\title{geneView's module UI representation} +\usage{ +geneViewUI(id, plot.columns = 3) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{plot.columns}{Initial value of plot column slider. Integer value between 1 and 7 (Default = 3).} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +geneView's module UI representation +} diff --git a/man/global_cor_heatmap.Rd b/man/global_cor_heatmap.Rd new file mode 100644 index 0000000..8f3a512 --- /dev/null +++ b/man/global_cor_heatmap.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/global_cor_heatmap.R +\name{global_cor_heatmap} +\alias{global_cor_heatmap} +\title{global correlation heatmap module server logic} +\usage{ +global_cor_heatmap(input, output, session, data, types, + plot.method = "static", width = "auto", height = "auto", ppi = 72) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{data}{data.table data visualized in plot (supports reactive).} + +\item{types}{data.table: (supports reactive) +column1: colnames of data +column2: corresponding column type +column3 = label (optional, used instead of id) +column4 = sub_label (optional, added to id/ label)} + +\item{plot.method}{Choose which method is used for plotting. Either "static" or "interactive" (Default = "static").} + +\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{height}{Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{ppi}{Pixel per inch. Defaults to 72 and supports reactive.} +} +\value{ +Reactive containing data used for plotting. +} +\description{ +global correlation heatmap module server logic +} diff --git a/man/global_cor_heatmapUI.Rd b/man/global_cor_heatmapUI.Rd new file mode 100644 index 0000000..3bd83c8 --- /dev/null +++ b/man/global_cor_heatmapUI.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/global_cor_heatmap.R +\name{global_cor_heatmapUI} +\alias{global_cor_heatmapUI} +\title{global correlation heatmap module UI representation} +\usage{ +global_cor_heatmapUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}} +} +\description{ +global correlation heatmap module UI representation +} diff --git a/man/global_cor_heatmap_guide.Rd b/man/global_cor_heatmap_guide.Rd new file mode 100644 index 0000000..72c08ac --- /dev/null +++ b/man/global_cor_heatmap_guide.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/global_cor_heatmap.R +\name{global_cor_heatmap_guide} +\alias{global_cor_heatmap_guide} +\title{global correlation heatmap module guide} +\usage{ +global_cor_heatmap_guide(session) +} +\arguments{ +\item{session}{The shiny session} +} +\value{ +A shiny reactive that contains the texts for the Guide steps. +} +\description{ +global correlation heatmap module guide +} diff --git a/man/heatmap.Rd b/man/heatmap.Rd new file mode 100644 index 0000000..cd9bd68 --- /dev/null +++ b/man/heatmap.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/heatmap.R +\name{heatmap} +\alias{heatmap} +\title{heatmap module server logic} +\usage{ +heatmap(input, output, session, data, types, plot.method = "static", + custom.row.label = NULL, label.sep = ", ", width = "auto", + height = "auto", ppi = 72) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{data}{data.table data visualized in plot (Supports reactive).} + +\item{types}{data.table: (Supports reactive) +column1: colnames of data +column2: corresponding column typ +column3: label (optional, used instead of id) +column4: sub_label (optional, added to id/ label)} + +\item{plot.method}{Choose which method is used for plotting. Either "static" or "interactive" (Default = "static").} + +\item{custom.row.label}{Data.table used for creating custom labels (supports reactive).} + +\item{label.sep}{Seperator used for label merging (Default = ", ").} + +\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{height}{Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{ppi}{Pixel per inch. Defaults to 72 and supports reactive.} +} +\value{ +Reactive containing data used for plotting. +} +\description{ +heatmap module server logic +} diff --git a/man/heatmapGuide.Rd b/man/heatmapGuide.Rd new file mode 100644 index 0000000..b5b6967 --- /dev/null +++ b/man/heatmapGuide.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/heatmap.R +\name{heatmapGuide} +\alias{heatmapGuide} +\title{heatmap module guide} +\usage{ +heatmapGuide(session, custom.row.label = FALSE) +} +\arguments{ +\item{session}{The shiny session} + +\item{custom.row.label}{Boolean. Show additional info. Default = FALSE.} +} +\value{ +A shiny reactive that contains the texts for the Guide steps. +} +\description{ +heatmap module guide +} diff --git a/man/heatmapUI.Rd b/man/heatmapUI.Rd new file mode 100644 index 0000000..bea9217 --- /dev/null +++ b/man/heatmapUI.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/heatmap.R +\name{heatmapUI} +\alias{heatmapUI} +\title{heatmap module UI representation} +\usage{ +heatmapUI(id, row.label = TRUE) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{row.label}{Boolean Value set initial Value for rowlabel checkbox (Default = TRUE).} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +heatmap module UI representation +} diff --git a/man/label.Rd b/man/label.Rd new file mode 100644 index 0000000..45da611 --- /dev/null +++ b/man/label.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/label.R +\name{label} +\alias{label} +\title{label module server logic} +\usage{ +label(input, output, session, data, label = "Select label columns", + multiple = TRUE, sep = ", ", unique = TRUE, unique_sep = "_", + disable = NULL) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{data}{Data.table used for label creation. Column names will be used for selection. (supports reactive)} + +\item{label}{Set label of selectizeInput.} + +\item{multiple}{Allow multiple selection which will be merged with sep (default = TRUE).} + +\item{sep}{Seperator used to collapse selection (default = ", ").} + +\item{unique}{Make labels unique. Defaults to TRUE. See \code{\link[base]{make.unique}}.} + +\item{unique_sep}{Seperator used for unique (default = "_"). Should differ from sep.} + +\item{disable}{Reactive containing boolean. To disable/ enable module.} +} +\value{ +Reactive containing list(label = vector of strings or NULL on empty selection, selected = user input). +} +\description{ +label module server logic +} diff --git a/man/labelUI.Rd b/man/labelUI.Rd new file mode 100644 index 0000000..e85959d --- /dev/null +++ b/man/labelUI.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/label.R +\name{labelUI} +\alias{labelUI} +\title{label module UI representation} +\usage{ +labelUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}} +} +\description{ +label module UI representation +} diff --git a/man/limit.Rd b/man/limit.Rd new file mode 100644 index 0000000..4d193d4 --- /dev/null +++ b/man/limit.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/limit.R +\name{limit} +\alias{limit} +\title{limit module server logic} +\usage{ +limit(input, output, session, lower = NULL, upper = NULL) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{lower}{Set lower limit (supports reactive).} + +\item{upper}{Set upper limit (supports reactive).} +} +\value{ +Reactive containing: list(lower, upper). +} +\description{ +limit module server logic +} diff --git a/man/limitUI.Rd b/man/limitUI.Rd new file mode 100644 index 0000000..d0af9aa --- /dev/null +++ b/man/limitUI.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/limit.R +\name{limitUI} +\alias{limitUI} +\title{limit module UI representation} +\usage{ +limitUI(id, label = "Limit") +} +\arguments{ +\item{id}{The ID of the modules namespace} + +\item{label}{Set the modules label.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}} +} +\description{ +limit module UI representation +} diff --git a/man/marker.Rd b/man/marker.Rd new file mode 100644 index 0000000..c8bf5fb --- /dev/null +++ b/man/marker.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/marker.R +\name{marker} +\alias{marker} +\title{marker module server logic} +\usage{ +marker(input, output, session, highlight.labels) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{highlight.labels}{Data.table from which labels are provided (Supports reactive).} +} +\value{ +A reactive which contains a named list (highlight, color, labelColumn, label). +} +\description{ +marker module server logic +} diff --git a/man/markerUI.Rd b/man/markerUI.Rd new file mode 100644 index 0000000..2533662 --- /dev/null +++ b/man/markerUI.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/marker.R +\name{markerUI} +\alias{markerUI} +\title{marker module UI representation} +\usage{ +markerUI(id, label = "Highlight/ Label Selected Features") +} +\arguments{ +\item{id}{The ID of the modules namespace} + +\item{label}{Set label of first element.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}} +} +\description{ +marker module UI representation +} diff --git a/man/orNumeric.Rd b/man/orNumeric.Rd new file mode 100644 index 0000000..e1bb02c --- /dev/null +++ b/man/orNumeric.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/orNumeric.R +\name{orNumeric} +\alias{orNumeric} +\title{orNumeric module server logic} +\usage{ +orNumeric(input, output, session, choices, value, label = "Column", + step = 100, stepsize = NULL, min. = shiny::reactive(min(choices.r(), + na.rm = TRUE)), max. = shiny::reactive(max(choices.r(), na.rm = TRUE)), + label.slider = NULL, zoomable = TRUE, reset = NULL) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{choices}{A list or a numeric vector with the possible choices offered in the UI. See \code{\link[shiny]{sliderInput}} (Supports reactive).} + +\item{value}{Initial value of the slider. Creates a ranged slider if numeric vector of two given (Supports reactive).} + +\item{label}{Label of the entire module.} + +\item{step}{Number of steps on interval (Default = 100).} + +\item{stepsize}{Value defining interval size of the slider. Will be used instead of step (Default = NULL).} + +\item{min.}{Minimum value that can be selected on slider (defaults to min(choices)) (Supports reactive).} + +\item{max.}{Maximum value that can be selected on slider (defaults to max(choices)) (Supports reactive).} + +\item{label.slider}{A character vector of length one with the label for the \code{\link[shiny]{sliderInput}}.} + +\item{zoomable}{Boolean to enable zooming. Redefine the sliders range. Defaults to TRUE.} + +\item{reset}{A reactive which will trigger a module reset on change.} +} +\value{ +Returns a reactive containing a named list with the label, the selected choices as a character vector (text) and a boolean vector of length \code{length(choices)} (bool), indicating whether a item has been chosen. If no item has been chosen, the return is \code{TRUE} for items. +} +\description{ +Provides server logic for the orNumeric module. +} diff --git a/man/orNumericUI.Rd b/man/orNumericUI.Rd new file mode 100644 index 0000000..4f9f579 --- /dev/null +++ b/man/orNumericUI.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/orNumeric.R +\name{orNumericUI} +\alias{orNumericUI} +\title{orNumeric module UI representation} +\usage{ +orNumericUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +This module allows to select value/range inputs from a \code{\link[shiny]{sliderInput}} element. +The functions creates HTML tag definitions of its representation based on the parameters supplied. +} diff --git a/man/orTextual.Rd b/man/orTextual.Rd new file mode 100644 index 0000000..68f18ff --- /dev/null +++ b/man/orTextual.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/orTextual.R +\name{orTextual} +\alias{orTextual} +\title{orTextual module server logic} +\usage{ +orTextual(input, output, session, choices, selected = NULL, + label = "Column", delimiter = NULL, multiple = TRUE, contains = FALSE, + reset = NULL) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{choices}{A list or a character vector with the possible choices offered in the UI. See \code{\link[shiny]{selectInput}}.} + +\item{selected}{The initially selected value. See \code{\link[shiny]{selectInput}}.} + +\item{label}{A character vector of length one with the label for the \code{\link[shiny]{selectInput}}.} + +\item{delimiter}{A single character indicating if and how items are delimited (default: \code{NULL} indicates no delimitation). Only if contains = FALSE.} + +\item{multiple}{Whether or not selection of multiple items is allowed.} + +\item{contains}{Logical variable. If TRUE shows module as a textsearch input.} + +\item{reset}{A reactive which will trigger a module reset on change.} +} +\value{ +Returns a reactive containing a named list with the label, the selected choices as a character vector (text) and a boolean vector of length \code{length(choices)} (bool), indicating whether a item has been chosen. If no item has been chosen, the return is \code{TRUE} for items. +} +\description{ +Provides server logic for the orTextual module. +} diff --git a/man/orTextualUI.Rd b/man/orTextualUI.Rd new file mode 100644 index 0000000..cb92d9d --- /dev/null +++ b/man/orTextualUI.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/orTextual.R +\name{orTextualUI} +\alias{orTextualUI} +\title{orTextual module UI representation} +\usage{ +orTextualUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +This module allows to select (multiple) inputs from a \code{\link[shiny]{selectInput}} element. +The functions creates HTML tag definitions of its representation based on the parameters supplied. +} diff --git a/man/parse_MaxQuant.Rd b/man/parse_MaxQuant.Rd new file mode 100644 index 0000000..364d969 --- /dev/null +++ b/man/parse_MaxQuant.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parser.R +\name{parse_MaxQuant} +\alias{parse_MaxQuant} +\title{Converting MaxQuant Output file proteinGroups.txt to CLARION format +by creating a headline of metadata for each column} +\usage{ +parse_MaxQuant(proteinGroups_in, summary_in, outfile, outfile_reduced, + config = system.file("extdata", "parser_MaxQuant_config.json", package = + "wilson"), delimiter = ";", format = NULL, version = NULL, + experiment_id = NULL) +} +\arguments{ +\item{proteinGroups_in}{path of proteinGroup.txt file} + +\item{summary_in}{path of belonging summary.txt file} + +\item{outfile}{path of full CLARION output file} + +\item{outfile_reduced}{path of reduced CLARION output file} + +\item{config}{path of config file (containing information about metadata)} + +\item{delimiter}{delimiter (Default = ;)} + +\item{format}{pre-header information about format (optional)} + +\item{version}{pre-header information about version (optional)} + +\item{experiment_id}{pre-header information about experiment id (optional)} +} +\description{ +List with columns of reduced version (see config.json file) +If you only want the samples of a specific keyword write: column;exp +For example: + You got: + Intensity + Intensity 'experiment_name' +Do you want both add "Intensity" to the list. +Do you only want the sample add "Intensity;exp" to the list +Anything else like 'Intensity;ex' or 'Intesity;' results in writing both. +Only works if there are samples of that type. If not, column does not show up in file +} +\author{ +Rene Wiegandt +} diff --git a/man/parser.Rd b/man/parser.Rd new file mode 100644 index 0000000..4700c2b --- /dev/null +++ b/man/parser.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/parser.R +\name{parser} +\alias{parser} +\title{Method to parse input file.} +\usage{ +parser(file, dec = ".") +} +\arguments{ +\item{file}{Path to file that needs parsing.} + +\item{dec}{The decimal separator. See \code{\link[data.table]{fread}}.} +} +\value{ +named list containing list(header = list(), metadata = data.table, data = data.table) +} +\description{ +Method to parse input file. +} diff --git a/man/pca.Rd b/man/pca.Rd new file mode 100644 index 0000000..c6f509e --- /dev/null +++ b/man/pca.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pca.R +\name{pca} +\alias{pca} +\title{pca module server logic} +\usage{ +pca(input, output, session, data, types, levels = NULL, entryLabel = NULL, + width = 28, height = 28, ppi = 72) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{data}{data.table data visualized in plot. (Supports Reactive)} + +\item{types}{data.table: (Supports reactive) +column1: colnames of data +column2: corresponding column typ +column3: label (optional, used instead of id) +column4: sub_label (optional, added to id/ label)} + +\item{levels}{Levels from which data is selected (Defaults to unique(metadata[["level"]])). (Supports Reactive)} + +\item{entryLabel}{Define additional columns added to each entry (Default = NULL). Use a vector containing the desired columnnames e.g. c("column1", "column2").} + +\item{width}{Width of the plot in cm. Defaults to 28 and supports reactive.} + +\item{height}{Height of the plot in cm. Defaults to 28 and supports reactive.} + +\item{ppi}{Pixel per inch. Defaults to 72 and supports reactive.} +} +\value{ +A reactive containing list with dimensions. +} +\description{ +pca module server logic +} +\details{ +Width/ height/ ppi less or equal to zero will use default value. +} diff --git a/man/pcaGuide.Rd b/man/pcaGuide.Rd new file mode 100644 index 0000000..9dde83f --- /dev/null +++ b/man/pcaGuide.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pca.R +\name{pcaGuide} +\alias{pcaGuide} +\title{pca module guide} +\usage{ +pcaGuide(session) +} +\arguments{ +\item{session}{The shiny session} +} +\value{ +A shiny reactive that contains the texts for the Guide steps. +} +\description{ +pca module guide +} diff --git a/man/pcaUI.Rd b/man/pcaUI.Rd new file mode 100644 index 0000000..2bb3bc9 --- /dev/null +++ b/man/pcaUI.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/pca.R +\name{pcaUI} +\alias{pcaUI} +\title{pca module UI representation} +\usage{ +pcaUI(id, show.label = TRUE) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{show.label}{Set initial value of show label checkbox (Default = TRUE).} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +pca module UI representation +} diff --git a/man/scatterPlot.Rd b/man/scatterPlot.Rd new file mode 100644 index 0000000..c7e94e6 --- /dev/null +++ b/man/scatterPlot.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scatterPlot.R +\name{scatterPlot} +\alias{scatterPlot} +\title{scatterPlot module server logic} +\usage{ +scatterPlot(input, output, session, data, types, features = NULL, + markerReac = NULL, plot.method = "static", width = "auto", + height = "auto", ppi = 72) +} +\arguments{ +\item{input}{Shiny's input object} + +\item{output}{Shiny's output object} + +\item{session}{Shiny's session object} + +\item{data}{data.table data visualized in plot (Supports reactive).} + +\item{types}{data.table: (Supports reactive) +column1: colnames of data +column2: corresponding column type +column3: label (optional, used instead of id) +column4: sub_label (optional, added to id/ label)} + +\item{features}{data.table of the features to mark (first column = id)} + +\item{markerReac}{reactive containing inputs of marker module.} + +\item{plot.method}{Choose to rather render a 'interactive' or 'static' plot. Defaults to 'static'.} + +\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{height}{Height of the plot in cm. Defaults to minimal size for readable labels and supports reactive.} + +\item{ppi}{Pixel per inch. Defaults to 72 and supports reactive.} +} +\value{ +Returns reactive containing data used for plot. +} +\description{ +scatterPlot module server logic +} +\details{ +Make sure to have the same columnnames in data and features. +} diff --git a/man/scatterPlotGuide.Rd b/man/scatterPlotGuide.Rd new file mode 100644 index 0000000..8ebc226 --- /dev/null +++ b/man/scatterPlotGuide.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scatterPlot.R +\name{scatterPlotGuide} +\alias{scatterPlotGuide} +\title{scatterPlot module guide} +\usage{ +scatterPlotGuide(session, marker = FALSE) +} +\arguments{ +\item{session}{The shiny session} + +\item{marker}{Logical if marker step should be enabled (Default = FALSE).} +} +\value{ +A shiny reactive that contains the texts for the Guide steps. +} +\description{ +scatterPlot module guide +} diff --git a/man/scatterPlotUI.Rd b/man/scatterPlotUI.Rd new file mode 100644 index 0000000..002283d --- /dev/null +++ b/man/scatterPlotUI.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/scatterPlot.R +\name{scatterPlotUI} +\alias{scatterPlotUI} +\title{scatterPlot module UI representation} +\usage{ +scatterPlotUI(id) +} +\arguments{ +\item{id}{The ID of the modules namespace.} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +scatterPlot module UI representation +} diff --git a/man/searchData.Rd b/man/searchData.Rd new file mode 100644 index 0000000..79b581e --- /dev/null +++ b/man/searchData.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/function.R +\name{searchData} +\alias{searchData} +\title{Function to search data for selection} +\usage{ +searchData(input, choices, options = c("=", "<", ">"), min. = min(choices, + na.rm = TRUE), max. = max(choices, na.rm = TRUE)) +} +\arguments{ +\item{input}{Vector length one (single) or two (ranged) containing numeric values for selection.} + +\item{choices}{Vector on which input values are applied.} + +\item{options}{Vector on how the input and choices should be compared. It can contain: single = c("=", "<", ">") or ranged = c("inner", "outer").} + +\item{min.}{Minimum value that can be selected on slider (defaults to min(choices)).} + +\item{max.}{Maximum value that can be selected on slider (defaults to max(choices)).} +} +\value{ +Returns a logical vector with the length of choices, where every matched position is TRUE. +} +\description{ +Function to search data for selection +} diff --git a/man/sequentialPalettes.Rd b/man/sequentialPalettes.Rd new file mode 100644 index 0000000..3ac8f99 --- /dev/null +++ b/man/sequentialPalettes.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/colorPicker2.R +\name{sequentialPalettes} +\alias{sequentialPalettes} +\title{Function to generate sequential (one-sided) color palettes (e.g. for expression, enrichment)} +\usage{ +sequentialPalettes(n) +} +\arguments{ +\item{n}{Number of colors to generate} +} +\value{ +A data.table with (named) color palettes of length n +} +\description{ +Function to generate sequential (one-sided) color palettes (e.g. for expression, enrichment) +} diff --git a/man/transformation.Rd b/man/transformation.Rd new file mode 100644 index 0000000..7bb7819 --- /dev/null +++ b/man/transformation.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transformation.R +\name{transformation} +\alias{transformation} +\title{transformation module server logic} +\usage{ +transformation(input, output, session, data, transpose = FALSE, + pseudocount = 1, replaceInf = TRUE, replaceNA = TRUE) +} +\arguments{ +\item{input}{Shiny's input object.} + +\item{output}{Shiny's output object.} + +\item{session}{Shiny's session object.} + +\item{data}{Numeric matrix on which transformation is performed (column-wise). (Supports reactive)} + +\item{transpose}{Whether the matrix should be transposed to enable row-wise transformation.} + +\item{pseudocount}{Numeric Variable to add a pseudocount to log-based transformations.} + +\item{replaceInf}{Change Infinite to NA, applied after transformation.} + +\item{replaceNA}{Change NA to 0, applied after transformation.} +} +\value{ +Namedlist of two containing data and name of the used method. + data: Reactive containing the transformed matrix. Infinite values are replaced by NA and NA values are replaced by 0. + method: Reactive containing String. + transpose: Reactive containing String. +} +\description{ +The module provides several transformations on a numeric data matrix for the user. +} diff --git a/man/transformationUI.Rd b/man/transformationUI.Rd new file mode 100644 index 0000000..f013d98 --- /dev/null +++ b/man/transformationUI.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/transformation.R +\name{transformationUI} +\alias{transformationUI} +\title{transformation module UI representation} +\usage{ +transformationUI(id, label = "Transformation", selected = "raw", + choices = list(None = "raw", log2 = "log2", `-log2` = "-log2", log10 = + "log10", `-log10` = "-log10", `Z score` = "zscore", `regularized log` = + "rlog"), transposeOptions = FALSE) +} +\arguments{ +\item{id}{The ID of the modules namespace.} + +\item{label}{A character vector of length one with the label for the \code{\link[shiny]{selectInput}}.} + +\item{selected}{The initially selected value. See \code{\link[shiny]{selectInput}}.} + +\item{choices}{Named list of available transformations. Possible transformations are list(`None` = "raw", `log2` = "log2", `-log2` = "-log2", `log10` = "log10", `-log10` = "-log10", `Z score` = "zscore", `regularized log` = "rlog") which is also the default.} + +\item{transposeOptions}{Boolean value if transpose radioButtons are shown (Default = FALSE).} +} +\value{ +A list with HTML tags from \code{\link[shiny]{tag}}. +} +\description{ +This function provides an input to select a transformation method. +} diff --git a/wilson.Rproj b/wilson.Rproj new file mode 100644 index 0000000..49f2092 --- /dev/null +++ b/wilson.Rproj @@ -0,0 +1,19 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +StripTrailingWhitespace: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source