UpSetR group by color set

Question

I've stared at this for a couple of hours and don't seem to have found a solution. I would like upSet diagram to be colored by set. For example,

library('UpSetR')
movies <- read.csv( system.file("extdata", "movies.csv", package = "UpSetR"), 
                    header=T, sep=";" )
upset(movies, 
      sets = c("Action", "Comedy", "Drama"), 
      group.by="sets", matrix.color="blue", point.size=5,
      sets.bar.color=c("maroon","blue","orange"))

Looks like: However, I would like it to look like:

In other words, all the intersections of Drama in red, the intersections of Comedy in blue and Action in yellow. Thanks!

Answer 1

If you are willing to use a different package, my ComplexUpset allows to do it with:

library(ComplexUpset)

upset(
    movies, c("Action", "Comedy", "Drama"),
    width_ratio=0.2,
    group_by='sets',
    queries=list(
        upset_query(group='Drama', color='maroon'),
        upset_query(group='Comedy', color='blue'),
        upset_query(group='Action', color='orange'),
        upset_query(set='Drama', fill='maroon'),
        upset_query(set='Comedy', fill='blue'),
        upset_query(set='Action', fill='orange')
    )
)

Reproducible setup:

movies = as.data.frame(ggplot2movies::movies)
genres = colnames(movies)[18:24]
movies[genres] = movies[genres] == 1
movies[movies$mpaa == '', 'mpaa'] = NA
movies = na.omit(movies)

Answer 2

I added a mat_col argument to the upset function which allows to customize the colors of the intersections. Here is the modified myupset function.

