Merge pull request #8 from HendrikSchultheis/package_version

Patch No.1
loosolab · Mar 9, 2018 · 209f7e7 · 209f7e7
2 parents d770d31 + 0d2af65
commit 209f7e7
Show file tree

Hide file tree

Showing 16 changed files with 66 additions and 46 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -46,6 +46,8 @@ Imports: shiny,
     shinyBS,
     shinythemes,
     shinycssloaders,
-    log4r
+    log4r,
+    openssl,
+    methods
 RoxygenNote: 6.0.1
 biocViews:
diff --git a/R/and.R b/R/and.R
@@ -37,7 +37,7 @@ 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
+  # handle reactive data
   data.r <- shiny::reactive({
     if(shiny::is.reactive(data)){
       data()
@@ -60,7 +60,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
     return(show.elements)
   })
 
-  #handle reactive grouping
+  # handle reactive grouping
   element.grouping.r <- shiny::reactive({
     if(shiny::is.reactive(element.grouping)){
       element.grouping()
@@ -70,41 +70,41 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
   })
 
   parameter <- shiny::reactive({
-    #get column labels
+    # get column labels
     if(is.null(column.labels)){
       column.labels <- names(data.r())
     }else{
       column.labels <- column.labels
     }
-    #fill multiple if vector is too small
+    # fill multiple if vector is too small
     if(shiny::is.reactive(multiple)) {
       multiple <- multiple()
     }
     if (length(multiple) < ncol(data.r())) {
       multiple <- rep(multiple, length.out = ncol(data.r()))
     }
-    #fill contains if vector is too small
+    # fill contains if vector is too small
     if(shiny::is.reactive(contains)) {
       contains <- contains()
     }
     if (length(contains) < ncol(data.r())) {
       contains <- rep(contains, length.out = ncol(data.r()))
     }
-    #fill ranged if vector is too small
+    # fill ranged if vector is too small
     if(shiny::is.reactive(ranged)) {
       ranged <- ranged()
     }
     if (length(ranged) < ncol(data.r())) {
       ranged <- rep(ranged, length.out = ncol(data.r()))
     }
-    #fill delimiter if vector is too small
+    # fill delimiter if vector is too small
     if(shiny::is.reactive(delimiter)) {
       delimiter <- delimiter()
     }
     if (length(delimiter) < ncol(data.r()) & !is.null(delimiter)) {
       delimiter <- rep(delimiter, length.out = ncol(data.r()))
     }
-    #fill step if vector is too small
+    # fill step if vector is too small
     if(shiny::is.reactive(step)) {
       step <- step()
     }
@@ -116,7 +116,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
   })
 
   output$and <- shiny::renderUI({
-    #new progress indicator
+    # new progress indicator
     progress <- shiny::Progress$new()
     on.exit(progress$close())
     progress$set(0, message = "Render orModules:")
@@ -139,18 +139,18 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
           progress$inc(step, detail = x)
 
           if(is.numeric(data[[x]])){
-            ui <- orNumericUI(id = session$ns(paste0("orN-", make.names(x))))
+            ui <- orNumericUI(id = session$ns(openssl::sha1(x)))
           }else{
-            ui <- orTextualUI(id = session$ns(paste0("orT-", make.names(x))))
+            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]),
@@ -167,19 +167,19 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
       return <- lapply(1:ncol(data), function(x) {
         progress$inc(step, detail = names(data)[x])
         if (is.numeric(data[[x]])) {
-          ui <- orNumericUI(id = session$ns(paste0("orN-", make.names(names(data)[x]))))
+          ui <- orNumericUI(id = session$ns(openssl::sha1(names(data)[x])))
 
         } else{
-          ui <- orTextualUI(id = session$ns(paste0("orT-", make.names(names(data)[x]))))
+          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]),
@@ -190,7 +190,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
       })
     }
 
-    #initialize new modules
+    # initialize new modules
     modules()
 
     shiny::tagList(return)
@@ -199,7 +199,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
   # initialize or modules
   # returns a vector containing modules
   modules <- shiny::reactive({
-    #new progress indicator
+    # new progress indicator
     progress <- shiny::Progress$new()
     on.exit(progress$close())
     progress$set(0, message = "Filtering Module:")
@@ -211,7 +211,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
         if (parameter()$ranged[x]) {
           shiny::callModule(
             module = orNumeric,
-            id = paste0("orN-", make.names(names(data.r())[x])),
+            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],
@@ -223,7 +223,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
         } else{
           shiny::callModule(
             module = orNumeric,
-            id = paste0("orN-", make.names(names(data.r())[x])),
+            id = openssl::sha1(names(data.r())[x]),
             choices = data.r()[[x]],
             value = mean(data.r()[[x]], na.rm = TRUE),
             label = parameter()$column.labels[x],
@@ -236,7 +236,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
       } else{
         shiny::callModule(
           module = orTextual,
-          id = paste0("orT-", make.names(names(data.r())[x])),
+          id = openssl::sha1(names(data.r())[x]),
           choices = data.r()[[x]],
           label = parameter()$column.labels[x],
           delimiter = parameter()$delimiter[x],
@@ -249,7 +249,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
   })
 
   selection <- shiny::reactive({
-    #new progress indicator
+    # new progress indicator
     progress <- shiny::Progress$new()
     on.exit(progress$close())
     progress$set(0, message = "Apply Filter")
@@ -259,7 +259,7 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
     or.modules <- modules()
 
     step <- 0.9 / length(or.modules)
-    #OR modules selection
+    # OR modules selection
     or.selection.bool <- sapply(or.modules, function(x) {
       progress$inc(step, detail = x()$label)
       x()$bool
@@ -270,12 +270,12 @@ and <- function(input, output, session, data, show.elements = NULL, element.grou
       }
     })
 
-    #cast to matrix if sapply returns vector
+    # 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)
+    # selected rows (and selection)
     and.selection.bool <- apply(or.selection.bool, 1, all)
 
     or.selection.text <- unlist(or.selection.text)

diff --git a/R/featureSelector.R b/R/featureSelector.R
@@ -34,7 +34,7 @@ featureSelectorUI <- function(id){
           ),
           shiny::div(id = ns("guide_and"),
                      shiny::br(),
-                     shiny::uiOutput(ns("and.container"))
+                     shiny::uiOutput(ns("and_container"))
                      )
         )
       )
@@ -64,7 +64,7 @@ featureSelectorUI <- function(id){
 #'
 #' @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
+  # handle reactive data
   data.r <- shiny::reactive({
     if(shiny::is.reactive(data)){
       data.table::copy(data())
@@ -73,7 +73,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
     }
   })
 
-  #handle reactive features
+  # handle reactive features
   features.r <- shiny::reactive({
     if(is.null(features)){
       names(data.r())
@@ -90,7 +90,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
     }
   })
 
-  #handle reactive grouping
+  # handle reactive grouping
   feature.grouping.r <- shiny::reactive({
     if(shiny::is.reactive(feature.grouping)){
       feature.grouping()
@@ -149,13 +149,13 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
     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)
   })
 
-  #Fetch reactive guide for this module
+  # Fetch reactive guide for this module
   guide <- featureSelectorGuide(session, !is.null(feature.grouping))
   shiny::observeEvent(input$guide, {
     rintrojs::introjs(session, options = list(steps = guide(), scrollToElement = FALSE))
   })
 
-  output$and.container <- shiny::renderUI({
+  output$and_container <- shiny::renderUI({
     andUI(session$ns("and"))
   })
 
@@ -172,7 +172,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
+            # 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"))
           )
@@ -223,7 +223,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
     }
   })
 
-  output$table <- DT::renderDataTable(options = list(pageLength = 5, scrollX = TRUE, deferRender = TRUE, processing = FALSE, #deferRender = only render visible part of table
+  output$table <- DT::renderDataTable(options = list(pageLength = 5, scrollX = TRUE, deferRender = TRUE, processing = FALSE, # deferRender = only render visible part of table
                                                         columnDefs = list(list(
                                                           targets = "_all",
                                                           render = DT::JS(
@@ -266,7 +266,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
                        )
     }
 
-    #TODO add order information to filter
+    # TODO add order information to filter
 
     # search text
     if(!is.null(input$table_search)) {

diff --git 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) || is(logger, "logger")) {
+  if(is.null(logger) || methods::is(logger, "logger")) {
     assign(x = paste0("logger", token), value = logger, envir = wilson.globals)
   }
 }
@@ -22,10 +22,12 @@ set_logger <- function(logger, token = NULL) {
 #' @param level Set priority level of the message (number or character). See \code{\link[log4r]{levellog}}.
 #' @param token Use token bound to this identifier.
 #'
+#' @details Does nothing if logger doesn't exist.
+#'
 log_message <- function(message, level = c("DEBUG", "INFO", "WARN", "ERROR", "FATAL"), token = NULL) {
-  logger <- get(paste0("logger", token), envir = wilson.globals)
+  if(exists(paste0("logger", token), envir = wilson.globals)) {
+    logger <- get(paste0("logger", token), envir = wilson.globals)
 
-  if(!is.null(logger)) {
     switch(level,
       DEBUG = log4r::debug(logger, message),
       INFO = log4r::info(logger, message),

diff --git a/R/heatmap.R b/R/heatmap.R
@@ -346,7 +346,7 @@ heatmap <- function(input, output, session, data, types, plot.method = "static",
           plot <- plot()$plot
 
           # handle error
-          if(is(plot, "try-error")) {
+          if(methods::is(plot, "try-error")) {
             # TODO add logging
             stop("An error occured! Please try a different dataset.")
           }

diff --git a/R/pca.R b/R/pca.R
@@ -120,6 +120,7 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
       }
     }
   })
+
   # handle reactive sizes
   size <- shiny::reactive({
     width <- ifelse(shiny::is.reactive(width), width(), width)
@@ -171,9 +172,12 @@ pca <- function(input, output, session, data, types, levels = NULL, entryLabel =
     shiny::selectInput(session$ns("select"), label = "select data level", choices = unique(levels.r()))
   })
 
-  #update dimension inputs
+  # 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")
 

diff --git a/R/scatterPlot.R b/R/scatterPlot.R
@@ -327,7 +327,7 @@ scatterPlot <- function(input, output, session, data, types, x.names = NULL, y.n
 
   # disable plot if mandatory x- or y-axis missing
   shiny::observe({
-    if(!isTruthy(xaxis$selectedColumn()) || !isTruthy(yaxis$selectedColumn())) {
+    if(!shiny::isTruthy(xaxis$selectedColumn()) || !shiny::isTruthy(yaxis$selectedColumn())) {
       shinyjs::disable("plot")
     } else {
       shinyjs::enable("plot")

diff --git a/exec/and_example.R b/exec/and_example.R
@@ -3,6 +3,7 @@ source("../R/and.R")
 source("../R/orNumeric.R")
 source("../R/orTextual.R")
 source("../R/function.R")
+source("../R/global.R")
 
 ###Test Data
 table <- data.table::data.table(w = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 11),
@@ -34,7 +35,7 @@ server <- function(input, output, session) {
     table
   })
 
-  mod <-callModule(and, "id", data = data, show.elements = reactive(input$column), delimiter = delimiter, multiple = multiple, contains = contains, ranged = ranged, step = step, selection.default = "all", reset = reactive(input$reset))
+  mod <-callModule(and, "id", data = data, show.elements = reactive(input$column), delimiter = delimiter, multiple = multiple, contains = contains, ranged = ranged, step = step, reset = reactive(input$reset))
 
   output$id.out <- renderPrint({
     print(mod())

diff --git a/exec/featureSelector_example.R b/exec/featureSelector_example.R
@@ -5,6 +5,7 @@ source("../R/orNumeric.R")
 source("../R/orTextual.R")
 source("../R/featureSelector.R")
 source("../R/function.R")
+source("../R/global.R")
 
 # test data
 data <- data.table::as.data.table(mtcars, keep.rowname = "id")

diff --git a/exec/geneView_example.R b/exec/geneView_example.R
@@ -8,6 +8,7 @@ source("../R/geneView.R")
 source("../R/columnSelector.R")
 source("../R/label.R")
 source("../R/limit.R")
+source("../R/global.R")
 
 ####Test Data
 data <- data.table::data.table(id = rownames(mtcars), names = rownames(mtcars), mtcars)

diff --git a/exec/global_cor_heatmap_example.R b/exec/global_cor_heatmap_example.R
@@ -6,6 +6,7 @@ source("../R/columnSelector.R")
 source("../R/transformation.R")
 source("../R/global_cor_heatmap.R")
 source("../R/limit.R")
+source("../R/global.R")
 
 # test data
 data <- data.table::as.data.table(mtcars, keep.rowname = "id")