Merge branch 'master' into viewport

# Conflicts:
#	R/function.R

R/columnSelector.R

@@ -13,7 +13,8 @@ columnSelectorUI <- function(id, label = F, title = NULL) {
 
   shiny::tagList(
     shiny::tags$b(title),
-    shiny::HTML("<style scoped> div.selectize-input:not(.has-items) {background: #FFFFE1;} </style>"),
+    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"))}
   )
@@ -78,9 +79,10 @@ columnSelector <- function(input, output, session, type.columns, type = NULL, co
     if(multiple) {
       columnSelectLabel = paste0(columnSelectLabel, "(s)")
     }
+
     shiny::tagList(
       shiny::selectInput(session$ns("select.type"), label = columnTypeLabel, choices = type.r(), selected = type.r()[1], multiple = FALSE),
-      shiny::selectizeInput(session$ns("select.column"), label = columnSelectLabel, choices = choices, multiple = multiple)
+      shiny::div(shiny::selectizeInput(session$ns("select.column"), label = columnSelectLabel, choices = choices, multiple = multiple), class = "empty") # colored background if empty
     )
   })
 

R/featureSelector.R

@@ -100,7 +100,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
   })
 
   and_selected <- shiny::callModule(and, "and", data = data.r, show.elements = features.r, element.grouping = feature.grouping.r, delimiter = delimiter, multiple = multiple, contains = contains, ranged = ranged, step = step, reset = shiny::reactive(input$reset))
