Assign customisable colours to groups

- Assign different colours per created groups
- Edit colours by selecting a single group
- Blend colours when (automatically) mixing groups in survival analysis
- Use group colours when representing groups in plots
- Minor unit test fix

NAMESPACE

@@ -69,6 +69,7 @@ importFrom(XML,xmlRoot)
 importFrom(XML,xmlToList)
 importFrom(XML,xmlTreeParse)
 importFrom(colourpicker,colourInput)
+importFrom(colourpicker,updateColourInput)
 importFrom(data.table,fread)
 importFrom(digest,digest)
 importFrom(fastmatch,"%fin%")

NEWS

@@ -1,4 +1,4 @@
-# 1.2.2 (23 Jun, 2017)
+# 1.2.2 (14 Aug, 2017)
 
 * Update minimum version required of shiny (1.0.3)
 * Fix inconsistent browser history navigation
@@ -11,10 +11,11 @@
     * Parse sample information from TCGA samples using `parseTcgaSampleInfo`
     * Generate TCGA sample metadata when loading TCGA junction quantification
 * Data grouping:
+    * Assign a customisable colour per data group
+    * Export or import patient and sample identifiers of data groups
     * Add new set operations when grouping (such as complement, subtraction and
     symmetric difference)
     * Suggest attributes of interest when creating groups
-    * Export or import patient and sample identifiers of data groups
     * Allow to retrieve the universe of patient and sample identifiers by
     performing the complement group without any group selected
 * Differential splicing analysis:

R/analysis_diffSplicing.R

@@ -153,6 +153,7 @@ createSparklines <- function(hc, data, events, FUN, delim=NULL) {
 singleDiffAnalyses <- function(vector, group, threshold=1, step=100,
                                analyses=c("wilcoxRankSum", "ttest", "kruskal",
                                           "levene", "fligner")) {
+    colour  <- attr(group, "Colour")
     series  <- split(vector, group)
     samples <- vapply(series, function(i) sum(!is.na(i)), integer(1))
     valid   <- names(series)[samples >= threshold]
@@ -209,17 +210,30 @@ singleDiffAnalyses <- function(vector, group, threshold=1, step=100,
     # Density sparklines
     sparkline <- NULL
     if (any("density" == analyses)) {
-        data <- NULL
-        validSeries <- series[valid]
-        for (group in validSeries) {
+        data         <- NULL
+        validSeries  <- series[valid]
+        groupsColour <- NULL
+        for (each in seq(validSeries)) {
+            group <- validSeries[[each]]
             # Calculate the density of inclusion levels for each sample type 
             # with a greatly reduced number of points for faster execution
             den <- density(group, n=10, bw=0.01, na.rm=TRUE)
             data <- c(data, paste(sprintf('{"x":%s,"y":%s}', den$x, den$y),
                                   collapse=","))
+            if (!is.null(colour)) {
+                groupsColour <- c(groupsColour, 
+                                  unname(colour[names(validSeries)[[each]]]))
+            }
+        }
+        if (!is.null(colour)) {
+            sparkline <- paste(
+                sprintf('{"name":"%s", "data":[%s], "color":"%s"}', 
+                        names(validSeries), data, groupsColour), collapse=",")
+        } else {
+            sparkline <- paste(
+                sprintf('{"name":"%s", "data":[%s]}', 
+                        names(validSeries), data), collapse=",")
         }
-        sparkline <- paste(sprintf('{"name":"%s", "data":[%s]}', 
-                                   names(validSeries), data), collapse=",")
         sparkline <- paste("[", sparkline, "]")
     }
 
@@ -304,17 +318,24 @@ diffAnalyses <- function(psi, groups=NULL,
     }
 
     # Add artificial delimiters (required to identify group names later on)
+    colour           <- attr(groups, "Colour")
     parenthesisOpen  <- ".delim1."
     parenthesisClose <- ".delim2."
-    groups <- paste0(parenthesisOpen, groups, parenthesisClose)
+    groups           <- paste0(parenthesisOpen, groups, parenthesisClose)
+    groups           <- factor(groups)
+    if (!is.null(colour)) {
+        names(colour) <- paste0(parenthesisOpen, names(colour), 
+                                parenthesisClose)
+        attr(groups, "Colour") <- colour
+    }
 
     count <- 0
     stats <- apply(psi, 1, function(...) {
         count <<- count + 1
         if (count %% step == 0)
             progress("Performing statistical analysis", console=FALSE)
         return(singleDiffAnalyses(...))
-    }, factor(groups), threshold=1, step=step, analyses=analyses)
+    }, groups, threshold=1, step=step, analyses=analyses)
     print(Sys.time() - time)
 
     # Check the column names of the different columns

R/analysis_diffSplicing_event.R

@@ -127,30 +127,30 @@ plotDistribution <- function(psi, groups, rug=TRUE, vLine=TRUE, ...,
         min  <- roundDigits(min(row, na.rm=TRUE))
         samples <- sum(!is.na(row))
 
-        color <- JS("Highcharts.getOptions().colors[", count, "]")
+        colour <- unname(attr(groups, "Colour")[group])
+        if (is.null(colour))
+            colour <- JS("Highcharts.getOptions().colors[", count, "]")
 
         # Calculate the density of inclusion levels for each sample group
         den <- density(row, na.rm=TRUE, ...)
         hc <- hc %>%
             hc_add_series(den, type="area", name=group, median=med, var=vari,
-                          samples=samples, max=max, color=color, min=min)
+                          samples=samples, max=max, color=colour, min=min)
         # Rug plot
         if (rug) {
             hc <- hc_scatter(
                 hc, row, rep(0, length(row)), name=group, marker=list(
-                    enabled=TRUE, symbol="circle", radius=4, fillColor=color),
+                    enabled=TRUE, symbol="circle", radius=4,
+                    fillColor=paste0(colour, "60")), # Add opacity
                 median=med, var=vari, samples=samples, max=max, min=min)
         }
         # Save plot line with information
         if (vLine) {
             plotLines[[count + 1]] <- list(
                 label = list(text = paste("Median:", med, "/ Variance:", vari)),
                 # Colour the same as the series
-                color=color,
-                dashStyle="shortdash",
-                width=2,
-                value=med,
-                zIndex = 7)
+                color=colour, dashStyle="shortdash", width=2, value=med, 
+                zIndex=7)
         }
         count <- count + 1
     }
