PageRenderTime 18ms CodeModel.GetById 5ms app.highlight 9ms RepoModel.GetById 0ms app.codeStats 0ms

/R/TxdbView-class.R

http://github.com/tengfei/visnab
R | 442 lines | 248 code | 53 blank | 141 comment | 17 complexity | 6ac641d7510c3d307f9623fe58e67cf0 MD5 | raw file
  1##----------------------------------------------------------##
  2##             For class "IntervalView"
  3##----------------------------------------------------------##
  4
  5## setAs("TranscriptDb", "GRanges", function(From){
  6  
  7## })
  8
  9## TxdbGRanges.gen <- setProxyGRanges("Txdb")
 10TxdbView.gen <- setRefClass("TxdbView",
 11                            contains=c("QtVisnabView", "LinearView"),
 12                            fields=list(
 13                              track ="TranscriptDb",
 14                              introns="GRangesList",
 15                              fiveUTR="GRangesList",
 16                              threeUTR="GRangesList",
 17                              cds="GRangesList",
 18                              tx="GRanges",
 19                              exons = "GRanges"
 20                              ),
 21                            methods = list(
 22                              fetchFromSource = function(){
 23                                ## compute exons/intons/... store to operands?
 24                              }
 25                              
 26                              ))
 27
 28##----------------------------------------------------------##
 29##             "IntervalView" constructor
 30##----------------------------------------------------------##
 31
 32##' To create a view for displaying information in a \code{TranscriptDb}
 33##' object.
 34##'
 35##' The constructor may take some time to retrieve information from
 36##' a \code{TranscriptDb} object, and store all the information which
 37##' required for visualiztion as fields, this is currently not ideal,
 38##' since \pkg{GenomicFeatures} doesn't support sending a small query to
 39##' SQLite database yet.
 40##'
 41##' ##' @title  \code{TxdbView} object constructor.
 42##' @param track A TranscriptDb object
 43##' @param seqname Chromosome name, expect the
 44##' name with 'chr' prefix, e.g. 'chr1'.
 45##' @param geom Geometry of the view. default is 'full'.
 46##' \describe{
 47##'   \item{\code{full}}{Showing all the introns/cds/5'-UTR/3'-UTR,
 48##' grouped by transcripts.}
 49##'   \item{\code{dense}}{Showing one single genmoic structure, collapse
 50##' all information into one single strand.}
 51##'   \item{\code{slice}}{Cut off introns and facilitate gene-centric view.}
 52##' }
 53##' @param rescale Control view port behaviors when zoom in/out
 54##' \describe{
 55##'   \item{\code{geometry}}{Hide sroll bar when zoomed in, default}   
 56##'   \item{\code{transform}}{...}
 57##'   \item{\code{none}}{Showing scroll bar when zoomed in}
 58##' }
 59##' @param viewname Name used for this view, will show as widget title when
 60##' embeded into tracks view.
 61##' @return A \code{TxdbView} object.
 62##' @author Tengfei Yin <yintengfei@gmail.com>
 63TxdbView <- function(track,
 64                     seqname,
 65                     geom=c("full", "dense", "slice"),
 66                     rescale = c("geometry", "transform", "none"),
 67                     viewname = "TranscriptDb",
 68                     ...){
 69  ## tootip information
 70  ## TODO: need to get information automatical some where
 71  ## may be  integrate some data automatically
 72  tooltips <- capture.output(print(track))
 73
 74  if(missing(seqname))
 75    seqname <- as.character(unique(as.character(seqnames(seqinfo(track))))[1])
 76  start <- 0
 77  end <- seqlengths(track)[[seqname]]
 78  seqlength <- end
 79  xlimZoom <- c(start,end)
 80  
 81  geom <- match.arg(geom)
 82  geom <- new("TxdbViewGeomSingleEnum", geom)
 83
 84  rescale <- match.arg(rescale)
 85  rescale <- new("RescaleSingleEnum", rescale)
 86  
 87  pars <- GraphicPars(xlimZoom = xlimZoom,
 88                      geom = geom,
 89                      view = "TxdbView")
 90  ## store those infor in object, so make switch to other chromosome fast
 91  message("Loading Introns...")
 92  introns <- intronsByTranscript(track)
 93  message("Loading 5' UTR...")
 94  fiveUTR <- fiveUTRsByTranscript(track)
 95  message("Loading 3' UTR...")
 96  threeUTR <- threeUTRsByTranscript(track)
 97  message("Loading CDS...")
 98  cds <- cdsBy(track,by="tx")
 99  message("Loading transcripts...")
100  tx <- transcripts(track)
101  ## loading exons?                        
102  viewrange <- MutableGRanges(seqname, IRanges(start, end))
103  seqlengths(viewrange) <- end
104
105  mode <- IModeGroup(scaleMode = ScaleMode(zoomMode = "Horizontal"))
106  obj <- TxdbView.gen$new(track = track, pars = pars, mode = mode,
107                          viewrange = viewrange,
108                          introns = introns, fiveUTR = fiveUTR, threeUTR = threeUTR,
109                          rescale = rescale, tooltipinfo = tooltips,
110                          cds = cds,tx = tx, viewname = viewname,
111                          eventTrace = new("EventTrace"))
112
113  ## add default attributes
114  ## addAttr(obj$track,.color=obj$pars$fill,.hover=FALSE,.brushed=FALSE)
115  message("Processing and creating view...")
116  obj$createView()
117  obj$regSignal()
118  message("Ready")
119  return(obj)
120}
121
122############################################################
123## createview method
124############################################################
125TxdbView.gen$methods(createView = function(){
126  
127  seqname <- as.character(seqnames(viewrange))
128  setDislayWidgets()
129  setBgColor()
130
131  ## compute levels
132  tx.sub <- tx[seqnames(tx)==seqname]
133  tx_id <- values(tx.sub)$tx_id
134
135  .levels <- disjointBins(ranges(tx.sub))
136  names(.levels) <- tx_id
137  
138  introns.sub <- introns[names(introns) %in% as.character(tx_id)]
139  fiveUTR.sub <- fiveUTR[names(fiveUTR) %in% as.character(tx_id)]
140  threeUTR.sub <- threeUTR[names(threeUTR) %in% as.character(tx_id)]
141  cds.sub <- cds[names(cds) %in% as.character(tx_id)]
142  ## exons.sub <- exons[names(exons) %in% as.character(tx_id)]
143
144  int.l <- elementLengths(introns.sub)
145  futr.l <- elementLengths(fiveUTR.sub)
146  tutr.l <- elementLengths(threeUTR.sub)
147  cds.l <- elementLengths(cds.sub)
148  ## exons.l <- elementLengths(exons.sub)
149
150  int <- unlist(introns.sub)
151  futr <- unlist(fiveUTR.sub)
152  tutr <- unlist(threeUTR.sub)
153  cdss <- unlist(cds.sub)
154  ## exn <- unlist(exons.sub)
155  ## prepare for "reduce" geom
156  int.r <- reduce(int)
157  cds.r <- reduce(cdss)
158  five.r <- reduce(futr)
159  three.r <- reduce(tutr)
160  ## should think a better way to do this
161
162  irs <- reduce(c(cds.r,five.r,three.r))
163  int.r <- setdiff(int.r,irs)
164
165  values(int)$tx_id <- rep(names(introns.sub),int.l)
166  values(futr)$tx_id <- rep(names(fiveUTR.sub),futr.l)
167  values(tutr)$tx_id <- rep(names(threeUTR.sub),tutr.l)
168  values(cdss)$tx_id <- rep(names(cds.sub),cds.l)
169  ## values(exn)$tx_id <- rep(names(exons.sub),exons.l)
170
171  values(int)$.level <- .levels[as.character(values(int)$tx_id)]
172  values(futr)$.level <- .levels[as.character(values(futr)$tx_id)]
173  values(tutr)$.level <- .levels[as.character(values(tutr)$tx_id)]
174  values(cdss)$.level <- .levels[as.character(values(cdss)$tx_id)]
175  ## values(exn)$.level <- .levels[as.character(values(exn)$tx_id)]
176
177  ## int.pos <- int[strand(int)=="+"]
178  ## int.neg <- int[strand(int)=="-"]
179
180  ## tail(sort(width(introns.sub)))
181
182  st.int <- start(int)
183  ed.int <- end(int)
184  lv.int <- values(int)$.level
185  strand.int <- as.character(strand(int))
186
187  st.five <- start(futr)
188  ed.five <- end(futr)
189  lv.five <- values(futr)$.level
190
191  st.three <- start(tutr)
192  ed.three <- end(tutr)
193  lv.three <- values(tutr)$.level
194
195  st.cds <- start(cdss)
196  ed.cds <- end(cdss)
197  lv.cds <- values(cdss)$.level
198
199  ## for "dense"
200  st.five.r <- start(five.r)
201  ed.five.r <- end(five.r)
202
203  st.three.r <- start(three.r)
204  ed.three.r <- end(three.r)
205
206  st.cds.r <- start(cds.r)
207  ed.cds.r <- end(cds.r)
208
209  st.int.r <- start(int.r)
210  ed.int.r <- end(int.r)
211  strand.int.r <- as.character(strand(int.r))
212
213  ylim <- c(0,max(c(lv.int, lv.five, lv.cds, lv.three))*5+10)
214  xlim <- c(0,seqlengths(viewrange))
215  ## xlim.mar <- 0.05*diff(xlim)
216  ## ylim.mar <- 0.05*diff(ylim)
217
218  ## pars$xlim <<- c(xlim[1]-xlim.mar,xlim[2]+xlim.mar)
219  ## pars$ylim <<- c(ylim[1]-ylim.mar,ylim[2]+ylim.mar)
220  pars$xlimChanged$block()
221  pars$ylimChanged$block()
222  pars$xlim <<- xlim
223  pars$ylim <<- expand_range(ylim, mul = 0.05)
224  pars$xlimChanged$unblock()
225  pars$ylimChanged$unblock()
226
227
228  ## canonical strucuture
229  drawfun <- function(layer,painter,exposed){
230    pars$xlimZoomChanged$block()
231    pars$xlimZoom <<- as.matrix(exposed)[,1]
232    xlimZoom <- pars$xlimZoom
233    if(!eventTrace$selfSignal){
234      viewrange$rangesChanged$unblock()
235      ranges(viewrange) <<- IRanges(pars$xlimZoom[1], pars$xlimZoom[2])
236    }
237    if(eventTrace$selfSignal){
238      viewrange$rangesChanged$block()
239      ranges(viewrange) <<- IRanges(pars$xlimZoom[1], pars$xlimZoom[2])
240    }
241    pars$xlimZoomChanged$unblock()
242
243    if(pars$geom=="full"){
244      ## 5'UTR
245      if(length(st.five)>0)
246        qdrawRect(painter,st.five,10*lv.five-2,ed.five,
247                  10*lv.five+2,fill="black",stroke=NA)
248      ## 3'
249      if(length(st.three)>0)
250        qdrawRect(painter,st.three,10*lv.three-2,ed.three,
251                  10*lv.three+2,fill="black",stroke=NA)
252      ## cds
253      if(length(st.cds)>0)
254        qdrawRect(painter,st.cds,10*lv.cds-4,ed.cds,10*lv.cds+4,
255                  fill="black",stroke=NA)
256      ## intron
257      if(length(st.int)>0)
258        qdrawSegment(painter,st.int,10*lv.int,ed.int,10*lv.int,stroke="black")
259
260      if(diff(xlimZoom)<8e5){
261        unit <- as.integer(diff(xlimZoom)/50)
262        ## draw arrow to indicate strand
263        ## subset first
264        seqlengths(int)
265        grsub <- GRanges(seqnames(viewrange), ranges = ranges(viewrange))
266        intsub <- subsetByOverlaps(int, grsub)
267        st.int <- start(intsub)
268        ed.int <- end(intsub)
269        lv.int <- values(intsub)$.level
270        ardf <- lapply(seq_along(st.int), function(i){
271          n <- round((ed.int[i]-st.int[i])/unit, dig = 0)
272          xs <- cbreaks(c(st.int[i], ed.int[i]), pretty_breaks(n))$breaks
273          xs <- xs[xs >= st.int[i] & xs <= ed.int[i]]
274          df <- data.frame(x = xs, y = rep(as.numeric(lv.int[i])*10, length(xs)))
275        })
276        ardf <- do.call("rbind", ardf)
277        ## negative strand
278        idx <- as.character(strand(intsub)) == "-"
279        arrow <- qglyphArrow(dir = "left")
280        qdrawGlyph(painter, arrow, ardf[idx, "x"], ardf[idx, "y"], cex = 0.5, fill = NA)
281        arrow <- qglyphArrow(dir = "right")
282        qdrawGlyph(painter, arrow, ardf[!idx, "x"], ardf[!idx, "y"], cex = 0.5, fill = NA)
283        ## positive strand
284      }
285      pars$ylim <<- ylim
286    }
287    if(pars$geom=="dense"){
288      ## reduced structure
289      ## 5'UTR
290      if(length(st.five.r)>0)
291        qdrawRect(painter,st.five.r,10-2,ed.five.r,
292                  10+2,fill="black",stroke=NA)
293      ## 3'UTR
294      if(length(st.three.r)>0)
295        qdrawRect(painter,st.three.r,10-2,ed.three.r,
296                  10+2,fill        
297                  ="black",stroke=NA)
298      ## cds
299      if(length(st.cds.r)>0)
300        qdrawRect(painter,st.cds.r,10-4,ed.cds.r,10+4,
301                  fill="black",stroke=NA)
302      ## introns
303      if(length(st.int.r)>0)
304        qdrawSegment(painter,st.int.r,10,ed.int.r,10,stroke="black")
305
306      ## if(diff(xlimZoom)<8e5){
307      ##   unit <- as.integer(diff(xlimZoom)/50)
308      ## ## draw arrow to indicate strand
309      ##   ## subset first
310      ##   grsub <- GRanges(seqnames(viewrange), ranges = ranges(viewrange))
311      ##   intsub <- subsetByOverlaps(int, grsub)
312      ##   st.int <- start(intsub)
313      ##   ed.int <- end(intsub)
314      ##   lv.int <- values(intsub)$.level
315      ##   ardf <- lapply(seq_along(st.int), function(i){
316      ##     n <- round((ed.int[i]-st.int[i])/unit, dig = 0)
317      ##     xs <- cbreaks(c(st.int[i], ed.int[i]), pretty_breaks(n))$breaks
318      ##     xs <- xs[xs >= st.int[i] & xs <= ed.int[i]]
319      ##     df <- data.frame(x = xs, y = rep(10, length(xs)))
320      ##   })
321      ##   ardf <- do.call("rbind", ardf)
322      ##   ## negative strand
323      ##   idx <- as.character(strand(intsub)) == "-"
324      ##   ## reduce with no arrow
325      ##   ## arrow <- qglyphArrow(dir = "left")
326      ##   ## qdrawGlyph(painter, arrow, ardf[idx, "x"], ardf[idx, "y"], cex = 0.5, fill = NA)
327      ##   ## arrow <- qglyphArrow(dir = "right")
328      ##   ## qdrawGlyph(painter, arrow, ardf[!idx, "x"], ardf[!idx, "y"], cex = 0.5, fill = NA)
329      ##   ## positive strand
330      ## }
331
332      pars$ylim <<- c(-20,40)
333    }
334  }
335  ## selectedRangesFun
336  ## selectedRangesFun <- function(layer, painter){
337  ##   srm <- selectedRangesModel
338  ##   if(length(srm)>0){
339  ##     cols <- selectedRangesModelColor
340  ##     if((as.character(cols) %in% names(elementMetadata(srm)))){
341  ##       cols.value <- elementMetadata(srm)[[cols]]
342  ##       if(is.numeric(cols.value)){
343  ##         cols <- cscale(cols.value, pars$cpal)
344  ##       }else{
345  ##         cols <- dscale(factor(cols.value), pars$dpal)
346  ##       }}else{
347  ##         cols <- rep(cols,length(srm))
348  ##       }
349  ##     idx <- as.character(seqnames(selectedRangesModel)) == seqname
350  ##     qdrawRect(painter, start(srm)[idx], 0,
351  ##               end(srm)[idx], 10, stroke = NA, fill = cols[idx])
352  ##   }
353  ## }
354  keyOutFun <- function(layer, event){
355    eventTrace$focusin <<- FALSE
356  }
357  hoverEnterFun <- function(layer, event){
358    eventTrace$focusin <<- TRUE
359  }
360  hoverLeaveFun <- function(layer, event){
361    eventTrace$focusin <<- FALSE
362  }
363
364  rootLayer[0,0] <<- qlayer(scene, drawfun, 
365                       wheelFun= wheelEventZoom(),
366                       keyPressFun = keyPressEventZoom(),
367                       hoverEnterFun = hoverEnterFun,
368                       focusOutFun = keyOutFun, hoverLeaveFun = hoverLeaveFun)
369  
370  rootLayer[0,0]$setLimits(qrect(pars$xlim[1],pars$ylim[1],
371                            pars$xlim[2],pars$ylim[2]))
372
373  pars$ylimChanged$connect(function(){
374    rootLayer[0,0]$setLimits(qrect(pars$xlim,pars$ylim))
375  })
376  if(pars$geom == "dense")
377    rootLayer$setGeometry(0, 0, 800, 50)
378})
379
380TxdbView.gen$methods(regSignal = function(){
381  
382  viewrange$rangesChanged$connect(function(){
383    ## pars$xlimZoomChanged$block()
384    ## pars$xlimZoom <- as.matrix(exposed)[,1]
385    ## xlimZoom <- pars$xlimZoom
386    qupdate(scene)
387  })
388  
389  pars$xlimZoomChanged$connect(function(){
390    zoom_factor <- diff(pars$xlimZoom)/seqlengths(viewrange)
391    ## then scale view
392    view$resetTransform()
393    view$scale(1/zoom_factor, 1)
394    ## then center view
395    pos.x <- mean(pars$xlimZoom)
396    pos.y <- mean(pars$ylim)
397    pos.scene <- as.numeric(rootLayer[0,0]$mapToScene(pos.x, pos.y))
398    view$centerOn(pos.scene[1], pos.scene[2])
399  })
400  ## geom
401  pars$geomChanged$connect(function(){
402    qupdate(scene)
403  })
404  ## signal when change xlimZoom
405  ## seqname change should update view and update seqlength
406  viewrange$seqnamesChanged$connect(function(){
407    ## end <- max(end(ranges(track[seqnames(track)==seqname])))
408    viewrange$seqnamesChanged$block()
409    seqlengths(viewrange) <<- seqlengths(track)[[as.character(seqnames(viewrange))]]
410    viewrange$seqnamesChanged$unblock()
411    ## pars$xlimZoom <<- c(0 ,end)
412    ## selectedRange <<- c(start,end)
413    ## rootLayer[0,0]$close()
414    ## obj$rootLayer[0,0]$gridLayout()$removeAt(0)
415    rootLayer[0,0]$close()
416    view$resetTransform()
417    createView()
418    regSignal()
419  })
420  ## selectedRangesModelChanged$connect(function(){
421  ##   qupdate(scene)
422  ## })
423  pars$bgColorChanged$connect(function(){
424    bgcol <- pars$bgColor
425    bgalpha <- pars$alpha
426    qcol <- col2qcol(bgcol,bgalpha)
427    scene$setBackgroundBrush(qbrush(qcol))
428  })
429})
430
431TxdbView.gen$methods(show = function(){
432  view$show()
433})
434
435setMethod("print","TxdbView",function(x,..){
436  x$show()
437})
438
439
440
441
442