R/family_RowDotPlot.R

In iSEE: Interactive SummarizedExperiment Explorer

#' The RowDotPlot virtual class
#'
#' The RowDotPlot is a virtual class where each row in the \linkS4class{SummarizedExperiment} is represented by no more than one point (i.e., a \dQuote{dot}) in a brushable \link{ggplot} plot.
#' It provides slots and methods to extract \code{\link{rowData}} fields to control the per-point aesthetics on the plot.
#' This panel will transmit row identities in both its single and multiple selections, and it can receive multiple row selections but not multiple column selections.
#'
#' @section Slot overview:
#' The following slots control coloring of the points:
#' \itemize{
#' \item \code{ColorByRowData}, a string specifying the \code{\link{rowData}} field for controlling point color,
#' if \code{ColorBy="Row data"} (see the \linkS4class{Panel} class).
#' Defaults to the first field.
#' \item \code{ColorBySampleNameAssay}, a string specifying the assay of the SummarizedExperiment object containing values to use for coloring,
#' if \code{ColorBy="Sample name"}.
#' Defaults to the name of the first assay.
#' \item \code{ColorByFeatureNameColor}, a string specifying the color to use for coloring an individual sample on the plot,
#' if \code{ColorBy="Feature name"}.
#' Defaults to \code{"red"}.
#' }
#'
#' The following slots control other metadata-related aesthetic aspects of the points:
#' \itemize{
#' \item \code{ShapeByRowData}, a string specifying the \code{\link{rowData}} field for controlling point shape,
#' if \code{ShapeBy="Row data"} (see the \linkS4class{Panel} class).
#' The specified field should contain categorical values; defaults to the first such field.
#' \item \code{SizeByRowData}, a string specifying the \code{\link{rowData}} field for controlling point size,
#' if \code{SizeBy="Row data"} (see the \linkS4class{Panel} class).
#' The specified field should contain continuous values; defaults to the first such field.
#' }
#'
#' In addition, this class inherits all slots from its parent \linkS4class{DotPlot} and \linkS4class{Panel} classes.
#'
#' @section Supported methods:
#' In the following code snippets, \code{x} is an instance of a \linkS4class{RowDotPlot} class.
#' Refer to the documentation for each method for more details on the remaining arguments.
#'
#' For setting up data values:
#' \itemize{
#' \item \code{\link{.cacheCommonInfo}(x)} adds a \code{"RowDotPlot"} entry containing \code{valid.rowData.names}, a character vector of valid column data names (i.e., containing atomic values); \code{discrete.rowData.names}, a character vector of names for discrete columns; and \code{continuous.rowData.names}, a character vector of names of continuous columns.
#' This will also call the equivalent \linkS4class{DotPlot} method.
#' \item \code{\link{.refineParameters}(x, se)} replaces \code{NA} values in \code{ColorByFeatAssay} with the first valid assay name in \code{se}.
#' This will also call the equivalent \linkS4class{DotPlot} method.
#' }
#'
#' For defining the interface:
#' \itemize{
#' \item \code{\link{.hideInterface}(x, field)} returns a logical scalar indicating whether the interface element corresponding to \code{field} should be hidden.
#' This returns \code{TRUE} for row selection parameters (\code{"RowSelectionSource"}, \code{"RowSelectionType"} and \code{"RowSelectionSaved"}),
#' otherwise it dispatches to the \linkS4class{Panel} method.
#' }
#'
#' For monitoring reactive expressions:
#' \itemize{
#' \item \code{\link{.createObservers}(x, se, input, session, pObjects, rObjects)} sets up observers for all slots in the \linkS4class{RowDotPlot}.
#' This will also call the equivalent \linkS4class{DotPlot} method.
#' }
#'
#' For controlling selections:
#' \itemize{
#' \item \code{\link{.multiSelectionDimension}(x)} returns \code{"row"} to indicate that a row selection is being transmitted.
#' \item \code{\link{.singleSelectionDimension}(x)} returns \code{"feature"} to indicate that a feature identity is being transmitted.
#' }
#'
#' For documentation:
#' \itemize{
#' \item \code{\link{.definePanelTour}(x)} returns an data.frame containing the steps of a tour relevant to subclasses,
#' mostly tuning the more generic descriptions from the same method of the parent \linkS4class{DotPlot}.
#' }
#'
#' Unless explicitly specialized above, all methods from the parent classes \linkS4class{DotPlot} and \linkS4class{Panel} are also available.
#'
#' @section Subclass expectations:
#' Subclasses are expected to implement methods for, at least:
#' \itemize{
#' \item \code{\link{.generateDotPlotData}}
#' \item \code{\link{.fullName}}
#' \item \code{\link{.panelColor}}
#' }
#'
#' The method for \code{\link{.generateDotPlotData}} should create a \code{plot.data} data.frame with one row per row in the \linkS4class{SummarizedExperiment} object.
#'
#' @author Aaron Lun
#' @seealso
#' \linkS4class{DotPlot}, for the immediate parent class that contains the actual slot definitions.
#'
#' @docType methods
#' @aliases
#' initialize,RowDotPlot-method
#' .cacheCommonInfo,RowDotPlot-method
#' .refineParameters,RowDotPlot-method
#' .defineInterface,RowDotPlot-method
#' .createObservers,RowDotPlot-method
#' .hideInterface,RowDotPlot-method
#' .multiSelectionDimension,RowDotPlot-method
#' .singleSelectionDimension,RowDotPlot-method
#' .definePanelTour,RowDotPlot-method
#'
#' @name RowDotPlot-class
NULL

