Merge pull request #32 from HendrikSchultheis/transformation

Transformation

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: wilson
 Type: Package
 Title: Web-Based Interactive Omics Visualization
-Version: 2.0.2
+Version: 2.0.3
 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"),
@@ -46,7 +46,7 @@ Imports: shiny,
     openssl,
     methods,
     R6
-RoxygenNote: 6.1.0
+RoxygenNote: 6.1.1
 biocViews: 
 Suggests: knitr,
     rmarkdown,

NEWS.md

@@ -1,3 +1,5 @@
+# wilson 2.0.3
+- reactive transformation parameter
 # wilson 2.0.2
 - fixed CRAN check Note/ Error
 # wilson 2.0.1

R/geneView.R

@@ -143,7 +143,7 @@ geneView <- function(input, output, session, clarion, plot.method = "static", la
 
   # 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])))
+  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])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == selector$selected_columns()[1]][["level"]] == "contrast", 0, 1)))
   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)
@@ -182,7 +182,7 @@ geneView <- function(input, output, session, clarion, plot.method = "static", la
     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])))
+    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])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == selector$selected_columns()[1]][["level"]] == "contrast", 0, 1)))
     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)

R/global_cor_heatmap.R

@@ -207,7 +207,7 @@ global_cor_heatmap <- function(input, output, session, clarion, plot.method = "s
 
   # load internal modules
   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])))
+  transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == columns$selected_columns()[1]][["level"]] == "contrast", 0, 1)), replaceNA = FALSE)
   color <- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1])))
 
   # load dynamic ui
@@ -235,7 +235,7 @@ global_cor_heatmap <- function(input, output, session, clarion, plot.method = "s
     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])))
+    transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == columns$selected_columns()[1]][["level"]] == "contrast", 0, 1)), replaceNA = FALSE)
     color <<- shiny::callModule(colorPicker, "color", distribution = shiny::reactive(tolower(input$distribution)), winsorize = shiny::reactive(equalize(result_data()[, -1])))
     clear_plot(TRUE)
   })

R/heatmap.R

@@ -155,7 +155,7 @@ heatmap <- function(input, output, session, clarion, plot.method = "static", lab
 
   # 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])))
+  transform <- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == columns$selected_columns()[1]][["level"]] == "contrast", 0, 1)), replaceNA = 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))
 
@@ -177,7 +177,7 @@ heatmap <- function(input, output, session, clarion, plot.method = "static", lab
     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])))
