R/geom_rect-method.R

In ggbio: Visualization tools for genomic data

## TODO::
## Let's load a RefSeq data
## naming the interval
## two mode? packed, full with name (default)
## reduce is just a stat transformation at lower level
setGeneric("geom_rect", function(data, ...) standardGeneric("geom_rect"))

setMethod("geom_rect", "ANY", function(data, ...){
  ggplot2::geom_rect(data = data, ...)
})

## alignment should be convenient toggle with chevron...
setMethod("geom_rect", "GRanges", function(data,...,
                                           xlab, ylab, main,
                                           facets = NULL,
                                           stat = c("stepping", "identity"),
                                           rect.height = NULL,
                                           group.selfish = TRUE){


  ## make this by hand
  args <- list(...)
  args$facets <- facets
  args.aes <- parseArgsForAes(args)
  args.non <- parseArgsForNonAes(args)
  if("extend.size" %in% names(args.non))
    es <- args.non$extend.size
  else
    es <- 0
  args.facets <- subsetArgsByFormals(args, facet_grid, facet_wrap)
  facet <- .buildFacetsFromArgs(data, args.facets)
  stat <- match.arg(stat)
  if(length(data)){
  if(stat == "stepping"){
    if(is.null(rect.height))
      rect.height <- 0.4
    grl <- splitByFacets(data, facets)
    res <- endoapply(grl,
                     function(dt){
                       if("group" %in% names(args.aes))
                         dt <- addStepping(dt, group.name = quo_name(args.aes$group),
                                            group.selfish = group.selfish,
                                           extend.size = es)
                       else
                         dt <- addStepping(dt, extend.size = es)
                     })
    res <- unlist(res)
    df <- mold(res)

    args.aes <- args.aes[!(names(args.aes) %in% c("xmin", "xmax", "ymin", "ymax", "data"))]
    args.non <- args.non[!(names(args.non) %in% c("xmin", "xmax", "ymax", "ymax", "data", "facets"))]
    if("group" %in% names(args.aes))
      gpn <- quo_name(args.aes$group)
    else
      gpn <- "stepping"
    ## overcome 1 pixel problem
    args.aes.seg <- args.aes[!names(args.aes) %in%  c("group", "fill", "y", "xend", "yend", "x")]
    args.aes.seg <- c(args.aes.seg, list(x = substitute(start),
                                 xend = substitute(start),
                                 y = substitute(stepping - rect.height),
                                 yend = substitute(stepping + rect.height)))

    args.aes.seg <- args.aes.seg[names(args.aes.seg) != "size"]
    aes.res.seg <- do.call(aes, args.aes.seg)
    args.res.seg <- c(list(data = df), list(aes.res.seg),
                  args.non)
    p <- list(do.ggcall(ggplot2::geom_segment,args.res.seg))
    
    args.aes <- args.aes[names(args.aes) != "group"]
    args.aes <- c(args.aes, list(xmin = substitute(start),
                                 xmax = substitute(end),
                                 ymin = substitute(stepping - rect.height),
                                 ymax = substitute(stepping + rect.height)))

    args.aes <- args.aes[names(args.aes) != "size"]
    aes.res <- do.call(aes, args.aes)
    args.res <- c(list(data = df), list(aes.res),
                  args.non)
    
    p <- c(p, list(do.ggcall(ggplot2::geom_rect,args.res)))
    p <- .changeStrandColor(p, args.aes)
    .df.lvs <- unique(df$stepping)
    .df.sub <- df[, c("stepping", gpn)]
    .df.sub <- .df.sub[!duplicated(.df.sub$stepping),]
    ## FIXME:
    if(gpn != "stepping" & group.selfish){
      p <- c(p , list(scale_y_continuous(breaks = .df.sub$stepping,
                                         labels = as.character(.df.sub[, gpn]))))
    }else{
      p <- c(p, list(scale_y_continuous(breaks = NULL)))
    }
    if(missing(ylab))
      p <- c(p, list(ggplot2::ylab("")))
    else
      p <- c(p, list(ggplot2::ylab(ylab)))
  }
  
  if(stat == "identity"){
    if(!"y" %in% names(args.aes)){
      if(!all(c("ymin","ymax", "xmin", "xmax") %in% names(args.aes))){
        stop("aes(xmin =, xmax= , ymin =, ymax= ) is required for stat 'identity',
              you could also specify aes(y =) only as alternative")
      }else{
        args.aes.seg <- args.aes
        args.aes.seg$x <- args.aes$xmin
        args.aes.seg$xend <- args.aes$xmax
        args.aes.seg$y <- args.aes$ymin
        args.aes.seg$yend <- args.aes$ymax
      }
    }else{
      .y <- quo_squash(args.aes$y)
      if(is.null(rect.height)){
         rect.height <- diff(range(values(data)[,as.character(.y)]))/20
      }
      args.aes.seg <- args.aes
      args.aes.seg$x <- as.name("start")
      args.aes.seg$xend <- as.name("start")
      args.aes.seg$y <- substitute(y + rect.height, list(y = .y, rect.height = rect.height))
      args.aes.seg$yend <- substitute(y - rect.height , list(y = .y, rect.height = rect.height))
      
      args.aes$xmin <- as.name("start")
      args.aes$xmax <- as.name("end")
      args.aes$ymin <- substitute(y + rect.height, list(y = .y, rect.height = rect.height))
      args.aes$ymax <- substitute(y - rect.height , list(y = .y, rect.height = rect.height))
    }
    df <- mold(data)

    ## overcome 1 pixel problem
    args.aes.seg <- args.aes.seg[names(args.aes.seg) != "group"]
    args.aes.seg <- args.aes.seg[names(args.aes.seg) != "size"]
    
    aes.res.seg <- do.call(aes, args.aes.seg)
    args.res.seg <- c(list(data = df), list(aes.res.seg),
                  args.non)
    p <- list(do.ggcall(ggplot2::geom_segment,args.res.seg))
    args.aes <- args.aes[names(args.aes) != "group"]
    args.aes <- args.aes[names(args.aes) != "size"]
    
    aes.res <- do.call(aes, args.aes)
    args.res <- c(list(data = df), list(aes.res),
                  args.non)
    p <- c(p, list(do.ggcall(ggplot2::geom_rect,args.res)))
    p <- .changeStrandColor(p, args.aes)
    if(!missing(ylab))
        p <- c(p, list(ggplot2::ylab(ylab)))
  }}else{
    p <- NULL
  }
  p <- c(list(p) , list(facet))

  if(missing(xlab)) 
    xlab <- ""
  p <- c(p, list(ggplot2::xlab(xlab)))
  
  if(!missing(main))
    p <- c(p, list(labs(title = main)))
  
  p
})