/R/utils.R

  1setMethod('validateChr',c('GenomicRanges'),
  2          function(obj,model,...){
  3            if(inherits(class(model),'GenomicRanges'))
  4              chrset <- unique(as.character(seqnames(model)))
  5            else
  6              chrset <- model
  7            chr <- as.character(seqnames(obj))
  8            obj <- obj[chr %in% chrset]
  9            return(obj)
 10          })
 11
 12isValidatedChr <- function(grl,model){
 13  if(is(grl,'list')){
 14    chrset <- unique(as.character(seqnames(model)))
 15    allLst <- lapply(seq_len(length(grl)),function(i) {
 16      idx <- unique(as.character(seqnames(grl[[i]]))) %in% chrset
 17      if(all(idx)==FALSE){
 18        message(paste("Chromosome names of",names(grl)[i],"is invalid"))
 19        message(paste(unique(as.character(seqnames(grl[[i]])))[!idx],' '),'is invalid')
 20      }
 21      all(idx)
 22    })
 23    return(all(unlist(allLst)))
 24  }
 25  if(is(grl,'GenomicRanges')){
 26    chrset <- unique(as.character(seqnames(model)))
 27    idx <- unique(as.character(seqnames(grl))) %in% chrset
 28    return(all(idx))
 29  }
 30}
 31
 32containLetters <- function(obj,only=FALSE){
 33  obj <- as.character(obj)
 34  obj <- tolower(obj)
 35  obj <- unlist(strsplit(obj,""))
 36  if(!only){
 37    res <- any(obj%in%letters)
 38    return(res)
 39  }else{
 40    res <- all(obj%in%letters)
 41    return(res)
 42  }
 43}
 44
 45xy2polar <- function(x,y){
 46  angle <- atan(y/x)/pi*180
 47  radius <- sqrt(x^2+y^2)
 48  data.frame(radius=radius,angle=angle)
 49}
 50
 51visZoom <- function(obj,scale.factor=c(4,4)){
 52  ## this obj must contain list of scene, viewU, layer
 53  visenv$new.view <- qplotView(obj$scene)
 54  visenv$new.view$show()
 55  visenv$new.view$scale(scale.factor[1],scale.factor[2])
 56}
 57
 58setHover <- function(obj,layer.name){
 59  layers <- obj$layer
 60  nms <- names(layers)
 61  layers[[layer.name]]$setAcceptsHoverEvents(TRUE)
 62  for(i in setdiff(nms,layer.name)){
 63    layers[[i]]$setAcceptsHoverEvents(FALSE)
 64  }
 65}
 66
 67
 68setHoverNext <- function(obj){
 69  layers <- obj$layer
 70  nms <- names(layers)
 71  idx <- unlist(unname(lapply(layers,function(x) x$acceptsHoverEvents())))
 72  if(sum(idx)>1|sum(idx)==0){
 73    idx <- rep(FALSE,length(idx))
 74    idx[1] <- TRUE
 75    idxs <- 1
 76  }
 77  if(sum(idx)==1){
 78    idxs <- which(idx==TRUE)
 79    if(idxs==length(idx)){
 80      idxs <- 1
 81    }else{
 82      idxs <- idxs+1
 83    }
 84  }
 85  lapply(layers,function(x){
 86    x$setAcceptsHoverEvents(FALSE)
 87  })
 88  layers[[idxs]]$setAcceptsHoverEvents(TRUE)
 89  message(nms[idxs])
 90}
 91
 92col2qcol <- function(color,alpha=1){
 93  cols <- col2rgb(alpha(color,alpha),TRUE)
 94  qcolor(unname(cols[1,1]),
 95         unname(cols[2,1]),
 96         unname(cols[3,1]),
 97         unname(cols[4,1]))
 98}
 99