#' @export
#' @importFrom methods callNextMethod
setMethod("initialize", "RowDotPlot", function(.Object, ...) {
    args <- list(...)
    args <- .emptyDefault(args, .colorByRowData, NA_character_)
    args <- .emptyDefault(args, .colorBySampNameAssay, NA_character_)
    args <- .emptyDefault(args, .colorByFeatNameColor, iSEEOptions$get("selected.color"))

    args <- .emptyDefault(args, .shapeByRowData, NA_character_)

    args <- .emptyDefault(args, .sizeByRowData, NA_character_)

    # Defensive measure to avoid problems with cyclic graphs
    # that the user doesn't have permissions to change!
    args <- .emptyDefault(args, .selectColDynamic, FALSE)

    do.call(callNextMethod, c(list(.Object), args))
})

#' @importFrom S4Vectors setValidity2
setValidity2("RowDotPlot", function(object) {
    msg <- character(0)

    msg <- .singleStringError(msg, object,
        c(.colorByRowData, .colorBySampNameAssay, .colorByFeatNameColor))

    msg <- .allowableChoiceError(msg, object, .colorByField,
          c(.colorByNothingTitle, .colorByRowDataTitle, .colorByFeatNameTitle, .colorBySampNameTitle))

    msg <- .allowableChoiceError(msg, object, .shapeByField,
          c(.shapeByNothingTitle, .shapeByRowDataTitle))

    msg <- .allowableChoiceError(msg, object, .sizeByField,
          c(.sizeByNothingTitle, .sizeByRowDataTitle))

    if (length(msg)) {
        return(msg)
    }
    TRUE
})

#' @export
#' @importFrom SummarizedExperiment rowData
#' @importFrom methods callNextMethod
setMethod(".cacheCommonInfo", "RowDotPlot", function(x, se) {
    if (!is.null(.getCachedCommonInfo(se, "RowDotPlot"))) {
        return(se)
    }

    se <- callNextMethod()

    df <- rowData(se)
    displayable <- .findAtomicFields(df)

    subdf <- df[,displayable,drop=FALSE]
    discrete <- .whichGroupable(subdf)
    continuous <- .whichNumeric(subdf)

    .setCachedCommonInfo(se, "RowDotPlot",
        valid.rowData.names=displayable,
        discrete.rowData.names=displayable[discrete],
        continuous.rowData.names=displayable[continuous])
})

#' @export
#' @importFrom methods callNextMethod
setMethod(".refineParameters", "RowDotPlot", function(x, se) {
    x <- callNextMethod()
    if (is.null(x)) {
        return(NULL)
    }

    rdp_cached <- .getCachedCommonInfo(se, "RowDotPlot")
    dp_cached <- .getCachedCommonInfo(se, "DotPlot")

    available <- rdp_cached$valid.rowData.names
    x <- .replaceMissingWithFirst(x, .colorByRowData, available)

    assays <- dp_cached$valid.assay.names
    if (length(assays)) {
        assays <- c(intersect(iSEEOptions$get("assay"), assays), assays)
        x <- .replaceMissingWithFirst(x, .colorBySampNameAssay, assays)
    } else {
        x[[.colorBySampNameAssay]] <- NA_character_
    }

    discrete <- rdp_cached$discrete.rowData.names
    x <- .replaceMissingWithFirst(x, .shapeByRowData, discrete)

    continuous <- rdp_cached$continuous.rowData.names
    x <- .replaceMissingWithFirst(x, .sizeByRowData, continuous)
    
    x <- .replaceMissingWithFirst(x, .plotCustomLabelsText, rownames(se)[1])

    x
})

#' @export
setMethod(".hideInterface", "RowDotPlot", function(x, field) {
    if (field %in% c(.selectColSource, .selectColType, .selectColSaved, .selectColDynamic)) {
        TRUE
    } else {
        callNextMethod()
    }
})