@@ -639,6 +639,7 @@ diffSplicingEventServer <- function(input, output, session) {
         # Prepare groups of samples to analyse
         groups <- getSelectedGroups(input, "diffGroups", samples=TRUE,
                                     filter=colnames(psi))
+        colour <- attr(groups, "Colour")
         if ( !is.null(groups) ) {
             attrGroups <- groups
             psi <- psi[ , unlist(groups), drop=FALSE]
@@ -659,6 +660,7 @@ diffSplicingEventServer <- function(input, output, session) {
         eventPSI <- as.numeric(psi[event, ])
         eventPSI <- filterGroups(eventPSI, groups)
         groups <- names(eventPSI)
+        attr(groups, "Colour") <- colour
 
         assembly <- getAssemblyVersion()
         plot <- plotDistribution(

R/analysis_diffSplicing_table.R

@@ -726,9 +726,11 @@ diffAnalysesSet <- function(session, input, output) {
         groups <- getSelectedGroups(input, "diffGroups", samples=TRUE,
                                     filter=colnames(psi))
         if ( !is.null(groups) ) {
+            colour     <- attr(groups, "Colour")
             attrGroups <- groups
-            psi <- psi[ , unlist(groups), drop=FALSE]
-            groups <- rep(names(groups), sapply(groups, length))
+            psi        <- psi[ , unlist(groups), drop=FALSE]
+            groups     <- rep(names(groups), sapply(groups, length))
+            attr(groups, "Colour") <- colour
         } else {
             attrGroups <- "All samples"
             groups <- rep(attrGroups, ncol(psi))

R/analysis_survival.R

@@ -204,6 +204,7 @@ checkSurvivalInput <- function (session, input, coxph=FALSE) {
         survTerms <- processSurvival(session, clinical, censoring, event, 
                                      timeStart, timeStop, groups, formulaStr, 
                                      scale=scale, coxph=coxph)
+        attr(survTerms, "Colour") <- attr(groups, "Colour")
         return(survTerms)
     }
 }
@@ -293,6 +294,7 @@ survivalServer <- function(input, output, session) {
         }
 
         # Plot survival curves
+        attr(surv, "Colour") <- attr(survTerms, "Colour")
         hc <- plotSurvivalCurves(surv, markTimes, intRanges, pvalue, plotTitle, 
                                  scale) %>% export_highcharts()
         if (!is.null(sub)) hc <- hc_subtitle(hc, text=sub)

R/globalAccess.R

@@ -254,6 +254,14 @@ getGroupsFrom <- function(dataset, category=getCategory(), complete=FALSE,
     # If available, return data of interest
     g <- groups[ , col, drop=TRUE]
     if (length(g) == 1) names(g) <- rownames(groups)
+
+    # Return colour lookup table for groups
+    if ("Colour" %in% colnames(groups)) {
+        colour <- groups[ , "Colour", drop=TRUE]
+        colour <- setNames(unlist(colour), names(colour))
+        attr(g, "Colour") <- colour
+    }
+
     return(g)
 }