R/utility_functions_bivariate.R

In SaskiaFreytag/schex: Hexbin plots for single cell omics data

.plot_hexbin_bivariate_helper_1 <- function(x, feature, out, cID, fan) {
    if (fan) {
        hh <- .make_hexbin_function(x + 1, "mean", cID)
        hh_sd <- .make_hexbin_function(x + 1, "sd", cID)
        hh_cv <- hh_sd / hh
    } else {
        hh <- .make_hexbin_function(x, "mean", cID)
        hh_sd <- .make_hexbin_function(x, "sd", cID)
    }

    out <- as_tibble(out)

    if (grepl("^[[:digit:]]", feature)) {
        feature <- paste0("F_", feature)
    }

    feature <- gsub("-", "_", feature)

    col_hh <- paste0(feature, "_", "mean")
    col_hh_sd <- paste0(feature, "_", "sd")

    func1 <- paste0("out$", col_hh, " <- hh")
    eval(parse(text = func1))

    func2 <- paste0("out$", col_hh_sd, " <- hh_sd")
    eval(parse(text = func2))

    if (fan) {
        col_hh_cv <- paste0(feature, "_", "cv")
        func3 <- paste0("out$", col_hh_cv, " <- hh_cv")
        eval(parse(text = func3))

        .plot_hexbin_bivariate_helper_2(out, x = col_hh, y = col_hh_cv, fan)
    } else {
        .plot_hexbin_bivariate_helper_2(out, x = col_hh, y = col_hh_sd, fan)
    }
}

.plot_hexbin_bivariate_helper_2 <- function(out, x, y, fan) {
    na_ind <- which(is.na(out[, y]))
    if (length(na_ind) > 0) {
        out[na_ind, y] <- 0
    }

    if (fan) {
        out[[y]] <- replace(out[[y]], out[[y]] > 1, 1)
    }

    out$bi_class <- .bi_class(out, x = x, y = y, fan)


    if (length(na_ind) > 0) {
        out$bi_class[na_ind] <- NA
        out[na_ind, y] <- NA
        out[na_ind, x] <- NA
    }

    out$bi_color <- .bivariate_colour_scheme(fan)[
        match(out$bi_class, .bivariate_colour_scheme(fan)[, 1]), 2
    ]
    out$bi_color[is.na(out$bi_class)] <- "grey"

    out
}


.bi_class <- function(out, x, y, fan) {
    if (fan) {
        breaks_x <- as.numeric(cut(out[[x]], 8))
        breaks_y <- as.numeric(cut(out[[y]], breaks = c(-1, 0.25, 0.5, 0.75, 1)))

        paste0(breaks_x, "-", breaks_y)
    } else {
        breaks_x <- as.numeric(cut(out[[x]], 4))
        breaks_y <- as.numeric(cut(out[[y]], 4))

        paste0(breaks_x, "-", breaks_y)
    }
}

.bivariate_colour_scheme <- function(fan) {
    if (fan) {
        matrix(ncol = 2, c(
            "1-1", "#421964",
            "2-1", "#3d4080",
            "3-1", "#326389",
            "4-1", "#30818c",
            "5-1", "#399e8b",
            "5-1", "#57ba7e",
            "6-1", "#92d267",
            "7-1", "#dde15c",
            "8-1", "#6b588e",
            "1-2", "#6b588e",
            "2-2", "#638c9f",
            "3-2", "#638c9f",
            "4-2", "#72b99b",
            "5-2", "#72b99b",
            "6-2", "#c4db7d",
            "7-2", "#c4db7d",
            "8-2", "#8f95b1",
            "1-3", "#8f95b1",
            "2-3", "#8f95b1",
            "3-3", "#8f95b1",
            "4-3", "#acd3a8",
            "5-3", "#acd3a8",
            "6-3", "#acd3a8",
            "7-3", "#acd3a8",
            "8-3", "#b7cac9",
            "1-4", "#b7cac9",
            "2-4", "#b7cac9",
            "3-4", "#b7cac9",
            "4-4", "#b7cac9",
            "5-4", "#b7cac9",
            "6-4", "#b7cac9",
            "7-4", "#b7cac9",
            "8-4", "#b7cac9"
        ), byrow = TRUE)
    } else {
        matrix(ncol = 2, c(
            "1-1", "#402d76",
            "2-1", "#6b588f",
            "3-1", "#9283aa",
            "4-1", "#b8b1c3",
            "1-2", "#30728b",
            "2-2", "#638c9f",
            "3-2", "#8da7b4",
            "4-2", "#b6c3c9",
            "1-3", "#43ad86",
            "2-3", "#72ba9c",
            "3-3", "#98c6b1",
            "4-3", "#bbd2c8",
            "1-4", "#b6da5f",
            "2-4", "#c4db7d",
            "3-4", "#cfdd9e",
            "4-4", "#d8ddbd"
        ), byrow = TRUE)
    }
}