#' @export
setMethod(".createObservers", "RowDotPlot", function(x, se, input, session, pObjects, rObjects) {
    callNextMethod()

    plot_name <- .getEncodedName(x)

    .createUnprotectedParameterObservers(plot_name,
        fields=c(.colorByRowData, .colorBySampNameAssay,
            .shapeByRowData, .sizeByRowData, .colorByFeatNameColor),
        input=input, pObjects=pObjects, rObjects=rObjects)

    .create_dimname_propagation_observer(plot_name, choices=rownames(se),
        session=session, pObjects=pObjects, rObjects=rObjects)

    .createMultiSelectionEffectObserver(plot_name,
        by_field=.selectRowSource, type_field=.selectRowType, saved_field=.selectRowSaved,
        input=input, session=session, pObjects=pObjects, rObjects=rObjects)
})

#' @export
setMethod(".multiSelectionDimension", "RowDotPlot", function(x) "row")

#' @export
setMethod(".singleSelectionDimension", "RowDotPlot", function(x) "feature")

###############################################################

setMethod(".getDiscreteMetadataChoices", "RowDotPlot", function(x, se) {
    .getCachedCommonInfo(se, "RowDotPlot")$discrete.rowData.names
})

setMethod(".getContinuousMetadataChoices", "RowDotPlot", function(x, se) {
    .getCachedCommonInfo(se, "RowDotPlot")$continuous.colData.names
})

setMethod(".getMetadataChoices", "RowDotPlot", function(x, se) {
    .getCachedCommonInfo(se, "RowDotPlot")$valid.rowData.names
})

setMethod(".defineDotPlotColorChoices", "RowDotPlot", function(x, se) {
    covariates <- .getMetadataChoices(x, se)
    all_assays <- .getCachedCommonInfo(se, "DotPlot")$valid.assay.names
    .define_color_options_for_row_plots(se, covariates, all_assays)
})

setMethod(".getDotPlotColorConstants", "RowDotPlot", function(x) {
    list(
        metadata=list(
            title=.colorByRowDataTitle,
            field=.colorByRowData
        ),
        name=list(
            title=.colorByFeatNameTitle,
            field=.colorByFeatName,
            table=.colorByRowTable,
            color=.colorByFeatNameColor,
            dynamic=.colorByFeatDynamic
        ),
        assay=list(
            title=.colorBySampNameTitle,
            field=.colorBySampName,
            assay=.colorBySampNameAssay,
            table=.colorByColTable,
            color=.colorBySampNameColor,
            dynamic=.colorBySampDynamic
        )
    )
})

setMethod(".getDotPlotSizeConstants", "RowDotPlot", function(x) {
    list(
        metadata=list(
            title=.sizeByRowDataTitle,
            field=.sizeByRowData
        )
    )
})

setMethod(".getDotPlotShapeConstants", "RowDotPlot", function(x) {
    list(
        metadata=list(
            title=.shapeByRowDataTitle,
            field=.shapeByRowData
        )
    )
})

setMethod(".getDotPlotMetadataCommand", "RowDotPlot", function(x) "rowData")

setMethod(".getDotPlotNamesCommand", "RowDotPlot", function(x) "rownames")

###############################################################
# See ?.addDotPlotDataColor for documentation on these methods.

setMethod(".addDotPlotDataColor", "RowDotPlot", function(x, envir) {
    color_choice <- x[[.colorByField]]

    if (color_choice == .colorByRowDataTitle) {
        covariate_name <- x[[.colorByRowData]]
        label <- covariate_name
        cmds <- sprintf("plot.data$ColorBy <- rowData(se)[, %s];", deparse(covariate_name))

    } else if (color_choice == .colorByFeatNameTitle) {
        chosen_gene <- x[[.colorByFeatName]]
        label <- chosen_gene
        cmds <- sprintf("plot.data$ColorBy <- logical(nrow(plot.data));\nplot.data[%s, 'ColorBy'] <- TRUE;",
            deparse(chosen_gene))

    } else if (color_choice  == .colorBySampNameTitle) {
        chosen_sample <- x[[.colorBySampName]]
        assay_choice <- x[[.colorBySampNameAssay]]
        label <- sprintf("%s\n(%s)", chosen_sample, assay_choice)
        cmds <- sprintf("plot.data$ColorBy <- assay(se, %s)[, %s];",
            deparse(assay_choice), deparse(chosen_sample))

    } else {
        return(NULL)
    }

    .textEval(cmds, envir)

    list(commands=cmds, labels=list(ColorBy=label))
})