+    transform <<- shiny::callModule(transformation, "transform", data = shiny::reactive(as.matrix(object()$data[, columns$selected_columns(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == columns$selected_columns()[1]][["level"]] == "contrast", 0, 1)), replaceNA = 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)

R/scatterPlot.R

@@ -187,8 +187,8 @@ scatterPlot <- function(input, output, session, clarion, marker.output = NULL, p
   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_x <- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(object()$data[, xaxis$selected_column(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == xaxis$selected_column()][["level"]] == "contrast", 0, 1)))
+  transform_y <- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(object()$data[, yaxis$selected_column(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == yaxis$selected_column()][["level"]] == "contrast", 0, 1)))
   # transform highlight data
   if (!is.null(marker.output)) {
     # note: same id as transform_x/y so it depends on same ui
@@ -223,8 +223,8 @@ scatterPlot <- function(input, output, session, clarion, marker.output = NULL, p
     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_x <<- shiny::callModule(transformation, "transform_x", data = shiny::reactive(as.matrix(object()$data[, xaxis$selected_column(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == xaxis$selected_column()][["level"]] == "contrast", 0, 1)))
+    transform_y <<- shiny::callModule(transformation, "transform_y", data = shiny::reactive(as.matrix(object()$data[, yaxis$selected_column(), with = FALSE])), pseudocount = shiny::reactive(ifelse(object()$metadata[key == yaxis$selected_column()][["level"]] == "contrast", 0, 1)))
     # transform highlight data
     if (!is.null(marker.output)) {
       # note: same id as transform_x/y so it depends on same ui

R/transformation.R

@@ -37,10 +37,10 @@ transformationUI <- function(id, label = "Transformation", selected = "raw", cho
 #' @param output Shiny's output object.
 #' @param session Shiny's session object.
 #' @param data Numeric matrix on which transformation is performed (column-wise). (Supports reactive)
-#' @param transpose Whether the matrix should be transposed to enable row-wise transformation.
-#' @param pseudocount Numeric Variable to add a pseudocount to log-based transformations.
-#' @param replaceInf Change Infinite to NA, applied after transformation.
-#' @param replaceNA Change NA to 0, applied after transformation.
+#' @param transpose Whether the matrix should be transposed to enable row-wise transformation. (Supports reactive)
+#' @param pseudocount Numeric Variable to add a pseudocount to log-based transformations. (Supports reactive)
+#' @param replaceInf Change Infinite to NA, applied after transformation. (Supports reactive)
+#' @param replaceNA Change NA to 0, applied after transformation. (Supports reactive)
 #'
 #' @return Namedlist of two containing data and name of the used method.
 #'         data: Reactive containing the transformed matrix. Infinite values are replaced by NA and NA values are replaced by 0.
@@ -49,7 +49,7 @@ 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
+  # handle reactive parameter
   data_r <- shiny::reactive({
     if (shiny::is.reactive(data)) {
       data()
@@ -58,6 +58,38 @@ transformation <- function(input, output, session, data, transpose = FALSE, pseu
     }
   })
 
+  transpose_r <- shiny::reactive({
+    if (shiny::is.reactive(transpose)) {
+      transpose()
+    } else {
+      transpose
+    }
+  })
+
+  pseudocount_r <- shiny::reactive({
+    if (shiny::is.reactive(pseudocount)) {
+      pseudocount()
+    } else {
+      pseudocount
+    }
+  })
+
+  replaceInf_r <- shiny::reactive({
+    if (shiny::is.reactive(replaceInf)) {
+      replaceInf()
+    } else {
+      replaceInf
+    }
+  })
+
+  replaceNA_r <- shiny::reactive({
+    if (shiny::is.reactive(replaceNA)) {
+      replaceNA()
+    } else {
+      replaceNA
+    }
+  })
+
   # reset
   shinyjs::reset("transform")
   shinyjs::reset("transpose")
@@ -111,30 +143,31 @@ transformation <- function(input, output, session, data, transpose = FALSE, pseu
   transformed_data <- shiny::reactive({
     data <- data_r()
 
-    if (transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
+    if (transpose_r() | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
       data <- t(data)
     }
 
     # transform data
     output <- switch(input$transform,
-      log2 = log2(data + pseudocount),
-      `-log2` = -log2(data + pseudocount),
-      log10 = log10(data + pseudocount),
-      `-log10` = -log10(data + pseudocount),
+      log2 = log2(data + pseudocount_r()),
+      `-log2` = -log2(data + pseudocount_r()),
+      log10 = log10(data + pseudocount_r()),
+      `-log10` = -log10(data + pseudocount_r()),
       zscore = scale(data, center = TRUE, scale = TRUE),
-      rlog = try_rlog(round(data) + pseudocount),
+      rlog = try_rlog(round(data) + pseudocount_r()),
       raw = data
     )
 
     # replace infinite with NA & NA with 0
-    if (replaceInf) {
+    if (replaceInf_r()) {
       is.na(output) <- vapply(output, FUN = is.infinite, FUN.VALUE = logical(1))
     }
-    if (replaceNA) {
+
+    if (replaceNA_r()) {
       output[is.na(output)] <- 0
     }
 
-    if (transpose | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
+    if (transpose_r() | ifelse(!is.null(input$transpose), input$transpose == "row", FALSE) & input$transform == "zscore") {
       output <- t(output)
     }
 

exec/transformation_example.R

@@ -3,21 +3,32 @@ library(shiny)
 source("../R/transformation.R")
 
 ui <- fluidPage(
-  transformationUI(id = "id", transposeOptions = TRUE)
+  h3("Module UI"),
+  transformationUI(id = "id", transposeOptions = TRUE),
+  hr(),
+  h3("Input parameter"),
+  numericInput(inputId = "pseudocount", label = "Pseudocount", value = 1),
+  checkboxInput(inputId = "transpose", label = "Transpose"),
+  checkboxInput(inputId = "replaceInf", label = "replace Inf with NA", value = TRUE),
+  checkboxInput(inputId = "replaceNA", label = "replace NA with 0", value = TRUE),
+  hr(),
+  h3("Module output"),
+  verbatimTextOutput(outputId = "module_out")
 )
 
 server <- function(input, output) {
-  data_matrix <- matrix( 0:10, ncol = 10)
+  data_matrix <- matrix(c(0:9, 0:9), ncol = 10)
 
   data <- reactive({
     data_matrix
   })
 
-  mod <- callModule(transformation, "id", data, transpose = F, pseudocount = 0, replaceInf = T, replaceNA = T)
+  mod <- callModule(transformation, "id", data, transpose = reactive(input$transpose), pseudocount = reactive(input$pseudocount), replaceInf = reactive(input$replaceInf), replaceNA = reactive(input$replaceNA))
 
-  observe({
+  output$module_out <- renderPrint({
     print(mod$method())
     print(mod$data())
+    print(mod$transpose())
   })
 }