Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
519 lines (427 sloc) 15.7 KB
#' @include tntTracks.R
### TnT Board ############################################################
#### Class Def for TnT Board ========
# A TnT Board is the object that holds a list of tracks and settings for the browser,
# it contains the following slots:
#
# o ViewRange
# Class "GRanges" that specifies the initial viewing range of rendered browser.
# According to the its seqlevel, trackdata that on extra chromosomes will be
# dropped before converted to JavaScript. It should be suppiled when constructing
# the Board.
# o CoordRange
# Class "IRanges" that defines the left and right coordinate of the board.
# o ZoomAllow
# Class "IRanges" that describes the minimal and maximal extent of the
# board (i.e. the limit when zooming in and out).
# o AllowDrag
# Logical, whether allow drag and zoom
# o TrackList
# List of tracks.
setClass("TnTBoard",
slots = c(
ViewRange = "GRanges",
CoordRange = "IRanges",
ZoomAllow = "IRanges",
AllowDrag = "logical",
TrackList = "list"
)
)
setClass("TnTGenome", contains = "TnTBoard",
slots = c(
Species = "character",
Chromosome = "character"
)
)
#### TnT Board Constructor ========
#' TnTBoard
#'
#' A TnTBoard or TnTGenome object stores a list of tracks and can be automatically
#' shown in an interactive R session or in rmarkdown output.
#'
#' @param tracklist One track or a list of tracks to view.
#' @param view.range Length-one GRanges object, sets the initial view range.
#' @param coord.range Length-one IRanges object or length-two numeric vector,
#' sets the coordinate limit of the board (i.e. minimum/maximum possible coordinate).
#' @param zoom.allow Length-one IRanges object or length-two numeric vector,
#' sets the minimum and maximum extent of the board (i.e. the limit when zooming in and zooming out).
#' @param allow.drag Logical, whether drag should be allowed? Default TRUE.
#' @param use.tnt.genome Logical, whether to add axis and location. `TnTGenome(...)` is essentially
#' a wrapper to `TnTBoard(..., use.tnt.genome = TRUE)`.
#'
#' @return
#' Returns a TnTBoard or TnTGenome object which has printing method to be rendered
#' as a htmlwidget.
#' @export
#'
#' @name tntboard
#' @aliases tntgenome
#'
#' @examples
#' track <- BlockTrack(GRanges("chr1", IRanges(start = c(100, 300, 500), width = c(10, 100, 200))))
#' \dontrun{
#' TnTGenome(track)
#' }
TnTBoard <- function (tracklist, view.range = GRanges(),
coord.range = IRanges(), zoom.allow = IRanges(), allow.drag = TRUE,
use.tnt.genome = FALSE) {
if (is(tracklist, "TnTTrack"))
tracklist <- list(tracklist)
else
stopifnot(all(vapply(tracklist, is, logical(1L), class2 = "TnTTrack")))
if (is.numeric(coord.range)) {
if (length(coord.range) == 2L)
coord.range <- IRanges(coord.range[1], coord.range[2])
else
stop("coord.range should be a length-one IRanges or a length-two numeric vector")
}
if (is.numeric(zoom.allow)) {
if (length(zoom.allow) == 2L)
zoom.allow <- IRanges(zoom.allow[1], zoom.allow[2])
else
stop("zoom.allow should be a length-one IRanges or a length-two numeric vector")
}
b <- new(if (use.tnt.genome) "TnTGenome" else "TnTBoard",
ViewRange = view.range, CoordRange = coord.range,
ZoomAllow = zoom.allow, TrackList = tracklist, AllowDrag = allow.drag)
b
}
#' @rdname tntboard
#' @export
TnTGenome <- function (tracklist, view.range = GRanges(),
coord.range = IRanges(), zoom.allow = IRanges(), allow.drag = TRUE) {
TnTBoard(tracklist, view.range = view.range,
coord.range = coord.range, zoom.allow = zoom.allow, allow.drag = allow.drag,
use.tnt.genome = TRUE)
}
#' Range of TnTBoard
#'
#' Get combined range of all tracks in a TnTBoard, used internally.
#'
#' @param x TnTBoard.
#' @param ...,with.revmap,ignore.strand,na.rm
#' Passed to \code{\link[GenomicRanges]{range,GenomicRanges-method}}.
#' @return GRanges.
setMethod(range, signature = c(x = "TnTBoard"),
function (x, ..., with.revmap=FALSE, ignore.strand=FALSE, na.rm=FALSE) {
if (length(list(...)))
warning("Extra arguments ignored.")
li.track <- tracklist(x)
rg <- do.call(range, c(unname(li.track),
list(with.revmap=with.revmap, ignore.strand=ignore.strand, na.rm=na.rm)))
rg
}
)
#### Accessors ========
#' Track List in TnTBoard
#'
#' The tracks of a TnTBoard are stored as a list which can be accessed or modified
#' with these functions.
#'
#' @param tntboard A TnTBoard or TnTGenome object
#'
#' @name tracklist
#' @return \code{tracklist} returns a list of tracks.
#' @export
#' @examples
#' bt <- BlockTrack(GRanges("chr21", IRanges(100, 1200)))
#' li.tracks <- list(bt, bt)
#' board <- TnTBoard(li.tracks)
#' tracklist(board)
#' \dontrun{
#' show(board)
#' }
#' tracklist(board) <- list(bt)
#' \dontrun{
#' show(board)
#' }
tracklist <- function (tntboard) {
tntboard@TrackList
}
#' @rdname tracklist
#' @param value A list of tracks
#' @export
`tracklist<-` <- function (tntboard, value) {
tntboard@TrackList <- value
tntboard
}
#### SeqInfo ========
#' @rdname seqinfo
setMethod("seqinfo", signature = "TnTBoard",
function (x) {
li.tracks <- tracklist(x)
li.seqinfo <- lapply(li.tracks, seqinfo)
do.call(merge, unname(li.seqinfo))
}
)
#### TnT Board Compilation ========
compileBoard <- function (tntboard) {
b <- wakeupBoard(tntboard)
if (is(b, "TnTGenome"))
spec <- .compileBoardSpec(b, use.tnt.genome = TRUE)
else
spec <- .compileBoardSpec(b)
tklst <- .compileTrackList(b)
tntdef <- c(spec, tklst)
tntdef
}
wakeupBoard <- function (tntboard) {
tntboard <- .selectView(tntboard)
tntboard <- .fillGenome(tntboard)
tntboard <- .filterSeq(tntboard)
tntboard <- .selectCoord(tntboard)
tntboard <- .selectZoom(tntboard)
tntboard
}
.filterSeq <- function (tntboard, use.seq = seqlevelsInUse(tntboard@ViewRange)) {
stopifnot(length(use.seq) == 1L)
li.t <- tracklist(tntboard)
li.t <- lapply(li.t, keepSeqlevels, value = use.seq, pruning.mode = "coarse")
tntboard@TrackList <- li.t
tntboard
}
.selectCoord <- function (tntboard) {
if (length(tntboard@CoordRange) == 1L)
return(tntboard)
if (length(tntboard@CoordRange) > 1L)
stop("Length of CoordRange is larger than one.")
viewrg <- tntboard@ViewRange
stopifnot(length(viewrg) == 1L)
# Use seqlevel from the view range
seqlv <- seqlevelsInUse(viewrg)
agg.seqinfo <- {
li.t <- tracklist(tntboard)
li.seqinfo <- lapply(li.t, seqinfo)
do.call(merge, unname(li.seqinfo))
}
seqlen <- {
if (!seqlv %in% seqlevels(agg.seqinfo))
stop("Seqlevel of the view range can not be found in the track list")
seqlengths(agg.seqinfo)[as.character(seqlv)]
}
if (!is.na(seqlen)) {
tntboard@CoordRange <- IRanges(0, seqlen + 1)
return(tntboard)
}
# Then seqlength is not known
coord <- {
## Aggregate from track data
rg <- range(tntboard, ignore.strand = TRUE)
rg <- keepSeqlevels(rg, seqlv, pruning.mode = "coarse")
stopifnot(length(rg) == 1L) # TODO: However, there will be cases that all the tracks are empty
ranges(rg) * .7
}
msg <- sprintf(paste("- Missing argument `coord.range` and seqlength is unknown:",
" automatically set coordinate limit to %s..%s ...", sep = "\n"),
start(coord), end(coord))
message(msg)
tntboard@CoordRange <- coord
tntboard
}
.selectView <- function (tntboard) {
## TODO: view range may support strands, i.e. only showing features on one strand
viewrange0 <- tntboard@ViewRange
tracklist0 <- tracklist(tntboard)
if (length(viewrange0) == 1L) {
# Already specified
## Update the combined seqinfo
comb.seqinfo <- do.call(merge, unname(lapply(tracklist0, seqinfo)))
comb.seqinfo <- merge(comb.seqinfo, seqinfo(viewrange0))
seqinfo(tntboard@ViewRange,
new2old = match(seqlevels(comb.seqinfo), seqlevels(tntboard@ViewRange))) <- comb.seqinfo
return(tntboard)
}
if (length(viewrange0) > 1L)
stop("Length of ViewRange is larger than one.")
# Then length(viewrange0) == 0
commonseqs <- {
li.tseqs <- lapply(tracklist0, function (t) seqlevelsInUse(t))
li.tseqs <- li.tseqs[lengths(li.tseqs) != 0]
if (!length(li.tseqs)) {
# No "InUse" seqlevels
li.tseqs <- lapply(tracklist0, seqlevels)
li.tseqs <- li.tseqs[lengths(li.tseqs) != 0]
}
if (!length(li.tseqs))
# All seqlevels are empty...
character()
else
Reduce(intersect, li.tseqs)
}
sel.seq <- {
if (!length(commonseqs))
stop("No common seqlevel is found in the track list.")
if (length(commonseqs) == 1)
sel.seq <- commonseqs
else
sel.seq <- commonseqs[1]
unname(sel.seq)
}
find.viewrg <- function (tntboard, sel.seq) {
li.track <- tracklist(tntboard)
comb.seqinfo <- do.call(merge, unname(lapply(li.track, seqinfo)))
li.rg <- lapply(li.track, range, ignore.strand = TRUE)
li.rg <- unname(lapply(li.rg, keepSeqlevels, value = sel.seq, pruning.mode = "coarse"))
stopifnot(all(lengths(li.rg) %in% c(1L, 0L)))
viewrg <- {
# Find the intersection of the ranges and use it as view range
viewrg <- Reduce(intersect, li.rg[lengths(li.rg) != 0])
if (length(viewrg)) {
# The intersection exists
## TODO
stopifnot(length(viewrg) == 1)
viewrg <- viewrg * .8
}
else {
# There is no intersection
## TODO
viewrg <- do.call(range, c(unname(li.rg), ignore.strand = TRUE))
stopifnot(length(viewrg) == 1)
viewrg <- viewrg * .8
}
seqinfo(viewrg, new2old = match(seqlevels(comb.seqinfo), seqlevels(viewrg))) <- comb.seqinfo
viewrg
}
viewrg
}
viewrg <- find.viewrg(tntboard = tntboard, sel.seq = sel.seq)
tntboard@ViewRange <- viewrg
message <- sprintf(paste("- Missing argument `view.range`:",
" automatically select %i..%i on seqlevel %s...", sep = "\n"),
start(viewrg), end(viewrg), seqlevelsInUse(viewrg))
message(message)
tntboard
}
.fillGenome <- function (tntboard) {
if (!is(tntboard, "TnTGenome"))
return(tntboard)
stopifnot(length(tntboard@ViewRange) == 1)
# Seqinfo of ViewRange is combined from the track list
seqinfo <- seqinfo(tntboard@ViewRange)
seqlv <- seqlevelsInUse(tntboard@ViewRange)
tntboard@Species <- unname(genome(seqinfo)[seqlv])
tntboard@Chromosome <- seqlv
tntboard
}
.selectZoom <- function (tntboard) {
zoomalo <- tntboard@ZoomAllow
if (length(zoomalo) == 1)
return(tntboard)
if (length(zoomalo) > 1)
stop("Length of ZoomAllow is larger than one.")
# Then ZoomAllow is not set
coord <- tntboard@CoordRange
stopifnot(length(coord) == 1)
tntboard@ZoomAllow <- if (width(coord) <= 15) IRanges(1, 100)
else IRanges(10, width(coord) + 100)
tntboard
}
.compileBoardSpec <- function (tntboard, use.tnt.genome = FALSE) {
.checkBoardSpec <- function (tntboard) {
b <- tntboard
stopifnot(
# These three slots should be prepared before converted to JS
length(b@ViewRange) == 1,
length(b@CoordRange) == 1,
length(b@ZoomAllow) == 1,
length(b@AllowDrag) == 1,
if (is(b, "TnTGenome"))
length(b@Species) == 1 else TRUE,
if (is(b, "TnTGenome"))
length(b@Chromosome) == 1 else TRUE
)
b
}
b <- .checkBoardSpec(tntboard)
if (use.tnt.genome)
jc.board.spec <- jc(
tnt.board.genome = ma(),
from = start(b@ViewRange),
to = end(b@ViewRange),
species = if (is.na(b@Species)) "Unknown" else b@Species,
chr = b@Chromosome,
min_coord = js(sprintf('new Promise (function (resolve) { resolve (%i); })',
start(b@CoordRange))),
max_coord = js(sprintf('new Promise (function (resolve) { resolve (%i); })',
end(b@CoordRange))),
zoom_out = end(b@ZoomAllow),
zoom_in = start(b@ZoomAllow),
allow_drag = b@AllowDrag
)
else
jc.board.spec <- jc(
tnt.board = ma(),
from = start(b@ViewRange),
to = end(b@ViewRange),
min = start(b@CoordRange),
max = end(b@CoordRange),
zoom_out = end(b@ZoomAllow),
zoom_in = start(b@ZoomAllow),
allow_drag = b@AllowDrag
)
jc.board.spec
}
.compileTrackList <- function (tntboard) {
tracklist <- tntboard@TrackList
li.jc <- lapply(tracklist, compileTrack)
names(li.jc) <- replicate(length(li.jc), "add_track")
jc <- asJC(li.jc)
jc
}
# .consolidateBackground <- function (tntboard) {
# # By the time of construction of each tnt track, the background color can
# # be either set to "NULL" or a scalar character.
# #
# # Before compilation of tntboard, this function examines these settings in
# # each track, replace the NULLs with a more suitable value.
# tracklist <- tntboard@TrackList
# li.colors <- lapply(tracklist, function (t) t@Background@.Data)
# colors <- unique(unlist(li.colors))
#
# if (!length(colors) || length(colors) >= 2L)
# default <- Biobase::mkScalar("white")
# else
# default <- Biobase::mkScalar(colors)
#
# tracklist <- lapply(tracklist, replace = default,
# function (track, replace) {
# if (is.null(track@Background))
# track@Background <- replace
# track
# }
# )
# tntboard@TrackList <- tracklist
# tntboard
# }
## Printing ====
setMethod("show", signature = c("TnTBoard"),
function (object) {
# TODO: Have to provide renderTnT and TnTOutput
widget <- trackWidget(object, elementId = NULL)
print(widget)
}
)
#' Printing TnTBoard in Rmarkdown
#'
#' S3 method to automatically render a TnTBoard with knitr.
#'
#' @param x A TnTBoard or TnTGenome object.
#' @param ...,options Passed to \code{htmlwidget:::knit_print.htmlwidget}.
#'
#' @return \code{htmlwidget:::knit_print.htmlwidget} invisibly returns a character
#' vector with "browsable_html" S3 class.
#' @references \code{\link[knitr]{knit_print}}
#' @export
#' @examples
#' track <- BlockTrack(GRanges("chr12", IRanges(c(100, 400, 700), width = 100)),
#' color = c("green", "red", "blue"))
#' tntboard <- TnTGenome(track)
#' \dontrun{
#' knitr::knit_print(tntboard)
#' }
knit_print.TnTBoard <- function (x, ..., options = NULL) {
# Redirect method to htmlwidget
x <- trackWidget(x, elementId = NULL)
knitr::knit_print(x, ..., options = options)
}
# setMethod("knit_print", signature = c(x = "TnTBoard"), knit_print.TnTBoard)