/R/utils.R
R | 307 lines | 228 code | 31 blank | 48 comment | 20 complexity | 53b18678455fc9f375622d0eddb07249 MD5 | raw file
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