-  row_selector <- shiny::callModule(orNumeric, "row_selector", choices = choices, value = value_wrapper, label = "Select TopX features:", stepsize = 1)
+  row_selector <- 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({
@@ -144,7 +144,7 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
   # reset row_selector
   shiny::observeEvent(input$reset, {
     value(NULL)
-    row_selector <<- shiny::callModule(orNumeric, "row_selector", choices = choices, value = value_wrapper, label = "Select TopX features:", stepsize = 1)
+    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
@@ -189,8 +189,8 @@ featureSelector <- function(input, output, session, data, features = NULL, featu
 
   # row selector info
   shiny::observeEvent(input$infobutton, {
-    title <- "Select TopX features"
-    content <- "Subset the TopX features from the currently selected candidates."
+    title <- "Select n features from the top and/or bottom of the list"
+    content <- "Subset the TopX and/or BottomX features from the currently selected candidates."
 
     shiny::showModal(
       shiny::modalDialog(

R/function.R

@@ -180,13 +180,13 @@ create_scatterplot <- function(data, transparency = 1, pointsize = 1, labelsize
 
       # set repelling point labels
       if(!is.null(highlight.labels)) {
-        plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, alpha = 0.5, seed = seed)
-        plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, 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, 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 = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, alpha = 0.5, seed = seed)
-      plot <- plot + ggrepel::geom_label_repel(data = highlight.data, mapping = ggplot2::aes(label = highlight.labels), size = labelsize * scale, color = "black", segment.color = "gray65", force = 2, max.iter = 10000, point.padding = grid::unit(0.1, "lines"), label.size = NA, fill = NA, 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, 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)
     }
   }
 

R/geneView.R

@@ -12,6 +12,7 @@ geneViewUI <- function(id, plot.columns = 3){
   shiny::tagList(
     rintrojs::introjsUI(),
     shinyjs::useShinyjs(),
+    shiny::singleton(shiny::tags$head(shiny::tags$link(rel = "stylesheet", type = "text/css", href = "wilson_www/styles.css"))),
     shiny::fluidPage(
       shiny::fluidRow(
         shinydashboard::box(
@@ -30,7 +31,6 @@ geneViewUI <- function(id, plot.columns = 3){
               width = 3,
 
               shiny::div(id = ns("guide_geneSelection"),
-                         shiny::HTML("<style scoped> div.selectize-input:not(.has-items) {background: #FFFFE1;} </style>"),
                          shiny::uiOutput(ns("genes"))),
               shiny::div(id = ns("guide_genelabel"),
                          labelUI(ns("labeller")))
@@ -197,6 +197,9 @@ geneView <- function(input, output, session, data, metadata, level = NULL, plot.
     #only fetch needed data (calculation on server-side)
     shiny::updateSelectizeInput(session, "genes", choices = unique(data.r()[[2]]), server = TRUE)
 
+    # colored if not has item
+    output <- shiny::div(class = "empty", output)
+
     return(output)
   })
 

R/orNumeric.R

@@ -12,7 +12,10 @@ orNumericUI <- function(id){
   ns <- shiny::NS(id)
 
   shiny::tagList(
-    shiny::tagList(shinyjs::useShinyjs(), shiny::uiOutput(ns("label"))),
+    shiny::tagList(shinyjs::useShinyjs(),
+                   shiny::singleton(shiny::tags$head(shiny::tags$link(rel = "stylesheet", type = "text/css", href = "wilson_www/styles.css"))),
+                   shiny::uiOutput(ns("label"))
+    ),
     shiny::uiOutput(ns("options")),
     shiny::uiOutput(ns("slider")),
     shiny::uiOutput(ns("info"))
@@ -37,7 +40,7 @@ orNumericUI <- function(id){
 #' @param zoomable Boolean to enable zooming. Redefine the sliders range. Defaults to TRUE.
 #' @param reset A reactive which will trigger a module reset on change.
 #'
-#' @return Returns a reactive containing a named list with the label, the selected choices as a character vector (text) and a boolean vector of length \code{length(choices)} (bool), indicating whether a item has been chosen. If no item has been chosen, the return is \code{TRUE} for items.
+#' @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){
@@ -89,142 +92,49 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
     }
   })
 
-  css <- shiny::reactive({
-    # range slider?
-    if(length(value.r()) > 1) {
-      shiny::req(input$options)
-      # span.irs-bar = range between points (inner)
-      # span.irs-line = range outside of points (outer)
-      # span.irs-slider.from = left point
-      # span.irs-slider.to = right point
-      # span.irs-from = text above left point
-      # span.irs-to = text above right point
-      # span.irs-min = left text above slider
-      # span.irs-max = right text above slider
-      # span.irs-single = joined texts above points
-
-      # inner css
-      if(input$options == "inner") {
-        css <- shiny::HTML(paste0("<style ", paste0("id=\"", session$ns("slider-style")) ,"\" scoped>"),
-                           "span.irs-bar {
-                             background: #428bca;
-                             border-top: 1px solid #428bca;
-                             border-bottom: 1px solid #428bca;
-                           }
-                           span.irs-from, span.irs-to, span.irs-single {
-                             background: #428bca;
-                             color: #FFF;
-                           }
-                           span.irs-line {
-                             border: 1px solid #CCC;
-                             background: linear-gradient(to bottom, #DDD -50%, #FFF 150%);
-                           }
-                           </style>")
-      # outer css
-      }else if(input$options == "outer") {
-        css <- shiny::HTML(paste0("<style ", paste0("id=\"", session$ns("slider-style")) ,"\" scoped>"),
-                           "span.irs-bar {
-                             border: 1px solid #CCC;
-                             background: linear-gradient(to bottom, #DDD -50%, #FFF 150%);
-                           }
-                           span.irs-from, span.irs-to, span.irs-single {
-                             background: rgba(0,0,0,0.1);
-                             color: #333;
-                           }
-                           span.irs-line {
-                             background: #428bca;
-                             border-top: 1px solid #428bca;
-                             border-bottom: 1px solid #428bca;
-                           }
-                           span.irs-min, span.irs-max {
-                             background: #428bca;
-                             color: #FFF;
-                           }
-                           </style>")
-      }
-    #single slider
-    }else {
-      # span.irs-min = left text above slider
-      # span.irs-max = right text above slider
-      # span.irs-single = text above point
-      # span.irs-slider.single = point
-      # span.irs-bar = bar left side of point
-      # span.irs-bar-edge = left edge of bar
-      # span.irs-line = bar right side of point
-
-      # default for <
-      less <- shiny::HTML(paste0("<style ", paste0("id=\"", session$ns("slider-style")) ,"\" scoped>"),
-                "span.irs-bar, span.irs-bar-edge {
-                  background: linear-gradient(to bottom, #DDD -50%, #FFF 150%);
-                  border: 1px solid #CCC;
-                  border-right: 0;
-
-                }
-               ")
-      # default for =
-      equal <- "span.irs-single {
-                  background: rgba(0,0,0,0.1);
-                  color: #333;
-                }"
-      # default for >
-      greater <- "</style>"
-
-      if(any("<" == input$options)) {
-        less <- shiny::HTML(paste0("<style ", paste0("id=\"", session$ns("slider-style")) ,"\" scoped>"),
-                  "span.irs-bar, span.irs-bar-edge {
-                    background: #428bca;
-                    border-top: 1px solid #428bca;
-                    border-bottom: 1px solid #428bca;
-                  }
-                  span.irs-min {
-                    background: #428bca;
-                    color: #FFF;
-                  }")
-      }
-      if(any("=" == input$options)) {
-        equal <- "span.irs-single {
-                 background: #428bca;
-                 color: #FFF;
-                }"
-      }
-
-      if(any(">" == input$options)) {
-        greater <- "span.irs-line {
-                      background: #428bca;
-                      border-top: 1px solid #428bca;
-                      border-bottom: 1px solid #428bca;
-                    }
-                    span.irs-max {
-                      background: #428bca;
-                      color: #FFF;
-                    }
-                    </style>"
-      }
-      shiny::HTML(less, equal, greater)
-    }
-  })
-
-  # insert style for slider
+  # change css classes so slider visually matches options
   shiny::observe({
-    # re-insert css if slider is re-rendered
-    min.r()
-    max.r()
-
-    # escape . to get valid css selector
-    # TODO better validation
-    selector <- gsub(pattern = ".", replacement = "\\.", x = session$ns("slider-style"), fixed = TRUE)
-    selector2 <- gsub(pattern = ".", replacement = "\\.", x = session$ns("slider"), fixed = TRUE)
-
-    if(length(value.r()) > 1) shiny::req(input$options)
-    shiny::removeUI(
-      selector = paste0("#", selector)
-    )
-
-    shiny::insertUI(
-      selector = paste0("#", selector2),
-      where = "afterBegin",
-      ui = css()
-    )
+      # change css classes if slider is re-rendered
+      min.r()
+      max.r()
+
+      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')"))
+        }
+      } else {
+        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')"))
+          } else {
+            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')"))
+          } else {
+            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')"))
+          } else {
+            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')"))
+        }
+      }
   })
 
   output$slider <- shiny::renderUI({
@@ -343,7 +253,8 @@ orNumeric <- function(input, output, session, choices, value, label = "Column",
     list(
       label = label,
       bool = selected(),
-      text = text
+      text = text,
+      value = input$slider
     )
   })
 

R/scatterPlot.R

@@ -9,6 +9,7 @@ scatterPlotUI <- function(id) {
   ns <- shiny::NS(id)
 
   shiny::tagList(shiny::fluidPage(
+    shiny::singleton(shiny::tags$head(shiny::tags$link(rel = "stylesheet", type = "text/css", href = "wilson_www/styles.css"))),
     shiny::fluidRow(shinydashboard::box(
       width = 12,
       shiny::div(style = "overflow-y: scroll; overflow-x: scroll; height: 800px; text-align: center",
@@ -273,7 +274,18 @@ scatterPlot <- function(input, output, session, data, types, features = NULL, ma
 
       result$highlight.color <- markerReac()$color
       if(markerReac()$highlight != "Disabled" & nrow(features.r()) > 0){
-        result$highlight.labels <- markerReac()$label
+        # restrict label to 100 or less
+        if(length(markerReac()$label) <= 100) {
+          result$highlight.labels <- markerReac()$label
+        } else {
+          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."),
+            duration = NULL,
+            type = "warning"
+          )
+          shinyjs::addClass(selector = paste0("#shiny-notification-", session$ns("label-limit")), class = "notification-position-center")
+        }
       }
 
       if(markerReac()$highlight == "Highlight" & nrow(features.r()) > 0){