diff --git a/.Rbuildignore b/.Rbuildignore
index 4d88d31..d73b159 100644
--- a/.Rbuildignore
+++ b/.Rbuildignore
@@ -1,3 +1,4 @@
^.*\.Rproj$
^\.Rproj\.user$
^\.buildkite.*
+^revdep$
diff --git a/.buildkite/wilson-env.yml b/.buildkite/wilson-env.yml
index 32b23f0..574754e 100644
--- a/.buildkite/wilson-env.yml
+++ b/.buildkite/wilson-env.yml
@@ -43,4 +43,3 @@ dependencies:
- r-devtools
- "readline==6.3"
- r-roxygen2
- - r-shinybs
diff --git a/DESCRIPTION b/DESCRIPTION
index 53c6f7a..74bdc07 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,13 +1,13 @@
Package: wilson
Type: Package
-Title: WIlsON Webbased Interactive Omics visualizatioN
-Version: 1.0.0
+Title: Web-Based Interactive Omics Visualization
+Version: 2.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.
+Description: This package provides modules for web-based tools that use plot based strategies to visualize and analyze multi-omics data.
+ 'wilson' utilizes the 'shiny' 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
@@ -34,7 +34,6 @@ Imports: shiny,
gplots,
reshape,
rintrojs,
- webshot,
RJSONIO,
ggrepel (>= 0.6.12),
DESeq2,
@@ -42,11 +41,10 @@ Imports: shiny,
FactoMineR,
factoextra,
heatmaply (>= 0.14.1),
- shinyBS,
- shinythemes,
shinycssloaders,
log4r,
openssl,
- methods
+ methods,
+ R6
RoxygenNote: 6.0.1
biocViews:
diff --git a/NAMESPACE b/NAMESPACE
index dac65a7..fdd8ef2 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,10 +1,9 @@
# Generated by roxygen2: do not edit by hand
+export(Clarion)
export(and)
export(andUI)
export(colorPicker)
-export(colorPicker2)
-export(colorPicker2UI)
export(colorPickerUI)
export(columnSelector)
export(columnSelectorUI)
diff --git a/R/and.R b/R/and.R
index f37bcf2..0d7f889 100644
--- a/R/and.R
+++ b/R/and.R
@@ -38,8 +38,8 @@ andUI <- function(id) {
#' @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_r <- shiny::reactive({
+ if (shiny::is.reactive(data)) {
data()
}else{
data
@@ -47,69 +47,69 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
})
# handle reactive show.elements
- show.elements.r <- shiny::reactive({
- if(shiny::is.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())
+ 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_r <- shiny::reactive({
+ if (shiny::is.reactive(element.grouping)) {
element.grouping()
- }else{
+ } else {
element.grouping
}
})
parameter <- shiny::reactive({
# get column labels
- if(is.null(column.labels)){
- column.labels <- names(data.r())
- }else{
+ 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)) {
+ if (shiny::is.reactive(multiple)) {
multiple <- multiple()
}
- if (length(multiple) < ncol(data.r())) {
- multiple <- rep(multiple, length.out = ncol(data.r()))
+ 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)) {
+ if (shiny::is.reactive(contains)) {
contains <- contains()
}
- if (length(contains) < ncol(data.r())) {
- contains <- rep(contains, length.out = ncol(data.r()))
+ 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)) {
+ if (shiny::is.reactive(ranged)) {
ranged <- ranged()
}
- if (length(ranged) < ncol(data.r())) {
- ranged <- rep(ranged, length.out = ncol(data.r()))
+ 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)) {
+ if (shiny::is.reactive(delimiter)) {
delimiter <- delimiter()
}
- if (length(delimiter) < ncol(data.r()) & !is.null(delimiter)) {
- delimiter <- rep(delimiter, length.out = ncol(data.r()))
+ 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)) {
+ if (shiny::is.reactive(step)) {
step <- step()
}
- if (length(step) < ncol(data.r()) & !is.null(step)) {
- step <- rep(step, length.out = ncol(data.r()))
+ 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))
@@ -122,35 +122,35 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
progress$set(0, message = "Render orModules:")
# select data based on show.elements
- data <- data.r()[, show.elements.r(), with = FALSE]
+ data <- data_r()[, show_elements_r(), with = FALSE]
step <- ncol(data)
- if(!is.null(element.grouping.r())){
+ if (!is.null(element_grouping_r())) {
# only group shown data
- element.grouping <- element.grouping.r()[element.grouping.r()[[1]] %in% show.elements.r()]
+ element.grouping <- element_grouping_r()[element_grouping_r()[[1]] %in% show_elements_r()]
- grouping <- tapply(element.grouping[[1]], element.grouping[[2]], function(x){x})
+ 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){
+ return <- lapply(seq_len(length(grouping)), function(i){
group <- lapply(unlist(grouping[i]), function(x){
progress$inc(step, detail = x)
- if(is.numeric(data[[x]])){
+ if (is.numeric(data[[x]])) {
ui <- orNumericUI(id = session$ns(openssl::sha1(x)))
- }else{
+ } else {
ui <- orTextualUI(id = session$ns(openssl::sha1(x)))
}
- if(length(ui) < 4){ # orTextual
+ 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
+ } else { # orNumeric
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 1, ui[2]),
@@ -163,23 +163,23 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
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) {
+ } else {
+ return <- lapply(seq_len(ncol(data)), function(x) {
progress$inc(step, detail = names(data)[x])
if (is.numeric(data[[x]])) {
ui <- orNumericUI(id = session$ns(openssl::sha1(names(data)[x])))
- } else{
+ } else {
ui <- orTextualUI(id = session$ns(openssl::sha1(names(data)[x])))
}
- if(length(ui) < 4){ # orTextual
+ 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
+ } else { # orNumeric
shiny::tagList(shiny::fluidRow(
shiny::column(width = 4, ui[1]),
shiny::column(width = 1, ui[2]),
@@ -203,41 +203,41 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(0, message = "Filtering Module:")
- step <- ncol(data.r())
+ 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]])) {
+ lapply(seq_len(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 = openssl::sha1(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))),
+ id = openssl::sha1(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)),
+ 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 = openssl::sha1(names(data.r())[x]),
- choices = data.r()[[x]],
- value = mean(data.r()[[x]], na.rm = TRUE),
+ id = openssl::sha1(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)),
+ 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 = openssl::sha1(names(data.r())[x]),
- choices = as.character(data.r()[[x]]),
+ id = openssl::sha1(names(data_r())[x]),
+ choices = as.character(data_r()[[x]]),
label = parameter()$column.labels[x],
delimiter = parameter()$delimiter[x],
multiple = parameter()$multiple[x],
@@ -256,35 +256,31 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
log_message(message = "Applying filter...", level = "INFO", token = session$token)
- or.modules <- modules()
+ or_modules <- modules()
- step <- 0.9 / length(or.modules)
+ step <- 0.9 / length(or_modules)
# OR modules selection
- or.selection.bool <- sapply(or.modules, function(x) {
+ or_selection_bool <- vapply(or_modules, FUN.VALUE = logical(nrow(data_r())), FUN = function(x) {
progress$inc(step, detail = x()$label)
x()$bool
})
- or.selection.text <- sapply(or.modules, function(x) {
- if(shiny::isTruthy(x()$text)){
+
+ or_selection_text <- lapply(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)
+ and_selection_bool <- apply(or_selection_bool, 1, all)
- or.selection.text <- unlist(or.selection.text)
+ or_selection_text <- unlist(or_selection_text)
progress$set(1)
log_message(message = "Done.", level = "INFO", token = session$token)
- return(list(bool = and.selection.bool, text = unlist(or.selection.text)))
+ return(list(bool = and_selection_bool, text = unlist(or_selection_text)))
})
return(selection)
diff --git a/R/clarion.R b/R/clarion.R
new file mode 100644
index 0000000..22ce390
--- /dev/null
+++ b/R/clarion.R
@@ -0,0 +1,255 @@
+#' Clarion R6-class definition
+#'
+#' Use this to create a clarion object.
+#' This object is used by all top-level wilson modules.
+#'
+#' @section Methods:
+#' \describe{
+#' \item{\code{get_id()}}{
+#' Returns name of unique identifier column. Assumes first feature to be unique if not specified.
+#' }
+#' \item{\code{get_name()}}{
+#' Returns name of name column. If not specified return unique Id.
+#' }
+#' \item{\code{get_delimiter()}}{
+#' Return delimiter used within multi-value fields (no delimiter = NULL).
+#' }
+#' \item{\code{is_delimited(x)}}{
+#' Logical whether the given column name is delimited.
+#' }
+#' \item{\code{get_factors()}}{
+#' Returns a data.table columns: key and factor(s) if any. Named factors (e.g. factor1="name") will be cropped to their name.
+#' }
+#' \item{\code{validate(solve = TRUE)}}{
+#' Check the object for inconsistencies. For solve = TRUE try to resolve some warnings.
+#' }
+#' }
+#'
+#' @param header A named list. Defaults to NULL.
+#' @param metadata Clarion metadata in form of a data.table.
+#' @param data Data.table according to metadata.
+#' @param validate Logical value to validate on initialization. Defaults to TRUE.
+#'
+#' @field header List of global information regarding the whole experiment.
+#' @field metadata Data.table with additional information for each column.
+#' @field data Data.table containing experiment result data.
+#'
+#' @examples
+#' \dontrun{
+#' # initializing a new object
+#' object <- Clarion$new(header, metadata, data, validate = TRUE)
+#'
+#' # create a deep copy
+#' object_copy <- object$clone(deep = TRUE)
+#' }
+#'
+#' @format NULL
+#' @usage NULL
+#' @export
+Clarion <- R6::R6Class("Clarion",
+ public = list(
+ header = NULL,
+ metadata = NULL,
+ data = NULL,
+ get_id = function() {
+ # return unique_id
+ # if no type return first feature
+ if (is.element("type", names(self$metadata))) {
+ return(self$metadata[type == "unique_id"][["key"]])
+ } else {
+ return(self$metadata[level == "feature"][["key"]][1])
+ }
+ },
+ get_name = function() {
+ # return name
+ # if not existing fall back to unqiue_id
+ if (is.element("type", names(self$metadata)) && is.element("name", self$metadata[["type"]])) {
+ return(self$metadata[type == "name"][["key"]])
+ }
+ return(self$get_id())
+ },
+ get_delimiter = function() {
+ self$header$delimiter
+ },
+ is_delimited = function(x) {
+ if (is.element("type", names(self$metadata))) {
+ return(self$metadata[key == x, type] == "array")
+ } else {
+ return(FALSE)
+ }
+ },
+ get_factors = function() {
+ # returns data.table key(, factor columns)
+ # only name for named factors (e.g. factor1="name")
+
+ # get factor columns
+ columns <- grep("^factor\\d+", names(self$metadata), perl = TRUE, value = TRUE)
+ # on no factors return key column
+ if (length(columns) == 0) return(self$metadata[, "key"])
+
+ # extract names
+ ext_names <- sub("^factor\\d+=\"(.*)\"", replacement = "\\1", columns, perl = TRUE)
+
+ # get factor table
+ factor_table <- self$metadata[, c("key", columns), with = FALSE]
+ # rename columns
+ names(factor_table)[-1] <- ext_names
+
+ return(factor_table)
+ },
+ validate = function(solve = TRUE) {
+ # validate header
+ private$check_delimiter()
+ # validate metadata
+ private$check_metadata_header()
+ private$check_key()
+ private$check_level()
+ private$check_type()
+ private$check_label()
+ # validate data
+ private$check_data_header(solve)
+ private$check_data_min()
+ private$check_data_column_types()
+ },
+ initialize = function(header = NULL, metadata, data, validate = TRUE) {
+ self$header <- header
+ self$metadata <- metadata
+ self$data <- data
+
+ # coerce unique_id and name to character
+ if (self$get_id() == self$get_name()) {
+ cols <- self$get_id()
+ } else {
+ cols <- c(self$get_id(), self$get_name())
+ }
+ self$data[, (cols) := lapply(.SD, as.character), .SDcols = cols]
+
+ if (validate) self$validate()
+ }
+ ),
+ private = list(
+ # deep clone to force data.table copy
+ deep_clone = function(name, value) {
+ # invoke a deep copy for metadata and data field
+ if (name %in% c("metadata", "data")) {
+ data.table::copy(value)
+ } else {
+ value
+ }
+ },
+ ## header checks
+ check_delimiter = function() {
+ if (is.element("delimiter", names(self$header))) {
+ # case: no type column/ no type = array
+ if (!is.element("type", names(self$metadata)) || !is.element("array", self$metadata[["type"]])) {
+ warning("Found in-field-delimiter '", self$header$delimiter, "' but no type=array columns (in metadata) to apply to.")
+ }
+ }
+ },
+ ## metadata checks
+ check_metadata_header = function() {
+ # case: invalid column names
+ valid_names <- c("key", "factor\\d+(=\".*\")?", "level", "type", "label", "sub_label")
+ regex <- paste0("^", valid_names, "$", collapse = "|")
+ invalid_names <- grep(regex, names(self$metadata), invert = TRUE, value = TRUE, perl = TRUE)
+ if (length(invalid_names) > 0) {
+ warning("Metadata: Unexpected column names detected: ", paste0(invalid_names, collapse = ", "))
+ }
+ # case: missing mandatory column
+ requires <- c("key", "level")
+ missing <- !is.element(requires, names(self$metadata))
+ if (any(missing)) {
+ stop("Metadata: Mandatory column(s) missing! ", paste0(requires[missing], collapse = ", "))
+ }
+ },
+ check_key = function() {
+ # case: duplicated keys
+ if (anyDuplicated(self$metadata[["key"]])) {
+ stop("Metadata: Duplicate(s) in key detected! The following key(s) are duplicated: ", paste0(unique(self$metadata[["key"]][duplicated(self$metadata[["key"]])]), collapse = ", "))
+ }
+ # case: key not in data
+ missing <- setdiff(self$metadata[["key"]], names(self$data))
+ if (length(missing) > 0) {
+ warning("Metadata rows and data columns differ! Following rows are not defined in data: ", paste0(missing, collapse = ", "))
+ }
+ },
+ check_level = function() {
+ # case: invalid level
+ valid <- c("feature", "sample", "condition", "contrast")
+ unknown <- grep(pattern = paste0(valid, collapse = "|"), x = self$metadata[["level"]], perl = TRUE, invert = TRUE, value = TRUE)
+ if (length(unknown) > 0) {
+ warning("Metadata: Unknown level(s) found: ", paste0(unknown, collapse = ", "))
+ }
+ # case: minimal level requirements (feature + sample|condition|contrast)
+ if (!is.element("feature", self$metadata[["level"]]) && !any(is.element(c("sample", "condition", "contrast"), self$metadata[["level"]]))) {
+ stop("Metadata: Minimum level requirements not met! At least one feature (unique_id) and one sample, condition or contrast needed.")
+ }
+ },
+ check_type = function() {
+ if (is.element("type", names(self$metadata))) {
+ feature_types <- c("unique_id", "name", "category", "array")
+ remaining_types <- c("score", "ratio", "probability", "array")
+ # case: type doesn't fit level
+ # select and return keys with unknown type
+ unknown <- self$metadata[level == "feature"][!type %in% feature_types][["key"]]
+ unknown <- append(unknown, self$metadata[level %in% c("sample", "condition", "contrast")][!type %in% remaining_types][["key"]])
+ if (length(unknown) > 0) {
+ warning("Metadata: Level doesn't match type:", paste0(unknown, collapse = ", "))
+ }
+ # case: no unique_id defined
+ if (!is.element("unique_id", self$metadata[["type"]])) {
+ stop("Metadata: No unique_id defined in type! Please define a unique_id.")
+ }
+ # case: type = array but no delimiter
+ if (is.element("array", self$metadata[["type"]]) && !is.element("delimiter", names(self$header))) {
+ stop("Found type=array but no delimiter! Columns with multi-value fields require delimiter (in header) and type=array (in metadata).")
+ }
+ }
+ },
+ check_label = function() {
+ if (is.element("label", names(self$metadata))) {
+ # case: contrast label not delimited by '|'
+ contrast_labels <- grep(pattern = "\\|", x = self$metadata[level == "contrast"][["label"]], perl = TRUE, invert = TRUE, value = TRUE)
+ if (length(contrast_labels) > 0) {
+ warning("Metadata: Missing '|' delimiter in contrast label(s): ", paste0(contrast_labels, collapse = ", "))
+ }
+ }
+ },
+ ## data checks
+ check_data_header = function(solve = TRUE) {
+ # case: column not defined in metadata
+ missing <- setdiff(names(self$data), self$metadata[["key"]])
+ if (length(missing) > 0) {
+ if (solve) {
+ # omit undefined columns
+ self$data[, (missing) := NULL]
+ }
+ warning("Metadata rows and data columns differ! Following rows are missing in metadata: ", paste0(missing, collapse = ", "), if (solve) "\nOmitting data column(s)!")
+ }
+ # case: duplicated column names
+ if (anyDuplicated(names(self$data))) {
+ stop("Data: Column names not unique! Following names occur more than once: ", paste0(unique(names(self$data)[duplicated(names(self$data))]), collapse = ", "))
+ }
+ },
+ check_data_min = function() {
+ # case: minimum requirements not met (two columns: feature(unique_id) + sample|condition|contrast)
+ if (ncol(self$data) < 2) {
+ stop("Data: Minimum requirements not met! At least two columns needed, one with unique identifier and one with numeric values.")
+ }
+ },
+ check_data_column_types = function() {
+ # case: level = sample, condition, contrast not numeric
+ # except type=array because of delimiter
+ if (is.element("type", names(self$metadata))) {
+ expected_numeric_cols <- self$metadata[level %in% c("sample", "condition", "contrast")][type != "array"][["key"]]
+ } else {
+ expected_numeric_cols <- self$metadata[level %in% c("sample", "condition", "contrast")][["key"]]
+ }
+ not_numeric <- names(self$data[, expected_numeric_cols, with = FALSE][, which(!vapply(self$data[, expected_numeric_cols, with = FALSE], is.numeric, FUN.VALUE = logical(1)))])
+ if (length(not_numeric) > 0) {
+ stop("Data: Column(s): ", paste0(not_numeric, collapse = ", "), " not numeric! Probably wrong decimal separator.")
+ }
+ }
+ ),
+ lock_class = TRUE # prevent class modification
+)
diff --git a/R/colorPicker.R b/R/colorPicker.R
index 4e3b372..5825e12 100644
--- a/R/colorPicker.R
+++ b/R/colorPicker.R
@@ -5,62 +5,257 @@
#'
#' @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)
+#' @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 winsorize (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}}.
#'
-#' @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) {
+colorPickerUI <- function(id, label = "Color scheme", custom = FALSE, multiple = FALSE, show.reverse = TRUE, show.scaleoptions = TRUE, show.transparency = TRUE) {
ns <- shiny::NS(id)
- if(is.null(selected.choice)) {
- selected.choice <- choices[[1]]
- }
+ if (custom) {
+ ret <- list(colourpicker::colourInput(ns("picker"), label = NULL, value = "red"))
- if(length(label) == 1 & !single.colors) {
- ret <- list(shiny::selectInput(ns("scheme"), label = label, choices = choices, selected = selected.choice))
+ if (multiple) {
+ ret <- list(
+ shinyjs::useShinyjs(),
+ shiny::textInput(ns("palette"), label = NULL, value = "red,blue", placeholder = "e.g. black,#3c8dbc"),
+ 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(show.reverse) {
+ if (!custom | custom & multiple) {
+ 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.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)))
}
}
- 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.
+#' 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. Dynamically change lower and upper limit (supports reactive). Defaults to NULL.
+#' @param selected Set the default selected palette.
#'
-#' @return The \code{input} object.
+#' @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.
#'
-#' @section To do:
-#' Implement transparency calculation in case of one or more single colors.
+#' @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
-colorPicker <- function(input, output, session) {
- return(input)
+colorPicker <- 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
+ is_color <- 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, is_color))
+ 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/colorPicker2.R b/R/colorPicker2.R
deleted file mode 100644
index 48ba1f2..0000000
--- a/R/colorPicker2.R
+++ /dev/null
@@ -1,262 +0,0 @@
-#' 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
index 528de10..fa17e47 100644
--- a/R/columnSelector.R
+++ b/R/columnSelector.R
@@ -7,8 +7,8 @@
#' @return A list from \code{\link[shiny]{tag}} with the UI elements.
#'
#' @export
-columnSelectorUI <- function(id, label = F, title = NULL) {
- #create namespace
+columnSelectorUI <- function(id, label = FALSE, title = NULL) {
+ # create namespace
ns <- shiny::NS(id)
shiny::tagList(
@@ -16,7 +16,7 @@ columnSelectorUI <- function(id, label = F, title = NULL) {
shinyjs::useShinyjs(),
shiny::singleton(shiny::tags$head(shiny::tags$link(rel = "stylesheet", type = "text/css", href = "wilson_www/styles.css"))),
shiny::uiOutput(ns("out")),
- {if(label) shiny::uiOutput(ns("showLabel"))}
+ if (label) shiny::uiOutput(ns("show_label"))
)
}
@@ -26,43 +26,43 @@ columnSelectorUI <- function(id, label = F, title = NULL) {
#' @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)
+#' key = columnnames (id)
+#' level = datalevel/ type of column
+#' label = optional, used instead of id
+#' 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 column.type.label Changes the label of the first UI element
+#' @param label.label 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.
+#' @param sep Used to separate labels on multi value selection.
+#' @param suffix Added to label only on multiple = FALSE (supports reactive). Also uses sep as separator.
#'
-#' @return Returns the input. As named list: names("type", "selectedColumns", "label")
+#' @return Returns the input. As named list: names("type", "selected_columns", "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)){
+columnSelector <- function(input, output, session, type.columns, type = NULL, column.type.label = "Type of Column", label.label = "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{
+ } else {
type.columns
}
})
- type.r <- shiny::reactive({
- if(!is.null(type)){
- if(shiny::is.reactive(type)){
+ type_r <- shiny::reactive({
+ if (!is.null(type)) {
+ if (shiny::is.reactive(type)) {
type()
- }else{
+ } else {
type
}
- }else{
- unique(type.columns.r()[[2]])
+ } else {
+ unique(type_columns_r()[[2]])
}
})
- suffix.r <- shiny::reactive({
- if(shiny::is.reactive(suffix)) {
+ suffix_r <- shiny::reactive({
+ if (shiny::is.reactive(suffix)) {
suffix()
} else {
suffix
@@ -70,41 +70,47 @@ columnSelector <- function(input, output, session, type.columns, type = NULL, co
})
output$out <- shiny::renderUI({
- if(none){
- choices <- c("None", type.columns.r()[type.columns.r()[[2]] %in% type.r()[1]][[1]])
+ if (none) {
+ choices <- c("None", type_columns_r()[type_columns_r()[["level"]] %in% type_r()[1]][["key"]])
}else{
- choices <- type.columns.r()[type.columns.r()[[2]] %in% type.r()[1]][[1]]
+ choices <- type_columns_r()[type_columns_r()[["level"]] %in% type_r()[1]][["key"]]
}
- columnSelectLabel = "Select individual column"
- if(multiple) {
- columnSelectLabel = paste0(columnSelectLabel, "(s)")
+ column_select_label <- "Select individual column"
+ if (multiple) {
+ column_select_label <- paste0(column_select_label, "(s)")
}
shiny::tagList(
- shiny::selectInput(session$ns("select.type"), label = columnTypeLabel, choices = type.r(), selected = type.r()[1], multiple = FALSE),
- shiny::div(shiny::selectizeInput(session$ns("select.column"), label = columnSelectLabel, choices = choices, multiple = multiple), class = "empty") # colored background if empty
+ shiny::selectInput(session$ns("select_type"), label = column.type.label, choices = type_r(), selected = type_r()[1], multiple = FALSE),
+ shiny::div(shiny::selectizeInput(session$ns("select_column"), label = column_select_label, choices = choices, multiple = multiple), class = "empty") # colored background if empty
)
})
- #show label textInput
- output$showLabel <- shiny::renderUI({
- shiny::textInput(session$ns("select.label"), label = labelLabel)
+ # show label textInput
+ output$show_label <- shiny::renderUI({
+ shiny::textInput(session$ns("select_label"), label = label.label)
})
# 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]]
+ shiny::req(input$select_type)
+ # empty label on 'None'
+ if (none && input$select_column == "None") return("")
+
+ if (is.element("label", names(type_columns_r()))) {
+ label_id <- input$select_column
+ label_label <- type_columns_r()[type_columns_r()[["key"]] %in% input$select_column][["label"]]
# 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 <- input$select_column
+ }
+
+ # add sub_label
+ if (is.element("sub_label", names(type_columns_r()))) {
+ label <- paste(label, type_columns_r()[type_columns_r()[["key"]] %in% input$select_column][["sub_label"]])
}
label <- paste(label, collapse = sep)
@@ -114,48 +120,47 @@ columnSelector <- function(input, output, session, type.columns, type = NULL, co
# update label
shiny::observe({
- input$select.column
- suffix.r()
+ 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)
+ 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)
+ shiny::updateTextInput(session = session, inputId = "select_label", value = value)
}
})
})
- #show columns based on selected type
+ # 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]]
+ if (none) {
+ columns <- c("None", type_columns_r()[type_columns_r()[["level"]] %in% input$select_type][["key"]])
+ } else {
+ columns <- type_columns_r()[type_columns_r()[["level"]] %in% input$select_type][["key"]]
}
- shiny::updateSelectizeInput(session = session, inputId = "select.column", choices = columns)
+ shiny::updateSelectizeInput(session = session, inputId = "select_column", choices = columns)
})
- out.type <- shiny::reactive(input$select.type)
- out.selectedColumns <- shiny::reactive(if(shiny::isTruthy(input$select.column) && input$select.column != "None") input$select.column else "")
- out.label <- shiny::reactive({
- if(is.null(input$select.label)) {
+ out_type <- shiny::reactive(input$select_type)
+ out_selected_columns <- shiny::reactive(if (shiny::isTruthy(input$select_column) && input$select_column != "None") input$select_column else "")
+ out_label <- shiny::reactive({
+ if (is.null(input$select_label)) {
label <- create_label()
} else {
- label <- input$select.label
+ label <- input$select_label
}
- if(multiple) {
+ if (multiple) {
label <- unlist(strsplit(label, split = sep, fixed = TRUE))
}
return(label)
})
- return(list(type = out.type, selectedColumns = out.selectedColumns, label = out.label))
-
+ return(list(type = out_type, selected_columns = out_selected_columns, label = out_label))
}
diff --git a/R/featureSelector.R b/R/featureSelector.R
index 8ca752b..40b2bce 100644
--- a/R/featureSelector.R
+++ b/R/featureSelector.R
@@ -30,7 +30,7 @@ featureSelectorUI <- function(id){
shiny::actionButton(ns("guide"), "Launch guide", style = "color: #fff; background-color: #3c8dbc", icon = shiny::icon("question-circle")),
shiny::downloadButton(ns("download")),
shiny::br(),
- shiny::strong("NOTE: The SELECT button only evaluates the filter(s) below.",shiny::br(),
+ shiny::strong("NOTE: The SELECT button only evaluates the filter(s) below.", shiny::br(),
"Manual sub-selections on table applies instantly!", shiny::br(),
"Repress of SELECT button discards manual selections!")
)
@@ -52,65 +52,54 @@ featureSelectorUI <- function(id){
#' @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 clarion A clarion object. See \code{\link[wilson]{Clarion}}. (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 step Set numeric ORs number of 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.
+#' @details Keep in mind that the order of features (columns in clarion$data) is the order in which 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).
+#' @return Reactive containing names list: Selected data as reactive containing clarion object (object). 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)
+featureSelector <- function(input, output, session, clarion, multiple = TRUE, contains = FALSE, ranged = TRUE, step = 100, truncate = 30, selection.default = "all"){
+ # object/ data preparation
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion$clone(deep = TRUE)
}
})
- # 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
+ # delimiter vector
+ # only delimit type = array
+ delimiter <- shiny::reactive({
+ lapply(object()$metadata[["key"]], function(x) {
+ if (object()$is_delimited(x)) {
+ return(object()$get_delimiter())
+ } else {
+ return(NULL)
}
- }
+ })
})
- # 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))
+ and_selected <- shiny::callModule(and, "and", data = shiny::reactive(object()$data), element.grouping = shiny::reactive(object()$metadata[, c("key", "level")]), 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 n features from the top and/or bottom of the list", stepsize = 1)
# row_selector choices
choices <- shiny::reactive({
- if(nrow(data_output()$data) > 0) {
- c(1:nrow(data_output()$data))
+ if (nrow(data_output()$data) > 0) {
+ seq_len(nrow(data_output()$data))
} else {
c(0, 0)
}
@@ -121,7 +110,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
# select all if no values stored
value_wrapper <- shiny::reactive({
- if(is.null(value())) {
+ if (is.null(value())) {
value(c(min(choices()), max(choices())))
}
@@ -130,8 +119,8 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
# 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
+ 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 {
@@ -142,7 +131,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
}
})
# reset row_selector value on data change
- shiny::observeEvent(data.r(), {
+ shiny::observeEvent(object(), {
value(NULL)
})
@@ -155,7 +144,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
})
# Fetch reactive guide for this module
- guide <- featureSelectorGuide(session, !is.null(feature.grouping))
+ guide <- featureSelectorGuide(session)
shiny::observeEvent(input$guide, {
rintrojs::introjs(session, options = list(steps = guide(), scrollToElement = FALSE))
})
@@ -178,7 +167,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
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::tags$style(type = "text/css", "body {padding-right: 0px !important;}"),
shiny::actionLink(session$ns("infobutton"), label = NULL, icon = shiny::icon("question-circle"))
)
),
@@ -220,7 +209,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
row_order <- input$table_rows_all
# don't select whole table
- if(any(row_selector()$bool == FALSE) & length(row_selector()$bool) == length(row_order)) {
+ if (any(row_selector()$bool == FALSE) & length(row_selector()$bool) == length(row_order)) {
DT::selectRows(proxy, row_order[row_selector()$bool])
} else {
# delete selection
@@ -247,15 +236,15 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
select <- shiny::eventReactive(eventExpr = input$select, {
log_message(message = "Filtering data", level = "INFO", token = session$token)
- data <- data.r()[and_selected()$bool]
+ data <- object()$data[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)) {
+ if (!is.null(input$table_rows_selected)) {
data <- data_output()$data[input$table_rows_selected]
- } else if(!is.null(input$table_rows_all)) {
+ } else if (!is.null(input$table_rows_all)) {
data <- data_output()$data[input$table_rows_all]
} else {
data <- data_output()$data
@@ -265,7 +254,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
filter <- data_output()$filter
# number of rows selected
- if(!is.null(input$table_rows_selected)) {
+ if (!is.null(input$table_rows_selected)) {
filter <- append(filter, after = 1,
values = paste("Selected:", length(input$table_rows_selected))
)
@@ -274,8 +263,8 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
# TODO add order information to filter
# search text
- if(!is.null(input$table_search)) {
- if(nchar(input$table_search) > 0) {
+ 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, ")"))
@@ -283,7 +272,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
}
}
- return(list(data = data, filter = filter))
+ return(list(object = Clarion$new(header = object()$header, metadata = object()$metadata, data = data, validate = FALSE), filter = filter))
})
# store change
@@ -291,28 +280,28 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
# 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]
+ if (data_change() == 0) {
+ if (selection.default == "all") {
+ data <- object()$data
+ } else if (selection.default == "none") {
+ data <- object()$data[FALSE]
}
# create filter text
- filter <- paste("Result:" , nrow(data), "hits")
- } else if(data_change() == 1) {
+ 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))
+ return(list(data = data, filter = filter))
})
# observe most recent change
shiny::observe({
- data.r()
+ object()$data
data_change(0)
})
shiny::observe({
@@ -326,7 +315,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
content = function(file) {
log_message("FeatureSelector: download", "INFO", token = session$token)
- data.table::fwrite(x = result()$data, file = file, sep = "\t")
+ data.table::fwrite(x = result()$object$data, file = file, sep = "\t")
}
)
@@ -336,12 +325,14 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
#' 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(
+featureSelectorGuide <- function(session) {
+ 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.",
"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.
@@ -363,14 +354,5 @@ featureSelectorGuide <- function(session, grouping = FALSE) {
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
index 1b71fbe..d93701a 100644
--- a/R/function.R
+++ b/R/function.R
@@ -3,18 +3,21 @@
#' @param data data.table containing plot data
#' column 1: id
#' column 2, 3(, 4): x, y(, z)
+#' @param data.labels Vector of labels used for data. Length has to be equal to nrow(data).
+#' @param data.hovertext Character vector with additional hovertext. Length has to be equal to nrow(data).
#' @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 color 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.data data.table containing data to highlight. Same structure as data.
+#' @param highlight.labels Vector of labels used for highlighted data. Length has to be equal to nrow(highlight.data).
+#' @param highlight.hovertext Character vector with additional hovertext. Length has to be equal to nrow(highlight.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}}.
@@ -30,46 +33,47 @@
#' @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", scale = 1){
+create_scatterplot <- function(data, data.labels = NULL, data.hovertext = NULL, transparency = 1, pointsize = 1, labelsize = 3, color = NULL, x_label = "", y_label = "", z_label = "", density = TRUE, line = TRUE, categorized = FALSE, highlight.data = NULL, highlight.labels = NULL, highlight.hovertext = NULL, highlight.color = "#FF0000", xlim = NULL, ylim = NULL, colorbar.limits = NULL, width = "auto", height = "auto", ppi = 72, plot.method = "static", scale = 1){
# force evaluation of all arguments
# no promises in plot object
forceArgs()
########## prepare data ##########
- #set labelnames if needed
+ # 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])}
+ if (ncol(data) >= 4) z_label <- ifelse(nchar(z_label), z_label, names(data)[4])
- # make column names unqiue to prevent overwrite
+ # make column names unique to prevent overwrite
columnnames <- names(data)
names(data) <- make.unique(columnnames)
- if(!is.null(highlight.data)) {
+ if (!is.null(highlight.data)) {
columnnames.highlight <- names(highlight.data)
names(highlight.data) <- make.unique(columnnames.highlight)
}
- # get intern columnnames
+ # get internal 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]
+ 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]
+ # delete labels & hovertext accordingly
+ data.labels <- data.labels[rows_to_keep_data]
+ data.hovertext <- data.hovertext[rows_to_keep_data]
+ if (!is.null(highlight.data)) {
+ highlight.labels <- highlight.labels[rows_to_keep_high]
+ highlight.hovertext <- highlight.hovertext[rows_to_keep_high]
}
########## assemble plot ##########
- theme1 <- ggplot2::theme ( #no gray background or helper lines
+ 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(),
@@ -81,123 +85,138 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
axis.title.y = ggplot2::element_text(face = "bold", color = "black", size = 10 * scale),
plot.title = ggplot2::element_text(face = "bold", color = "black", size = 12 * scale),
text = ggplot2::element_text(size = 10 * scale)
- # legend.background = element_rect(color = "red") #border color
- # legend.key = element_rect("green") #not working!
+ # legend.background = element_rect(color = "red") # border color
+ # legend.key = element_rect("green") # not working!
)
- ###z-axis exists?
- if(ncol(data) >= 4){
+ ### z-axis exists?
+ if (ncol(data) >= 4) {
plot <- ggplot2::ggplot(data = data)
- ###scatter with color axis
- if(categorized == FALSE){
+ ### scatter with color axis
+ if (!categorized) {
plot <- plot +
- ###color_gradient
- ggplot2::scale_color_gradientn(colors = colors, name = z_label, limits = colorbar.limits, oob = scales::squish)
+ ### color_gradient
+ ggplot2::scale_color_gradientn(colors = color, name = z_label, limits = colorbar.limits, oob = scales::squish)
- ###scatter with categories
- }else if(categorized == TRUE){
- #change categorized column to factor
+ ### scatter with categories
+ } else if (categorized == TRUE) {
+ # change categorized column to factor
data <- data[, (z_head) := as.factor(data[[z_head]])]
- ###categorized plot
+ ### 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
+ ggplot2::scale_color_manual(
+ # labels = data[, z_head],
+ values = grDevices::colorRampPalette(color)(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
+ # guide=guide_legend(title="sdsds") # legend for points
)
}
- #set names
+ # 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)))
+ } else {
+ plot <- ggplot2::ggplot(data = data, ggplot2::aes_(x = as.name(x_head), y = as.name(y_head)))
}
- if(density == TRUE){
+ if (density) {
### 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$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")
+ plot <- plot + ggplot2::scale_fill_gradient(low = "white", high = "black") +
+ # guides(fill=FALSE) + # remove density legend
+ ggplot2::labs(fill = "Density")
}
- if(line == TRUE){
+ if (line) {
### diagonal line
- plot <- plot + ggplot2::geom_abline(intercept=0, slope=1)
+ plot <- plot + ggplot2::geom_abline(intercept = 0, slope = 1)
}
plot <- plot +
- ggplot2::xlab(x_label) + #axis labels
+ 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]])
+ if (plot.method == "interactive") {
+ # set hovertext
+ # list of arguments for paste0
+ args <- list(
+ "", data[[1]],
+ "", x_label, ": ", data[[x_head]],
+ "", y_label, ": ", data[[y_head]]
+ )
+
+ # append z-axis
+ if (ncol(data) >= 4) {
+ args <- append(args, list("", z_label, ": ", data[[z_head]]))
}
+ # append additional hovertext
+ if (!is.null(data.hovertext)) {
+ args <- append(args, list("", data.hovertext), after = 2)
+ }
+
+ # eval arguments with paste0
+ hovertext <- do.call(paste0, args)
- #set points
+ # set points
plot <- plot + ggplot2::geom_point(size = pointsize * scale, 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]])
+ if (!is.null(highlight.data)) {
+ # set highlighted hovertext
+ # list of arguments for paste0
+ highlight.args <- list(
+ "", highlight.data[[1]],
+ "", x_label, ": ", highlight.data[[x_head]],
+ "", y_label, ": ", highlight.data[[y_head]]
+ )
+
+ # append z-axis
+ if (ncol(data) >= 4) {
+ highlight.args <- append(highlight.args, list("", z_label, ": ", highlight.data[[z_head]]))
+ }
+ # append additional hovertext
+ if (!is.null(highlight.hovertext)) {
+ highlight.args <- append(highlight.args, list("", highlight.hovertext), after = 2)
}
- #set highlighted points
- plot <- plot + ggplot2::geom_point(size = pointsize * scale, alpha = transparency, inherit.aes = TRUE, data = highlight.data, color = highlight.color, show.legend = FALSE, ggplot2::aes(text = hovertext.high))
+ # eval arguments with paste0
+ highlight.hovertext <- do.call(paste0, highlight.args)
+
+ # set highlighted points
+ plot <- plot + ggplot2::geom_point(size = pointsize * scale, alpha = transparency, inherit.aes = TRUE, data = highlight.data, color = highlight.color, show.legend = FALSE, ggplot2::aes(text = highlight.hovertext))
}
# static points without hovertexts
- } else if(plot.method == "static") {
+ } else if (plot.method == "static") {
seed <- Sys.getpid() + Sys.time()
# set points
plot <- plot + ggplot2::geom_point(size = pointsize * scale, alpha = transparency)
# set highlighted points
- if(!is.null(highlight.data)) {
+ if (!is.null(highlight.data)) {
plot <- plot + ggplot2::geom_point(size = pointsize * scale, alpha = transparency, inherit.aes = TRUE, data = highlight.data, color = highlight.color, show.legend = FALSE)
# set repelling point labels
- if(!is.null(highlight.labels)) {
+ if (!is.null(highlight.labels)) {
plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, 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 * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, 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 * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, 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 * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, seed = seed)
+ # set repelling labels (for data)
+ } else if (!is.null(data.labels)) {
+ plot <- plot + ggrepel::geom_label_repel(mapping = ggplot2::aes(label = data.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, point.padding = grid::unit(0.1, "lines"), label.size = NA, alpha = 0.5, seed = seed)
+ plot <- plot + ggrepel::geom_label_repel(mapping = ggplot2::aes(label = data.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 1000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, seed = seed)
}
}
- #set axis limits
- if(!is.null(xlim)){
+ # set axis limits
+ if (!is.null(xlim)) {
plot <- plot + ggplot2::xlim(xlim)
}
- if(!is.null(ylim)){
+ if (!is.null(ylim)) {
plot <- plot + ggplot2::ylim(ylim)
}
@@ -205,18 +224,18 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
- #estimate legend width
+ # estimate legend width
legend.width <- 0
legend.padding <- 20 # 10 on both sides
legend.thickness <- 30
- if(density){
+ if (density) {
legend.width <- nchar("Density")
}
- if(ncol(data) > 3){
+ if (ncol(data) > 3) {
legend.width <- ifelse(legend.width > nchar(z_label), legend.width, nchar(z_label))
}
- if(density | ncol(data) > 3){
- #estimate tickwidth
+ 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)
@@ -225,14 +244,14 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
legend.width <- ifelse(legend.width > legend.thickness, legend.width, legend.thickness) + legend.padding
}
- #set width/ height
- if(width == "auto"){
+ # 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"){
+ if (height == "auto") {
# cm to px
height <- 28 * (ppi / 2.54)
} else {
@@ -246,25 +265,24 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
# size exceeded?
exceed_size <- FALSE
limit <- 500 * (ppi / 2.54)
- if(width > limit) {
+ if (width > limit) {
exceed_size <- TRUE
width <- limit
}
- if(height > limit) {
+ if (height > limit) {
exceed_size <- TRUE
height <- limit
}
- if(plot.method == "interactive") {
+ 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 * scale, font = list(size = labelsize * scale), 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 * scale, font = list(size = labelsize * scale), bgcolor = 'rgba(255, 255, 255, 0.5)')
- }
+ if (!is.null(highlight.labels) && !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 * scale, font = list(size = labelsize * scale), bgcolor = "rgba(255, 255, 255, 0.5)")
+ }
+ if (!is.null(data.labels)) {
+ plot <- plotly::add_annotations(p = plot, x = data[[x_head]], y = data[[y_head]], text = data.labels, standoff = pointsize * scale, font = list(size = labelsize * scale), bgcolor = "rgba(255, 255, 255, 0.5)")
}
}
@@ -279,9 +297,15 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
#' 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 color.group Vector of groups according to samples (= column names).
+#' @param color.title Title of the color legend.
+#' @param palette Vector of colors used for color palette.
+#' @param shape.group Vector of groups according to samples (= column names).
+#' @param shape.title Title of the shape legend.
+#' @param shapes Vector of shapes see \code{\link[graphics]{points}}. Will recycle/ cut off shapes if needed. Default = c(15:25)
+#' @param dimension.a Number of dimension displayed on X-Axis.
+#' @param dimension.b Number of dimension displayed on Y-Axis.
+#' @param dimensions Number of dimensions 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.
@@ -298,7 +322,7 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
#' @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, scale = 1) {
+create_pca <- function(data, color.group = NULL, color.title = NULL, palette = NULL, shape.group = NULL, shape.title = NULL, shapes = c(15:25), dimension.a = 1, dimension.b = 2, dimensions = 6, on.columns = TRUE, labels = FALSE, custom.labels = NULL, pointsize = 2, labelsize = 3, width = 28, height = 28, ppi = 72, scale = 1) {
# force evaluation of all arguments
# no promises in plot object
forceArgs()
@@ -308,73 +332,121 @@ create_pca <- function(data, dimensionA = 1, dimensionB = 2, dimensions = 6, on.
# prepare data ------------------------------------------------------------
# set custom labels
- if(!is.null(custom.labels)) {
- if(!is.numeric(data[[1]])) {
+ if (!is.null(custom.labels)) {
+ if (!is.numeric(data[[1]])) {
colnames(data)[-1] <- custom.labels
} else {
colnames(data) <- custom.labels
}
}
- #remove rows with NA
+ # remove rows with NA
data <- stats::na.omit(data)
- #check for rownames
- if(!is.numeric(data[[1]])){
+ # check for rownames
+ if (!is.numeric(data[[1]])) {
rownames <- data[[1]]
data[, 1 := NULL]
- }else{
+ } else {
rownames <- NULL
}
- #transpose
- if(on.columns){
+ # transpose
+ if (on.columns) {
data_t <- t(data)
- if(!is.null(rownames)){
+ if (!is.null(rownames)) {
colnames(data_t) <- rownames
}
- }else{
+ } else {
data_t <- as.matrix(data)
- if(!is.null(rownames)){
+ if (!is.null(rownames)) {
rownames(data_t) <- rownames
}
}
- #check if PCA possible
- if(ncol(data_t) < 3){
+ # 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)
+ # 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
+ 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 * scale),
- axis.title.y = ggplot2::element_text(color="black", size = 11 * scale),
- #plot.title = element_text(color="black", size=12),
+ 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 * scale),
+ axis.title.y = ggplot2::element_text(color = "black", size = 11 * scale),
+ # plot.title = element_text(color = "black", size = 12),
plot.title = ggplot2::element_blank(),
- legend.title = ggplot2::element_blank(),
- text = ggplot2::element_text(size = 12 * scale) #size for all (legend?) labels
- #legend.key = element_rect(fill="white")
+ legend.title = ggplot2::element_text(color = "black", size = 11 * scale),
+ text = ggplot2::element_text(size = 12 * scale) # 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 * scale, label = "none", axes.linetype = "blank", repel = FALSE)
+ # show points if neither color- nor shape-groups
+ if (is.null(color.group) && is.null(shape.group)) {
+ invisible <- "none"
+ } else {
+ invisible <- "ind"
+ # prepare df for mapping
+ df <- data.frame(x = pca$ind$coord[, dimension.a], y = pca$ind$coord[, dimension.b])
+ }
+
+ pca_plot <- factoextra::fviz_pca_ind(pca, axes = c(dimension.a, dimension.b), invisible = invisible, pointsize = pointsize * scale, label = "none", axes.linetype = "blank", repel = FALSE)
pca_plot <- pca_plot + theme1
- if(labels) {
+ # grouping
+ scale_color <- NULL
+ scale_shape <- NULL
+ # color points by groups
+ if (is.vector(color.group)) {
+ color.group <- as.factor(color.group)
+ df <- data.frame(df, color = color.group)
+
+ scale_color <- ggplot2::scale_color_manual(
+ values = grDevices::colorRampPalette(palette)(nlevels(color.group)),
+ name = color.title
+ )
+ }
+ # shape points by groups
+ if (is.vector(shape.group)) {
+ shape.group <- as.factor(shape.group)
+ df <- data.frame(df, shape = shape.group)
+
+ scale_shape <- ggplot2::scale_shape_manual(
+ values = rep(shapes, length.out = nlevels(shape.group)),
+ name = shape.title
+ )
+ }
+ # generate mapping
+ if (!is.null(color.group) && !is.null(shape.group)) {
+ mapping <- ggplot2::aes_string(x = "x", y = "y", color = "color", shape = "shape")
+ } else if (!is.null(color.group)) {
+ mapping <- ggplot2::aes_string(x = "x", y = "y", color = "color")
+ } else if (!is.null(shape.group)) {
+ mapping <- ggplot2::aes_string(x = "x", y = "y", shape = "shape")
+ }
+ # apply grouping
+ if (!is.null(color.group) || !is.null(shape.group)) {
+ pca_plot <- pca_plot +
+ ggplot2::geom_point(data = df, mapping = mapping, size = pointsize * scale) +
+ scale_color +
+ scale_shape
+ }
+
+ 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)),
+ mapping = ggplot2::aes_(x = pca$ind$coord[, dimension.a], y = pca$ind$coord[, dimension.b], label = rownames(pca$ind$coord)),
segment.color = "gray65",
size = labelsize * scale,
force = 2,
@@ -383,8 +455,8 @@ create_pca <- function(data, dimensionA = 1, dimensionB = 2, dimensions = 6, on.
)
}
- #ensure quadratic plot
- # if(width == height){
+ # ensure quadratic plot
+ # if (width == height) {
# pca_plot <- pca_plot + ggplot2::coord_fixed(ratio = 1)
# }
@@ -394,11 +466,11 @@ create_pca <- function(data, dimensionA = 1, dimensionB = 2, dimensions = 6, on.
# size exceeded?
exceed_size <- FALSE
- if(width > 500) {
+ if (width > 500) {
exceed_size <- TRUE
width <- 500
}
- if(height > 500) {
+ if (height > 500) {
exceed_size <- TRUE
height <- 500
}
@@ -428,7 +500,7 @@ create_pca <- function(data, dimensionA = 1, dimensionB = 2, dimensions = 6, on.
#' @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, scale = 1) {
+create_heatmap <- function(data, unitlabel = "auto", row.label = TRUE, row.custom.label = NULL, column.label = TRUE, column.custom.label = NULL, clustering = "none", clustdist = "auto", clustmethod = "auto", colors = NULL, winsorize.colors = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72, scale = 1) {
# force evaluation of all arguments
# no promises in plot object
forceArgs()
@@ -438,55 +510,55 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
requireNamespace("grDevices", quietly = TRUE)
requireNamespace("circlize", quietly = TRUE)
- #row label
- if(!is.null(row.custom.label)) {
- row.label.strings <- row.custom.label
+ # row label
+ if (!is.null(row.custom.label)) {
+ row_label_strings <- row.custom.label
} else {
- row.label.strings <- data[[1]]
+ row_label_strings <- data[[1]]
}
# column label
- if(!is.null(column.custom.label)) {
- column.label.strings <- column.custom.label
+ if (!is.null(column.custom.label)) {
+ column_label_strings <- column.custom.label
} else {
- column.label.strings <- names(data)[-1]
+ column_label_strings <- names(data)[-1]
}
# cm to pixel
- if(is.numeric(width)) {
+ if (is.numeric(width)) {
width <- width * (ppi / 2.54)
}
- if(is.numeric(height)) {
+ if (is.numeric(height)) {
height <- height * (ppi / 2.54)
}
# plot --------------------------------------------------------------------
- if(plot.method == "interactive"){
- #estimate label sizes
- #row label
+ if (plot.method == "interactive") {
+ # estimate label sizes
+ # row label
rowlabel_size <- ifelse(row.label, max(nchar(data[[1]]), na.rm = TRUE) * 8 * scale, 0)
- #column label
- collabel_size <- ifelse(column.label, (2 + log2(max(nchar(names(data)), na.rm = TRUE))^2) * 10, 0)
- #legend
+ # 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
+ # plot size
+ # auto_width <- 20 * (ncol(data) - 1) + rowlabel_size + legend
auto_height <- 10 * nrow(data) + collabel_size
- #data
+ # data
plot <- heatmaply::heatmapr(data[, -1],
- labRow = row.label.strings,
- labCol = column.label.strings,
+ 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
+ # width = width, #not working
+ # height = height
)
- #layout
+ # layout
plot <- heatmaply::heatmaply(plot,
plot_method = "ggplot",
node_type = "heatmap",
@@ -497,12 +569,12 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
plot <- plotly::layout(plot, autosize = ifelse(width == "auto", TRUE, FALSE), margin = list(l = rowlabel_size, r = legend, b = collabel_size), showlegend = FALSE)
# decide which sizes should be used
- if(width == "auto") {
+ if (width == "auto") {
width <- 0
# } else if(width <= auto_width) {
# width <- auto_width
}
- if(height == "auto") {
+ if (height == "auto") {
height <- auto_height
}
@@ -513,11 +585,11 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
# size exceeded?
exceed_size <- FALSE
limit <- 500 * (ppi / 2.54)
- if(width > limit) {
+ if (width > limit) {
exceed_size <- TRUE
width <- limit
}
- if(height > limit) {
+ if (height > limit) {
exceed_size <- TRUE
height <- limit
}
@@ -528,21 +600,21 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
# address correct axis
# scale axis tickfont
ticks <- list(size = 12 * scale)
- if(clustering == "both" || clustering == "column"){
+ if (clustering == "both" || clustering == "column") {
plot <- plotly::layout(plot, xaxis = list(showticklabels = column.label, tickfont = ticks),
yaxis2 = list(showticklabels = row.label, tickfont = ticks)
)
- }else if(clustering == "row" || clustering == "none"){
+ }else if (clustering == "row" || clustering == "none") {
plot <- plotly::layout(plot, xaxis = list(showticklabels = column.label, tickfont = ticks),
yaxis = list(showticklabels = row.label, tickfont = ticks)
)
}
- #don't show dendrogram ticks
- if(clustering == "row"){
+ # don't show dendrogram ticks
+ if (clustering == "row") {
plot <- plotly::layout(plot, xaxis2 = list(showticklabels = FALSE)
)
- }else if(clustering == "column"){
+ }else if (clustering == "column") {
plot <- plotly::layout(plot, yaxis = list(showticklabels = FALSE)
)
}
@@ -552,41 +624,41 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
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
+ }else if (plot.method == "static") {
+
+ # clustering
+ if (clustering == "none") {
+ cluster_rows <- FALSE
+ cluster_columns <- FALSE
+ } else if (clustering == "row") {
+ cluster_rows <- TRUE
+ cluster_columns <- FALSE
+ } else if (clustering == "column") {
+ cluster_rows <- FALSE
+ cluster_columns <- TRUE
+ } else if (clustering == "both") {
+ cluster_rows <- TRUE
+ cluster_columns <- TRUE
}
#
# Create new colour brakepoints in case of winsorizing
#
- if(!is.null(winsorize.colors)) {
+ if (!is.null(winsorize.colors)) {
breaks <- seq(winsorize.colors[1], winsorize.colors[2], length = length(colors))
} else {
breaks <- seq(min(apply(data[, -1], 2, function(x) {min(x, na.rm = TRUE)})), max(apply(data[, -1], 2, function(x) {max(x, na.rm = TRUE)})), 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])
+ # 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
+ row.names(prep_data) <- row_label_strings
+ colnames(prep_data) <- column_label_strings
plot <- try(ComplexHeatmap::Heatmap(
- prep.data,
+ prep_data,
name = unitlabel,
col = colors,
cluster_rows = cluster_rows,
@@ -617,40 +689,40 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
)
))
- #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/ height calculation
+ col_names_maxlength_label_width <- max(vapply(colnames(prep_data), FUN.VALUE = numeric(1), graphics::strwidth, units = "in", font = 12)) # longest column label when plotted in inches
+ col_names_maxlength_label_height <- max(vapply(colnames(prep_data), FUN.VALUE = numeric(1), graphics::strheight, units = "in", font = 12)) # highest column label when plotted in inches
+ row_names_maxlength_label_width <- max(vapply(rownames(prep_data), FUN.VALUE = numeric(1), graphics::strwidth, units = "in", font = 12)) # longest row label when plotted in inches
+ row_names_maxlength_label_height <- max(vapply(rownames(prep_data), FUN.VALUE = numeric(1), 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 (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
+ 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
+ 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)
+ 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
+ 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)
+ 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") {
+ if (height == "auto") {
height <- auto_height
}
- if(width == "auto") {
+ if (width == "auto") {
width <- auto_width
}
@@ -660,11 +732,11 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
# size exceeded?
exceed_size <- FALSE
- if(width > 500) {
+ if (width > 500) {
exceed_size <- TRUE
width <- 500
}
- if(height > 500) {
+ if (height > 500) {
exceed_size <- TRUE
height <- 500
}
@@ -681,7 +753,7 @@ create_heatmap <- function(data, unitlabel='auto', row.label=T, row.custom.label
#' @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 plot.type String specifying 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
@@ -703,38 +775,38 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# force evaluation of all arguments
# no promises in plot object
forceArgs()
- #grouping
- #group by factor if existing (fill with key if empty)
+ # 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)
+ 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)) {
+ # 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 <- data[, vapply(data, is.numeric, FUN.VALUE = logical(1)), with = FALSE]
data_cols <- names(data)
- data <- data.table::transpose(data) #switch columns <> rows
+ data <- data.table::transpose(data) # switch columns <> rows
- #place former colnames in cols
+ # 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
+ data.table::setcolorder(data, c("cols", colnames(data)[seq_len(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)
+ 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")
@@ -742,28 +814,28 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
###################
# Choose color palette
###################
- if (facet.target == "gene") { #facet = gene
+ if (facet.target == "gene") { # facet = gene
num_colors <- conditions
}
- if (facet.target == "condition") { #facet = condition
+ 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{
+ 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){
+ get.se <- function(y) {
se <- stats::sd(y) / sqrt(length(y))
mu <- mean(y)
- data.frame(ymin = mu-se, y = y, ymax = mu+se)
+ data.frame(ymin = mu - se, y = y, ymax = mu + se)
}
###################
@@ -773,20 +845,21 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# 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){
+ 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]]))
+ 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 <- 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
+ 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") {
@@ -795,24 +868,22 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
###################
# plot --------------------------------------------------------------------
-
- theme1 <- ggplot2::theme( #no gray background or helper lines
+ 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
+ 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.position = "none", # remove legend
legend.title = ggplot2::element_blank(),
axis.title.x = ggplot2::element_blank(),
text = ggplot2::element_text(family = "mono", size = 15 * scale)
-
- #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
+ # 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))
@@ -828,30 +899,30 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# 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 (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)
+ 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)
+ # 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")
+ 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 (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)
+ 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)
+ # 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")
+ matrixplot <- matrixplot + ggplot2::facet_wrap( ~ condition, nrow = rows, scales = "free_x")
}
}
@@ -859,26 +930,26 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# Further handle plot types
###################
- if (plot.type == "box") { #plot type: box
+ 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
+ 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
+ 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
+ # 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 == "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 + 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
@@ -887,100 +958,99 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# set y-axis ticks
y_ticks <- pretty(data[["value"]])
- if(length(data[["value"]]) != 1) {
- if(!is.null(ylimits)) {
+ 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)) {
+ 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"]]
+ # 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"]]
+ } 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
+ # dynamic plot in inches
+ # calculate cex for better strwidth calculation
ccex <- function(x){
- 2.3 - (x * log(1 + 1/x))
+ 2.3 - (x * log(1 + 1 / x))
}
- ###width estimation
+ ### width estimation
yaxis_label_height <- graphics::strheight(ylabel, units = "inches")
- if(length(data[["value"]]) == 1 && floor(data[["value"]]) == data[["value"]]) {
+ 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)
+ 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
+ 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)
+ auto_width <- 0.25 + yaxis_label_height + yaxis_tick_width + xaxis_tick_height + (legend_width + 0.5) * legend_columns
- ###height estimation
+ ### height estimation
plot_height <- 4
- #top margin to prevent legend cut off
+ # 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)
+ 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
+ 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)
+ } 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)
+ 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
+ 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)
+ # 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)
+ title_height <- max(graphics::strheight(title_names, units = "inches", cex = 2), na.rm = TRUE)
plot_height <- 2
@@ -992,10 +1062,10 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
auto_height <- auto_height * 2.54
# use greater/ automatic sizes
- if(width == "auto") {
+ if (width == "auto") {
width <- auto_width
}
- if(height == "auto") {
+ if (height == "auto") {
height <- auto_height
}
@@ -1005,17 +1075,17 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
# size exceeded?
exceed_size <- FALSE
- if(width > 500) {
+ if (width > 500) {
exceed_size <- TRUE
width <- 500
}
- if(height > 500) {
+ if (height > 500) {
exceed_size <- TRUE
height <- 500
}
# plotly ------------------------------------------------------------------
- if(plot.method == "interactive"){
+ if (plot.method == "interactive") {
matrixplotly <- plotly::ggplotly(
tooltip = "text",
matrixplot,
@@ -1036,18 +1106,18 @@ create_geneview <- function(data, grouping, plot.type = "line", facet.target = "
#' @param values Numeric vector or table
#'
#' @return Vector with c(min, max).
-equalize <- function(values){
- if(is.vector(values)){
+equalize <- function(values) {
+ if (is.vector(values)) {
min <- abs(min(values, na.rm = TRUE))
max <- abs(max(values, na.rm = TRUE))
- }else{
+ } 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){
+ if (min > max) {
result <- min
- }else{
+ } else {
result <- max
}
@@ -1064,49 +1134,49 @@ equalize <- function(values){
#'
#' @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)){
+ # 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.){
+ 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)){
+ if (is.na(x) | is.nan(x)) {
return(FALSE)
}
- #range
- if("inner" == options){
- if(x >= input[1] & x <= input[2]) return(TRUE)
+ # 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)
+ if ("outer" == options) {
+ if (x < input[1] | x > input[2]) return(TRUE)
}
return(FALSE)
})
- }else{
+ } else {
selection <- vapply(choices, FUN.VALUE = logical(1), function(x) {
# NA & NaN == FALSE
- if(is.na(x) | is.nan(x)){
+ 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)
+ 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)
@@ -1127,7 +1197,7 @@ searchData <- function(input, choices, options = c("=", "<", ">"), min. = min(ch
#' @param height in centimeter.
#' @param ppi pixel per inch. Defaults to 72.
#' @param save_plot Logical if plot object should be saved as .RData.
-#' @param ui List of user inputs. Will be converted to Javascript Object Notation. See \code{\link[RJSONIO]{toJSON}}
+#' @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, save_plot = TRUE, ui = NULL) {
@@ -1158,13 +1228,13 @@ download <- function(file, filename, plot, width, height, ppi = 72, save_plot =
# 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", useDingbats = FALSE)
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()
+ on.exit(setwd(wd)) # make sure working directory will be restored
setwd(tempdir())
plotly::export(p = plot, file = plot_file_pdf)
plotly::export(p = plot, file = plot_file_png)
@@ -1198,8 +1268,8 @@ download <- function(file, filename, plot, width, height, ppi = 72, save_plot =
if (save_plot) {
# create temp file name
plot_object_file <- tempfile(pattern = "plot_object", fileext = ".RData")
- ggplot2_version <- as.character(packageVersion("ggplot2"))
- plotly_version <- as.character(packageVersion("plotly"))
+ ggplot2_version <- as.character(utils::packageVersion("ggplot2"))
+ plotly_version <- as.character(utils::packageVersion("plotly"))
r_version <- R.Version()$version.string
save(plot, ggplot2_version, plotly_version, r_version, file = plot_object_file)
diff --git a/R/geneView.R b/R/geneView.R
index 6061fdc..72aead3 100644
--- a/R/geneView.R
+++ b/R/geneView.R
@@ -39,13 +39,14 @@ geneViewUI <- function(id, plot.columns = 3){
width = 3,
shiny::div(id = ns("guide_columnSelection"),
columnSelectorUI(ns("selector"), title = "Grouping:"),
+ labelUI(ns("group")),
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::selectInput(ns("plot_type"), 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")),
@@ -55,9 +56,9 @@ geneViewUI <- function(id, plot.columns = 3){
shiny::column(
width = 3,
shiny::div(id = ns("guide_color"),
- colorPicker2UI(id = ns("color"), show.transparency = FALSE, show.scaleoptions = FALSE)),
+ colorPickerUI(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::sliderInput(ns("plot_columns"), label = "Plot Columns", min = 1, max = 7, value = plot.columns, step = 1))
)
),
shiny::fluidRow(
@@ -83,18 +84,9 @@ geneViewUI <- function(id, plot.columns = 3){
#' @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 clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
#' @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 label.sep Separator 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.
@@ -106,32 +98,26 @@ geneViewUI <- function(id, plot.columns = 3){
#' @return Reactive containing data.table used for plotting.
#'
#' @export
+geneView <- function(input, output, session, clarion, plot.method = "static", label.sep = ", ", width = "auto", height = "auto", ppi = 72, scale = 1){
+ # globals/ initialization #####
+ clear_plot <- shiny::reactiveVal(FALSE)
+ # disable downloadButton on init
+ shinyjs::disable("download")
-geneView <- function(input, output, session, data, metadata, level = NULL, plot.method = "static", custom.label = NULL, label.sep = ", ", width = "auto", height = "auto", ppi = 72, scale = 1){
- #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
+ # input preparation #####
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion$clone(deep = TRUE)
}
})
+
# handle reactive sizes
size <- shiny::reactive({
width <- ifelse(shiny::is.reactive(width), width(), width)
@@ -139,13 +125,13 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi)
scale <- ifelse(shiny::is.reactive(scale), scale(), scale)
- if(!is.numeric(width) || width <= 0) {
+ if (!is.numeric(width) || width <= 0) {
width <- "auto"
}
- if(!is.numeric(height) || height <= 0) {
+ if (!is.numeric(height) || height <= 0) {
height <- "auto"
}
- if(!is.numeric(ppi) || ppi <= 0) {
+ if (!is.numeric(ppi) || ppi <= 0) {
ppi <- 72
}
@@ -155,49 +141,18 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
scale = scale)
})
- #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()))
- })
-
- # clear plot
- clearPlot <- shiny::reactiveVal(FALSE)
-
- # reset
- shiny::observeEvent(input$reset, {
- log_message("GeneView: reset", "INFO", token = session$token)
-
- 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]))
- clearPlot(TRUE)
- })
-
- 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)
- }
+ # modules/ ui #####
+ color <- shiny::callModule(colorPicker, "color", distribution = "all", selected = "Dark2")
+ transform <- shiny::callModule(transformation, "transform", shiny::reactive(as.matrix(object()$data[which(object()$data[[object()$get_name()]] %in% input$genes), selector$selected_columns(), with = FALSE])))
+ selector <- shiny::callModule(columnSelector, "selector", type.columns = shiny::reactive(object()$metadata[level != "feature", c("key", "level")]), column.type.label = "Select Columns")
+ custom_label <- shiny::callModule(label, "labeller", data = shiny::reactive(object()$data[which(object()$data[[object()$get_name()]] %in% input$genes)]), sep = label.sep)
+ factor_data <- shiny::callModule(label, "group", label = "Select grouping factors", data = shiny::reactive(object()$get_factors()[key %in% selector$selected_columns(), !"key"]), sep = label.sep, unique = FALSE)
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)
+ # only fetch needed data (calculation on server-side)
+ shiny::updateSelectizeInput(session, "genes", choices = unique(object()$data[[object()$get_name()]]), server = TRUE)
# colored if not has item
output <- shiny::div(class = "empty", output)
@@ -205,92 +160,84 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
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")
+ output$geneView <- shiny::renderUI({
+ if (plot.method == "interactive") {
+ shinycssloaders::withSpinner(plotly::plotlyOutput(session$ns("interactive")), proxy.height = "800px")
+ } else if (plot.method == "static") {
+ shinycssloaders::withSpinner(shiny::plotOutput(session$ns("static")), proxy.height = "800px")
}
})
- # 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")
- }
+ # functionality/ plotting #####
+ # reset
+ shiny::observeEvent(input$reset, {
+ log_message("GeneView: reset", "INFO", token = session$token)
+
+ shinyjs::reset("genes")
+ shinyjs::reset("plot_type")
+ shinyjs::reset("groupby")
+ shinyjs::reset("plot_columns")
+ color <<- shiny::callModule(colorPicker, "color", distribution = "all", selected = "Dark2")
+ transform <<- shiny::callModule(transformation, "transform", shiny::reactive(as.matrix(object()$data[which(object()$data[[object()$get_name()]] %in% input$genes), selector$selected_columns(), with = FALSE])))
+ selector <<- shiny::callModule(columnSelector, "selector", type.columns = shiny::reactive(object()$metadata[level != "feature", c("key", "level")]), column.type.label = "Select Columns")
+ custom_label <<- shiny::callModule(label, "labeller", data = shiny::reactive(object()$data[which(object()$data[[object()$get_name()]] %in% input$genes)]), sep = label.sep)
+ factor_data <<- shiny::callModule(label, "group", label = "Select grouping factors", data = shiny::reactive(object()$get_factors()[key %in% selector$selected_columns(), !"key"]), sep = label.sep, unique = FALSE)
+ limiter <<- shiny::callModule(limit, "limit", lower = shiny::reactive(get_limits()[1]), upper = shiny::reactive(get_limits()[2]))
+ clear_plot(TRUE)
})
- result.data <- shiny::eventReactive(input$plot, {
- result <- data.table::data.table(data.r()[, c(1, 2)], data.table::as.data.table(transform$data()))
+ get_limits <- shiny::reactive({
+ equalize(result_data()$data[, c(-1, -2)])
+ })
- # label selected?
- if(!is.null(custom.label)) {
- # drop not selected
- label <- custom_label()$label[which(result[[2]] %in% input$genes)]
- } else {
- label <- NULL
- }
+ result_data <- shiny::eventReactive(input$plot, {
+ columns <- switch((object()$get_id() == object()$get_name()) + 1,
+ c(object()$get_id(), object()$get_name()),
+ object()$get_id())
- result <- result[result[[2]] %in% input$genes]
+ result <- data.table::data.table(object()$data[which(object()$data[[object()$get_name()]] %in% input$genes), columns, with = FALSE], data.table::as.data.table(transform$data()))
+
+ label <- custom_label()$label
return(list(data = result, label = label))
})
- # disable downloadButton on init
- shinyjs::disable("download")
-
plot <- shiny::eventReactive(input$plot, {
log_message("GeneView: computing plot...", "INFO", token = session$token)
# enable downloadButton
shinyjs::enable("download")
- clearPlot(FALSE)
+ clear_plot(FALSE)
- #new progress indicator
+ # 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
+ # generate groups from selection
+ if (is.null(factor_data()$label)) {
+ factor <- ""
+ } else {
+ factor <- factor_data()$label
+ }
+ grouping <- data.table::data.table(object()$metadata[key %in% selector$selected_columns(), key], factor)
+
+ # plot
plot <- create_geneview(
- data = processed.data,
- grouping = metadata.r()[level == selector$type() & key %in% selector$selectedColumns(), c(1, 2)],
- plot.type = input$plotType,
+ data = if (object()$get_id() == object()$get_name()) result_data()$data else result_data()$data[, -2], # without name column
+ grouping = grouping,
+ plot.type = input$plot_type,
facet.target = input$groupby,
- facet.cols = input$plotColumns,
- colors = colorPicker()$palette,
+ facet.cols = input$plot_columns,
+ colors = color()$palette,
ylabel = input$label,
- gene.label = result.data()$label,
+ gene.label = result_data()$label,
ylimits = unlist(unname(limiter())),
plot.method = plot.method,
width = size()$width,
@@ -304,50 +251,15 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
return(plot)
})
- #enable plot button only if plot possible
- shiny::observe({
- if(is.null(input$genes) || !shiny::isTruthy(selector$selectedColumns())){
- 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"){
- shinycssloaders::withSpinner(plotly::plotlyOutput(session$ns("interactive")), proxy.height = "800px")
- }else if (plot.method == "static"){
- shinycssloaders::withSpinner(shiny::plotOutput(session$ns("static")), proxy.height = "800px")
- }
- })
-
- if(plot.method == "interactive") {
+ # render plot ######
+ if (plot.method == "interactive") {
output$interactive <- plotly::renderPlotly({
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("GeneView: render plot interactive", "INFO", token = session$token)
- #progress indicator
+ # progress indicator
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Rendering plot", value = 0)
@@ -358,17 +270,17 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
return(plot)
}
})
- } else if(plot.method == "static") {
+ } 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)),
{
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("GeneView: render plot static", "INFO", token = session$token)
- #progress indicator
+ # progress indicator
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Rendering plot", value = 0.3)
@@ -381,6 +293,7 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
})
}
+ # download #####
output$download <- shiny::downloadHandler(filename = "geneView.zip",
content = function(file) {
log_message("GeneView: download", "INFO", token = session$token)
@@ -393,46 +306,124 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
# format data
data <- list(
genes = input$genes,
- columns = list(type = selector$type(), selectedColumns = selector$selectedColumns()),
+ columns = list(type = selector$type(), selectedColumns = selector$selected_columns()),
+ group = factor_data()$selected,
groupby = input$groupby
)
# format options
- if(!is.null(custom.label)) {
- label <- custom_label()$selected
- } else {
- label <- NULL
- }
+ label <- custom_label()$selected
options <- list(
- plot_type = input$plotType,
+ plot_type = input$plot_type,
transformation = transform$method(),
yaxis_label = input$label,
yaxis_limit = limiter(),
- plot_column = input$plotColumns,
- colors = list(scheme = colorPicker()$name, reverse = colorPicker()$reverse),
+ plot_column = input$plot_columns,
+ colors = list(scheme = color()$name, reverse = color()$reverse),
custom_label = label
)
# merge all
- all <- list(data = data, options = options)
+ list(data = data, options = options)
})
- return(shiny::reactive(result.data()$data))
+ # notifications #####
+ # enable plot button only if plot possible
+ shiny::observe({
+ if (is.null(input$genes) || !shiny::isTruthy(selector$selected_columns())) {
+ shiny::removeNotification(session$ns("violin"))
+ shinyjs::disable("plot")
+ } else if (input$plot_type == "violin") {
+ factor_levels <- table(droplevels(as.factor(factor_data()$label), exclude = ""))
+
+ if (input$groupby == "condition") {
+ # every level >= 3 times
+ factor_levels <- ifelse(length(factor_levels) > 0, factor_levels, FALSE)
+ if (all(factor_levels >= 3)) {
+ shiny::removeNotification(session$ns("violin"))
+ shinyjs::enable("plot")
+ } else {
+ shiny::showNotification(
+ paste("Violin plot not feasible. Insufficient data. Please try a boxplot instead."),
+ duration = 5,
+ type = "warning",
+ id = session$ns("violin")
+ )
+ shinyjs::disable("plot")
+ }
+ } else if (input$groupby == "gene") {
+ # at least one level >= 3 times
+ if (any(factor_levels >= 3)) {
+ shiny::removeNotification(session$ns("violin"))
+ shinyjs::enable("plot")
+ } else {
+ shiny::showNotification(
+ paste("Violin plot not feasible. Insufficient data. Please try a boxplot instead."),
+ duration = 5,
+ type = "warning",
+ id = session$ns("violin")
+ )
+ shinyjs::disable("plot")
+ }
+ }
+ } else {
+ shiny::removeNotification(session$ns("violin"))
+ shinyjs::enable("plot")
+ }
+ })
+
+ # warning for heavy computation
+ 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 = session$ns("warning")
+ )
+ }else{
+ shiny::removeNotification(session$ns("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 = session$ns("limit"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("limit"))
+ }
+ })
+ # Fetch the reactive guide for this module
+ guide <- geneViewGuide(session)
+ shiny::observeEvent(input$guide, {
+ rintrojs::introjs(session, options = list(steps = guide()))
+ })
+
+ 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) {
+geneViewGuide <- function(session) {
steps <- list(
"guide_geneSelection" = "Gene selection
Select genes to be displayed.",
+ "guide_genelabel" = "Custom label
+ Select one or more columns to be used as a label instead of the names above.",
"guide_columnSelection" = "Column selection
First select a column type for visualization, then select individual columns from all columns of the chosen type.
+ Second select grouping factor(s). Condense the above selected columns to factor(s). 'None' will result in no grouping, multiple selection in a single merged factor.
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.",
@@ -451,11 +442,5 @@ geneViewGuide <- function(session, label = FALSE) {
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.R b/R/global.R
index d5ae871..75aea44 100644
--- a/R/global.R
+++ b/R/global.R
@@ -11,7 +11,7 @@ wilson.globals <- new.env(parent = emptyenv())
#'
#' @export
set_logger <- function(logger, token = NULL) {
- if(is.null(logger) || methods::is(logger, "logger")) {
+ if (is.null(logger) || methods::is(logger, "logger")) {
assign(x = paste0("logger", token), value = logger, envir = wilson.globals)
}
}
@@ -25,7 +25,7 @@ set_logger <- function(logger, token = NULL) {
#' @details Does nothing if logger doesn't exist.
#'
log_message <- function(message, level = c("DEBUG", "INFO", "WARN", "ERROR", "FATAL"), token = NULL) {
- if(exists(paste0("logger", token), envir = wilson.globals)) {
+ if (exists(paste0("logger", token), envir = wilson.globals)) {
logger <- get(paste0("logger", token), envir = wilson.globals)
switch(level,
diff --git a/R/global_cor_heatmap.R b/R/global_cor_heatmap.R
index 974ed50..77292d7 100644
--- a/R/global_cor_heatmap.R
+++ b/R/global_cor_heatmap.R
@@ -81,7 +81,7 @@ global_cor_heatmapUI <- function(id) {
choices = c("Sequential", "Diverging"),
multiple = FALSE
),
- colorPicker2UI(
+ colorPickerUI(
id = ns("color"),
show.transparency = FALSE
)
@@ -147,35 +147,37 @@ global_cor_heatmapUI <- function(id) {
#' @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 clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
#' @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.
#' @param scale Scale plot size. Defaults to 1, 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, scale = 1) {
+global_cor_heatmap <- function(input, output, session, clarion, plot.method = "static", width = "auto", height = "auto", ppi = 72, scale = 1) {
+ # globals -----------------------------------------------------------------
+ # clear plot
+ clear_plot <- shiny::reactiveVal(FALSE)
+ # disable downloadButton on init
+ shinyjs::disable("download")
+
# 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)
- }
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
- return(data)
+ clarion$clone(deep = TRUE)
+ }
})
+
# handle reactive sizes
size <- shiny::reactive({
width <- ifelse(shiny::is.reactive(width), width(), width)
@@ -183,17 +185,17 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi)
scale <- ifelse(shiny::is.reactive(scale), scale(), scale)
- if(!is.numeric(width) || width <= 0) {
+ if (!is.numeric(width) || width <= 0) {
width <- "auto"
}
- if(!is.numeric(height) || height <= 0) {
- if(plot.method == "interactive") {
+ if (!is.numeric(height) || height <= 0) {
+ if (plot.method == "interactive") {
height <- 28
- }else {
+ } else {
height <- "auto"
}
}
- if(!is.numeric(ppi) || ppi <= 0) {
+ if (!is.numeric(ppi) || ppi <= 0) {
ppi <- 72
}
@@ -204,25 +206,22 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
})
# 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])))
+ columns <- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])))
+ color <- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1])))
# load dynamic ui
- if(plot.method == "static") {
+ if (plot.method == "static") {
output$cor_heatmap <- shiny::renderUI({
shinycssloaders::withSpinner(shiny::plotOutput(outputId = session$ns("static")), proxy.height = "800px")
})
- }else if(plot.method == "interactive") {
+ } else if (plot.method == "interactive") {
output$cor_heatmap <- shiny::renderUI({
shinycssloaders::withSpinner(plotly::plotlyOutput(outputId = session$ns("interactive")), proxy.height = "800px")
})
}
# functionality -----------------------------------------------------------
- # clear plot
- clearPlot <- shiny::reactiveVal(FALSE)
-
# reset ui
shiny::observeEvent(input$reset, {
log_message("Global correlation heatmap: reset", "INFO", token = session$token)
@@ -235,22 +234,22 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
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])))
- clearPlot(TRUE)
+ columns <<- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])))
+ color <<- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1])))
+ clear_plot(TRUE)
})
# warning if plot size exceeds limits
shiny::observe({
- if(plot()$exceed_size) {
+ if (plot()$exceed_size) {
shiny::showNotification(
ui = "Width and/ or height exceed limit. Using 500 cm instead.",
- id = "limit",
+ id = session$ns("limit"),
type = "warning"
)
} else {
- shiny::removeNotification("limit")
+ shiny::removeNotification(session$ns("limit"))
}
})
@@ -262,22 +261,22 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
# show warning if not enough columns selected
shiny::observe({
- shiny::req(columns$selectedColumns())
+ shiny::req(columns$selected_columns())
- if(length(columns$selectedColumns()) < 2) {
+ if (length(columns$selected_columns()) < 2) {
shiny::showNotification(
ui = "Warning! At least two columns needed. Please select more.",
- id = "less_data_warning",
+ id = session$ns("less_data_warning"),
type = "warning"
)
} else {
- shiny::removeNotification("less_data_warning")
+ shiny::removeNotification(session$ns("less_data_warning"))
}
})
# enable/ disable plot button
shiny::observe({
- if(!shiny::isTruthy(columns$selectedColumns()) || length(columns$selectedColumns()) < 2) {
+ if (!shiny::isTruthy(columns$selected_columns()) || length(columns$selected_columns()) < 2) {
shinyjs::disable("plot")
}else {
shinyjs::enable("plot")
@@ -291,10 +290,10 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
# show right methods
shiny::observe({
- if(input$calc == "distance") {
+ if (input$calc == "distance") {
shiny::updateSelectInput(session = session, inputId = "calc_method",
choices = c("euclidean", "maximum", "manhattan", "canberra", "minkowski"))
- }else if(input$calc == "correlation") {
+ } else if (input$calc == "correlation") {
shiny::updateSelectInput(session = session, inputId = "calc_method", choices = c("spearman", "pearson", "kendall"))
}
})
@@ -307,16 +306,11 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
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")
+ if (input$calc == "distance") {
+ processed_data <- data.table::as.data.table(as.matrix(stats::dist(t(transform$data()), method = input$calc_method)), keep.rownames = "Names")
+ } else if (input$calc == "correlation") {
+ processed_data <- data.table::as.data.table(stats::cor(transform$data(), method = input$calc_method), keep.rownames = "Names")
}
# update progress indicator
@@ -325,9 +319,6 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
return(processed_data)
})
- # disable downloadButton on init
- shinyjs::disable("download")
-
# build plot object
plot <- shiny::eventReactive(input$plot, {
log_message("Global correlation heatmap: computing plot...", "INFO", token = session$token)
@@ -335,7 +326,7 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
# enable downloadButton
shinyjs::enable("download")
# show plot
- clearPlot(FALSE)
+ clear_plot(FALSE)
# progress indicator
progress <- shiny::Progress$new()
@@ -343,12 +334,12 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
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") {
+ 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") {
+ if (input$label == "rlog") {
unitlabel <- "log2"
shiny::updateTextInput(session = session, inputId = "label", value = unitlabel)
} else {
@@ -369,12 +360,12 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
clustering = "both",
clustdist = input$distance,
clustmethod = input$method,
- colors = colorPicker()$palette,
+ colors = color()$palette,
width = size()$width,
height = size()$height,
ppi = size()$ppi,
plot.method = plot.method,
- winsorize.colors = colorPicker()$winsorize,
+ winsorize.colors = color()$winsorize,
scale = size()$scale
)
@@ -386,12 +377,12 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
})
# render plot
- if(plot.method == "static") {
+ 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)),
{
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Global correlation heatmap: render plot static", "INFO", token = session$token)
@@ -412,9 +403,9 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
}
}
)
- }else if(plot.method == "interactive") {
+ } else if (plot.method == "interactive") {
output$interactive <- plotly::renderPlotly({
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Global correlation heatmap: render plot interactive", "INFO", token = session$token)
@@ -443,7 +434,7 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
user_input <- shiny::reactive({
# format selection
- selection <- list(type = columns$type(), selectedColumns = columns$selectedColumns())
+ selection <- list(type = columns$type(), selected_columns = columns$selected_columns())
# format calculation
calculation <- list(
@@ -460,14 +451,14 @@ global_cor_heatmap <- function(input, output, session, data, types, plot.method
# format options
options <- list(
transformation = transform$method(),
- color = list(distribution = input$distribution, scheme = colorPicker()$name, reverse = colorPicker()$reverse, winsorize = colorPicker()$winsorize),
+ color = list(distribution = input$distribution, scheme = color()$name, reverse = color()$reverse, winsorize = color()$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)
+ list(selection = selection, calculation = calculation, clustering = clustering, options = options)
})
# return plotting data
diff --git a/R/heatmap.R b/R/heatmap.R
index dccdacc..1f25ac4 100644
--- a/R/heatmap.R
+++ b/R/heatmap.R
@@ -34,13 +34,13 @@ heatmapUI <- function(id, row.label = TRUE) {
multiple = FALSE
),
shiny::selectInput(
- ns("cluster.distance"),
+ ns("cluster_distance"),
label = "Cluster distance",
choices = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "pearson", "spearman", "kendall"),
multiple = FALSE
),
shiny::selectInput(
- ns("cluster.method"),
+ ns("cluster_method"),
label = "Cluster method",
choices = c("average", "ward.D", "ward.D2", "single", "complete", "mcquitty"),
multiple = FALSE))
@@ -57,16 +57,16 @@ heatmapUI <- function(id, row.label = TRUE) {
choices = c("Sequential", "Diverging"),
multiple = FALSE
),
- colorPicker2UI(ns("color"), show.transparency = FALSE)
+ colorPickerUI(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),
+ 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::checkboxInput(ns("column_label"), label = "Column label", value = TRUE)
)
)
),
@@ -91,15 +91,9 @@ heatmapUI <- function(id, row.label = TRUE) {
#' @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 clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
#' @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 label.sep Separator 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.
@@ -108,19 +102,30 @@ heatmapUI <- function(id, row.label = TRUE) {
#' @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, scale = 1) {
+heatmap <- function(input, output, session, clarion, plot.method = "static", label.sep = ", ", width = "auto", height = "auto", ppi = 72, scale = 1) {
+ # globals/ initialization #####
# cluster limitation
static <- 11000
interactive <- 3000
+ # clear plot
+ clear_plot <- shiny::reactiveVal(FALSE)
+ # disable downloadButton on init
+ shinyjs::disable("download")
+
+ # input preparation #####
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
- #handle reactive data
- data.r <- shiny::reactive({
- if(shiny::is.reactive(data)){
- data <- data.table::copy(data())
- }else{
- data <- data.table::copy(data)
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion$clone(deep = TRUE)
}
})
+
# handle reactive sizes
size <- shiny::reactive({
width <- ifelse(shiny::is.reactive(width), width(), width)
@@ -128,17 +133,17 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi)
scale <- ifelse(shiny::is.reactive(scale), scale(), scale)
- if(!is.numeric(width) || width <= 0) {
+ if (!is.numeric(width) || width <= 0) {
width <- "auto"
}
- if(!is.numeric(height) || height <= 0) {
- if(plot.method == "interactive") {
+ if (!is.numeric(height) || height <= 0) {
+ if (plot.method == "interactive") {
height <- 28
- }else {
+ } else {
height <- "auto"
}
}
- if(!is.numeric(ppi) || ppi <= 0) {
+ if (!is.numeric(ppi) || ppi <= 0) {
ppi <- 72
}
@@ -148,150 +153,77 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
scale = scale)
})
- # 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())
+ # modules/ ui #####
+ columns <- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])))
+ color <- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(transform$data())))
+ custom_label <- shiny::callModule(label, "labeller", data = shiny::reactive(object()$data), label = "Select row label", sep = label.sep, disable = shiny::reactive(!input$row_label))
- if(shiny::isTruthy(columns$selectedColumns())){
- 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
+ # automatic unitlabel
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")
- }
+ shiny::updateTextInput(session = session, inputId = "label", value = transform$method())
})
- # clear plot
- clearPlot <- shiny::reactiveVal(FALSE)
-
+ # functionality/ plotting #####
# reset ui
shiny::observeEvent(input$reset, {
log_message("Heatmap: reset", "INFO", token = session$token)
- shinyjs::reset("cluster.distance")
- shinyjs::reset("cluster.method")
+ 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))
- }
- clearPlot(TRUE)
+ shinyjs::reset("row_label")
+ shinyjs::reset("column_label")
+ columns <<- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])))
+ color <<- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(transform$data())))
+ custom_label <<- shiny::callModule(label, "labeller", data = shiny::reactive(object()$data), label = "Select row label", sep = label.sep, disable = shiny::reactive(!input$row_label))
+ clear_plot(TRUE)
})
- 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
+ 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)
+ processed_data <- data.table::data.table(object()$data[, object()$get_id(), with = FALSE], transform$data())
progress$set(1)
return(processed_data)
})
- # disable downloadButton on init
- shinyjs::disable("download")
-
plot <- shiny::eventReactive(input$plot, {
log_message("Heatmap: computing plot...", "INFO", token = session$token)
# enable downloadButton
shinyjs::enable("download")
- clearPlot(FALSE)
+ clear_plot(FALSE)
- #new progress indicator
+ # 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(),
+ data = result_data(),
unitlabel = input$label,
- row.label = input$row.label,
- row.custom.label = label,
- column.label = input$column.label,
+ row.label = input$row_label,
+ row.custom.label = 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,
+ clustdist = input$cluster_distance,
+ clustmethod = input$cluster_method,
+ colors = color()$palette,
width = size()$width,
height = size()$height,
ppi = size()$ppi,
scale = size()$scale,
plot.method = plot.method,
- winsorize.colors = colorPicker()$winsorize
+ winsorize.colors = color()$winsorize
)
progress$set(1)
@@ -300,19 +232,19 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
return(plot)
})
- #render choosen plotUI
- if(plot.method == "interactive"){
+ # render plot #####
+ if (plot.method == "interactive") {
output$heatmap <- shiny::renderUI({
shinycssloaders::withSpinner(plotly::plotlyOutput(session$ns("interactive")), proxy.height = "800px")
})
output$interactive <- plotly::renderPlotly({
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Heatmap: render plot interactive", "INFO", token = session$token)
- #new progress indicator
+ # new progress indicator
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(0.2, message = "Render plot")
@@ -324,7 +256,7 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
return(plot)
}
})
- }else{
+ } else {
output$heatmap <- shiny::renderUI({
shinycssloaders::withSpinner(shiny::plotOutput(session$ns("static")), proxy.height = "800px")
})
@@ -333,12 +265,12 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
width = shiny::reactive(plot()$width * (plot()$ppi / 2.54)),
height = shiny::reactive(plot()$height * (plot()$ppi / 2.54)),
{
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Heatmap: render plot static", "INFO", token = session$token)
- #new progress indicator
+ # new progress indicator
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(0.2, message = "Render plot")
@@ -346,7 +278,7 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
plot <- plot()$plot
# handle error
- if(methods::is(plot, "try-error")) {
+ if (methods::is(plot, "try-error")) {
# TODO add logging
stop("An error occured! Please try a different dataset.")
}
@@ -357,6 +289,8 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
})
}
+
+ # download #####
output$download <- shiny::downloadHandler(filename = "heatmap.zip",
content = function(file) {
log_message("Heatmap: download", "INFO", token = session$token)
@@ -364,32 +298,32 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
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())
+ selection <- list(type = columns$type(), selectedColumns = columns$selected_columns())
# format clustering
clustering <- list(
clustering = input$clustering,
- distance = input$cluster.distance,
- method = input$cluster.method
+ 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),
+ color = list(distribution = input$distribution, scheme = color()$name, reverse = color()$reverse, winsorize = color()$winsorize),
unit_label = input$label,
- row_label = input$row.label,
+ row_label = input$row_label,
custom_row_label = custom_label()$selected,
- column_label = input$column.label
+ column_label = input$column_label
)
# merge all
- all <- list(selection = selection, clustering = clustering, options = options)
+ list(selection = selection, clustering = clustering, options = options)
})
+ # notifications #####
# enable/ disable plot button
# show warning if disabled
shiny::observe({
@@ -397,58 +331,109 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
show_warning <- TRUE
# are columns selected?
- if(shiny::isTruthy(columns$selectedColumns())) {
- row.num <- nrow(shiny::isolate(data.r()))
- col.num <- length(columns$selectedColumns())
+ if (shiny::isTruthy(columns$selected_columns())) {
+ row_num <- nrow(shiny::isolate(object()$data))
+ col_num <- length(columns$selected_columns())
# minimal heatmap possible (greater 1x1)?
- if(row.num > 1 || col.num > 1) {
+ if (row_num > 1 || col_num > 1) {
# no clustering for single rows or columns
- if(row.num == 1 && !is.element(input$clustering, c("both", "row"))) {
+ if (row_num == 1 && !is.element(input$clustering, c("both", "row"))) {
show_warning <- FALSE
shinyjs::enable("plot")
- } else if(col.num == 1 && !is.element(input$clustering, c("both", "column"))) {
+ } else if (col_num == 1 && !is.element(input$clustering, c("both", "column"))) {
show_warning <- FALSE
shinyjs::enable("plot")
- } else if(row.num > 1 && col.num > 1) { # no border case heatmaps
+ } else if (row_num > 1 && col_num > 1) { # no border case heatmaps
show_warning <- FALSE
shinyjs::enable("plot")
}
}
- if(show_warning) {
+ if (show_warning) {
shiny::showNotification(
ui = "Warning! Insufficient columns/ rows. Either disable the respective clustering or expand the dataset.",
- id = "insuf_data",
+ id = session$ns("insuf_data"),
type = "warning"
)
} else {
- shiny::removeNotification("insuf_data")
+ shiny::removeNotification(session$ns("insuf_data"))
}
# maximum heatmap reached?
- if(plot.method == "static" && row.num > static || plot.method == "interactive" && row.num > interactive) {
+ if (plot.method == "static" && row_num > static || plot.method == "interactive" && row_num > interactive) {
shinyjs::disable("plot")
}
}
})
- # automatic unitlabel
+ # cluster limitation
shiny::observe({
- shiny::updateTextInput(session = session, inputId = "label", value = transform$method())
+ shiny::req(object())
+
+ if (shiny::isTruthy(columns$selected_columns())) {
+ if (input$clustering != "none") { # clustering
+ if (plot.method == "static" && nrow(object()$data) > 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")
+ )
+ } else if (plot.method == "interactive" && nrow(object()$data) > 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")
+ )
+ } else {
+ shiny::removeNotification(session$ns("notification"))
+ }
+ } else if (nrow(object()$data) > 200) { # computation warning
+ shiny::showNotification(
+ paste("Caution! You selected", nrow(object()$data), "genes. This will take a while to compute."),
+ duration = 5,
+ type = "warning",
+ id = session$ns("notification")
+ )
+ } 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 = session$ns("limit"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("limit"))
+ }
})
- return(result.data)
+ # Fetch the reactive guide for this module
+ guide <- heatmapGuide(session)
+ shiny::observeEvent(input$guide, {
+ rintrojs::introjs(session, options = list(steps = guide()))
+ })
+
+ 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) {
+heatmapGuide <- function(session) {
steps <- list(
"guide_selection" = "Data selection
Select a column type for visualization, then select individual columns based on the chosen type.",
@@ -462,14 +447,11 @@ heatmapGuide <- function(session, custom.row.label = FALSE) {
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.",
+ You can set a label for the color legend that describes the underlying data unit. Furthermore, you can enable/disable row and column labels.
+ Use the input to generate custom row-labels. The selected columns will be merged and used as label.",
"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
index 64817e3..6709dab 100644
--- a/R/label.R
+++ b/R/label.R
@@ -21,9 +21,9 @@ labelUI <- function(id){
#' @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 sep Separator 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 unique_sep Separator 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).
@@ -31,8 +31,8 @@ labelUI <- function(id){
#' @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_r <- shiny::reactive({
+ if (shiny::is.reactive(data)) {
data()
} else {
data
@@ -41,13 +41,13 @@ label <- function(input, output, session, data, label = "Select label columns",
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"))
+ 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)) {
+ if (!is.null(disable)) {
shiny::observe({
- if(disable()) {
+ if (disable()) {
shinyjs::disable("label_creator")
} else {
shinyjs::enable("label_creator")
@@ -56,13 +56,13 @@ label <- function(input, output, session, data, label = "Select label columns",
}
shiny::reactive({
- if(!shiny::isTruthy(input$label_creator) || !is.null(disable) && disable()) return(NULL)
+ 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]
+ custom_label <- data_r()[, do.call(paste, c(... = .SD, sep = sep)), .SDcols = input$label_creator]
# make unique labels
- if(unique) {
+ if (unique) {
custom_label <- make.unique(custom_label, sep = unique_sep)
}
diff --git a/R/limit.R b/R/limit.R
index e7499f7..5dac9c6 100644
--- a/R/limit.R
+++ b/R/limit.R
@@ -11,8 +11,8 @@ limitUI <- function(id, label = "Limit"){
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))
+ shiny::fluidRow(shiny::column(shiny::numericInput(ns("lower_limit"), label = "Lower limit", value = -2), width = 6),
+ shiny::column(shiny::numericInput(ns("upper_limit"), label = "Upper limit", value = 2), width = 6))
)
}
@@ -30,20 +30,20 @@ limitUI <- function(id, label = "Limit"){
limit <- function(input, output, session, lower = NULL, upper = NULL){
# reset on re-run
shinyjs::reset("enable")
- shinyjs::reset("lowerLimit")
- shinyjs::reset("upperLimit")
+ shinyjs::reset("lower_limit")
+ shinyjs::reset("upper_limit")
# evaluate reactive parameter
- lower.r <- shiny::reactive({
- if(shiny::is.reactive(lower)) {
+ lower_r <- shiny::reactive({
+ if (shiny::is.reactive(lower)) {
lower()
} else {
lower
}
})
- upper.r <- shiny::reactive({
- if(shiny::is.reactive(upper)) {
+ upper_r <- shiny::reactive({
+ if (shiny::is.reactive(upper)) {
upper()
} else {
upper
@@ -52,42 +52,42 @@ limit <- function(input, output, session, lower = NULL, upper = NULL){
# update ui
shiny::observe({
- if(!is.null(input$enable) && input$enable) {
- shiny::isolate(shiny::updateNumericInput(session = session, inputId = "lowerLimit", value = lower.r()))
+ if (!is.null(input$enable) && input$enable) {
+ shiny::isolate(shiny::updateNumericInput(session = session, inputId = "lower_limit", value = lower_r()))
}
})
shiny::observe({
- if(!is.null(input$enable) && input$enable) {
- shiny::isolate(shiny::updateNumericInput(session = session, inputId = "upperLimit", value = upper.r()))
+ if (!is.null(input$enable) && input$enable) {
+ shiny::isolate(shiny::updateNumericInput(session = session, inputId = "upper_limit", value = upper_r()))
}
})
shiny::observe({
# lowerLimit = smaller than upper
- shiny::updateNumericInput(session = session, inputId = "lowerLimit", max = input$upperLimit - 1)
+ shiny::updateNumericInput(session = session, inputId = "lower_limit", max = input$upper_limit - 1)
# upperLimit = greater than lower
- shiny::updateNumericInput(session = session, inputId = "upperLimit", min = input$lowerLimit + 1)
+ shiny::updateNumericInput(session = session, inputId = "upper_limit", min = input$lower_limit + 1)
})
# enable ui if checkbox checked
shiny::observeEvent(input$enable, {
- if(input$enable) {
- shinyjs::enable("lowerLimit")
- shinyjs::enable("upperLimit")
+ if (input$enable) {
+ shinyjs::enable("lower_limit")
+ shinyjs::enable("upper_limit")
} else {
- shinyjs::disable("lowerLimit")
- shinyjs::disable("upperLimit")
+ shinyjs::disable("lower_limit")
+ shinyjs::disable("upper_limit")
}
})
# return values
shiny::reactive({
- if(!is.null(input$enable) && !input$enable) {
+ if (!is.null(input$enable) && !input$enable) {
NULL
} else {
- list(lower = input$lowerLimit,
- upper = input$upperLimit)
+ list(lower = input$lower_limit,
+ upper = input$upper_limit)
}
})
}
diff --git a/R/marker.R b/R/marker.R
index 359c332..7199a99 100644
--- a/R/marker.R
+++ b/R/marker.R
@@ -11,7 +11,7 @@ markerUI <- function(id, label = "Highlight/ Label Selected Features"){
shiny::tagList(
shiny::selectInput(ns("highlight"), label = label, choices = c("Disabled", "Highlight", "Exclusive")),
- colorPicker2UI(ns("color"), label = "Color", custom = TRUE),
+ colorPickerUI(ns("color"), label = "Color", custom = TRUE),
labelUI(ns("label"))
)
@@ -22,26 +22,37 @@ markerUI <- function(id, label = "Highlight/ Label Selected Features"){
#' @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).
+#' @param clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
#'
-#' @return A reactive which contains a named list (highlight, color, labelColumn, label).
+#' @return A named list containing reactives (highlight, color, labelColumn, label, clarion).
#'
#' @export
-marker <- function(input, output, session, highlight.labels){
- highlight.labels.r <- shiny::reactive({
- if(shiny::is.reactive(highlight.labels)){
- highlight.labels()
- }else{
- highlight.labels
+marker <- function(input, output, session, clarion){
+ # input preparation #####
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion()
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion
}
})
- 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)
+ # modules #####
+ color <- shiny::callModule(colorPicker, "color")
+ labeller <- shiny::callModule(label, "label", data = shiny::reactive(object()$data), unique = FALSE)
- list(highlight = input$highlight, color = color()$palette, labelColumn = labeller()$selected, label = labeller()$label)
- })
+ return(
+ list(
+ highlight = shiny::reactive(input$highlight),
+ color = shiny::reactive(color()$palette),
+ label_column = shiny::reactive(labeller()$selected),
+ label = shiny::reactive(labeller()$label),
+ clarion = object
+ )
+ )
}
diff --git a/R/orNumeric.R b/R/orNumeric.R
index a2df084..e430787 100644
--- a/R/orNumeric.R
+++ b/R/orNumeric.R
@@ -43,33 +43,33 @@ orNumericUI <- function(id){
#' @return Returns a reactive containing a named list with the label, the selected choices as a character vector (text), a boolean vector of length \code{length(choices)} (bool), and a vector of the selected value(s) (value), 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)) {
+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_r <- shiny::reactive({
+ if (shiny::is.reactive(value)) {
value()
} else {
value
}
})
- min.r <- shiny::reactive({
- if(shiny::is.reactive(min.)) {
+ min_r <- shiny::reactive({
+ if (shiny::is.reactive(min.)) {
min.()
} else {
min.
}
})
- max.r <- shiny::reactive({
- if(shiny::is.reactive(max.)) {
+ max_r <- shiny::reactive({
+ if (shiny::is.reactive(max.)) {
max.()
} else {
max.
@@ -81,10 +81,10 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
})
output$options <- shiny::renderUI({
- if(shiny::isolate(length(value.r()) > 1)){
+ if (shiny::isolate(length(value_r()) > 1)) {
shiny::radioButtons(inputId = session$ns("options"), label = NULL, inline = FALSE,
choices = list("inner", "outer"))
- }else{
+ } else {
shiny::selectInput(inputId = session$ns("options"), label = NULL,
choices = c("=", "<", ">"),
selected = NULL,
@@ -95,98 +95,98 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
# change css classes so slider visually matches options
shiny::observe({
# change css classes if slider is re-rendered
- min.r()
- max.r()
+ min_r()
+ max_r()
- if(length(value.r()) > 1){
+ if (length(value_r()) > 1) {
shiny::req(input$options)
- if(input$options == "inner") {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('outer')"))
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('inner')"))
- } else if(input$options == "outer") {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('inner')"))
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('outer')"))
+ if (input$options == "inner") {
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('outer')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('inner')"))
+ } else if (input$options == "outer") {
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('inner')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('outer')"))
}
} else {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('empty')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('empty')"))
- if(shiny::isTruthy(input$options)) {
- if(any(input$options == ">")) {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('greater')"))
+ if (shiny::isTruthy(input$options)) {
+ if (any(input$options == ">")) {
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('greater')"))
} else {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('greater')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('greater')"))
}
- if(any(input$options == "=")) {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('equal')"))
+ if (any(input$options == "=")) {
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('equal')"))
} else {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('equal')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('equal')"))
}
- if(any(input$options == "<")) {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').addClass('less')"))
+ if (any(input$options == "<")) {
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').addClass('less')"))
} else {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('less')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('less')"))
}
} else {
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('greater')"))
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('equal')"))
- shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"),"')).find('span').removeClass('less')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('greater')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('equal')"))
+ shinyjs::runjs(paste0("$(document.getElementById('", session$ns("slider"), "')).find('span').removeClass('less')"))
}
}
})
output$slider <- shiny::renderUI({
- min. <- min.r()
- max. <- max.r()
- value <- value.r()
+ 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%")),
+ if (zoomable) shiny::column(width = 3, shiny::numericInput(session$ns("min_val"), 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%"))
+ if (zoomable) shiny::column(width = 3, shiny::numericInput(session$ns("max_val"), min = min., max = max., value = max., label = NULL, width = "100%"))
)
)
return(out)
})
- if(shiny::is.reactive(reset)) {
+ if (shiny::is.reactive(reset)) {
shiny::observeEvent(reset(), {
# require rendered UI
shiny::req(input$slider)
- shinyjs::reset("minVal")
- shinyjs::reset("maxVal")
+ shinyjs::reset("min_val")
+ shinyjs::reset("max_val")
shinyjs::reset("options")
- min. <- min.r()
- max. <- max.r()
- value <- value.r()
+ 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
+ if (zoomable) {
+ # zoomable slider
shiny::observe({
- shiny::req(input$minVal, input$maxVal)
+ shiny::req(input$min_val, input$max_val)
- 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)
+ interval <- ifelse(is.null(stepsize), abs(input$min_val - input$max_val) / step, stepsize)
+ shiny::updateSliderInput(session, inputId = "slider", min = input$min_val, max = input$max_val, step = interval)
})
- #only useful values
+ # only useful values
shiny::observe({
- shiny::req(input$minVal, input$maxVal)
+ shiny::req(input$min_val, input$max_val)
- shiny::updateNumericInput(session, inputId = "minVal", max = input$maxVal)
- shiny::updateNumericInput(session, inputId = "maxVal", min = input$minVal)
+ shiny::updateNumericInput(session, inputId = "min_val", max = input$max_val)
+ shiny::updateNumericInput(session, inputId = "max_val", min = input$min_val)
})
}
@@ -194,27 +194,27 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
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::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
+ 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
+ # 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){
+ 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%")))
+ if (length(value_r()) > 1) content <- shiny::tagList(content, shiny::div(shiny::img(src = path, width = "90%")))
}
shiny::showModal(
@@ -229,23 +229,23 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
})
selected <- shiny::reactive({
- searchData(input = input$slider, choices = choices.r(), options = input$options, min. = min.r(), max. = max.r())
+ searchData(input = input$slider, choices = choices_r(), options = input$options, min. = min_r(), max. = max_r())
})
out <- shiny::reactive({
- value <- value.r()
+ 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")) {
+ 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)){
+ if (shiny::isTruthy(input$options)) {
text <- paste(paste(input$options, collapse = " "), input$slider)
}
}
diff --git a/R/orTextual.R b/R/orTextual.R
index a51e073..c070544 100644
--- a/R/orTextual.R
+++ b/R/orTextual.R
@@ -37,10 +37,10 @@ orTextualUI <- function(id){
#'
#' @export
orTextual <- function(input, output, session, choices, selected = NULL, label = "Column", delimiter = NULL, multiple = TRUE, contains = FALSE, reset = NULL){
- raw.choices <- choices
+ raw_choices <- choices
- #delimit choices
- if(!is.null(delimiter) & contains == FALSE){
+ # delimit choices
+ if (!is.null(delimiter) & contains == FALSE) {
choices <- unlist(strsplit(choices, split = delimiter, fixed = TRUE))
}
@@ -49,11 +49,11 @@ orTextual <- function(input, output, session, choices, selected = NULL, label =
})
output$select <- shiny::renderUI({
- if(contains){
+ if (contains) {
ui <- shiny::textInput(session$ns("column"), label = NULL)
- }else{
+ } else {
ui <- shiny::selectizeInput(session$ns("column"), label = NULL, choices = NULL, multiple = multiple, selected = NULL)
- #only fetch needed data (calculation on server-side)
+ # only fetch needed data (calculation on server-side)
shiny::updateSelectizeInput(session, "column", choices = unique(choices), selected = selected, server = TRUE)
}
@@ -62,28 +62,28 @@ orTextual <- function(input, output, session, choices, selected = NULL, label =
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;}"),
+ # 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)) {
+ if (shiny::is.reactive(reset)) {
shiny::observeEvent(reset(), {
- if(is.null(selected)){
+ if (is.null(selected)) {
shinyjs::reset("column")
- }else{
+ } else {
shiny::updateSelectizeInput(session, "column", selected = selected)
}
})
}
- #show right info
+ # show right info
shiny::observeEvent(input$infobutton, {
- if(contains){
+ if (contains) {
title <- "Textsearch"
content <- shiny::HTML("Enter some text which will be used for textsearch.")
- }else{
+ } else {
title <- "Text"
content <- shiny::HTML("Select one or multiple values to filter.")
}
@@ -98,27 +98,27 @@ orTextual <- function(input, output, session, choices, selected = NULL, label =
)
})
- selected.choices <- shiny::reactive({
- if(!is.null(input$column)){
- #escape all regex symbols
- esc.choices <- paste0("\\Q", input$column, "\\E")
+ 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)
+ 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)){
+ # 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)))
+ } else {
+ return(!logical(length = length(raw_choices)))
}
})
- return(shiny::reactive(list(label = label, bool = selected.choices(), text = input$column)))
+ return(shiny::reactive(list(label = label, bool = selected_choices(), text = input$column)))
}
diff --git a/R/parser.R b/R/parser.R
index dbde275..9827548 100644
--- a/R/parser.R
+++ b/R/parser.R
@@ -11,7 +11,7 @@
#' 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.
+#' Anything else like 'Intensity;ex' or 'Intensity;' 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
@@ -27,24 +27,24 @@
#'
#' @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)){
+ if (missing(proteinGroups_in)) {
stop("The proteinGroups file was not given")
}
- if(missing(summary_in)){
+ if (missing(summary_in)) {
stop("The summary file was not given")
}
- if(missing(outfile)){
+ if (missing(outfile)) {
stop("The output file was not given")
}
- if(missing(outfile_reduced)){
+ 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){
+ 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,
@@ -52,7 +52,7 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
"sublabel" = r$sublabel
)
})
- meta <- do.call('rbind', dr)
+ do.call("rbind", dr)
}
@@ -63,38 +63,37 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
# @param scores,ratios,category,ary vectors with Strings
# @return String type of given column
- get_sample_type <- function(name, scores, ratios, prob, category, ary){
+ 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 (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") }
+ 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_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") }
+ 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") }
+ 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")
}
@@ -103,15 +102,15 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
# 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){
+ 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 = ' ')
+ 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 = ' ')
+ label <- paste(utils::head(col_head_split[[1]], -1), collapse = " ")
sublabel <- col_head_split[[1]][length(col_head_split[[1]])]
}
return(list(label, sublabel))
@@ -126,26 +125,26 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
# @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){
+ 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){
+ 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)
+ 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,"[%]")
+ 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]))
+ 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)
@@ -155,7 +154,7 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
}))
overlap <- setdiff(red_exp_list, col_names)
red_exp_list <- red_exp_list[!(red_exp_list %in% overlap)]
- return(list(red_exp_list,overlap))
+ return(list(red_exp_list, overlap))
}
@@ -167,32 +166,32 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
# @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
+ 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(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
+ 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)
+ 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='')
+ 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]))
+ exp_names <- (unique(summary_file[Experiment != "", Experiment]))
meta <- get_meta_from_config(meta_config = meta_config)
@@ -213,36 +212,36 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
# get metadata for each sample column
# append rows to data table with metadata
- samples_list <- lapply(col_names, function(col_head){
+ 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)),
+ 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"))
+ "sublabel" = c(trimws(gsub(name_brackets, "", col_head), "r"))
)
return(de)
}
}))
})
- samples <- do.call('rbind', Filter(Negate(is.null), samples_list))
+ 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"]])){
+ 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)),
+ 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]),
@@ -251,40 +250,40 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
return(de2)
}
})
- remaining <- do.call('rbind', Filter(Negate(is.null), remaining_list))
+ 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)
+ 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,
+ 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]]),]
+ 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=", "))
+ 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=", "))
+ 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)
+ version = version, exp_id = experiment_id, pGroups = proteinGroups, delimiter = delimiter)
- #writing reduced CLARION file
+ # 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)
}
@@ -294,7 +293,7 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
#' @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)
+#' @return Clarion object. See \code{\link[wilson]{Clarion}}
#'
#' @import data.table
#'
@@ -302,19 +301,19 @@ parse_MaxQuant <- function(proteinGroups_in, summary_in, outfile, outfile_reduce
parser <- function(file, dec = ".") {
message(paste("Parsing file:", file))
- #number of rows for each part
+ # number of rows for each part
con <- file(file, open = "r")
- num.header <- 0
- num.metadata <- 0
+ num_header <- 0
+ num_metadata <- 0
tryCatch(expr = {
- while(TRUE) {
+ while (TRUE) {
line <- readLines(con = con, n = 1)
- if(grepl("^!", line, perl = TRUE)) {
- num.header <- num.header + 1
- } else if(grepl("^#", line, perl = TRUE)) {
- num.metadata <- num.metadata + 1
+ if (grepl("^!", line, perl = TRUE)) {
+ num_header <- num_header + 1
+ } else if (grepl("^#", line, perl = TRUE)) {
+ num_metadata <- num_metadata + 1
} else {
break
}
@@ -323,117 +322,41 @@ parser <- function(file, dec = ".") {
close(con = con)
})
- ###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
- # remove quotes from delimiter
- if (!is.null(header$delimiter) && grepl(header$delimiter, pattern = '^".*"$', perl = TRUE)) {
- header$delimiter <- substr(header$delimiter, start = 2, stop = nchar(header$delimiter) - 1)
+ ### parse header
+ if (num_header > 0) {
+ 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
+ # remove quotes from delimiter
+ if (!is.null(header$delimiter) && grepl(header$delimiter, pattern = '^".*"$', perl = TRUE)) {
+ header$delimiter <- substr(header$delimiter, start = 2, stop = nchar(header$delimiter) - 1)
+ }
+ } else {
+ header <- NULL
}
- ###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 #
+ ### 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
+ # 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
+ # 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."))
- }
+ ### parse data
+ data <- data.table::fread(input = file, header = TRUE, skip = num_header + num_metadata, fill = FALSE, dec = dec, integer64 = "double")
data.table::setindexv(metadata, names(metadata)[1])
data.table::setindexv(data, names(data)[1])
- return(list(header = header, metadata = metadata, data = data))
+ return(Clarion$new(header = header, metadata = metadata, data = data))
}
-
diff --git a/R/pca.R b/R/pca.R
index 8d4d166..edca112 100644
--- a/R/pca.R
+++ b/R/pca.R
@@ -33,15 +33,22 @@ pcaUI <- function(id, show.label = TRUE) {
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::numericInput(ns("dim_a"), label = "PCA dimension (x-axis)", min = 1, max = 6, step = 1, value = 1),
+ shiny::numericInput(ns("dim_b"), label = "PCA dimension (y-axis)", min = 1, max = 6, step = 1, value = 2)
+ ),
+ shiny::div(id = ns("guide_grouping"),
+ labelUI(ns("group")),
+ labelUI(ns("group2"))
)
),
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("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::div(id = ns("guide_color"),
+ colorPickerUI(id = ns("colorPicker"), show.scaleoptions = FALSE, show.transparency = FALSE)
)
)
),
@@ -66,14 +73,7 @@ pcaUI <- function(id, show.label = TRUE) {
#' @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 clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
#' @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.
@@ -86,38 +86,26 @@ pcaUI <- function(id, show.label = TRUE) {
#' @import data.table
#'
#' @export
-pca <- function(input, output, session, data, types, levels = NULL, entryLabel = NULL, width = 28, height = 28, ppi = 72, scale = 1) {
- #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 = ", ")
- }
+pca <- function(input, output, session, clarion, width = 28, height = 28, ppi = 72, scale = 1) {
+ # globals/ initialization #####
+ # clear plot
+ clear_plot <- shiny::reactiveVal(value = FALSE)
+ # disable downloadButton on init
+ shinyjs::disable("download")
+ # disable plot button on init
+ shinyjs::disable("plot")
- return(data)
- })
- types.r <- shiny::reactive({
- if(shiny::is.reactive(types)){
- types()
- }else{
- types
- }
- })
- levels.r <- shiny::reactive({
- if(is.null(levels)){
- types.r()[["level"]]
- }else{
- if(shiny::is.reactive(levels)){
- levels()
- }else{
- levels
- }
+ # input preparation #####
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion$clone(deep = TRUE)
}
})
@@ -128,13 +116,13 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi)
scale <- ifelse(shiny::is.reactive(scale), scale(), scale)
- if(!is.numeric(width) | width <= 0) {
+ if (!is.numeric(width) | width <= 0) {
width <- 28
}
- if(!is.numeric(height) | height <= 0) {
+ if (!is.numeric(height) | height <= 0) {
height <- 28
}
- if(!is.numeric(ppi) | ppi <= 0) {
+ if (!is.numeric(ppi) | ppi <= 0) {
ppi <- 72
}
@@ -144,103 +132,61 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
scale = scale)
})
+ # modules/ ui #####
+ columns <- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ factor_data <- shiny::callModule(label, "group", label = "Select color grouping factors", data = shiny::reactive(object()$get_factors()[key %in% columns$selected_columns(), !"key"]), unique = FALSE)
+ factor_data2 <- shiny::callModule(label, "group2", label = "Select shape grouping factors", data = shiny::reactive(object()$get_factors()[key %in% columns$selected_columns(), !"key"]), unique = FALSE)
+ color <- shiny::callModule(colorPicker, "colorPicker", distribution = "categorical", selected = "Dark2")
- guide <- pcaGuide(session)
- shiny::observeEvent(input$guide, {
- rintrojs::introjs(session, options = list(steps = guide()))
- })
+ # update dimension inputs
+ shiny::observe({
+ col_num <- length(shiny::req(columns$selected_columns()))
- # clear plot
- clearPlot <- shiny::reactiveVal(value = FALSE)
+ if (col_num >= 3) {
+ value_a <- ifelse(col_num <= input$dim_a, col_num - 1, input$dim_a)
+ value_b <- ifelse(col_num <= input$dim_b, col_num - 1, input$dim_b)
- #reset ui
+ shiny::updateNumericInput(session = session, inputId = "dim_a", max = col_num - 1, value = value_a)
+ shiny::updateNumericInput(session = session, inputId = "dim_b", max = col_num - 1, value = value_b)
+ }
+ })
+
+ # functionality/ plotting #####
+ # reset ui
shiny::observeEvent(input$reset, {
log_message("PCA: reset", "INFO", token = session$token)
shinyjs::reset("label")
- shinyjs::reset("dimA")
- shinyjs::reset("dimB")
+ shinyjs::reset("dim_a")
+ shinyjs::reset("dim_b")
shinyjs::reset("pointsize")
shinyjs::reset("labelsize")
- columnSelect <<- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(types.r()[level %in% levels.r()]), columnTypeLabel = "Column types to choose from")
- clearPlot(TRUE)
- })
-
- columnSelect <- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(types.r()[level %in% levels.r()]), columnTypeLabel = "Column types to choose from")
-
- output$datalevel <- shiny::renderUI({
- shiny::selectInput(session$ns("select"), label = "select data level", choices = unique(levels.r()))
- })
-
- # disable plot button on init
- shinyjs::disable("plot")
- # update dimension inputs
- shiny::observe({
- col.num <- length(shiny::req(columnSelect$selectedColumns()))
-
- if(col.num < 3 || nrow(shiny::isolate(data.r())) < 3 || is.na(input$dimA) || is.na(input$dimB)){
- shinyjs::disable("plot")
-
- # show warning if not enough selected
- shiny::showNotification(
- ui = "Not enough columns/ rows selected! At least 3 of each needed for plotting.",
- id = "warning",
- type = "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")
- }
+ columns <<- shiny::callModule(columnSelector, "select", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column types to choose from")
+ factor_data <<- shiny::callModule(label, "group", label = "Select color grouping factors", data = shiny::reactive(object()$get_factors()[key %in% columns$selected_columns(), !"key"]), unique = FALSE)
+ factor_data2 <<- shiny::callModule(label, "group2", label = "Select shape grouping factors", data = shiny::reactive(object()$get_factors()[key %in% columns$selected_columns(), !"key"]), unique = FALSE)
+ color <<- shiny::callModule(colorPicker, "colorPicker", distribution = "categorical", selected = "Dark2")
+ clear_plot(TRUE)
})
- selected <- shiny::reactive({
+ result_data <- 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]
+ selected <- object()$data[, c(object()$get_id(), columns$selected_columns()), with = FALSE]
progress$set(1)
return(selected)
})
- # disable downloadButton on init
- shinyjs::disable("download")
-
- computed.data <- shiny::eventReactive(input$plot, {
+ plot <- shiny::eventReactive(input$plot, {
log_message("PCA: computing plot...", "INFO", token = session$token)
# enable downloadButton
shinyjs::enable("download")
- clearPlot(FALSE)
+ clear_plot(FALSE)
#new progress indicator
progress <- shiny::Progress$new()
@@ -248,14 +194,19 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
progress$set(0.2, message = "Render plot")
plot <- create_pca(
- data = selected(),
- dimensionA = input$dimA,
- dimensionB = input$dimB,
- dimensions = length(columnSelect$selectedColumns()) - 1,
+ data = result_data(),
+ color.group = factor_data()$label,
+ color.title = paste0(factor_data()$selected, collapse = ", "),
+ palette = color()$palette,
+ shape.group = factor_data2()$label,
+ shape.title = paste0(factor_data2()$selected, collapse = ", "),
+ dimension.a = input$dim_a,
+ dimension.b = input$dim_b,
+ dimensions = length(columns$selected_columns()) - 1,
pointsize = input$pointsize,
labelsize = input$labelsize,
labels = input$label,
- custom.labels = columnSelect$label(),
+ custom.labels = columns$label(),
on.columns = TRUE,
width = size()$width,
height = size()$height,
@@ -267,21 +218,19 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
log_message("PCA: done.", "INFO", token = session$token)
- # show plot
- shinyjs::show("pca")
-
return(plot)
})
+ # render plot #####
# get width in pixel
plot_width <- shiny::reactive({
- width <- computed.data()$width * (computed.data()$ppi / 2.54)
+ width <- plot()$width * (plot()$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)
+ height <- plot()$height * (plot()$ppi / 2.54)
ifelse(height < 50, 50, height)
})
@@ -289,49 +238,114 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
width = plot_width,
height = plot_height,
{
- if(clearPlot()){
+ if (clear_plot()) {
return()
} else {
log_message("PCA: render plot", "INFO", token = session$token)
- computed.data()$plot
+ plot()$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) {
+ # group data by dimension
+ reorganized_data <- shiny::reactive({
+ dims <- lapply(colnames(plot()$data$var$coord), function(dim) {
+ dim_data <- lapply(plot()$data$var, function(table) {
table[, dim]
})
+
+ do.call(cbind, dim_data)
})
+
+ names(dims) <- colnames(plot()$data$var$coord)
+
+ return(dims)
})
+ # download #####
output$download <- shiny::downloadHandler(filename = "pca.zip",
content = function(file) {
log_message("PCA: download", "INFO", token = session$token)
- 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())
+ download(file = file, filename = "pca.zip", plot = plot()$plot, width = plot_width() / (plot()$ppi / 2.54), height = plot_height() / (plot()$ppi / 2.54), ppi = plot()$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)
+ data = list(type = columns$type(), selectedColumns = columns$selected_columns()),
+ dimensions = list(xaxis = input$dim_a, yaxis = input$dim_b),
+ colorGrouping = factor_data()$selected,
+ shapeGrouping = factor_data2()$selected
)
# format options
options <- list(
show_label = input$label,
pointsize = input$pointsize,
- labelsize = input$labelsize
+ labelsize = input$labelsize,
+ colorOptions = list(scheme = color()$name, reverse = color()$reverse)
)
# merge all
- all <- list(selection = selection, options = options)
+ list(selection = selection, options = options)
+ })
+
+ # notifications #####
+ # invalid dimension/ insufficient data warnings
+ # enable/ disable plot button
+ shiny::observe({
+ shinyjs::enable("plot")
+
+ # no selection
+ if (!shiny::isTruthy(columns$selected_columns())) {
+ shinyjs::disable("plot")
+ } else {
+ col_num <- length(columns$selected_columns())
+ # insufficient data
+ if (col_num < 3 || nrow(shiny::isolate(object()$data)) < 3) {
+ shinyjs::disable("plot")
+ shiny::showNotification(
+ ui = "Not enough columns/ rows selected! At least 3 of each needed for plotting.",
+ id = session$ns("data"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("data"))
+ }
+
+ # invalid dimension
+ if (col_num >= 3 && (is.na(input$dim_a) || is.na(input$dim_b) || input$dim_a <= 0 || input$dim_a >= col_num || input$dim_b <= 0 || input$dim_b >= col_num)) {
+ shinyjs::disable("plot")
+ shiny::showNotification(
+ ui = "Invalid dimension(s)! Please select an integer value between 1 and number of selected columns - 1.",
+ id = session$ns("dimension"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("dimension"))
+ }
+ }
+ })
+
+ # 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 = session$ns("limit"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("limit"))
+ }
+ })
+
+ guide <- pcaGuide(session)
+ shiny::observeEvent(input$guide, {
+ rintrojs::introjs(session, options = list(steps = guide()))
})
- return(reorganized.data)
+ return(reorganized_data)
}
#' pca module guide
@@ -348,8 +362,13 @@ pcaGuide <- function(session) {
"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_grouping" = "Grouping
+ Use the provided factor(s) to show groups based on colors and/ or shapes of the datapoints.
+ Multi-factor selections will be merged and evaluated as a single factor.",
"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_color" = "Color palettes
+ Choose a color palette used for color grouping. The selected pallette can also be reversed.",
"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."
)
diff --git a/R/scatterPlot.R b/R/scatterPlot.R
index 82dc67e..950b2ea 100644
--- a/R/scatterPlot.R
+++ b/R/scatterPlot.R
@@ -28,7 +28,7 @@ scatterPlotUI <- function(id) {
columnSelectorUI(
id = ns("xaxis"),
title = "Data on x-axis",
- label = T
+ label = TRUE
)
),
shiny::div(id = ns("guide_xaxis_transformation"),
@@ -43,7 +43,7 @@ scatterPlotUI <- function(id) {
columnSelectorUI(
id = ns("yaxis"),
title = "Data on y-axis",
- label = T
+ label = TRUE
)
),
shiny::div(id = ns("guide_yaxis_transformation"),
@@ -59,7 +59,7 @@ scatterPlotUI <- function(id) {
columnSelectorUI(
id = ns("zaxis"),
title = "Data on z-axis",
- label = T
+ label = TRUE
),
shiny::checkboxInput(
inputId = ns("force_cat"),
@@ -71,7 +71,7 @@ scatterPlotUI <- function(id) {
shiny::column(
width = 3,
shiny::div(id = ns("guide_color"),
- colorPicker2UI(id = ns("color"))
+ colorPickerUI(id = ns("color"))
),
shiny::div(id = ns("guide_pointsize"),
shiny::sliderInput(
@@ -116,17 +116,8 @@ scatterPlotUI <- function(id) {
#' @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 x.names Character vector of column names(data column names) which will be available for x-axis. Can be reactive.
-#' @param y.names Character vector of column names(data column names) which will be available for y-axis. Can be reactive.
-#' @param z.names Character vector of column names(data column names) which will be available for z-axis. Can be reactive.
-#' @param features data.table of the features to mark (first column = id)
-#' @param markerReac reactive containing inputs of marker module.
+#' @param clarion A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)
+#' @param marker.output Marker module output. See \code{\link[wilson]{marker}}.
#' @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.
@@ -135,30 +126,39 @@ scatterPlotUI <- function(id) {
#'
#' @return Returns reactive containing data used for plot.
#'
-#' @details Make sure to have the same columnnames in data and features.
+#' @details As markerOutput provides a second dataset used for highlighting it is crucial for it to have the same columnnames as the dataset provided by clarion.
+#' @details Intersections between marker and clarion will be removed from clarion in favor of highlighting them.
#'
#' @export
-scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.names = NULL, z.names = NULL, features = NULL, markerReac = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72, scale = 1) {
- #handle reactive data
- data.r <- shiny::reactive({
- if(shiny::is.reactive(data)){
- data <- data.table::copy(data())
- }else{
- data <- data.table::copy(data)
- }
+scatterPlot <- function(input, output, session, clarion, marker.output = NULL, plot.method = "static", width = "auto", height = "auto", ppi = 72, scale = 1) {
+ # globals/ initialization #####
+ # clear plot
+ clear_plot <- shiny::reactiveVal(FALSE)
+ # disable downloadbutton on init
+ shinyjs::disable("download")
+ # set labelsize default for interactive
+ if (plot.method == "interactive") shiny::updateSliderInput(session = session, inputId = "labelsize", value = 10)
- return(data)
- })
- #handle reactive features
- features.r <- shiny::reactive({
- if(shiny::is.reactive(features)){
- features <- features()
- }else{
- features <- features
- }
+ # input preparation #####
+ object <- shiny::reactive({
+ # support reactive
+ if (shiny::is.reactive(clarion)) {
+ if (!methods::is(clarion(), "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
- return(features)
+ clarion()$clone(deep = TRUE)
+ } else {
+ if (!methods::is(clarion, "Clarion")) shiny::stopApp("Object of class 'Clarion' needed!")
+
+ clarion$clone(deep = TRUE)
+ }
})
+ # create deep copy of marker data if existing
+ if (!is.null(marker.output)) {
+ marker_object <- shiny::reactive({
+ marker.output$clarion()$clone(deep = TRUE)
+ })
+ }
+
# handle reactive sizes
size <- shiny::reactive({
width <- ifelse(shiny::is.reactive(width), width(), width)
@@ -166,13 +166,13 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
ppi <- ifelse(shiny::is.reactive(ppi), ppi(), ppi)
scale <- ifelse(shiny::is.reactive(scale), scale(), scale)
- if(!is.numeric(width) || width <= 0) {
+ if (!is.numeric(width) || width <= 0) {
width <- "auto"
}
- if(!is.numeric(height) || height <= 0) {
+ if (!is.numeric(height) || height <= 0) {
height <- "auto"
}
- if(!is.numeric(ppi) || ppi <= 0) {
+ if (!is.numeric(ppi) || ppi <= 0) {
ppi <- 72
}
@@ -182,152 +182,63 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
scale = scale)
})
- # available types for corresponding axis
- types_x <- shiny::reactive({
- if(shiny::is.reactive(types)) {
- t <- types()
- } else {
- t <- types
- }
-
- if(shiny::is.reactive(x.names)) {
- x <- x.names()
- } else {
- x <- x.names
- }
- if(is.null(x)) return(t)
-
- t[key %in% x]
- })
-
- types_y <- shiny::reactive({
- if(shiny::is.reactive(types)) {
- t <- types()
- } else {
- t <- types
- }
-
- if(shiny::is.reactive(y.names)) {
- y <- y.names()
- } else {
- y <- y.names
- }
- if(is.null(y)) return(t)
-
- t[key %in% y]
- })
-
- types_z <- shiny::reactive({
- if(shiny::is.reactive(types)) {
- t <- types()
- } else {
- t <- types
- }
-
- if(shiny::is.reactive(z.names)) {
- z <- z.names()
- } else {
- z <- z.names
- }
- if(is.null(z)) return(t)
-
- t[key %in% z]
- })
-
- #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]))
-
- # clear plot
- clearPlot <- shiny::reactiveVal(FALSE)
-
- #reset ui
- shiny::observeEvent(input$reset, {
- log_message("Scatterplot: reset", "INFO", token = session$token)
-
- shinyjs::reset("density")
- shinyjs::reset("line")
- shinyjs::reset("pointsize")
- shinyjs::reset("labelsize")
- shinyjs::reset("force_cat")
- xaxis <<- shiny::callModule(columnSelector, "xaxis", type.columns = types_x, 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_y, 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_z, 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(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]))
- clearPlot(TRUE)
- })
-
- winsorize <- shiny::reactive({
- if(zaxis$selectedColumn() != "") {
- equalize(result.data()$processed.data[, 4])
- } else {
- NULL
- }
- })
-
- xaxis <- shiny::callModule(columnSelector, "xaxis", type.columns = types_x, 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_y, 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_z, 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]))
+ # modules/ ui #####
+ xaxis <- shiny::callModule(columnSelector, "xaxis", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_x$method()))
+ yaxis <- shiny::callModule(columnSelector, "yaxis", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_y$method()))
+ zaxis <- shiny::callModule(columnSelector, "zaxis", type.columns = shiny::reactive(object()$metadata[, intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Color label", multiple = FALSE, none = TRUE)
+ color <- shiny::callModule(colorPicker, "color", distribution = "all", winsorize = shiny::reactive(switch(shiny::isTruthy(zaxis$selected_column()) + 1, NULL, equalize(object()$data[, zaxis$selected_column(), with = FALSE]))))
+ transform_x <- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(object()$data[, xaxis$selected_column(), with = FALSE])))
+ transform_y <- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(object()$data[, yaxis$selected_column(), with = FALSE])))
+ # transform highlight data
+ if (!is.null(marker.output)) {
+ # note: same id as transform_x/y so it depends on same ui
+ highlight_transform_x <- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(marker_object()$data[, xaxis$selected_column(), with = FALSE])))
+ highlight_transform_y <- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(marker_object()$data[, yaxis$selected_column(), with = FALSE])))
+ }
+ 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") {
+ if (plot.method == "static") {
output$scatter <- shiny::renderUI({
shinycssloaders::withSpinner(shiny::plotOutput(outputId = session$ns("static")), proxy.height = "800px")
})
- }else if(plot.method == "interactive") {
+ } else if (plot.method == "interactive") {
output$scatter <- shiny::renderUI({
shinycssloaders::withSpinner(plotly::plotlyOutput(outputId = session$ns("interactive")), proxy.height = "800px")
})
}
- # show warning if there would more than 10 categories
- shiny::observe({
- shiny::req(!is.null(zaxis$selectedColumn()))
-
- # something selected?
- if(zaxis$selectedColumn() != "") {
- # categories used?
- if(input$force_cat || !is.numeric(data.r()[[zaxis$selectedColumn()]])) {
- cat_num <- length(unique(data.r()[[zaxis$selectedColumn()]]))
-
- if(cat_num > 10) {
- shiny::showNotification(
- id = session$ns("cat-limit"),
- paste("Warning! There are", cat_num, "different categories selected. This can result in unexpected behavior. Recommended are 10 or less categories."),
- duration = NULL,
- type = "warning"
- )
+ # functionality/ plotting #####
+ # reset ui
+ shiny::observeEvent(input$reset, {
+ log_message("Scatterplot: reset", "INFO", token = session$token)
- shinyjs::runjs(paste0("$(document.getElementById('", paste0("shiny-notification-", session$ns("cat-limit")), "')).addClass('notification-position-center');"))
- } else {
- shiny::removeNotification(session$ns("cat-limit"))
- }
- } else {
- shiny::removeNotification(session$ns("cat-limit"))
- }
- } else {
- shiny::removeNotification(session$ns("cat-limit"))
+ shinyjs::reset("density")
+ shinyjs::reset("line")
+ shinyjs::reset("pointsize")
+ shinyjs::reset("labelsize")
+ shinyjs::reset("force_cat")
+ xaxis <<- shiny::callModule(columnSelector, "xaxis", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_x$method()))
+ yaxis <<- shiny::callModule(columnSelector, "yaxis", type.columns = shiny::reactive(object()$metadata[level != "feature", intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Axis label", multiple = FALSE, suffix = shiny::reactive(transform_y$method()))
+ zaxis <<- shiny::callModule(columnSelector, "zaxis", type.columns = shiny::reactive(object()$metadata[, intersect(names(object()$metadata), c("key", "level", "label", "sub_label")), with = FALSE]), column.type.label = "Column type to choose from", label.label = "Color label", multiple = FALSE, none = TRUE)
+ color <<- shiny::callModule(colorPicker, "color", distribution = "all", winsorize = shiny::reactive(switch(shiny::isTruthy(zaxis$selected_column()) + 1, NULL, equalize(object()$data[, zaxis$selected_column(), with = FALSE]))))
+ transform_x <<- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(object()$data[, xaxis$selected_column(), with = FALSE])))
+ transform_y <<- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(object()$data[, yaxis$selected_column(), with = FALSE])))
+ # transform highlight data
+ if (!is.null(marker.output)) {
+ # note: same id as transform_x/y so it depends on same ui
+ highlight_transform_x <<- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(marker_object()$data[, xaxis$selected_column(), with = FALSE])))
+ highlight_transform_y <<- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(marker_object()$data[, yaxis$selected_column(), with = FALSE])))
}
+ 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]))
+ clear_plot(TRUE)
})
# disable plot if mandatory x- or y-axis missing
shiny::observe({
- if(!shiny::isTruthy(xaxis$selectedColumn()) || !shiny::isTruthy(yaxis$selectedColumn())) {
+ if (!shiny::isTruthy(xaxis$selected_column()) || !shiny::isTruthy(yaxis$selected_column())) {
shinyjs::disable("plot")
} else {
shinyjs::enable("plot")
@@ -335,131 +246,190 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
})
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())
+ # reassemble after transformation
+ # columns: unique_id, x, y(, z)
+ if (shiny::isTruthy(zaxis$selected_column())) {
+ z <- object()$data[, zaxis$selected_column(), with = FALSE]
+ data.table::data.table(object()$data[, object()$get_id(), with = FALSE], transform_x$data(), transform_y$data(), z)
+ } else {
+ data.table::data.table(object()$data[, object()$get_id(), with = FALSE], 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
+ if (!is.null(marker.output)) {
+ highlight_data <- shiny::reactive({
+ # return null on empty table
+ if (nrow(marker.output$clarion()$data) == 0) return()
+ # reassemble after transformation
+ # columns: unique_id, x, y(, z)
+ if (shiny::isTruthy(zaxis$selected_column())) {
+ z <- marker_object()$data[, zaxis$selected_column(), with = FALSE]
+ data.table::data.table(marker_object()$data[, marker_object()$get_id(), with = FALSE], highlight_transform_x$data(), highlight_transform_y$data(), z)
+ } else {
+ data.table::data.table(marker_object()$data[, marker_object()$get_id(), with = FALSE], highlight_transform_x$data(), highlight_transform_y$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,
+ processed_data = NULL,
+ data_label = NULL,
+ data_hovertext = NULL,
+ highlight_color = NULL,
+ highlight_label = NULL,
+ highlight_hovertext = NULL,
+ highlight_data = NULL,
xlim = NULL,
ylim = NULL
)
- #get selected data
+ # get selected data
progress$set(0.3, detail = "transforming")
- processed.data <- transformed_data()
+ 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))
+ # no highlighting either disabled or N/A
+ if (is.null(marker.output) || is.null(highlight_data()) || marker.output$highlight() == "Disabled") {
+ # 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())){
+ # add name to hovertext
+ if (plot.method == "interactive" && object()$get_name() != object()$get_id()) {
+ result$data_hovertext <- object()$data[[object()$get_name()]]
+ }
- result$highlight.color <- markerReac()$color
- if(markerReac()$highlight != "Disabled" & nrow(features.r()) > 0){
- # restrict label to 100 or less
- if(length(markerReac()$label) <= 100) {
- result$highlight.labels <- markerReac()$label
- } else {
+ result$processed_data <- processed_data
+ } else {
+ # get highlight data
+ highlight_data <- highlight_data()
+
+ # get axis limit including both datasets
+ result$xlim <- c(min(processed_data[, 2], highlight_data[, 2], na.rm = TRUE), max(processed_data[, 2], highlight_data[, 2], na.rm = TRUE))
+ result$ylim <- c(min(processed_data[, 3], highlight_data[, 3], na.rm = TRUE), max(processed_data[, 3], highlight_data[, 3], na.rm = TRUE))
+
+ # get colors
+ result$highlight_color <- marker.output$color()
+
+ if (marker.output$highlight() == "Highlight") {
+ # omit duplicates from processed.data
+ processed_data <- data.table::fsetdiff(x = processed_data, y = highlight_data)
+
+ # for everything duplicated = empty processed.data
+ if (nrow(processed_data) == 0) {
+ # notification that highlight color will be ignored
shiny::showNotification(
- id = session$ns("label-limit"),
- paste("Warning! Label restricted to 100 or less labels. Currently selected:", length(markerReac()$label), "Please select fewer genes to label."),
+ id = session$ns("full_highlight"),
+ ui = "Ignoring highlight color as complete dataset is selected. Otherwise z-axis coloring would be lost.",
duration = NULL,
type = "warning"
)
- shinyjs::runjs(paste0("$(document.getElementById('", paste0("shiny-notification-", session$ns("label-limit")), "')).addClass('notification-position-center');"))
+ # show notification in center
+ shinyjs::runjs(paste0("$(document.getElementById('", paste0("shiny-notification-", session$ns("full_highlight")), "')).addClass('notification-position-center');"))
+
+ # add name to hovertext
+ if (plot.method == "interactive" && marker_object()$get_name() != marker_object()$get_id()) {
+ result$data_hovertext <- marker_object()$data[[marker_object()$get_name()]]
+ }
+
+ result$processed_data <- highlight_data
+ } else {
+ # add name to hovertext
+ if (plot.method == "interactive" && object()$get_name() != object()$get_id()) {
+ # only keep selected rows
+ result$data_hovertext <- object()$data[processed_data, on = object()$get_id()][[object()$get_name()]]
+ }
+ # add name to hovertext
+ if (plot.method == "interactive" && marker_object()$get_name() != marker_object()$get_id()) {
+ result$highlight_hovertext <- marker_object()$data[[marker_object()$get_name()]]
+ }
+
+ result$processed_data <- processed_data
+ result$highlight_data <- highlight_data
}
- }
- 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
+ # set label; ignore if more than 100
+ if (length(marker.output$label()) <= 100) {
+ if (nrow(processed_data) == 0) {
+ result$data_label <- marker.output$label()
+ } else {
+ result$highlight_label <- marker.output$label()
+ }
+ }
+ } else if (marker.output$highlight() == "Exclusive") {
+ # add name to hovertext
+ if (plot.method == "interactive" && marker_object()$get_name() != marker_object()$get_id()) {
+ result$data.hovertext <- marker_object()$data[[marker_object()$get_name()]]
+ }
+
+ result$processed_data <- highlight_data
+
+ # set label; ignore if more than 100
+ if (length(marker.output$label()) <= 100) {
+ result$data_label <- marker.output$label()
+ }
}
- }else{
- result$processed.data <- processed.data
}
progress$set(1)
return(result)
})
- #disable downloadbutton on init
- shinyjs::disable("download")
-
plot <- shiny::eventReactive(input$plot, {
log_message("Scatterplot: computing plot...", "INFO", token = session$token)
- #enable downloadbutton
+ # enable downloadbutton
shinyjs::enable("download")
- clearPlot(FALSE)
+ clear_plot(FALSE)
- #new progress indicator
+ # 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()))
+ if (!is.null(limit_x())) {
+ xlimit <- unlist(limit_x())
} else {
- xlimit <- result.data()$xlim
+ xlimit <- result_data()$xlim
}
- if(!is.null(limit_y())) {
- ylimit <- unlist(unname(limit_y()))
+ if (!is.null(limit_y())) {
+ ylimit <- unlist(limit_y())
} else {
- ylimit <- result.data()$ylim
+ ylimit <- result_data()$ylim
}
plot <- create_scatterplot(
- data = result.data()$processed.data,
- colors = colors,
+ data = result_data()$processed_data,
+ data.labels = result_data()$data_label,
+ data.hovertext <- result_data()$data_hovertext,
+ color = color()$palette,
x_label = xaxis$label(),
y_label = yaxis$label(),
z_label = zaxis$label(),
- transparency = colorPicker()$transparency,
+ transparency = color()$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,
+ highlight.data = result_data()$highlight_data,
+ highlight.color = result_data()$highlight_color,
+ highlight.labels = result_data()$highlight_label,
+ highlight.hovertext = result_data()$highlight_hovertext,
xlim = xlimit,
ylim = ylimit,
- colorbar.limits = colorPicker()$winsorize,
+ colorbar.limits = color()$winsorize,
plot.method = plot.method,
width = size()$width,
height = size()$height,
ppi = size()$ppi,
scale = size()$scale,
- categorized = if(input$force_cat || ncol(result.data()$processed.data) >= 4 && !is.numeric(result.data()$processed.data[[4]])) TRUE else FALSE
+ categorized = if (input$force_cat || ncol(result_data()$processed_data) >= 4 && !is.numeric(result_data()$processed_data[[4]])) TRUE else FALSE
)
progress$set(1)
@@ -467,25 +437,13 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
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") {
+ # 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)),
{
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Scatterplot: render plot static", "INFO", token = session$token)
@@ -494,14 +452,14 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
}
}
)
- } else if(plot.method == "interactive") {
+ } else if (plot.method == "interactive") {
output$interactive <- plotly::renderPlotly({
- if(clearPlot()) {
+ if (clear_plot()) {
return()
} else {
log_message("Scatterplot: render plot interactive", "INFO", token = session$token)
- #new progress indicator
+ # new progress indicator
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(0.2, message = "Render plot")
@@ -514,6 +472,7 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
})
}
+ # download #####
output$download <- shiny::downloadHandler(filename = "scatterPlot.zip",
content = function(file) {
log_message("Scatterplot: download", "INFO", token = session$token)
@@ -521,7 +480,6 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
}
)
-
user_input <- shiny::reactive({
# format axis
xaxis <- lapply(xaxis, function(x) { x() })
@@ -535,10 +493,10 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
# format appearance
appearance <- list(
- scheme = colorPicker()$name,
- reverse = colorPicker()$reverse,
- winsorize = colorPicker()$winsorize,
- transparency = colorPicker()$transparency,
+ scheme = color()$name,
+ reverse = color()$reverse,
+ winsorize = color()$winsorize,
+ transparency = color()$transparency,
pointsize = input$pointsize,
labelsize = input$labelsize)
@@ -547,15 +505,85 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
# format marker
marker <- NULL
- if(!is.null(markerReac)) {
- marker <- markerReac()
+ if (!is.null(marker.output)) {
+ marker <- list(
+ highlight = marker.output$highlight(),
+ color = marker.output$color(),
+ label_column = marker.output$label_column(),
+ label = marker.output$label()
+ )
+ }
+
+ # merge all
+ list(axis = axis, appearance = appearance, options = options, marker = marker)
+ })
+
+ # notifications #####
+ # show warning if there would be more than 10 categories
+ shiny::observe({
+ # something selected?
+ if (shiny::isTruthy(zaxis$selected_column())) {
+ # categories used?
+ if (input$force_cat || !is.numeric(object()$data[[zaxis$selected_column()]])) {
+ cat_num <- length(unique(object()$data[[zaxis$selected_column()]]))
+
+ if (cat_num > 10) {
+ shiny::showNotification(
+ id = session$ns("cat-limit"),
+ paste("Warning! There are", cat_num, "different categories selected. This can result in unexpected behavior. Recommended are 10 or less categories."),
+ duration = NULL,
+ type = "warning"
+ )
+
+ shinyjs::runjs(paste0("$(document.getElementById('", paste0("shiny-notification-", session$ns("cat-limit")), "')).addClass('notification-position-center');"))
+ } else {
+ shiny::removeNotification(session$ns("cat-limit"))
+ }
+ } else {
+ shiny::removeNotification(session$ns("cat-limit"))
+ }
+ } else {
+ shiny::removeNotification(session$ns("cat-limit"))
+ }
+ })
+
+ # 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 = session$ns("limit"),
+ type = "warning"
+ )
+ } else {
+ shiny::removeNotification(session$ns("limit"))
}
+ })
+
+ # label restriction warning
+ if (!is.null(marker.output)) {
+ shiny::observe({
+ if (marker.output$highlight() != "Disabled" && length(marker.output$label()) > 100) {
+ shiny::showNotification(
+ id = session$ns("label-limit"),
+ paste("Warning! Label restricted to 100 or less labels. Currently selected:", length(marker.output$label()), "Please select fewer genes to label or else they will be ignored."),
+ duration = NULL,
+ type = "warning"
+ )
+ shinyjs::runjs(paste0("$(document.getElementById('", paste0("shiny-notification-", session$ns("label-limit")), "')).addClass('notification-position-center');"))
+ } else {
+ shiny::removeNotification(session$ns("label-limit"))
+ }
+ })
+ }
- #merge all
- all <- list(axis = axis, appearance = appearance, options = options, marker = marker)
+ # Fetch the reactive guide for this module
+ guide <- scatterPlotGuide(session, !is.null(marker.output))
+ shiny::observeEvent(input$guide, {
+ rintrojs::introjs(session, options = list(steps = guide()))
})
- return(shiny::reactive({unique(data.table::rbindlist(list(result.data()$processed.data, result.data()$highlight.data)))}))
+ return(shiny::reactive({unique(data.table::rbindlist(list(result_data()$processed_data, result_data()$highlight_data)))}))
}
#' scatterPlot module guide
@@ -598,8 +626,8 @@ scatterPlotGuide <- function(session, marker = FALSE) {
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){
+ # 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.
diff --git a/R/transformation.R b/R/transformation.R
index 2b7a87c..2a13f15 100644
--- a/R/transformation.R
+++ b/R/transformation.R
@@ -16,13 +16,13 @@ transformationUI <- function(id, label = "Transformation", selected = "raw", cho
ret <- list(
shiny::tags$b(label),
- #shiny::actionLink(ns("help"), label = NULL, icon = shiny::icon("question-circle")), # removed for now
+ # 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){
+ multiple = FALSE))
+ if (transposeOptions) {
ret <- list(ret, shinyjs::useShinyjs(), shiny::radioButtons(ns("transpose"), label = NULL, choices = c(`row-wise` = "row", `column-wise` = "column")))
}
@@ -49,20 +49,20 @@ transformationUI <- function(id, label = "Transformation", selected = "raw", cho
#'
#' @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)){
+ # handle reactive data
+ data_r <- shiny::reactive({
+ if (shiny::is.reactive(data)) {
data()
- }else{
+ } else {
data
}
})
- #reset
+ # reset
shinyjs::reset("transform")
shinyjs::reset("transpose")
- #helptext
+ # helptext
# shiny::observeEvent(input$help, {
# title <- "Data transformation"
# content <- shiny::HTML("Choose a method with which the given data is transformed:
")
@@ -109,13 +109,13 @@ transformation <- function(input, output, session, data, transpose = FALSE, pseu
}
transformed_data <- shiny::reactive({
- data <- data.r()
+ data <- data_r()
- if(transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore"){
+ if (transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
data <- t(data)
}
- #transform data
+ # transform data
output <- switch(input$transform,
log2 = log2(data + pseudocount),
`-log2` = -log2(data + pseudocount),
@@ -126,32 +126,32 @@ transformation <- function(input, output, session, data, transpose = FALSE, pseu
raw = data
)
- #replace infinite with NA & NA with 0
- if(replaceInf){
- is.na(output) <- sapply(output, is.infinite)
+ # replace infinite with NA & NA with 0
+ if (replaceInf) {
+ is.na(output) <- vapply(output, FUN = is.infinite, FUN.VALUE = logical(1))
}
- if(replaceNA){
+ if (replaceNA) {
output[is.na(output)] <- 0
}
- if(transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore"){
+ if (transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
output <- t(output)
}
return(output)
})
- #enable transposeOptions only if relevant
+ # enable transposeOptions only if relevant
shiny::observe({
- if(input$transform == "zscore"){
+ if (input$transform == "zscore") {
shinyjs::enable("transpose")
- }else{
+ } else {
shinyjs::disable("transpose")
}
})
method <- shiny::reactive({
- if(input$transform == "zscore") {
+ if (input$transform == "zscore") {
paste(input$transform, input$transpose)
} else {
input$transform
diff --git a/R/zzz.R b/R/zzz.R
index 24d61b2..ffc2441 100644
--- a/R/zzz.R
+++ b/R/zzz.R
@@ -2,3 +2,17 @@
# make server aware of images
shiny::addResourcePath(prefix = "wilson_www", directoryPath = system.file("www", package = "wilson"))
}
+
+# hideous hack
+# set variables otherwise noted by R cmd check 'no visible binding for...'
+if (getRversion() >= "2.15.1") {
+ utils::globalVariables(
+ c(
+ "Experiment",
+ "col_name",
+ "condition",
+ "level",
+ "type"
+ )
+ )
+}
diff --git a/exec/colorPicker2_example.R b/exec/colorPicker2_example.R
deleted file mode 100644
index 04c2721..0000000
--- a/exec/colorPicker2_example.R
+++ /dev/null
@@ -1,33 +0,0 @@
-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
index 8c70c85..38c889b 100644
--- a/exec/colorPicker_example.R
+++ b/exec/colorPicker_example.R
@@ -2,12 +2,30 @@ library(shiny)
source("../R/colorPicker.R")
-ui <- fluidPage(colorPickerUI("id"))
+ui <- fluidPage(
+ column(width = 4,
+ colorPickerUI("custom.single", custom = TRUE, label = "Single color select"),
+ verbatimTextOutput("cs.t")
+ ),
+ column(width = 4,
+ colorPickerUI("custom.multiple", custom = TRUE, multiple = TRUE, label = "Multiple color select/ custom colorpalette"),
+ verbatimTextOutput("cm.t")
+ ),
+ column(width = 4,
+ colorPickerUI("defined", label = "predefined palettes", show.scaleoptions = T),
+ verbatimTextOutput("d.t")
+ )
+ )
+
server <- function(input, output) {
- mod <- callModule(colorPicker, "id")
+ def <- callModule(colorPicker, "defined", distribution = "all", num.color = 3)
+ cs <- callModule(colorPicker, "custom.single", num.colors = 3)
+ cm <- callModule(colorPicker, "custom.multiple", num.colors = 3)
- observe(print(mod$scheme))
+ output$d.t <- renderPrint(def())
+ output$cs.t <- renderPrint(cs())
+ output$cm.t <- renderPrint(cm())
}
diff --git a/exec/columnSelector_example.R b/exec/columnSelector_example.R
index 004144b..3641471 100644
--- a/exec/columnSelector_example.R
+++ b/exec/columnSelector_example.R
@@ -1,8 +1,9 @@
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"))
+### Test Data
+table <- data.table::data.table(id = c("a", "b", "c", "d", "e", "f", "g", "h", "i", "j"), level = c("sample", "condition", "contrast"), sub_label = "sub")
+names(table)[1] <- "key"
ui <- fluidPage(
fluidRow(
@@ -26,22 +27,21 @@ 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)
+ 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$selected_column())
print(mod$label())
})
output$second <- renderPrint({
print(mod2$type())
- print(mod2$selectedColumn())
+ print(mod2$selected_column())
print(mod2$label())
})
}
# Run the application
shinyApp(ui = ui, server = server)
-
diff --git a/exec/featureSelector_example.R b/exec/featureSelector_example.R
index 1d3cfa6..b60611d 100644
--- a/exec/featureSelector_example.R
+++ b/exec/featureSelector_example.R
@@ -6,16 +6,17 @@ source("../R/orTextual.R")
source("../R/featureSelector.R")
source("../R/function.R")
source("../R/global.R")
+source("../R/clarion.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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
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")
@@ -24,12 +25,18 @@ ui <- dashboardPage(header = dashboardHeader(),
server <- function(input, output) {
- mod <-callModule(featureSelector, "id", data = data, delimiter = ",", features = reactive(input$columns), feature.grouping = metadata)
+ mod <- callModule(featureSelector, "id", clarion = clarion)
output$filter <- renderText({
paste(mod()$filter, collapse = "\n")
})
+ observe({
+ print(mod()$object$header)
+ print(mod()$object$metadata)
+ print(mod()$object$data)
+ })
+
}
# Run the application
diff --git a/exec/geneView_example.R b/exec/geneView_example.R
index 10fac4a..592bd2f 100644
--- a/exec/geneView_example.R
+++ b/exec/geneView_example.R
@@ -2,19 +2,21 @@
library(shiny)
library(shinydashboard)
source("../R/function.R")
-source("../R/colorPicker2.R")
+source("../R/colorPicker.R")
source("../R/transformation.R")
source("../R/geneView.R")
source("../R/columnSelector.R")
source("../R/label.R")
source("../R/limit.R")
source("../R/global.R")
+source("../R/clarion.R")
-####Test Data
-data <- data.table::data.table(id = rownames(mtcars), names = rownames(mtcars), mtcars)
+# test data
+data <- data.table::as.data.table(mtcars, keep.rowname = "id")
# 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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)), factor1 = c(rep("a", 5), rep("b", 7)), factor2 = c(rep("1", 7), rep("2", 5)), factor3 = c(rep("", 4), rep("test", 5), rep("test2", 3)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
####
ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(
@@ -26,17 +28,7 @@ ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(
)))
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), scale = reactive(input$scale))
+ gene <- callModule(geneView, "id", clarion = clarion, plot.method = "static", width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
observe({
print(gene())
diff --git a/exec/global_cor_heatmap_example.R b/exec/global_cor_heatmap_example.R
index 215865a..78fa5be 100644
--- a/exec/global_cor_heatmap_example.R
+++ b/exec/global_cor_heatmap_example.R
@@ -1,18 +1,21 @@
library(shiny)
library(shinydashboard)
source("../R/function.R")
-source("../R/colorPicker2.R")
+source("../R/colorPicker.R")
source("../R/columnSelector.R")
source("../R/transformation.R")
source("../R/global_cor_heatmap.R")
source("../R/limit.R")
source("../R/global.R")
+source("../R/clarion.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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
+#####
ui <- dashboardPage(
header = dashboardHeader(),
@@ -29,7 +32,7 @@ ui <- dashboardPage(
)
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), scale = reactive(input$scale))
+ table <- shiny::callModule(global_cor_heatmap, "id", clarion = clarion, plot.method = "static", width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
shiny::observe({
print(table())
diff --git a/exec/heatmap_example.R b/exec/heatmap_example.R
index 6f65148..9e0bd23 100644
--- a/exec/heatmap_example.R
+++ b/exec/heatmap_example.R
@@ -1,20 +1,21 @@
-
library(shiny)
library(shinydashboard)
source("../R/function.R")
-source("../R/colorPicker2.R")
+source("../R/colorPicker.R")
source("../R/columnSelector.R")
source("../R/transformation.R")
source("../R/heatmap.R")
source("../R/label.R")
source("../R/limit.R")
source("../R/global.R")
+source("../R/clarion.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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
####
@@ -27,15 +28,7 @@ ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(
)))
server <- function(input, output) {
- table <- reactive({
- data
- })
- typ <- reactive({
- # without annotation
- metadata[ type != "annotation"]
- })
-
- heat <- callModule(heatmap, "id", data = table, types = typ, plot.method = "interactive", custom.row.label = table, width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
+ heat <- callModule(heatmap, "id", clarion = clarion, plot.method = "interactive", width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
observe({
print(heat())
diff --git a/exec/marker_example.R b/exec/marker_example.R
index 42ff0eb..1dc2939 100644
--- a/exec/marker_example.R
+++ b/exec/marker_example.R
@@ -1,14 +1,17 @@
library(shiny)
source("../R/marker.R")
-source("../R/colorPicker2.R")
+source("../R/colorPicker.R")
source("../R/label.R")
+source("../R/limit.R")
+source("../R/clarion.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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
####
ui <- fluidPage(
@@ -17,11 +20,16 @@ ui <- fluidPage(
)
server <- function(input, output) {
-
- marker <-callModule(marker, "mark", highlight.labels = data)
+ marker <- callModule(marker, "mark", clarion = clarion)
output$output <- renderPrint({
- marker()
+ list(
+ highlight = marker$highlight(),
+ color = marker$color(),
+ label_column = marker$label_column(),
+ label = marker$label(),
+ clarion = marker$clarion()
+ )
})
}
diff --git a/exec/orNumeric_example.R b/exec/orNumeric_example.R
index 0e9fc24..9be5dca 100644
--- a/exec/orNumeric_example.R
+++ b/exec/orNumeric_example.R
@@ -10,20 +10,20 @@ ui <- fluidPage(
tags$br(),
column(width = 6,
orNumericUI(id = "ranged"),
- verbatimTextOutput("ran.out")
+ verbatimTextOutput("ran_out")
),
column(width = 6,
orNumericUI(id = "single"),
- verbatimTextOutput("sin.out")
+ 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)
+ choices1 <- c(0:10)
+ choices2 <- c(11:20)
choices <- reactive({
- if(input$test == 1) {
+ if (input$test == 1) {
choices1
} else {
choices2
@@ -36,11 +36,11 @@ server <- function(input, output) {
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))
+ 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())
+ output$ran_out <- renderPrint(ranged())
+ output$sin_out <- renderPrint(single())
}
# Run the application
diff --git a/exec/orTextual_example.R b/exec/orTextual_example.R
index 374a163..02ddc26 100644
--- a/exec/orTextual_example.R
+++ b/exec/orTextual_example.R
@@ -6,15 +6,15 @@ 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")
+ verbatimTextOutput("co_out")
),
column(width = 4,
orTextualUI(id = "delimit"),
- verbatimTextOutput("del.out")
+ verbatimTextOutput("del_out")
),
column(width = 4,
orTextualUI(id = "nodelimit"),
- verbatimTextOutput("nodel.out")
+ verbatimTextOutput("nodel_out")
),
actionButton("button", "reset")
)
@@ -24,11 +24,11 @@ server <- function(input, output) {
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))
+ 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())
+ output$co_out <- renderPrint(contains())
+ output$del_out <- renderPrint(delimit())
+ output$nodel_out <- renderPrint(no_delimit())
}
# Run the application
diff --git a/exec/pca_example.R b/exec/pca_example.R
index 107a5b8..4ea4570 100644
--- a/exec/pca_example.R
+++ b/exec/pca_example.R
@@ -5,12 +5,17 @@ source("../R/columnSelector.R")
source("../R/function.R")
source("../R/pca.R")
source("../R/global.R")
+source("../R/clarion.R")
+source("../R/label.R")
+source("../R/colorPicker.R")
+source("../R/limit.R")
-#### Test Data
+####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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)), factor1 = c(rep("group_a", 6), rep("group_b", 6)), factor2 = c(rep("group_1", 3), rep("group_2", 3), rep("group_3", 6)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
####
ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(
@@ -22,7 +27,7 @@ ui <- dashboardPage(header = dashboardHeader(), sidebar = dashboardSidebar(
)))
server <- function(input, output) {
- callModule(pca, "id", data = data, types = metadata, levels = metadata[level != "annotation"][["level"]], width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
+ callModule(pca, "id", clarion = clarion, width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
}
# Run the application
diff --git a/exec/scatterPlot_example.R b/exec/scatterPlot_example.R
index 292c753..e18482d 100644
--- a/exec/scatterPlot_example.R
+++ b/exec/scatterPlot_example.R
@@ -2,7 +2,7 @@
library(shiny)
library(shinydashboard)
source("../R/function.R")
-source("../R/colorPicker2.R")
+source("../R/colorPicker.R")
source("../R/columnSelector.R")
source("../R/transformation.R")
source("../R/scatterPlot.R")
@@ -10,12 +10,14 @@ source("../R/marker.R")
source("../R/limit.R")
source("../R/label.R")
source("../R/global.R")
+source("../R/clarion.R")
####Test Data
-data <- data.table::data.table(id = rownames(mtcars), mtcars)
+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)))
+metadata <- data.table::data.table(names(data), level = c("feature", rep("sample", 7), rep("condition", 4)))
names(metadata)[1] <- "key"
+clarion <- Clarion$new(data = data, metadata = metadata)
####
ui <- dashboardPage(header = dashboardHeader(),
@@ -33,9 +35,11 @@ ui <- dashboardPage(header = dashboardHeader(),
)
server <- function(input, output) {
- marker <- callModule(marker, "marker", data)
- # highlight all manual cars
- plot <- callModule(scatterPlot, "id", data = data, types = metadata, x.names = metadata[level != "annotation"][["key"]], y.names = metadata[level != "annotation"][["key"]], features = data[am == 1], markerReac = marker, plot.method = "interactive", width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
+ # highlight first 10 cars
+ marked <- Clarion$new(metadata = metadata, data = data[1:10])
+ marker <- callModule(marker, "marker", clarion = marked)
+
+ plot <- callModule(scatterPlot, "id", clarion = clarion, marker.output = marker, plot.method = "interactive", width = reactive(input$width), height = reactive(input$height), scale = reactive(input$scale))
observe({
print(plot())
diff --git a/man/Clarion.Rd b/man/Clarion.Rd
new file mode 100644
index 0000000..43df4ff
--- /dev/null
+++ b/man/Clarion.Rd
@@ -0,0 +1,64 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/clarion.R
+\docType{data}
+\name{Clarion}
+\alias{Clarion}
+\title{Clarion R6-class definition}
+\arguments{
+\item{header}{A named list. Defaults to NULL.}
+
+\item{metadata}{Clarion metadata in form of a data.table.}
+
+\item{data}{Data.table according to metadata.}
+
+\item{validate}{Logical value to validate on initialization. Defaults to TRUE.}
+}
+\description{
+Use this to create a clarion object.
+This object is used by all top-level wilson modules.
+}
+\section{Fields}{
+
+\describe{
+\item{\code{header}}{List of global information regarding the whole experiment.}
+
+\item{\code{metadata}}{Data.table with additional information for each column.}
+
+\item{\code{data}}{Data.table containing experiment result data.}
+}}
+
+\section{Methods}{
+
+\describe{
+ \item{\code{get_id()}}{
+ Returns name of unique identifier column. Assumes first feature to be unique if not specified.
+ }
+ \item{\code{get_name()}}{
+ Returns name of name column. If not specified return unique Id.
+ }
+ \item{\code{get_delimiter()}}{
+ Return delimiter used within multi-value fields (no delimiter = NULL).
+ }
+ \item{\code{is_delimited(x)}}{
+ Logical whether the given column name is delimited.
+ }
+ \item{\code{get_factors()}}{
+ Returns a data.table columns: key and factor(s) if any. Named factors (e.g. factor1="name") will be cropped to their name.
+ }
+ \item{\code{validate(solve = TRUE)}}{
+ Check the object for inconsistencies. For solve = TRUE try to resolve some warnings.
+ }
+ }
+}
+
+\examples{
+\dontrun{
+# initializing a new object
+object <- Clarion$new(header, metadata, data, validate = TRUE)
+
+# create a deep copy
+object_copy <- object$clone(deep = TRUE)
+}
+
+}
+\keyword{datasets}
diff --git a/man/categoricalPalettes.Rd b/man/categoricalPalettes.Rd
index da8e4f0..fbc0a82 100644
--- a/man/categoricalPalettes.Rd
+++ b/man/categoricalPalettes.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/colorPicker2.R
+% Please edit documentation in R/colorPicker.R
\name{categoricalPalettes}
\alias{categoricalPalettes}
\title{Function to generate categorical (qualitative) color palettes}
diff --git a/man/colorPicker.Rd b/man/colorPicker.Rd
index 515c07c..5581d4d 100644
--- a/man/colorPicker.Rd
+++ b/man/colorPicker.Rd
@@ -4,7 +4,8 @@
\alias{colorPicker}
\title{colorPicker module server logic}
\usage{
-colorPicker(input, output, session)
+colorPicker(input, output, session, num.colors = 256, distribution = "all",
+ winsorize = NULL, selected = NULL)
}
\arguments{
\item{input}{Shiny's input object}
@@ -12,15 +13,23 @@ colorPicker(input, output, session)
\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. Dynamically change lower and upper limit (supports reactive). Defaults to NULL.}
+
+\item{selected}{Set the default selected palette.}
}
\value{
-The \code{input} object.
+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 colorPicker module.
+Provides server logic for the colorPicker2 module.
}
-\section{To do}{
+\details{
+A custom colorpalette's return will be NULL if there is something wrong with it.
-Implement transparency calculation in case of one or more single colors.
+equalize will be returned as FALSE if not selected.
}
-
diff --git a/man/colorPicker2.Rd b/man/colorPicker2.Rd
deleted file mode 100644
index 0d87a9d..0000000
--- a/man/colorPicker2.Rd
+++ /dev/null
@@ -1,35 +0,0 @@
-% 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
deleted file mode 100644
index 576b2d3..0000000
--- a/man/colorPicker2UI.Rd
+++ /dev/null
@@ -1,32 +0,0 @@
-% 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
index 13db175..2c2260a 100644
--- a/man/colorPickerUI.Rd
+++ b/man/colorPickerUI.Rd
@@ -4,24 +4,24 @@
\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)
+colorPickerUI(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{choices}{A character vector with choices for the color scheme dropdown. See \code{\link[shiny]{selectInput}}.}
+\item{custom}{Boolean if TRUE custom colors can be selected (Default = FALSE).}
-\item{selected.choice}{The initially selected value(s) of the dropdown. If NULL (default), the first value of schemes will be taken.}
+\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.}
+\item{show.reverse}{Logical, whether or not to show the reverse switch (Default = TRUE).}
-\item{show.transparency}{Logical, whether or not to show the transparency slider.}
+\item{show.scaleoptions}{Logical, whether or not to show color scaling option winsorize (Default = TRUE).}
-\item{single.colors}{Logical, whether or not to make a single color chooser. (Only if length(label) == 1 needed)}
+\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}}.
@@ -30,13 +30,3 @@ A list with HTML tags from \code{\link[shiny]{tag}}.
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
index 886804c..5f08b90 100644
--- a/man/columnSelector.Rd
+++ b/man/columnSelector.Rd
@@ -5,7 +5,7 @@
\title{columnSelector module server logic}
\usage{
columnSelector(input, output, session, type.columns, type = NULL,
- columnTypeLabel = "Type of Column", labelLabel = "Label",
+ column.type.label = "Type of Column", label.label = "Label",
multiple = TRUE, none = FALSE, sep = ", ", suffix = NULL)
}
\arguments{
@@ -16,27 +16,27 @@ columnSelector(input, output, session, type.columns, type = NULL,
\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)}
+key = columnnames (id)
+level = datalevel/ type of column
+label = optional, used instead of id
+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{column.type.label}{Changes the label of the first UI element}
-\item{labelLabel}{Change label above label text input.}
+\item{label.label}{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{sep}{Used to separate labels on multi value selection.}
-\item{suffix}{Added to label only on multiple = FALSE (supports reactive). Also uses sep as seperator.}
+\item{suffix}{Added to label only on multiple = FALSE (supports reactive). Also uses sep as separator.}
}
\value{
-Returns the input. As named list: names("type", "selectedColumns", "label")
+Returns the input. As named list: names("type", "selected_columns", "label")
}
\description{
columnSelector module server logic
diff --git a/man/columnSelectorUI.Rd b/man/columnSelectorUI.Rd
index a81a734..dca9df2 100644
--- a/man/columnSelectorUI.Rd
+++ b/man/columnSelectorUI.Rd
@@ -4,7 +4,7 @@
\alias{columnSelectorUI}
\title{columnSelector module UI representation}
\usage{
-columnSelectorUI(id, label = F, title = NULL)
+columnSelectorUI(id, label = FALSE, title = NULL)
}
\arguments{
\item{id}{The ID of the modules namespace.}
diff --git a/man/create_geneview.Rd b/man/create_geneview.Rd
index 8ca3d08..c4f7932 100644
--- a/man/create_geneview.Rd
+++ b/man/create_geneview.Rd
@@ -16,7 +16,7 @@ create_geneview(data, grouping, plot.type = "line", facet.target = "gene",
column1 : key
column2 : factor1}
-\item{plot.type}{String specifing which plot type is used c("box", "line", "violin", "bar").}
+\item{plot.type}{String specifying which plot type is used c("box", "line", "violin", "bar").}
\item{facet.target}{Target to plot on x-Axis c("gene", "condition").}
diff --git a/man/create_heatmap.Rd b/man/create_heatmap.Rd
index c425135..4686f1f 100644
--- a/man/create_heatmap.Rd
+++ b/man/create_heatmap.Rd
@@ -4,11 +4,12 @@
\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, scale = 1)
+create_heatmap(data, unitlabel = "auto", row.label = TRUE,
+ row.custom.label = NULL, column.label = TRUE,
+ column.custom.label = NULL, clustering = "none", clustdist = "auto",
+ clustmethod = "auto", colors = NULL, winsorize.colors = NULL,
+ plot.method = "static", width = "auto", height = "auto", ppi = 72,
+ scale = 1)
}
\arguments{
\item{data}{data.table containing plot data. First column contains row labels.}
diff --git a/man/create_pca.Rd b/man/create_pca.Rd
index fbb0e70..4426b10 100644
--- a/man/create_pca.Rd
+++ b/man/create_pca.Rd
@@ -4,19 +4,32 @@
\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,
- scale = 1)
+create_pca(data, color.group = NULL, color.title = NULL, palette = NULL,
+ shape.group = NULL, shape.title = NULL, shapes = c(15:25),
+ dimension.a = 1, dimension.b = 2, dimensions = 6, on.columns = TRUE,
+ labels = FALSE, custom.labels = NULL, pointsize = 2, labelsize = 3,
+ width = 28, height = 28, ppi = 72, scale = 1)
}
\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{color.group}{Vector of groups according to samples (= column names).}
-\item{dimensionB}{Number of dimension displayed on Y-Axis.}
+\item{color.title}{Title of the color legend.}
-\item{dimensions}{Number of dimesions to create.}
+\item{palette}{Vector of colors used for color palette.}
+
+\item{shape.group}{Vector of groups according to samples (= column names).}
+
+\item{shape.title}{Title of the shape legend.}
+
+\item{shapes}{Vector of shapes see \code{\link[graphics]{points}}. Will recycle/ cut off shapes if needed. Default = c(15:25)}
+
+\item{dimension.a}{Number of dimension displayed on X-Axis.}
+
+\item{dimension.b}{Number of dimension displayed on Y-Axis.}
+
+\item{dimensions}{Number of dimensions to create.}
\item{on.columns}{Boolean perform pca on columns or rows.}
diff --git a/man/create_scatterplot.Rd b/man/create_scatterplot.Rd
index 1eb26de..d219acd 100644
--- a/man/create_scatterplot.Rd
+++ b/man/create_scatterplot.Rd
@@ -4,25 +4,31 @@
\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", scale = 1)
+create_scatterplot(data, data.labels = NULL, data.hovertext = NULL,
+ transparency = 1, pointsize = 1, labelsize = 3, color = NULL,
+ x_label = "", y_label = "", z_label = "", density = TRUE,
+ line = TRUE, categorized = FALSE, highlight.data = NULL,
+ highlight.labels = NULL, highlight.hovertext = NULL,
+ highlight.color = "#FF0000", xlim = NULL, ylim = NULL,
+ colorbar.limits = NULL, width = "auto", height = "auto", ppi = 72,
+ plot.method = "static", scale = 1)
}
\arguments{
\item{data}{data.table containing plot data
column 1: id
column 2, 3(, 4): x, y(, z)}
+\item{data.labels}{Vector of labels used for data. Length has to be equal to nrow(data).}
+
+\item{data.hovertext}{Character vector with additional hovertext. Length has to be equal to nrow(data).}
+
\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{color}{Vector of colors used for color palette.}
\item{x_label}{Label x-Axis}
@@ -36,9 +42,11 @@ column 2, 3(, 4): x, y(, z)}
\item{categorized}{Z-Axis (if exists) as categories.}
-\item{highlight.data}{data.table containing data to highlight.}
+\item{highlight.data}{data.table containing data to highlight. Same structure as data.}
+
+\item{highlight.labels}{Vector of labels used for highlighted data. Length has to be equal to nrow(highlight.data).}
-\item{highlight.labels}{Vector of labels used for highlighted data.}
+\item{highlight.hovertext}{Character vector with additional hovertext. Length has to be equal to nrow(highlight.data).}
\item{highlight.color}{String with hexadecimal color-code.}
diff --git a/man/divergingPalettes.Rd b/man/divergingPalettes.Rd
index 8513548..d8d6211 100644
--- a/man/divergingPalettes.Rd
+++ b/man/divergingPalettes.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/colorPicker2.R
+% Please edit documentation in R/colorPicker.R
\name{divergingPalettes}
\alias{divergingPalettes}
\title{Function to generate diverging (two-sided) color palettes (e.g. for log2fc, zscore)}
diff --git a/man/download.Rd b/man/download.Rd
index d210e9f..ba92f84 100644
--- a/man/download.Rd
+++ b/man/download.Rd
@@ -24,7 +24,7 @@ download(file, filename, plot, width, height, ppi = 72, save_plot = TRUE,
\item{save_plot}{Logical if plot object should be saved as .RData.}
-\item{ui}{List of user inputs. Will be converted to Javascript Object Notation. See \code{\link[RJSONIO]{toJSON}}}
+\item{ui}{List of user inputs. Will be converted to JavaScript Object Notation. See \code{\link[RJSONIO]{toJSON}}}
}
\value{
See \code{\link[utils]{zip}}.
diff --git a/man/featureSelector.Rd b/man/featureSelector.Rd
index c52d853..6499180 100644
--- a/man/featureSelector.Rd
+++ b/man/featureSelector.Rd
@@ -4,8 +4,7 @@
\alias{featureSelector}
\title{featureSelector module server logic}
\usage{
-featureSelector(input, output, session, data, features = NULL,
- feature.grouping = NULL, delimiter = "|", multiple = TRUE,
+featureSelector(input, output, session, clarion, multiple = TRUE,
contains = FALSE, ranged = TRUE, step = 100, truncate = 30,
selection.default = "all")
}
@@ -16,13 +15,7 @@ featureSelector(input, output, session, data, features = NULL,
\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{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
\item{multiple}{Whether or not textual ORs should allow multiple selections. (Fills vector sequentially if needed)(Supports reactive)}
@@ -30,18 +23,18 @@ featureSelector(input, output, session, data, features = NULL,
\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{step}{Set numeric ORs number of 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).
+Reactive containing names list: Selected data as reactive containing clarion object (object). 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.
+Keep in mind that the order of features (columns in clarion$data) is the order in which multiple, contains, ranged and step are evaluated.
}
diff --git a/man/featureSelectorGuide.Rd b/man/featureSelectorGuide.Rd
index 1bdba64..0871913 100644
--- a/man/featureSelectorGuide.Rd
+++ b/man/featureSelectorGuide.Rd
@@ -4,12 +4,10 @@
\alias{featureSelectorGuide}
\title{featureSelector module guide}
\usage{
-featureSelectorGuide(session, grouping = FALSE)
+featureSelectorGuide(session)
}
\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.
diff --git a/man/forceArgs.Rd b/man/forceArgs.Rd
new file mode 100644
index 0000000..5c83a7b
--- /dev/null
+++ b/man/forceArgs.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/function.R
+\name{forceArgs}
+\alias{forceArgs}
+\title{Force evaluation of the parent function's arguments.}
+\usage{
+forceArgs(args)
+}
+\arguments{
+\item{args}{List of Argument names to force evaluation. Defaults to all named arguments see \code{\link[base]{match.call}}.}
+}
+\description{
+Force evaluation of the parent function's arguments.
+}
+\details{
+Similar to \code{\link[base]{forceAndCall}} but used from within the respective function.
+
+This method is not using \code{\link[base]{force}} as it is restricted to it's calling environment. Instead \code{\link[base]{get}} is used.
+}
diff --git a/man/geneView.Rd b/man/geneView.Rd
index b8e755d..882f0ce 100644
--- a/man/geneView.Rd
+++ b/man/geneView.Rd
@@ -4,9 +4,9 @@
\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, scale = 1)
+geneView(input, output, session, clarion, plot.method = "static",
+ label.sep = ", ", width = "auto", height = "auto", ppi = 72,
+ scale = 1)
}
\arguments{
\item{input}{Shiny's input object.}
@@ -15,23 +15,11 @@ geneView(input, output, session, data, metadata, level = NULL,
\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{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
\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{label.sep}{Separator used for label merging (Default = ", ").}
\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.}
diff --git a/man/geneViewGuide.Rd b/man/geneViewGuide.Rd
index 8470d5e..dab0b44 100644
--- a/man/geneViewGuide.Rd
+++ b/man/geneViewGuide.Rd
@@ -4,12 +4,10 @@
\alias{geneViewGuide}
\title{geneView module guide}
\usage{
-geneViewGuide(session, label = FALSE)
+geneViewGuide(session)
}
\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.
diff --git a/man/global_cor_heatmap.Rd b/man/global_cor_heatmap.Rd
index 80e86b8..cf0d13e 100644
--- a/man/global_cor_heatmap.Rd
+++ b/man/global_cor_heatmap.Rd
@@ -4,9 +4,8 @@
\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,
- scale = 1)
+global_cor_heatmap(input, output, session, clarion, plot.method = "static",
+ width = "auto", height = "auto", ppi = 72, scale = 1)
}
\arguments{
\item{input}{Shiny's input object}
@@ -15,13 +14,7 @@ global_cor_heatmap(input, output, session, data, types,
\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{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
\item{plot.method}{Choose which method is used for plotting. Either "static" or "interactive" (Default = "static").}
diff --git a/man/heatmap.Rd b/man/heatmap.Rd
index 077dbf4..e26c853 100644
--- a/man/heatmap.Rd
+++ b/man/heatmap.Rd
@@ -4,9 +4,9 @@
\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, scale = 1)
+heatmap(input, output, session, clarion, plot.method = "static",
+ label.sep = ", ", width = "auto", height = "auto", ppi = 72,
+ scale = 1)
}
\arguments{
\item{input}{Shiny's input object}
@@ -15,19 +15,11 @@ heatmap(input, output, session, data, types, plot.method = "static",
\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{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
\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{label.sep}{Separator used for label merging (Default = ", ").}
\item{width}{Width of the plot in cm. Defaults to minimal size for readable labels and supports reactive.}
diff --git a/man/heatmapGuide.Rd b/man/heatmapGuide.Rd
index b5b6967..207ec23 100644
--- a/man/heatmapGuide.Rd
+++ b/man/heatmapGuide.Rd
@@ -4,12 +4,10 @@
\alias{heatmapGuide}
\title{heatmap module guide}
\usage{
-heatmapGuide(session, custom.row.label = FALSE)
+heatmapGuide(session)
}
\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.
diff --git a/man/label.Rd b/man/label.Rd
index 45da611..6db0f24 100644
--- a/man/label.Rd
+++ b/man/label.Rd
@@ -21,11 +21,11 @@ label(input, output, session, data, label = "Select label columns",
\item{multiple}{Allow multiple selection which will be merged with sep (default = TRUE).}
-\item{sep}{Seperator used to collapse selection (default = ", ").}
+\item{sep}{Separator 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{unique_sep}{Separator used for unique (default = "_"). Should differ from sep.}
\item{disable}{Reactive containing boolean. To disable/ enable module.}
}
diff --git a/man/marker.Rd b/man/marker.Rd
index c8bf5fb..db5689c 100644
--- a/man/marker.Rd
+++ b/man/marker.Rd
@@ -4,7 +4,7 @@
\alias{marker}
\title{marker module server logic}
\usage{
-marker(input, output, session, highlight.labels)
+marker(input, output, session, clarion)
}
\arguments{
\item{input}{Shiny's input object.}
@@ -13,10 +13,10 @@ marker(input, output, session, highlight.labels)
\item{session}{Shiny's session object.}
-\item{highlight.labels}{Data.table from which labels are provided (Supports reactive).}
+\item{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
}
\value{
-A reactive which contains a named list (highlight, color, labelColumn, label).
+A named list containing reactives (highlight, color, labelColumn, label, clarion).
}
\description{
marker module server logic
diff --git a/man/orNumeric.Rd b/man/orNumeric.Rd
index 329c270..ee9a85e 100644
--- a/man/orNumeric.Rd
+++ b/man/orNumeric.Rd
@@ -5,8 +5,8 @@
\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)),
+ 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{
diff --git a/man/parse_MaxQuant.Rd b/man/parse_MaxQuant.Rd
index 364d969..300c565 100644
--- a/man/parse_MaxQuant.Rd
+++ b/man/parse_MaxQuant.Rd
@@ -38,7 +38,7 @@ For example:
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.
+Anything else like 'Intensity;ex' or 'Intensity;' results in writing both.
Only works if there are samples of that type. If not, column does not show up in file
}
\author{
diff --git a/man/parser.Rd b/man/parser.Rd
index 4700c2b..6c17acb 100644
--- a/man/parser.Rd
+++ b/man/parser.Rd
@@ -12,7 +12,7 @@ parser(file, dec = ".")
\item{dec}{The decimal separator. See \code{\link[data.table]{fread}}.}
}
\value{
-named list containing list(header = list(), metadata = data.table, data = data.table)
+Clarion object. See \code{\link[wilson]{Clarion}}
}
\description{
Method to parse input file.
diff --git a/man/pca.Rd b/man/pca.Rd
index eee0778..4d7571a 100644
--- a/man/pca.Rd
+++ b/man/pca.Rd
@@ -4,8 +4,8 @@
\alias{pca}
\title{pca module server logic}
\usage{
-pca(input, output, session, data, types, levels = NULL, entryLabel = NULL,
- width = 28, height = 28, ppi = 72, scale = 1)
+pca(input, output, session, clarion, width = 28, height = 28, ppi = 72,
+ scale = 1)
}
\arguments{
\item{input}{Shiny's input object}
@@ -14,17 +14,7 @@ pca(input, output, session, data, types, levels = NULL, entryLabel = NULL,
\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{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (Supports reactive)}
\item{width}{Width of the plot in cm. Defaults to 28 and supports reactive.}
diff --git a/man/scatterPlot.Rd b/man/scatterPlot.Rd
index 7d7489b..7adce15 100644
--- a/man/scatterPlot.Rd
+++ b/man/scatterPlot.Rd
@@ -4,8 +4,7 @@
\alias{scatterPlot}
\title{scatterPlot module server logic}
\usage{
-scatterPlot(input, output, session, data, types, x.names = NULL,
- y.names = NULL, z.names = NULL, features = NULL, markerReac = NULL,
+scatterPlot(input, output, session, clarion, marker.output = NULL,
plot.method = "static", width = "auto", height = "auto", ppi = 72,
scale = 1)
}
@@ -16,23 +15,9 @@ scatterPlot(input, output, session, data, types, x.names = NULL,
\item{session}{Shiny's session object}
-\item{data}{data.table data visualized in plot (Supports reactive).}
+\item{clarion}{A clarion object. See \code{\link[wilson]{Clarion}}. (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{x.names}{Character vector of column names(data column names) which will be available for x-axis. Can be reactive.}
-
-\item{y.names}{Character vector of column names(data column names) which will be available for y-axis. Can be reactive.}
-
-\item{z.names}{Character vector of column names(data column names) which will be available for z-axis. Can be reactive.}
-
-\item{features}{data.table of the features to mark (first column = id)}
-
-\item{markerReac}{reactive containing inputs of marker module.}
+\item{marker.output}{Marker module output. See \code{\link[wilson]{marker}}.}
\item{plot.method}{Choose to rather render a 'interactive' or 'static' plot. Defaults to 'static'.}
@@ -51,5 +36,7 @@ Returns reactive containing data used for plot.
scatterPlot module server logic
}
\details{
-Make sure to have the same columnnames in data and features.
+As markerOutput provides a second dataset used for highlighting it is crucial for it to have the same columnnames as the dataset provided by clarion.
+
+Intersections between marker and clarion will be removed from clarion in favor of highlighting them.
}
diff --git a/man/sequentialPalettes.Rd b/man/sequentialPalettes.Rd
index 3ac8f99..b22d2dd 100644
--- a/man/sequentialPalettes.Rd
+++ b/man/sequentialPalettes.Rd
@@ -1,5 +1,5 @@
% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/colorPicker2.R
+% Please edit documentation in R/colorPicker.R
\name{sequentialPalettes}
\alias{sequentialPalettes}
\title{Function to generate sequential (one-sided) color palettes (e.g. for expression, enrichment)}
diff --git a/revdep/README.md b/revdep/README.md
new file mode 100644
index 0000000..3b38cae
--- /dev/null
+++ b/revdep/README.md
@@ -0,0 +1,56 @@
+# Setup
+
+## Platform
+
+|setting |value |
+|:--------|:----------------------------|
+|version |R version 3.5.0 (2018-04-23) |
+|system |x86_64, mingw32 |
+|ui |RStudio (1.2.747) |
+|language |(EN) |
+|collate |German_Germany.1252 |
+|tz |Europe/Berlin |
+|date |2018-06-29 |
+
+## Packages
+
+|package |* |version |date |source |
+|:---------------|:--|:-------|:----------|:-----------------------------------|
+|circlize | |0.4.4 |2018-06-10 |CRAN (R 3.5.0) |
+|colourpicker | |1.0 |2017-09-27 |CRAN (R 3.5.0) |
+|ComplexHeatmap | |1.18.1 |2018-06-19 |Bioconductor (R 3.5.0) |
+|data.table | |1.11.4 |2018-05-27 |CRAN (R 3.5.0) |
+|DESeq2 | |1.20.0 |2018-05-01 |Bioconductor |
+|DT | |0.4 |2018-01-30 |CRAN (R 3.5.0) |
+|factoextra | |1.0.5 |2017-08-22 |CRAN (R 3.5.0) |
+|FactoMineR | |1.41 |2018-05-04 |CRAN (R 3.5.0) |
+|ggplot2 | |2.2.1 |2016-12-30 |CRAN (R 3.5.0) |
+|ggrepel | |0.8.0 |2018-05-09 |CRAN (R 3.5.0) |
+|gplots | |3.0.1 |2016-03-30 |CRAN (R 3.5.0) |
+|heatmaply | |0.15.0 |2018-06-23 |CRAN (R 3.5.0) |
+|log4r | |0.2 |2014-09-29 |CRAN (R 3.5.0) |
+|openssl | |1.0.1 |2018-03-03 |CRAN (R 3.5.0) |
+|plotly | |4.7.1 |2017-07-29 |CRAN (R 3.5.0) |
+|plyr | |1.8.4 |2016-06-08 |CRAN (R 3.5.0) |
+|R6 | |2.2.2 |2017-06-17 |CRAN (R 3.5.0) |
+|RColorBrewer | |1.1-2 |2014-12-07 |CRAN (R 3.5.0) |
+|reshape | |0.8.7 |2017-08-06 |CRAN (R 3.5.0) |
+|rintrojs | |0.2.0 |2017-07-04 |CRAN (R 3.5.0) |
+|rje | |1.9 |2014-08-06 |CRAN (R 3.5.0) |
+|rjson | |0.2.20 |2018-06-08 |CRAN (R 3.5.0) |
+|RJSONIO | |1.3-0 |2014-07-28 |CRAN (R 3.5.0) |
+|scales | |0.5.0 |2017-08-24 |CRAN (R 3.5.0) |
+|shiny | |1.1.0 |2018-05-17 |CRAN (R 3.5.0) |
+|shinycssloaders | |0.2.0 |2017-05-12 |CRAN (R 3.5.0) |
+|shinydashboard | |0.7.0 |2018-03-21 |CRAN (R 3.5.0) |
+|shinyjs | |1.0 |2018-01-08 |CRAN (R 3.5.0) |
+|viridis | |0.5.1 |2018-03-29 |CRAN (R 3.5.0) |
+|wilson | |2.0.0 |2018-06-29 |local (HendrikSchultheis/wilson@NA) |
+
+# Check results
+
+0 packages
+
+
+
+
diff --git a/revdep/checks.rds b/revdep/checks.rds
new file mode 100644
index 0000000..dc78959
Binary files /dev/null and b/revdep/checks.rds differ
diff --git a/revdep/problems.md b/revdep/problems.md
new file mode 100644
index 0000000..368348c
--- /dev/null
+++ b/revdep/problems.md
@@ -0,0 +1,56 @@
+# Setup
+
+## Platform
+
+|setting |value |
+|:--------|:----------------------------|
+|version |R version 3.5.0 (2018-04-23) |
+|system |x86_64, mingw32 |
+|ui |RStudio (1.2.747) |
+|language |(EN) |
+|collate |German_Germany.1252 |
+|tz |Europe/Berlin |
+|date |2018-06-29 |
+
+## Packages
+
+|package |* |version |date |source |
+|:---------------|:--|:-------|:----------|:-----------------------------------|
+|circlize | |0.4.4 |2018-06-10 |CRAN (R 3.5.0) |
+|colourpicker | |1.0 |2017-09-27 |CRAN (R 3.5.0) |
+|ComplexHeatmap | |1.18.1 |2018-06-19 |Bioconductor (R 3.5.0) |
+|data.table | |1.11.4 |2018-05-27 |CRAN (R 3.5.0) |
+|DESeq2 | |1.20.0 |2018-05-01 |Bioconductor |
+|DT | |0.4 |2018-01-30 |CRAN (R 3.5.0) |
+|factoextra | |1.0.5 |2017-08-22 |CRAN (R 3.5.0) |
+|FactoMineR | |1.41 |2018-05-04 |CRAN (R 3.5.0) |
+|ggplot2 | |2.2.1 |2016-12-30 |CRAN (R 3.5.0) |
+|ggrepel | |0.8.0 |2018-05-09 |CRAN (R 3.5.0) |
+|gplots | |3.0.1 |2016-03-30 |CRAN (R 3.5.0) |
+|heatmaply | |0.15.0 |2018-06-23 |CRAN (R 3.5.0) |
+|log4r | |0.2 |2014-09-29 |CRAN (R 3.5.0) |
+|openssl | |1.0.1 |2018-03-03 |CRAN (R 3.5.0) |
+|plotly | |4.7.1 |2017-07-29 |CRAN (R 3.5.0) |
+|plyr | |1.8.4 |2016-06-08 |CRAN (R 3.5.0) |
+|R6 | |2.2.2 |2017-06-17 |CRAN (R 3.5.0) |
+|RColorBrewer | |1.1-2 |2014-12-07 |CRAN (R 3.5.0) |
+|reshape | |0.8.7 |2017-08-06 |CRAN (R 3.5.0) |
+|rintrojs | |0.2.0 |2017-07-04 |CRAN (R 3.5.0) |
+|rje | |1.9 |2014-08-06 |CRAN (R 3.5.0) |
+|rjson | |0.2.20 |2018-06-08 |CRAN (R 3.5.0) |
+|RJSONIO | |1.3-0 |2014-07-28 |CRAN (R 3.5.0) |
+|scales | |0.5.0 |2017-08-24 |CRAN (R 3.5.0) |
+|shiny | |1.1.0 |2018-05-17 |CRAN (R 3.5.0) |
+|shinycssloaders | |0.2.0 |2017-05-12 |CRAN (R 3.5.0) |
+|shinydashboard | |0.7.0 |2018-03-21 |CRAN (R 3.5.0) |
+|shinyjs | |1.0 |2018-01-08 |CRAN (R 3.5.0) |
+|viridis | |0.5.1 |2018-03-29 |CRAN (R 3.5.0) |
+|wilson | |2.0.0 |2018-06-29 |local (HendrikSchultheis/wilson@NA) |
+
+# Check results
+
+0 packages with problems
+
+
+
+
diff --git a/revdep/timing.md b/revdep/timing.md
new file mode 100644
index 0000000..59483ca
--- /dev/null
+++ b/revdep/timing.md
@@ -0,0 +1,5 @@
+# Check times
+
+
+
+