setMethod(".addDotPlotDataShape", "RowDotPlot", function(x, envir) {
    shape_choice <- x[[.shapeByField]]

    if (shape_choice == .shapeByRowDataTitle) {
        covariate_name <- x[[.shapeByRowData]]
        label <- covariate_name
        cmds <- sprintf("plot.data$ShapeBy <- rowData(se)[, %s];", deparse(covariate_name))

    } else {
        return(NULL)
    }

    .textEval(cmds, envir)

    list(commands=cmds, labels=list(ShapeBy=label))
})

setMethod(".addDotPlotDataSize", "RowDotPlot", function(x, envir) {
    size_choice <- x[[.sizeByField]]

    if (size_choice == .sizeByRowDataTitle) {
        covariate_name <- x[[.sizeByRowData]]
        label <- covariate_name
        cmds <- sprintf("plot.data$SizeBy <- rowData(se)[, %s];", deparse(covariate_name))

    } else {
        return(NULL)
    }

    .textEval(cmds, envir)

    list(commands=cmds, labels=list(SizeBy=label))
})

setMethod(".addDotPlotDataFacets", "RowDotPlot", function(x, envir) {
    facet_cmds <- NULL
    labels <- list()

    facet_row <- x[[.facetByRow]]
    if (facet_row!=.noSelection) {
        facet_cmds["FacetRow"] <- sprintf(
            "plot.data$FacetRow <- rowData(se)[, %s];", deparse(facet_row))
        labels$FacetRow <- facet_row
    }

    facet_column <- x[[.facetByColumn]]
    if (facet_column!=.noSelection) {
        facet_cmds["FacetColumn"] <- sprintf(
            "plot.data$FacetColumn <- rowData(se)[, %s];", deparse(facet_column))
        labels$FacetColumn <- facet_column
    }

    .textEval(facet_cmds, envir)

    list(commands=facet_cmds, labels=labels)
})

setMethod(".addDotPlotDataSelected", "RowDotPlot", function(x, envir) {
    if (!exists("row_selected", envir=envir, inherits=FALSE)) {
        return(NULL)
    }

    cmds <- c(
        header1="",
        header2="# Receiving row point selection",
        SelectBy="plot.data$SelectBy <- rownames(plot.data) %in% unlist(row_selected);"
    )

    if (x[[.selectEffect]] == .selectRestrictTitle) {
        cmds["saved"] <- "plot.data.all <- plot.data;"
        cmds["subset"] <- "plot.data <- subset(plot.data, SelectBy);"
    }
    cmds["footer"] <- ""

    .textEval(cmds, envir)

    cmds
})

#' @importFrom ggplot2 scale_color_manual geom_point
setMethod(".colorDotPlot", "RowDotPlot", function(x, colorby, x_aes="X", y_aes="Y") {
    color_choice <- x[[.colorByField]]

    # This slightly duplicates the work in .define_colorby_for_row_plot(),
    # but this is necessary to separate the function of data acquisition and plot generation.
    if (color_choice == .colorByRowDataTitle) {
        covariate_name <- x[[.colorByRowData]]
        cmds <- .create_color_scale("rowDataColorMap", deparse(covariate_name), colorby)

    } else if (color_choice == .colorByFeatNameTitle) {
        col_choice <- x[[.colorByFeatNameColor]]
        c(
            sprintf(
                "scale_color_manual(values=c(`FALSE`='black', `TRUE`=%s), drop=FALSE) +",
                deparse(col_choice)
            ),
            sprintf(
                "geom_point(aes(x=%s, y=%s), data=subset(plot.data, ColorBy == 'TRUE'), col=%s, alpha=1%s) +",
                x_aes, y_aes, deparse(col_choice),
                ifelse(x[[.sizeByField]] == .sizeByNothingTitle,
                    paste0(", size=5*", x[[.plotPointSize]]),
                    ""
                )
            )
        )

    } else if (color_choice == .colorBySampNameTitle) {
        assay_choice <- x[[.colorBySampNameAssay]]
        .create_color_scale("assayColorMap", deparse(assay_choice), colorby)
    } else {
        .colorByNoneDotPlotScale(x)
    }
})

###############################################################

#' @export
setMethod(".definePanelTour", "RowDotPlot", function(x) {
    collated <- callNextMethod()

    collated$intro[collated$intro=="PLACEHOLDER_COLOR"] <- "We can choose to color by different per-row attributes - from the row metadata, across a specific sample of an assay, or to identify a chosen feature.<br/><br/><strong>Action:</strong> try out some of the different choices. Note how further options become available when each choice is selected."

    data.frame(element=collated[,1], intro=collated[,2], stringsAsFactors=FALSE)
})