R/coexpression.R

In maxsonBraunLab/CITE-Viz: "CITEViz: Classifying Cell Clusters in CITE-Seq Data using the Flow Cytometry Gating Workflow"

#' Bilinear Interpolation
#'
#' Takes in a given x and y coordinate, the dimension of a square grid,
#' and four values representing the base red, green, or blue (RGB)
#' color values (0-255) of the four quadrants of the square grid
#' Returns the bilinear interpolated red, green, or blue value
#' (0-255) of the given input coordinates (x,y)
#'
#' @param x integer vector
#' @param y integer vector
#' @param ngrid integer taken from get_color_matrix_df
#' @param quad11 integer
#' @param quad21 integer
#' @param quad12 integer
#' @param quad22 integer
#' @noRd
#'
#' @return numeric vector for color values used in coexpression plot
get_bilinear_val <- function(x, y, ngrid, quad11, quad21, quad12, quad22) {
    temp_val <- quad11 * (ngrid - x) * (ngrid - y) +
        quad21 * x * (ngrid - y) +
        quad12 * (ngrid - x) * y +
        quad22 * x * y
    bilinear_val <- temp_val / (ngrid * ngrid)
    return(bilinear_val)
}


#' Create 2D color dataframe for gene/ADT coexpression
#'
#' @param ngrid integer setting the resolution (dimensions) of color
#' grid (e.g., ngrid = 16 sets a 16x16 color grid). Default is ngrid=16.
#'
#' @importFrom grDevices rgb
#' @noRd
#'
#' @return dataframe for use in coexpression legend
get_color_matrix_df <- function(ngrid = 16) {
    color_matrix_df <- expand.grid(x = 0:ngrid, y = 0:ngrid)
    color10 <- c(255, 0, 0) # RGB of red quadrant of 2d color matrix
    color01 <- c(0, 0, 255) # RGB of blue quadrant of 2d color matrix
    color00 <- c(217, 217, 217) # RGB of gray quadrant of 2d color matrix
    color11 <- c(255, 0, 255) # RBG of pink/violet quadrant of 2d color matrix
    color_matrix_df$R <- get_bilinear_val(
        color_matrix_df$x,
        color_matrix_df$y, ngrid,
        color00[1], color10[1], color01[1], color11[1]
    )
    color_matrix_df$G <- get_bilinear_val(
        color_matrix_df$x,
        color_matrix_df$y, ngrid,
        color00[2], color10[2], color01[2], color11[2]
    )
    color_matrix_df$B <- get_bilinear_val(
        color_matrix_df$x,
        color_matrix_df$y, ngrid,
        color00[3], color10[3], color01[3], color11[3]
    )
    color_matrix_df$hex_color_mix <- rgb(color_matrix_df$R, color_matrix_df$G, color_matrix_df$B, maxColorValue = 255)

    return(color_matrix_df)
}


#' Create 2D color legend plot for gene/ADT coexpression
#'
#' @param input Shiny internal parameter object containing UI user input values
#' @param input_data_type An integer value indicating if the user-uploaded input files are RDS files holding Seurat objects or SingleCellExperiment objects (1 = Seurat object, 2 = SingleCellExperiment object, etc.)
#' @param rds_object An RDS object containing metadata, assays, and reductions for a CITE-seq experiment. Can be NULL if the user uploaded an alternate supported file instead of an RDS file.
#' @param input_file_df A dataframe generated by retrieving file input data from a fileInput element in the UI (i.e., by running input$file_input in the app server). This dataframe contains information about each file uploaded by the user, such as the name of each file as it appears on the user's local filesystem (input_file_df$name) and the temporary datapath with which data from the file can be read in (input_file_df$datapath).
#'
#' @import magrittr
#' @importFrom ggplot2 aes ggplot geom_tile labs scale_x_continuous scale_y_continuous theme
#' @importFrom shiny req
#' @importFrom plotly ggplotly layout
#' @return legend for app coexpression plot in the form of a ggplot object.
#' @noRd
create_2d_color_legend <- function(input, input_data_type, rds_object, input_file_df) {

    # require these UI input items to render
    req(input$file_input, input$Assay_x_axis, input$Assay_y_axis, input$x_axis_feature, input$y_axis_feature)

    # selected metadata to color clusters by
    color_x <- input$x_axis_feature
    color_y <- input$y_axis_feature

    count_data_x <- get_data(
        category = "assays",
        input_data_type = input_data_type,
        rds_object = rds_object,
        input_file_df = input_file_df,
        assay_name = input$Assay_x_axis,
        reduction_name = NULL,
        assay_data_to_get = color_x
    )

    # extract count values as a vector from the original count data dataframe
    count_data_x <- count_data_x[[color_x]]
    count_data_y <- get_data(
        category = "assays",
        input_data_type = input_data_type,
        rds_object = rds_object,
        input_file_df = input_file_df,
        assay_name = input$Assay_y_axis,
        reduction_name = NULL,
        assay_data_to_get = color_y
    )

    # extract count values as a vector from the original count data dataframe
    count_data_y <- count_data_y[[color_y]]
    ngrid <- 16
    color_matrix_df <- get_color_matrix_df(ngrid)
    x <- quote(x)
    y <- quote(y)

    # show plot of 2D color legend
    p <- color_matrix_df %>%
        ggplot(aes(x = !!x, y = !!y)) +
        geom_tile(fill = color_matrix_df$hex_color_mix) +
        labs(x = input$x_axis_feature, y = input$y_axis_feature) +
        scale_x_continuous(
            breaks = c(0, ngrid),
            labels = c(
                paste0("low\n", round(min(count_data_x), digits = 2)),
                paste0("high\n", round(max(count_data_x), digits = 2))
            )
        ) +
        scale_y_continuous(
            breaks = c(0, ngrid),
            labels = c(
                paste0("low\n", round(min(count_data_y), digits = 2)),
                paste0("high\n", round(max(count_data_y), digits = 2))
            )
        ) +
        theme(text = element_text(size = 12))

    p <- ggplotly(p) %>% layout(hovermode = FALSE)

    return(p)
}