100baseColor <- function(base,pal=brewer_pal(pal="Set1")){
101  cols <- dscale(base,brewer_pal(pal="Set1"))
102  obj <- list()
103  for(i in 1:length(base))
104    obj[[base[i]]] <- cols[i]
105  class(obj) <- "ColorList"
106  obj
107}
108
109reduceChr <- function(obj){
110  grl <- split(obj,seqnames(obj))
111  lst <- lapply(names(grl),function(nms){
112    GRanges(seqnames=nms,IRanges(0,max(end(grl[[nms]]))))
113  })
114  ngr <- do.call('c',lst)
115  sortChr(ngr)
116}
117
118## ------------------------------------------------------------
119## Utils for MutableGRanges
120## ------------------------------------------------------------
121## Add extra attributes to an MutableRanges object
122## This is going to be naming routines in visnab.
123## Specific signal should be bound to MR object.
124setGeneric("addAttr",function(obj,...) standardGeneric("addAttr"))
125## genAttr <- function(N, ...){
126##     lst <- list(...)
127##     nms <- names(lst)
128##     lst <- lapply(nms, function(attr){
129##       val <- lst[[attr]]
130##       rep(val, N)
131##     })
132##     names(lst) <- nms
133##     do.call(data.frame, lst)
134##   }
135
136
137setMethod("addAttr","SimpleMutableGRanges",function(obj,...){
138  lst <- list(...)
139  nms <- names(lst)
140  df <- elementMetadata(obj)
141  nms.exist <- colnames(df)
142  idx <- rep(FALSE,length(nms))
143  lst <- lapply(lst,function(x) rep(x,nrow(df)))
144  sapply(seq_along(nms),function(i){
145    if((nms[i] %in% nms.exist)&&(identical(as.character(lst[[nms[i]]]),as.character(df[,nms[i]]))))
146      idx[i] <<- TRUE
147  })
148  lst <- lst[!idx]
149  dfex <- as.data.frame(do.call(cbind,lst),stringsAsFactors=FALSE)
150  ## New attributes, haven't check selection in plumbr yet
151  df.nw <- c(df,as(dfex,"DataFrame"))
152  df.nw
153  obj
154  elementMetadata(obj)  <- df.nw
155  ## elementMetadata(obj)  <- df
156  obj
157})
158
159setMethod("addAttr","GRanges",function(obj,...){
160  lst <- list(...)
161  nms <- names(lst)
162  sapply(nms, function(nm){
163    elementMetadata(obj)[,nm] <<- lst[[nm]]
164  })
165  obj
166})
167
168## ## setMethod("addAttr","MutableGRanges",function(obj,...){
169## ##   lst <- list(...)
170## ##   nms <- names(lst)
171## ##   sapply(nms, function(nm){
172## ##     elementMetadata(obj)[,nm] <- lst[[nm]]
173## ##   })
174## ##   obj
175## ## })
176
177## setGeneric("addDefAttr",function(obj,...) standardGeneric("addDefAttr"))
178
179
180## ------------------------------------------------------------
181## Utils for GenomicRanges
182## ------------------------------------------------------------
183## Should output to a nice tooltip format
184setGeneric("getTooltipInfo",function(obj,...) standardGeneric("getTooltipInfo"))
185## Suppose any hiden name is not for shown
186setMethod("getTooltipInfo","GenomicRanges",function(obj,i,...){
187  df <- values(obj)[i,,drop=FALSE]
188  df$chrom <- as.character(seqnames(obj))[i]
189  df$start <- start(obj)[i]
190  df$end <- end(obj)[i]
191  nms <- colnames(df)
192  nms <- grep("^[^\\.]",nms,value=TRUE)
193  tips <- "\n"
194  for(nm in nms){
195    tips <- paste(tips,paste(nm," : ",df[,nm],"\n",sep=""),sep="")
196  }
197  tips
198})
199
200chrAll <- function(...){
201  lst <- list(...)
202  chr.lst <- lapply(lst,function(gr){
203    chrs <- unique(as.character(seqnames(gr)))
204    if("to.chr" %in% names(values(gr))){
205      chrs2 <- unique(as.character(values(gr)$to.chr))
206      chrs <- unique(c(chrs,chrs2))
207    }
208    chrs
209  })
210  chrs <- sortChr(unique(unlist(chr.lst)))
211  return(chrs)
212}
213
214## Interactive indicator
215## start to record
216
217IMessageStart <- function(geometry=qrect(0,0,10,100),leaf=20,freq=0.05){
218  .indicatorScene <<- qscene()
219  .indicatorLayer <<- qlayer(.indicatorScene)
220  .indicatorView <<- qplotView(.indicatorScene)
221  .messageLayer <- qlayer(.indicatorLayer,paintFun=function(layer,painter){
222    if(exists(".message"))
223      qdrawText(painter,.message,0,0,color="black")
224  },col=1,rowSpan=3)
225  gr <- GRanges(seqnames=paste("chr",1:leaf),
226                ranges=IRanges(start=rep(1,leaf),
227                  end=rep(10,leaf)))
228  obj <- CircularView(list(gr),tracksType="sector",model=gr,scene=.indicatorScene,
229                      view=.indicatorView,rootLayer=.indicatorLayer,col=0,row=0,
230                      .sectorText=FALSE,
231                      tracksWidth=80)
232  obj$show()
233  layout <- .indicatorLayer$gridLayout()
234  layout$setRowPreferredHeight(0,10)
235  layout$setColumnPreferredWidth(0,10)
236  layout$setColumnPreferredWidth(1,100)
237
238  ## colorchange
239  ## if(.indicatorFlag){
240  if(TRUE){
241    for(idx in 1:leaf){
242      values(obj$tracks[[1]])$.color[idx] <- "black"
243      Sys.sleep(freq)
244      values(obj$tracks[[1]])$.color[idx] <- "white"
245      Sys.sleep(freq)
246    }
247  }
248}
249
250
251
252##
253## IMessageStart(freq=0.0001)
254## .indicatorScene$setBackgroundBrush(qbrush(col2qcol("black",0)))
255## .indicatorScene$setBackgroundBrush(qbrush(qcolor(255,255,0,0)))
256
257## .indicatorScene$setBackgroundBrush(qbrush(col2qcol("lightgray"), Qt$Qt$VerPattern))
258
259IMessage <- function(..., scene=.indicatorScene,
260                     view=.indicatorView,
261                     rootLayer=.indicatorLayer,
262                     leaf=7){
263  ## fun with circular view, pseudo "chromosome"
264  ## should support RangedData later
265  .message <<- paste(...)
266}
267
268## IMessage()
269
270GCcontent <- function(files, regions){
271  grl <- pileupAsGRanges(files, regions)
272  if(sum(values(gr)$depth))
273      gcc <- (sum(values(gr)$G)+sum(values(gr)$C))/sum(values(gr)$depth)
274  values(region)$GCcontent <- gcc
275  region
276}
277
278## ## utils to generate pair-end
279pspanGR <- function(file, region, sameChr = TRUE, isize.cutoff = 170){
280  ## FIXME: move unmated?
281  bam <- scanBam(file, param=ScanBamParam(which = region),
282                       flag = scanBamFlag(hasUnmappedMate = FALSE))
283  bam <- bam[[1]]
284  bamrd <- GRanges(bam$rname, IRanges(bam$pos, width = bam$qwidth),
285                      strand = bam$strand,
286                      mseqname = bam$mrnm,
287                      mstart = bam$mpos,
288                      isize = bam$isize)
289  ## why negative?sometime
290  bamrd <- bamrd[abs(bam$isize) >= isize.cutoff]
291  if(sameChr){
292    idx <- as.character(seqnames(bamrd)) == values(bamrd)$mseqname 
293    bamrd <- bamrd[idx]
294  }
295  if(length(bamrd)){
296  p1 <- GRanges(seqnames(bamrd),
297                ranges(bamrd))
298  p2 <- GRanges(values(bamrd)$mseqname,
299                IRanges(values(bamrd)$mstart, width = 75))
300  pspan <- punion(p1, p2, fill.gap = TRUE)
301  pgaps <- pgap(ranges(p1), ranges(p2))
302  return(list(pspan = pspan, pgaps = pgaps, p1 = p1, p2 = p2))
303}else{
304  return(NULL)
305}
306}
307