R/plot_locus_multi.R

In bschilder/echoplot: echoverse module: Locus plot creation for fine-mapping and colocalization studies

#' Plot multi-GWAS/QTL or multi-ancestry fine-mapping results
#'
#' Plot multi-GWAS/QTL or multi-ancestry(i.e. trans-ethnic) fine-mapping
#'  results generated by tools like \link[echofinemap]{PAINTOR}. 
#' @param dat_ls A named list of \link[data.table]{data.table}s generated by
#' \code{echolocatoR::finemap_loci}.
#' @param conditions Conditions to group \code{dat_ls} by.
#' The length of \code{conditions} must equal the number of
#'  items in \code{dat_ls}. 
#' @param LD_ls A named list of link disequilibrium (LD) matrices 
#' (one per item in \code{dat_ls}).  
#' @inheritParams plot_locus
#' @inheritDotParams plot_locus
#' 
#' @export
#' @importFrom data.table rbindlist
#' @importFrom stats setNames
#' @importFrom echoLD get_lead_r2
#' @examples 
#' locus_dir <- file.path(tempdir(),echodata::locus_dir)
#' #### Make dat_ls ####
#' dat <- echodata::filter_snps(echodata::BST1, bp_distance = 10000) 
#' dat_ls <- list(gwas1=dat, gwas2=dat)
#' #### Make LD_ls ####
#' LD_matrix <- echodata::BST1_LD_matrix
#' LD_ls <- list(ancestry1=LD_matrix, ancestry2=LD_matrix)
#' #### Make plot ####
#' plot_list <- plot_locus_multi(dat_ls = dat_ls, 
#'                               LD_ls = LD_ls,
#'                               locus_dir = locus_dir)
plot_locus_multi <- function(dat_ls,
                             LD_ls,
                             locus_dir,
                             conditions=names(dat_ls), 
                             show_plot=TRUE, 
                             verbose=TRUE,
                             ...){ 
    #### Check names ####
    if(is.null(conditions)){
        messager("No conditions provided.",
                 "Generating default names: 'dataset#'",v=verbose)
        names(dat_ls) <- paste0("dataset",seq_len(length(dat_ls)))
        conditions <- names(dat_ls)
    }
    if(length(conditions)!=length(conditions)){
        stp <- paste(
            "length(conditions) must equal",
            "the number of items in dat_ls."
        )
        stop(stp)
    }
    #### Check LD ####
    if(length(LD_ls)!=length(dat_ls)){
        if(length(LD_ls)==1){
            messager("Only 1 item in LD_ls provided.",
                     "Using the same LD matrix for all",
                     length(dat_ls),"primary datasets.",v=verbose)
        } else {
            stp <- paste(
                "length(LD_ls) must equal 1",
                "or the number of items in dat_ls."
            )
            stop(stp)
        }
    }
    #### Get LD ####
    dat_ls <- lapply(stats::setNames(seq_len(length(dat_ls)),
                                     names(dat_ls)),
                     function(i){
        echoLD::get_lead_r2(
            dat = dat_ls[[i]],
            LD_matrix = LD_ls[[i]],
            LD_format = "guess",
            verbose = verbose)
    })
    plot_dat <- data.table::rbindlist(dat_ls, 
                                      use.names = TRUE,
                                      idcol = "condition")
    gg <- plot_locus(dat = plot_dat,
                     locus_dir = locus_dir, 
                     facet_formula = "condition + Method~.",
                     ...)
    return(gg)
}