myupset <- function (data, nsets = 5, nintersects = 40, sets = NULL, keep.order = F, 
    set.metadata = NULL, intersections = NULL, matrix.color = "gray23", mat_col=NULL,
    main.bar.color = "gray23", mainbar.y.label = "Intersection Size", 
    mainbar.y.max = NULL, sets.bar.color = "gray23", sets.x.label = "Set Size", 
    point.size = 2.2, line.size = 0.7, mb.ratio = c(0.7, 0.3), 
    expression = NULL, att.pos = NULL, att.color = main.bar.color, 
    order.by = c("freq", "degree"), decreasing = c(T, F), show.numbers = "yes", 
    number.angles = 0, group.by = "degree", cutoff = NULL, queries = NULL, 
    query.legend = "none", shade.color = "gray88", shade.alpha = 0.25, 
    matrix.dot.alpha = 0.5, empty.intersections = NULL, color.pal = 1, 
    boxplot.summary = NULL, attribute.plots = NULL, scale.intersections = "identity", 
    scale.sets = "identity", text.scale = 1, set_size.angles = 0, 
    set_size.show = FALSE, set_size.numbers_size = NULL, set_size.scale_max = NULL)  {

    startend <- UpSetR:::FindStartEnd(data)
    first.col <- startend[1]
    last.col <- startend[2]
    if (color.pal == 1) {
        palette <- c("#1F77B4", "#FF7F0E", "#2CA02C", "#D62728", 
            "#9467BD", "#8C564B", "#E377C2", "#7F7F7F", "#BCBD22", 
            "#17BECF")
    }
    else {
        palette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", 
            "#0072B2", "#D55E00", "#CC79A7")
    }
    if (is.null(intersections) == F) {
        Set_names <- unique((unlist(intersections)))
        Sets_to_remove <- UpSetR:::Remove(data, first.col, last.col, Set_names)
        New_data <- UpSetR:::Wanted(data, Sets_to_remove)
        Num_of_set <-UpSetR:::Number_of_sets(Set_names)
        if (keep.order == F) {
            Set_names <- UpSetR:::order_sets(New_data, Set_names)
        }
        All_Freqs <- UpSetR:::specific_intersections(data, first.col, 
            last.col, intersections, order.by, group.by, decreasing, 
            cutoff, main.bar.color, Set_names)
    }
    else if (is.null(intersections) == T) {
        Set_names <- sets
        if (is.null(Set_names) == T || length(Set_names) == 0) {
            Set_names <- UpSetR:::FindMostFreq(data, first.col, last.col, 
                nsets)
        }
        Sets_to_remove <- UpSetR:::Remove(data, first.col, last.col, Set_names)
        New_data <- UpSetR:::Wanted(data, Sets_to_remove)
        Num_of_set <- UpSetR:::Number_of_sets(Set_names)
        if (keep.order == F) {
            Set_names <- UpSetR:::order_sets(New_data, Set_names)
        }
        All_Freqs <- UpSetR:::Counter(New_data, Num_of_set, first.col, 
            Set_names, nintersects, main.bar.color, order.by, 
            group.by, cutoff, empty.intersections, decreasing)
    }
    Matrix_setup <- UpSetR:::Create_matrix(All_Freqs)
    labels <- UpSetR:::Make_labels(Matrix_setup)
    att.x <- c()
    att.y <- c()
    if (is.null(attribute.plots) == F) {
        for (i in seq_along(attribute.plots$plots)) {
            if (length(attribute.plots$plots[[i]]$x) != 0) {
                att.x[i] <- attribute.plots$plots[[i]]$x
            }
            else if (length(attribute.plots$plots[[i]]$x) == 
                0) {
                att.x[i] <- NA
            }
            if (length(attribute.plots$plots[[i]]$y) != 0) {
                att.y[i] <- attribute.plots$plots[[i]]$y
            }
            else if (length(attribute.plots$plots[[i]]$y) == 
                0) {
                att.y[i] <- NA
            }
        }
    }
    BoxPlots <- NULL
    if (is.null(boxplot.summary) == F) {
        BoxData <- UpSetR:::IntersectionBoxPlot(All_Freqs, New_data, first.col, 
            Set_names)
        BoxPlots <- list()
        for (i in seq_along(boxplot.summary)) {
            BoxPlots[[i]] <- UpSetR:::BoxPlotsPlot(BoxData, boxplot.summary[i], 
                att.color)
        }
    }
    customAttDat <- NULL
    customQBar <- NULL
    Intersection <- NULL
    Element <- NULL
    legend <- NULL
    EBar_data <- NULL
    if (is.null(queries) == F) {
        custom.queries <- UpSetR:::SeperateQueries(queries, 2, palette)
        customDat <- UpSetR:::customQueries(New_data, custom.queries, 
            Set_names)
        legend <- UpSetR:::GuideGenerator(queries, palette)
        legend <- UpSetR:::Make_legend(legend)
        if (is.null(att.x) == F && is.null(customDat) == F) {
            customAttDat <- UpSetR:::CustomAttData(customDat, Set_names)
        }
        customQBar <- UpSetR:::customQueriesBar(customDat, Set_names, 
            All_Freqs, custom.queries)
    }
    if (is.null(queries) == F) {
        Intersection <- UpSetR:::SeperateQueries(queries, 1, palette)
        Matrix_col <- intersects(UpSetR:::QuerieInterData, Intersection, 
            New_data, first.col, Num_of_set, All_Freqs, expression, 
            Set_names, palette)
        Element <- UpSetR:::SeperateQueries(queries, 1, palette)
        EBar_data <- UpSetR:::ElemBarDat(Element, New_data, first.col, 
            expression, Set_names, palette, All_Freqs)
    }
    else {
        Matrix_col <- NULL
    }
    if (!is.null(mat_col)) {
      Matrix_col <- mat_col
    }
    Matrix_layout <- UpSetR:::Create_layout(Matrix_setup, matrix.color, 
        Matrix_col, matrix.dot.alpha)
    Set_sizes <- UpSetR:::FindSetFreqs(New_data, first.col, Num_of_set, 
        Set_names, keep.order)
    Bar_Q <- NULL
    if (is.null(queries) == F) {
        Bar_Q <- intersects(UpSetR:::QuerieInterBar, Intersection, New_data, 
            first.col, Num_of_set, All_Freqs, expression, Set_names, 
            palette)
    }
    QInter_att_data <- NULL
    QElem_att_data <- NULL
    if ((is.null(queries) == F) & (is.null(att.x) == F)) {
        QInter_att_data <- intersects(UpSetR:::QuerieInterAtt, Intersection, 
            New_data, first.col, Num_of_set, att.x, att.y, expression, 
            Set_names, palette)
        QElem_att_data <- elements(UpSetR:::QuerieElemAtt, Element, New_data, 
            first.col, expression, Set_names, att.x, att.y, palette)
    }
    AllQueryData <- UpSetR:::combineQueriesData(QInter_att_data, QElem_att_data, 
        customAttDat, att.x, att.y)
    ShadingData <- NULL
    if (is.null(set.metadata) == F) {
        ShadingData <- UpSetR:::get_shade_groups(set.metadata, Set_names, 
            Matrix_layout, shade.alpha)
        output <- UpSetR:::Make_set_metadata_plot(set.metadata, Set_names)
        set.metadata.plots <- output[[1]]
        set.metadata <- output[[2]]
        if (is.null(ShadingData) == FALSE) {
            shade.alpha <- unique(ShadingData$alpha)
        }
    }
    else {
        set.metadata.plots <- NULL
    }
    if (is.null(ShadingData) == TRUE) {
        ShadingData <- UpSetR:::MakeShading(Matrix_layout, shade.color)
    }
    Main_bar <- suppressMessages(UpSetR:::Make_main_bar(All_Freqs, Bar_Q, 
        show.numbers, mb.ratio, customQBar, number.angles, EBar_data, 
        mainbar.y.label, mainbar.y.max, scale.intersections, 
        text.scale, attribute.plots))
    Matrix <- UpSetR:::Make_matrix_plot(Matrix_layout, Set_sizes, All_Freqs, 
        point.size, line.size, text.scale, labels, ShadingData, 
        shade.alpha)
    Sizes <- UpSetR:::Make_size_plot(Set_sizes, sets.bar.color, mb.ratio, 
        sets.x.label, scale.sets, text.scale, set_size.angles, 
        set_size.show, set_size.scale_max, set_size.numbers_size)
    structure(class = "upset", .Data = list(Main_bar = Main_bar, 
        Matrix = Matrix, Sizes = Sizes, labels = labels, mb.ratio = mb.ratio, 
        att.x = att.x, att.y = att.y, New_data = New_data, expression = expression, 
        att.pos = att.pos, first.col = first.col, att.color = att.color, 
        AllQueryData = AllQueryData, attribute.plots = attribute.plots, 
        legend = legend, query.legend = query.legend, BoxPlots = BoxPlots, 
        Set_names = Set_names, set.metadata = set.metadata, set.metadata.plots = set.metadata.plots))
}

Here is an example showing how to use it.

# The matrix of colors for the 3 x 12 intersection grid
mtxcol <- data.frame(x=rep(1:12,each=3), 
                     color=rep(c("maroon","blue","orange"),each=12))

movies <- read.csv(system.file("extdata", "movies.csv", package = "UpSetR"), 
                   header=T, sep=";")
myupset(movies, 
      sets = c("Action", "Comedy", "Drama"),
      group.by="sets", point.size=5, mat_col=mtxcol,
      sets.bar.color=c("maroon","blue","orange"))