R/plotCorrelation-methods.R

In acidgenomics/acidplots: Acid Genomics Plot Functions and Themes

#' @name plotCorrelation
#' @inherit AcidGenerics::plotCorrelation
#' @note Updated 2024-03-27.
#'
#' @section Correlation coefficient calculations:
#'
#' Correlation coefficient calcluations are generated by
#' `ggpmisc::stat_poly_eq`. Refer to the [ggpmisc GitHub repo][] for details.
#'
#' [ggpmisc GitHub repo]: https://github.com/aphalo/ggpmisc/
#'
#' @inheritParams AcidRoxygen::params
#' @param ... Additional arguments.
#'
#' @param colors `list(3)`.
#' Named list defining the colors of `dots`, `line`, and `se`, for confidence
#' interval standard error.
#'
#' @param labelPoints `logical(1)`.
#' For `matrix` method, label points on plot with row names?
#'
#' @param pointLabelCol `character(1)` or `NULL`.
#' For `data.frame` method, which column name or position should be used to
#' label points on the plot?
#'
#' @param r2 `logical(1)`.
#' Show information on the `lm` fit?
#' This includes the equation, and the coefficient of determination (R^2).
#' Refer to `ggpmisc::stat_poly_eq` for details.
#'
#' @param se `logical(1)`.
#' Display confidence interval around the `lm` fit line?
#' Refer to `ggplot2::geom_smooth` for details.
#'
#' @param xCol,yCol `character(1)` or `integer(1)`.
#' X and Y column name or position.
#'
#' @seealso
#' - `ggpmisc::stat_poly_eq`.
#' - `ggplot2::geom_smooth`.
#'
#' @examples
#' data(RangedSummarizedExperiment, package = "AcidTest")
#'
#' ## SummarizedExperiment ====
#' object <- RangedSummarizedExperiment
#' plotCorrelation(
#'     object = object,
#'     xCol = 1L,
#'     yCol = 2L,
#'     trans = "identity"
#' )
NULL



## Updated 2023-12-10.
`plotCorrelation,data.frame` <- # nolint
    function(object,
             xCol,
             yCol,
             pointLabelCol = NULL,
             labels = list(
                 "title" = NULL,
                 "subtitle" = NULL,
                 "x" = NULL,
                 "y" = NULL
             ),
             trans = c("identity", "log10", "log2"),
             r2 = TRUE,
             se = TRUE,
             colors = list(
                 "dots" = "black",
                 "line" = "black",
                 "se" = "gray"
             )) {
        assert(
            validObject(object),
            hasCols(object),
            hasRows(object),
            isString(xCol) || isInt(xCol),
            isString(yCol) || isInt(yCol),
            isString(pointLabelCol) ||
                isInt(pointLabelCol) ||
                is.null(pointLabelCol),
            isFlag(r2),
            isFlag(se),
            is.list(colors),
            areSetEqual(
                x = names(colors),
                y = names(eval(formals()[["colors"]]))
            )
        )
        if (isFALSE(se)) {
            colors[["se"]] <- NA
        }
        trans <- match.arg(trans)
        isLog <- !identical(trans, "identity")
        labels <- matchLabels(labels)
        df <- as.data.frame(object)
        df <- df[, c(xCol, yCol), drop = FALSE]
        if (is.null(labels[["x"]])) {
            labels[["x"]] <- colnames(df)[[1L]]
        }
        if (is.null(labels[["y"]])) {
            labels[["y"]] <- colnames(df)[[2L]]
        }
        colnames(df) <- c("x", "y")
        if (!is.null(pointLabelCol)) {
            df[["label"]] <- object[[pointLabelCol]]
        }
        df <- df[complete.cases(df), , drop = FALSE]
        assert(hasRows(df))
        labs <- do.call(what = labs, args = labels)
        assert(is(labs, "labels"))
        if (isTRUE(isLog)) {
            assert(
                allArePositive(df[["x"]]),
                allArePositive(df[["y"]])
            )
        }
        if (isTRUE(isLog)) {
            base <- switch(
                EXPR = trans,
                "log2" = 2L,
                "log10" = 10L
            )
            limits <- list(
                "x" = c(
                    base^min(floor(log(df[["x"]], base = base))),
                    base^max(ceiling(log(df[["x"]], base = base)))
                ),
                "y" = c(
                    base^min(floor(log(df[["y"]], base = base))),
                    base^max(ceiling(log(df[["y"]], base = base)))
                )
            )
            assert(!any(unlist(limits) == 0L))
            breaks <- list(
                "x" = base^seq(
                    from = log(limits[["x"]][[1L]], base = base),
                    to = log(limits[["x"]][[2L]], base = base),
                    by = 1L
                ),
                "y" = base^seq(
                    from = log(limits[["y"]][[1L]], base = base),
                    to = log(limits[["y"]][[2L]], base = base),
                    by = 1L
                )
            )
        }
        formula <- y ~ x
        p <- ggplot(
            data = df,
            mapping = aes(
                x = .data[["x"]],
                y = .data[["y"]]
            )
        ) +
            geom_point(color = colors[["dots"]]) +
            geom_smooth(
                method = "lm",
                formula = formula,
                se = TRUE,
                color = colors[["line"]],
                fill = colors[["se"]]
            )
        if (isTRUE(r2)) {
            requireNamespaces("ggpmisc")
            p <- p + ggpmisc::stat_poly_eq(
                mapping = aes(label = paste(
                    after_stat(.data[["eq.label"]]),
                    after_stat(.data[["rr.label"]]),
                    sep = "*\", \"*"
                )),
                formula = formula,
                parse = TRUE
            )
        }
        p <- p + labs
        if (isTRUE(isLog)) {
            p <- p +
                scale_x_continuous(
                    trans = trans,
                    breaks = breaks[["x"]],
                    limits = limits[["x"]],
                    labels = comma
                ) +
                scale_y_continuous(
                    trans = trans,
                    breaks = breaks[["y"]],
                    limits = limits[["y"]],
                    labels = comma
                ) +
                annotation_logticks(
                    base = base,
                    sides = "bl"
                )
        }
        if (!is.null(pointLabelCol)) {
            p <- p +
                acid_geom_label_repel(
                    mapping = aes(label = .data[["label"]])
                )
        }
        p
    }



