diff --git a/DESCRIPTION b/DESCRIPTION index 26aae51..cd6b0fe 100644 --- 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 index fc1afd0..492f551 100644 --- 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 index 16d3fba..8618491 100644 --- 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 index 3845d2f..d5ae871 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) || 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 index 4b4a691..dccdacc 100644 --- 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 index e3cd1da..249af4f 100644 --- 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 index 613ecba..82dc67e 100644 --- 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 index 6b9e494..146add7 100644 --- 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 index f699717..1d3cfa6 100644 --- 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 index 4441db5..10fac4a 100644 --- 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 index 01d31f5..215865a 100644 --- 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") diff --git a/exec/heatmap_example.R b/exec/heatmap_example.R index 9f32763..6f65148 100644 --- a/exec/heatmap_example.R +++ b/exec/heatmap_example.R @@ -8,6 +8,7 @@ source("../R/transformation.R") source("../R/heatmap.R") source("../R/label.R") source("../R/limit.R") +source("../R/global.R") ####Test Data data <- data.table::as.data.table(mtcars, keep.rowname = "id") diff --git a/exec/marker_example.R b/exec/marker_example.R index 3894c5b..42ff0eb 100644 --- a/exec/marker_example.R +++ b/exec/marker_example.R @@ -4,7 +4,7 @@ source("../R/marker.R") source("../R/colorPicker2.R") source("../R/label.R") -####Test Data +#### 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))) @@ -12,14 +12,16 @@ names(metadata)[1] <- "key" #### ui <- fluidPage( - markerUI(id = "mark") + markerUI(id = "mark"), + verbatimTextOutput(outputId = "output") ) server <- function(input, output) { marker <-callModule(marker, "mark", highlight.labels = data) - observe({print(marker()) + output$output <- renderPrint({ + marker() }) } diff --git a/exec/pca_example.R b/exec/pca_example.R index d7be244..107a5b8 100644 --- a/exec/pca_example.R +++ b/exec/pca_example.R @@ -4,6 +4,7 @@ library(shinydashboard) source("../R/columnSelector.R") source("../R/function.R") source("../R/pca.R") +source("../R/global.R") #### Test Data data <- data.table::as.data.table(mtcars, keep.rowname = "id") diff --git a/exec/scatterPlot_example.R b/exec/scatterPlot_example.R index 9f36aca..292c753 100644 --- a/exec/scatterPlot_example.R +++ b/exec/scatterPlot_example.R @@ -9,6 +9,7 @@ source("../R/scatterPlot.R") source("../R/marker.R") source("../R/limit.R") source("../R/label.R") +source("../R/global.R") ####Test Data data <- data.table::data.table(id = rownames(mtcars), mtcars) diff --git a/man/log_message.Rd b/man/log_message.Rd index d94a471..eea02ae 100644 --- a/man/log_message.Rd +++ b/man/log_message.Rd @@ -17,3 +17,6 @@ log_message(message, level = c("DEBUG", "INFO", "WARN", "ERROR", "FATAL"), \description{ logger message convenience function } +\details{ +Does nothing if logger doesn't exist. +}