Merge pull request #46 from SingerLab/ks

version upgrade
SingerLab · Jul 18, 2023 · 44b83c8 · 44b83c8
2 parents 66efbea + a3862e5
commit 44b83c8
Show file tree

Hide file tree

Showing 24 changed files with 658 additions and 185 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: gac
-Version: 0.0.9035
-Date: 2023-05-23
+Version: 0.0.9036
+Date: 2023-07-18
 Title: Genetic Analysis of Cells
 Authors@R: person("Rodrigo Gularte Merida",
 	   role = c("aut", "cre"),

diff --git a/NAMESPACE b/NAMESPACE
@@ -14,6 +14,8 @@ export(binaryDDRC)
 export(buildCNR)
 export(callCN)
 export(callDNA_CN)
+export(chr_breaks)
+export(chr_colors)
 export(cluster_heterogeneity)
 export(create_chromosome_annotation)
 export(doKSpectral)
@@ -33,6 +35,8 @@ export(list_genes_in_region)
 export(lookupCN)
 export(mapd)
 export(mark.genes)
+export(maximum.percentage)
+export(mid_chr)
 export(minimum.intersect)
 export(nbins)
 export(ncells)
@@ -50,6 +54,7 @@ export(plot_cn_correlations)
 export(plot_effect)
 export(plot_frequencies)
 export(plot_lr)
+export(plot_sK)
 export(proportion_of_polymorphic_loci)
 export(pull_gene_copy_numbers)
 export(pull_gene_details)
@@ -99,6 +104,7 @@ importFrom(graphics,legend)
 importFrom(graphics,lines)
 importFrom(graphics,plot)
 importFrom(graphics,points)
+importFrom(graphics,segments)
 importFrom(grid,gpar)
 importFrom(grid,unit)
 importFrom(qvalue,qvalue)

diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,13 @@
+# gac 0.0.9036
+* allow arguments to be passed down tho HeatmapAnnotation when implementing create_chromosome_annotation
+* simplified create_chromosome_annotation base functions
+
+* `add_in_silico_root` now exits if "X" contains `cell.name` e.g. 'diploid'
+
+* adds plot_sK to inspect kParameter and kStable
+
+* new method for assigning clusters in Bray Curtis Dissimilarity
+
 # gac 0.0.9035
 * added function to add an in-silico root cell and clone
 

diff --git a/R/add_in_silico_root.R b/R/add_in_silico_root.R
@@ -1,4 +1,3 @@
-
 #' build an in-silico root cell and clone profile
 #'
 #' By default cell is a female diploid cell
@@ -31,8 +30,14 @@
 #'
 #' @importFrom assertthat assert_that
 #' @export
-add_in_silico_root <- function(cnr, cell.name = "diploid",
-                               female = TRUE, base.ploidy = 2L) {
+add_in_silico_root <- function(cnr, base.ploidy = 2L,
+                               cell.name = "diploid",
+                               female = TRUE) {
+
+    if(any(cell.name %in% colnames(cnr$X))) {
+        stop("diploid root exists, please remove or change name")
+    }
+
     ## 
     if(!is.integer(base.ploidy)) {
         base.ploidy <- as.integer(round(base.ploidy))

diff --git a/R/create_chromAnno.R b/R/create_chromAnno.R
@@ -44,36 +44,37 @@ create_chromosome_annotation <- function(cnr, side = "left", ...) {
 #'
 #' @param cnr a cnr bundle
 #'
+#' @param labels_gp graphic parameters from \link[grid]{gpar}, default fontsize = 10
+#' 
+#' @param labels_rot label rotation, default 90
+#'
 #' @param ... additional prameters passed to HeatmapAnnotation
 #' 
 #' @importFrom ComplexHeatmap rowAnnotation anno_mark
 #' @importFrom grid gpar
-create_chromosome_annotation_left <- function(cnr, ...) {
-    cf <- factor(cnr$chromInfo$bin.chrom)
-    grs <- c("#404040", "#BABABA")
-    rp <- ceiling(length(unique(cf))/2)
-    chl <- rep(grs, rp)
-    chl <- chl[1:length(unique(cf))]
-    names(chl) <- unique(cf)
+create_chromosome_annotation_left <- function(cnr,
+                                              labels_gp = grid::gpar(fontsize = 10),
+                                              labels_rot = 90, ...) {
 
-    chrBreaks <- cumsum(table(cnr$chromInfo$bin.chrom))
-    if (length(chrBreaks) == 1) {
-        midChr <- floor(chrBreaks/2)
-    }
-    else {
-        midChr <-
-            chrBreaks - floor((chrBreaks - c(1, chrBreaks[1:(length(chrBreaks) - 
-                                                             1)]))/2)
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cf <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cf <- factor(cnr$chromInfo$bin.chrom)
     }
+
+    midChr <- mid_chr(cnr)
+    chl <- chr_colors(cnr)
+
     chrAnno <- ComplexHeatmap::rowAnnotation(
         labs = ComplexHeatmap::anno_mark(at = midChr, 
-                         labels = unique(cf),
+                         labels = names(midChr),
                          side = "left",
-                         labels_gp = grid::gpar(fontsize = 10)), 
-        chr = cf, col = list(chr = chl),
+                         labels_gp = labels_gp,
+                         labels_rot = labels_rot), 
+        chr = cf, col = list(chr = chl[names(midChr)]),
         show_annotation_name = FALSE,
-        show_legend = FALSE)
-
+        show_legend = FALSE,
+        ...)
 
     return(chrAnno)
 }
@@ -89,32 +90,26 @@ create_chromosome_annotation_left <- function(cnr, ...) {
 #' @importFrom grid gpar
 create_chromosome_annotation_top <- function(cnr,
                                              labels_gp = grid::gpar(fontsize = 10),
-                                             labels_rot = 90, ...) {
-    cf <- factor(cnr$chromInfo$bin.chrom)
-    grs <- c("#404040", "#BABABA")
-    rp <- ceiling(length(unique(cf))/2)
-    chl <- rep(grs, rp)
-    chl <- chl[1:length(unique(cf))]
-    names(chl) <- unique(cf)
-
-    chrBreaks <- cumsum(table(cnr$chromInfo$bin.chrom))
-    if (length(chrBreaks) == 1) {
-        midChr <- floor(chrBreaks/2)
-    }
-    else {
-        midChr <-
-            chrBreaks - floor((chrBreaks - c(1, chrBreaks[1:(length(chrBreaks) - 
-                                                             1)]))/2)
+                                             labels_rot = 0, ...) {
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cf <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cf <- factor(cnr$chromInfo$bin.chrom)
     }
+
+    midChr <- mid_chr(cnr)
+    chl <- chr_colors(cnr)
+
     chrAnno <- ComplexHeatmap::HeatmapAnnotation(
         labs = ComplexHeatmap::anno_mark(at = midChr, 
-                         labels = unique(cf),
+                                         labels = names(midChr),
                          side = "top",
                          labels_gp = labels_gp,
-                         labels_rot = labels_rot, ...), 
-        chr = cf, col = list(chr = chl),
+                         labels_rot = labels_rot), 
+        chr = cf, col = list(chr = chl[names(midChr)]),
         show_annotation_name = FALSE,
-        show_legend = FALSE)
+        show_legend = FALSE,
+        ...)
 
     return(chrAnno)
 }
@@ -130,69 +125,149 @@ create_chromosome_annotation_top <- function(cnr,
 #' @importFrom grid gpar
 create_chromosome_annotation_bottom <- function(cnr,
                                              labels_gp = grid::gpar(fontsize = 10),
-                                             labels_rot = 90, ...) {
-    cf <- factor(cnr$chromInfo$bin.chrom)
-    grs <- c("#404040", "#BABABA")
-    rp <- ceiling(length(unique(cf))/2)
-    chl <- rep(grs, rp)
-    chl <- chl[1:length(unique(cf))]
-    names(chl) <- unique(cf)
-
-    chrBreaks <- cumsum(table(cnr$chromInfo$bin.chrom))
-    if (length(chrBreaks) == 1) {
-        midChr <- floor(chrBreaks/2)
-    }
-    else {
-        midChr <-
-            chrBreaks - floor((chrBreaks - c(1, chrBreaks[1:(length(chrBreaks) - 
-                                                             1)]))/2)
+                                             labels_rot = 0, ...) {
+
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cf <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cf <- factor(cnr$chromInfo$bin.chrom)
     }
+
+    midChr <- mid_chr(cnr)
+    chl <- chr_colors(cnr)
+
     chrAnno <- ComplexHeatmap::HeatmapAnnotation(
-        chr = cf, col = list(chr = chl),
+        chr = cf, col = list(chr = chl[names(midChr)]),
         labs = ComplexHeatmap::anno_mark(at = midChr, 
-                         labels = unique(cf),
+                         labels = names(midChr),
                          side = "bottom",
                          labels_gp = labels_gp,
-                         labels_rot = labels_rot, ...), 
+                         labels_rot = labels_rot), 
         show_annotation_name = FALSE,
-        show_legend = FALSE)
+        show_legend = FALSE,
+        ...)
 
     return(chrAnno)
 }
 
 #' create chromosome annotations for custom heatmaps
 #'
 #' @param cnr a cnr bundle
+#'
+#' @param labels_gp graphic parameters from \link[grid]{gpar}, default fontsize = 10
+#'
+#' @param labels_rot label rotation, default 90
+#'
 #' @param ... additional prameters passed to HeatmapAnnotation
 #' 
 #' @importFrom ComplexHeatmap rowAnnotation anno_mark
 #' @importFrom grid gpar
-create_chromosome_annotation_right <- function(cnr, ...) {
-    cf <- factor(cnr$chromInfo$bin.chrom)
-    grs <- c("#404040", "#BABABA")
-    rp <- ceiling(length(unique(cf))/2)
-    chl <- rep(grs, rp)
-    chl <- chl[1:length(unique(cf))]
-    names(chl) <- unique(cf)
+create_chromosome_annotation_right <- function(cnr,
+                                               labels_gp = grid::gpar(fontsize = 10),
+                                               labels_rot = 90, ...) {
 
-    chrBreaks <- cumsum(table(cnr$chromInfo$bin.chrom))
-    if (length(chrBreaks) == 1) {
-        midChr <- floor(chrBreaks/2)
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cf <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cf <- factor(cnr$chromInfo$bin.chrom)
     }
-    else {
-        midChr <-
-            chrBreaks - floor((chrBreaks - c(1, chrBreaks[1:(length(chrBreaks) - 
-                                                             1)]))/2)
-    }
-
+
+    midChr <- mid_chr(cnr)
+    chl <- chr_colors(cnr)
+
     chrAnno <- ComplexHeatmap::rowAnnotation(
-        chr = cf, col = list(chr = chl),
+        chr = cf, col = list(chr = chl[names(midChr)]),
         labs = ComplexHeatmap::anno_mark(at = midChr, 
-                         labels = unique(cf),
+                         labels = names(midChr),
                          side = "right",
-                         labels_gp = grid::gpar(fontsize = 10),
-                         ...), 
-        show_legend = FALSE)
+                         labels_gp = labels_gp,
+                         labels_rot = labels_rot),
+        show_legend = FALSE,
+        ...)
 
     return(chrAnno)
 }
+
+
+#' estiamte chromosome midpoint locations along a continuous genome
+#'
+#' @param cnr a cnr
+#'
+#' @param bin  weather to use bin or gene data, default is true
+#'
+#' @return
+#' A named vector of chromosome midpoints. Useful for adding tick
+#' marks in figures.  Midpoint is not the centromere location.
+#' 
+#' @export
+mid_chr <- function(cnr, bin = TRUE) {
+    brk <- chr_breaks(cnr, bin = bin)
+
+    if (length(brk) == 1) {
+        mid.pt <- floor(brk/2)
+    } else {
+        mid.pt <-
+            brk - floor((brk - c(1, brk[1:(length(brk) - 1)]))/2)
+    }
+        return(mid.pt)
+}
+
+
+#' estimate chromosome end locations along a continuous genome
+#'
+#' @param cnr a cnr
+#'
+#' @param bin  weather to use bin or gene data, default is true
+#'
+#' @return
+#' A named vector of chromosome breaks locations in the data.
+#' Useful when adding lines to seaparete chromosomes,  or
+#' a background when highlighting a chromosome
+#' 
+#' @export
+chr_breaks <- function(cnr, bin = TRUE) {
+
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cnr$chromInfo$bin.chrom <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cnr$chromInfo$bin.chrom <- factor(cnr$chromInfo$bin.chrom)
+    }
+
+    if(bin) {
+        brk <- cumsum(table(cnr$chromInfo$bin.chrom))
+    } else {
+        brk <- cumsum(table(cnr$gene.index$chrom))
+    }
+
+    return(brk)
+}
+
+
+#' chromosome colors
+#' @param cnr a cnr bundle
+#'
+#' @param col alternating chromosome colors, default is c("#404040", "#BABABA")
+#' 
+#' @param bin  weather to use bin or gene data, default is true
+#'
+#' @return
+#' A named vector of default chromosome colors
+#' @export
+chr_colors <- function(cnr, col = c("#404040", "#BABABA"),
+                       bin = TRUE) {
+
+    if(is.factor(cnr$chromInfo$bin.chrom)) {
+        cf <- droplevels(cnr$chromInfo$bin.chrom)
+    } else {
+        cf <- factor(cnr$chromInfo$bin.chrom)
+    }
+
+    rp <- ceiling(length(unique(cf))/2)
+
+    chl <- rep(col, rp)
+    chl <- chl[1:length(unique(cf))]
+    names(chl) <- unique(cf)
+
+    return(chl)
+}
+