## Updated 2023-12-10.
`plotCorrelation,matrix` <- # nolint
    function(object,
             xCol,
             yCol,
             labelPoints = FALSE,
             ...) {
        assert(
            validObject(object),
            hasCols(object),
            isString(xCol) || isInt(xCol),
            isString(yCol) || isInt(yCol),
            isFlag(labelPoints)
        )
        df <- as.data.frame(object)
        df <- df[, c(xCol, yCol), drop = FALSE]
        if (isTRUE(labelPoints)) {
            assert(
                nrow(df) <= 50L,
                hasRownames(df),
                msg = "Can't label points for this object."
            )
            pointLabelCol <- "label"
            df[[pointLabelCol]] <- rownames(df)
        } else {
            pointLabelCol <- NULL
        }
        rownames(df) <- NULL
        plotCorrelation(
            object = df,
            xCol = xCol,
            yCol = yCol,
            pointLabelCol = pointLabelCol,
            ...
        )
    }



## Updated 2021-02-09.
`plotCorrelation,Matrix` <- # nolint
    `plotCorrelation,matrix`

## Updated 2023-04-27.
`plotCorrelation,DFrame` <- # nolint
    `plotCorrelation,data.frame`



## Updated 2023-12-10.
`plotCorrelation,SE` <- # nolint
    function(object, assay = 1L, ...) {
        assert(
            validObject(object),
            isString(assay) || isInt(assay)
        )
        assay <- assay(x = object, i = assay)
        plotCorrelation(object = assay, ...)
    }



#' @rdname plotCorrelation
#' @export
setMethod(
    f = "plotCorrelation",
    signature = signature(object = "DFrame"),
    definition = `plotCorrelation,DFrame`
)


#' @rdname plotCorrelation
#' @export
setMethod(
    f = "plotCorrelation",
    signature = signature(object = "Matrix"),
    definition = `plotCorrelation,Matrix`
)

#' @rdname plotCorrelation
#' @export
setMethod(
    f = "plotCorrelation",
    signature = signature(object = "SummarizedExperiment"),
    definition = `plotCorrelation,SE`
)

#' @rdname plotCorrelation
#' @export
setMethod(
    f = "plotCorrelation",
    signature = signature(object = "data.frame"),
    definition = `plotCorrelation,data.frame`
)

#' @rdname plotCorrelation
#' @export
setMethod(
    f = "plotCorrelation",
    signature = signature(object = "matrix"),
    definition = `plotCorrelation,matrix`
)