ideograms.r

.one_chrom_outline <- function(chrom_name, len, offset, width, centro_s, centro_e, notch_prop=0.6){
    one_side <- c(0, centro_s-offset, (centro_s + centro_e)/2, centro_e+offset, len)
    wd = width/2
    data.frame(
      chrom = chrom_name,
      x = c(one_side, rev(one_side), 0),
      y = c(wd, wd, notch_prop * wd, wd, wd, -wd, -wd, -notch_prop * wd, -wd, -wd, wd)
      )    
}


## Take data.frames from bed files (i.e. Chrom, Start, End) with sizes of
## chromosomes an locations of centromeres and produce a data.frame to used as
## input to geom_path() to draw an ideogram.
#
# sizes = genome 'sizes' data.frame with two columns:
#   chrom = chromosome name
#   len = length of chromosome
# centromeres = location of centromeres in BED format, first three columns:
#   chrom = chromosome name
#   start = start of interval including centro
#   end = end of interval including centro
# offset = When should the notch begin before/after the start/end of the centro
# width = total width of the chromosome (will be centred on zero in the plot)
# notch prop = notch width as proportion of total width 
# 
   
chrom_outline_df <- function(sizes, centromeres, offset, width, notch_prop=0.6){
    if(nrow(centro) != nrow(sizes)){
        stop("number of centromeres and number of chroms is different?")
    }
    if( any(centro$chrom != sizes$chrom)){
        stop("centros and choms in difference order?")
    }
    n = nrow(centro)
    res <- data.frame()
    #accumulating in a for loop! Can't see a prettier way...
    for( chrom_i in 1:n ){
        df <- .one_chrom_outline( sizes$chrom[chrom_i],
                                  sizes$len[chrom_i],
                                  offset,
                                  width,
                                  centromeres$start[chrom_i],
                                  centromeres$end[chrom_i],
                                  notch_prop)        
        res <- rbind(res, df)
    }
    res
}

upper_triangles <- function(chrom_df){
    per_chrom <- split(chrom_df, chrom_df$chrom)
    do.call(rbind.data.frame, lapply(per_chrom, function(x) x[c(2:4,2),]))
}

lower_triangles <- function(chrom_df){
    per_chrom <- split(chrom_df, chrom_df$chrom)
    do.call(rbind.data.frame, lapply(per_chrom, function(x) x[c(7:9,7),]))
}

geom_bed <- function(data, bottom, top, ...){    
    data$interval <- 1:nrow(data)
    data$top <- top
    data$bottom <- bottom
    geom_rect(data=data, aes(xmin=start, xmax=end, ymin=bottom, ymax=top, group=interval), ...)
}

geom_locus <- function(data, y, ...){
    data$y <- y
    geom_point(data=data, aes(x=(start+end)/2, y=y), ...)
}

# Make one
nice_blue <- "#0051d4"
ssp <- read_bed("ssp_data.tsv")
AT <- read_bed("AT_rich.bed")
sizes <- read.table("EfFl1_v0_1.sizes", comment = "m", col.names=c("chrom", "len"))
centro <- read_bed("centro.bed")
chrom_df <- chrom_outline_df(sizes, centro, 1e5, 0.4)

ggplot() + geom_bed(AT, -.2,.2, fill=nice_blue) +
    geom_locus(ssp, y=0.3, alpha=0.8) + 
    scale_y_continuous(limits=c(-1,1)) + 
    scale_x_continuous("Positon (Mb)", labels = function(x) x/1e6) +
    geom_label_repel(data=ssp, aes((start + end)/2,0.3, label=V6), nudge_y=0.5) +
    geom_polygon(data=upper_triangles(chrom_df), aes(x,y), fill="white", colour=NA) +
    geom_polygon(data=lower_triangles(chrom_df), aes(x,y), fill="white", colour=NA) +
    geom_path(data=chrom_df, aes(x,y)) + facet_wrap(chrom ~ ., ncol=2) + theme_bw() +
    theme(legend.position = "none",
          panel.grid = element_blank(),
          axis.title.y = element_blank(),
          axis.text.y = element_blank(),
          axis.ticks.y  = element_blank()
    ) 

nice !!! where can I get the example data? Thanks.