#' Feature co-expression dimension reduction plot
#'
#' @param input Shiny internal parameter object containing UI user input values
#' @param input_data_type An integer value indicating if the user-uploaded input files are RDS files holding Seurat objects or SingleCellExperiment objects (1 = Seurat object, 2 = SingleCellExperiment object, etc.)
#' @param rds_object An RDS object containing metadata, assays, and reductions for a CITE-seq experiment. Can be NULL if the user uploaded an alternate supported file instead of an RDS file.
#'
#' @import magrittr
#' @importFrom ggplot2 aes ggplot geom_tile labs scale_x_continuous scale_y_continuous
#' @importFrom shiny req
#' @importFrom dplyr left_join
#' @importFrom plotly plot_ly config layout event_register
#' @return dimension reduction plot with the correct colors for a 2-feature co-expression plot
#' @noRd
coexpression_plot <- function(input, input_data_type, rds_object) {

    # require these UI input items to render
    req(input$file_input, input$Assay_x_axis, input$Assay_y_axis, input$x_axis_feature, input$y_axis_feature)

    # reduction choice as a string
    reduction <- input$reduction_expr_2d

    # selected metadata to color clusters by
    color_x <- input$x_axis_feature
    color_y <- input$y_axis_feature

    count_data_x <- get_data(
        category = "assays",
        input_data_type = input_data_type,
        rds_object = rds_object,
        input_file_df = input_file_df,
        assay_name = input$Assay_x_axis,
        reduction_name = NULL,
        assay_data_to_get = color_x
    )

    count_data_y <- get_data(
        category = "assays",
        input_data_type = input_data_type,
        rds_object = rds_object,
        input_file_df = input_file_df,
        assay_name = input$Assay_y_axis,
        reduction_name = NULL,
        assay_data_to_get = color_y
    )

    # extract only the count values as a vector from the original count data dataframe
    count_data_x <- count_data_x[[color_x]]

    # extract only the count values as a vector from the original count data dataframe
    count_data_y <- count_data_y[[color_y]]

    # gather reductions information
    cell_data <- get_data(
        category = "reductions",
        input_data_type = input_data_type,
        rds_object = rds_object,
        input_file_df = input_file_df,
        assay_name = NULL,
        reduction_name = reduction
    )

    # create list containing all column names of cell_data
    cell_col <- colnames(cell_data)

    # map gene expression values to 2d color grid
    ngrid <- 16
    color_matrix_df <- get_color_matrix_df(ngrid)

    coexpression_df <- data.frame(
        x = round(ngrid * count_data_x / max(count_data_x)),
        y = round(ngrid * count_data_y / max(count_data_y))
    )

    coexpression_umap_df <- cbind(coexpression_df, cell_data) # combine umap reduction data with expression data
    mapped_df <- left_join(coexpression_umap_df, color_matrix_df, by = c("x", "y")) # map hex color codes to interpolated gene expression values in merged data and create a new data frame

    m <- list(
        r = 120
    )

    # create UMAP that colors by expression levels
    p <- plot_ly(mapped_df,
        source = "expression_2d_plot",
        x = ~ cell_data[, 1],
        y = ~ cell_data[, 2],
        customdata = rownames(cell_data),
        type = "scatter",
        mode = "markers",
        width = "400px",
        marker = list(
            size = 3,
            color = ~ mapped_df$hex_color_mix
        )
    ) %>%
    config(
        toImageButtonOptions = list(
            format = "png",
            scale = 10
        )
    ) %>%
    layout(
        showlegend = FALSE,
        title = toupper(reduction),
        xaxis = list(title = cell_col[1]),
        yaxis = list(title = cell_col[2]),
        dragmode = "select",
        margin = m
    ) %>%
        event_register("plotly_selected")

    return(p)

}