├── .Rinstignore ├── .Rbuildignore ├── tests ├── test-all.R └── testthat │ └── test_grob.R ├── .gitignore ├── vignettes ├── figures │ ├── facet.pdf │ ├── geoms.pdf │ ├── grl.pdf │ ├── icon.pdf │ ├── man.pdf │ ├── ssx3.pdf │ ├── ucsc.png │ ├── vcf.pdf │ ├── diagram.pdf │ ├── drawing.pdf │ ├── splice.pdf │ ├── cir-single.pdf │ ├── facet_gr.pdf │ ├── geom_arch.pdf │ ├── geom_arrow.pdf │ ├── geom_bar.pdf │ ├── geom_rect.pdf │ ├── karyogram.pdf │ ├── stat_gene.pdf │ ├── stat_table.pdf │ ├── coord_genome.pdf │ ├── coord_linear.pdf │ ├── geom_chevron.pdf │ ├── geom_segment.pdf │ ├── stat_reduce.pdf │ ├── track_layout.pdf │ ├── geom_alignment.pdf │ ├── geom_arrowrect.pdf │ ├── layout_circle.pdf │ ├── layout_default.pdf │ ├── stat_aggregate.pdf │ ├── stat_coverage.pdf │ ├── stat_identity.pdf │ ├── stat_mismatch.pdf │ ├── stat_stepping.pdf │ ├── truncate_gaps.pdf │ ├── circular-9-circle.pdf │ ├── layout_karyogram.pdf │ ├── coord_truncate_gaps.pdf │ ├── stat_coverage_icon.pdf │ ├── Manhattan-plotGrandLinear.pdf │ ├── autoplot_GappedAlignment.pdf │ ├── circular-lower-link-track.pdf │ └── rangeslinkedtodata-link4.pdf ├── knit.sh ├── ggbio.Rnw ├── fakevignettes │ └── ggbio.Rnw └── Makefile ├── R ├── zzz.R ├── stat_gene-method.R ├── layout_linear-method.R ├── AllGenerics.R ├── coord_genome-method.R ├── stat_stepping-method.R ├── ggplot-method.R ├── AllClasses.R ├── geom_bar-method.R ├── rescale-method.R ├── Grob-class.R ├── scales.R ├── plotSpliceSum-method.R ├── stat_reduce-method.R ├── stat_table-method.R ├── geom_segment-method.R ├── stat_identity-method.R ├── plotFragLength-method.R ├── Plot-class.R ├── Cache-class.R ├── hack.R ├── geom_arrowrect-method.R ├── stat_bin-method.R ├── plotGrandLinear.R ├── geom_rect-method.R ├── geom_arrow-method.R ├── stat_mismatch-method.R ├── theme.R └── geom_chevron-method.R ├── README.md ├── man ├── scale_fill_fold_change.Rd ├── scale_fill_giemsa.Rd ├── Plot-class.Rd ├── scale_x_sequnit.Rd ├── Grob-class.Rd ├── nav.Rd ├── Tracked-class.Rd ├── arrangeGrobByParsingLegend.Rd ├── ggbio-class.Rd ├── stat_mismatch-method.Rd ├── stat_gene-method.Rd ├── rescale-method.Rd ├── ggsave.Rd ├── geom_bar-method.Rd ├── stat_table-method.Rd ├── plotSingleChrom.Rd ├── stat_stepping-method.Rd ├── plotFragLength.Rd ├── stat_reduce-method.Rd ├── theme.Rd ├── stat_bin-method.Rd ├── plotSpliceSum.Rd ├── stat_coverage-method.Rd ├── geom_arch-method.Rd ├── stat_identity-method.Rd ├── stat_slice-method.Rd ├── geom_arrowrect-method.Rd ├── geom_segment-method.Rd ├── geom_rect-method.Rd ├── geom_arrow-method.Rd ├── plotRangesLinkedToData.Rd ├── stat_aggregate-method.Rd ├── plotStackedOverview.Rd ├── layout_circle-method.Rd └── geom_chevron-method.Rd ├── inst └── CITATION ├── .github └── workflows │ └── R-CMD-check-and-coverage.yaml ├── NEWS ├── DESCRIPTION └── NAMESPACE /.Rinstignore: -------------------------------------------------------------------------------- 1 | inst/doc/figures -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | inst/doc/figures 2 | ^\.github$ 3 | -------------------------------------------------------------------------------- /tests/test-all.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | test_check("ggbio") -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .Rhistory 3 | /vignettes/realvignettes/auto/ggbio.el 4 | -------------------------------------------------------------------------------- /vignettes/figures/facet.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/facet.pdf -------------------------------------------------------------------------------- /vignettes/figures/geoms.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geoms.pdf -------------------------------------------------------------------------------- /vignettes/figures/grl.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/grl.pdf -------------------------------------------------------------------------------- /vignettes/figures/icon.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/icon.pdf -------------------------------------------------------------------------------- /vignettes/figures/man.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/man.pdf -------------------------------------------------------------------------------- /vignettes/figures/ssx3.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/ssx3.pdf -------------------------------------------------------------------------------- /vignettes/figures/ucsc.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/ucsc.png -------------------------------------------------------------------------------- /vignettes/figures/vcf.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/vcf.pdf -------------------------------------------------------------------------------- /vignettes/figures/diagram.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/diagram.pdf -------------------------------------------------------------------------------- /vignettes/figures/drawing.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/drawing.pdf -------------------------------------------------------------------------------- /vignettes/figures/splice.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/splice.pdf -------------------------------------------------------------------------------- /vignettes/figures/cir-single.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/cir-single.pdf -------------------------------------------------------------------------------- /vignettes/figures/facet_gr.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/facet_gr.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_arch.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_arch.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_arrow.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_arrow.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_bar.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_bar.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_rect.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_rect.pdf -------------------------------------------------------------------------------- /vignettes/figures/karyogram.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/karyogram.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_gene.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_gene.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_table.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_table.pdf -------------------------------------------------------------------------------- /vignettes/figures/coord_genome.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/coord_genome.pdf -------------------------------------------------------------------------------- /vignettes/figures/coord_linear.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/coord_linear.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_chevron.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_chevron.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_segment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_segment.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_reduce.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_reduce.pdf -------------------------------------------------------------------------------- /vignettes/figures/track_layout.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/track_layout.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_alignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_alignment.pdf -------------------------------------------------------------------------------- /vignettes/figures/geom_arrowrect.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/geom_arrowrect.pdf -------------------------------------------------------------------------------- /vignettes/figures/layout_circle.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/layout_circle.pdf -------------------------------------------------------------------------------- /vignettes/figures/layout_default.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/layout_default.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_aggregate.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_aggregate.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_coverage.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_coverage.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_identity.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_identity.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_mismatch.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_mismatch.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_stepping.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_stepping.pdf -------------------------------------------------------------------------------- /vignettes/figures/truncate_gaps.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/truncate_gaps.pdf -------------------------------------------------------------------------------- /vignettes/figures/circular-9-circle.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/circular-9-circle.pdf -------------------------------------------------------------------------------- /vignettes/figures/layout_karyogram.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/layout_karyogram.pdf -------------------------------------------------------------------------------- /vignettes/figures/coord_truncate_gaps.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/coord_truncate_gaps.pdf -------------------------------------------------------------------------------- /vignettes/figures/stat_coverage_icon.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/stat_coverage_icon.pdf -------------------------------------------------------------------------------- /vignettes/figures/Manhattan-plotGrandLinear.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/Manhattan-plotGrandLinear.pdf -------------------------------------------------------------------------------- /vignettes/figures/autoplot_GappedAlignment.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/autoplot_GappedAlignment.pdf -------------------------------------------------------------------------------- /vignettes/figures/circular-lower-link-track.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/circular-lower-link-track.pdf -------------------------------------------------------------------------------- /vignettes/figures/rangeslinkedtodata-link4.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lawremi/ggbio/HEAD/vignettes/figures/rangeslinkedtodata-link4.pdf -------------------------------------------------------------------------------- /vignettes/knit.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | Rdevscript -e "library(knitr);knit('ggbio.Rnw')" 3 | pdflatex ggbio.tex 4 | pdflatex ggbio.tex 5 | evince ggbio.pdf 6 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | .onAttach <- function(...){ 2 | tip <- "Need specific help about ggbio? try mailing \n the maintainer or visit https://lawremi.github.io/ggbio/" 3 | packageStartupMessage(tip) 4 | } 5 | -------------------------------------------------------------------------------- /R/stat_gene-method.R: -------------------------------------------------------------------------------- 1 | ## FIXME: more flexible name.expr arguments 2 | setGeneric("stat_gene", function(data, ...) standardGeneric("stat_gene")) 3 | setMethod("stat_gene", "TxDb", function(data, ...){ 4 | .Deprecated("geom_alignment") 5 | geom_alignment(data, ...) 6 | }) 7 | -------------------------------------------------------------------------------- /vignettes/ggbio.Rnw: -------------------------------------------------------------------------------- 1 | 2 | %% This vignette is a stub. Please look at 3 | %% .[/inst]/doc/realvignettes or run 'make real' 4 | %% to copy the real vignettes in the current directory. 5 | 6 | \documentclass[10pt]{article} 7 | %\VignetteIndexEntry{Part 0: Introduction and quick start} 8 | \begin{document} 9 | \end{document} 10 | -------------------------------------------------------------------------------- /vignettes/fakevignettes/ggbio.Rnw: -------------------------------------------------------------------------------- 1 | 2 | %% This vignette is a stub. Please look at 3 | %% .[/inst]/doc/realvignettes or run 'make real' 4 | %% to copy the real vignettes in the current directory. 5 | 6 | \documentclass[10pt]{article} 7 | %\VignetteIndexEntry{Part 0: Introduction and quick start} 8 | \begin{document} 9 | \end{document} 10 | -------------------------------------------------------------------------------- /R/layout_linear-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("layout_linear", function(data,...) 2 | standardGeneric("layout_linear")) 3 | 4 | setMethod("layout_linear", "GRanges", function(data, ...){ 5 | p <- autoplot(data, ...) 6 | p <- facet_grid(scales = "free_x", space = "free_x") + 7 | scale_x_continuous(breaks = NULL, expand = c(0, 0)) 8 | p 9 | }) 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # INSTALL 2 | [![R-CMD-check](https://github.com/lawremi/ggbio/workflows/R-CMD-check-and-coverage/badge.svg)](https://github.com/lawremi/ggbio/actions) 3 | [![Codecov test 4 | coverage](https://codecov.io/gh/lawremi/ggbio/branch/master/graph/badge.svg)](https://codecov.io/gh/lawremi/ggbio?branch=master) 5 | 6 | if (!requireNamespace("BiocManager", quietly=TRUE)) 7 | install.packages("BiocManager") 8 | BiocManager::install("ggbio") 9 | -------------------------------------------------------------------------------- /vignettes/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile to use knitr for package vignettes 2 | 3 | # put all PDF targets here, separated by spaces 4 | PDFS= ggbio.pdf 5 | 6 | all: $(PDFS) 7 | 8 | clean: 9 | rm -f *.tex *.bbl *.blg *.aux *.out *.log *.spl *tikzDictionary *.toc 10 | rm -f figures/ggbio-* ggbio-* 11 | cp fakevignettes/*.Rnw . 12 | 13 | %.pdf: %.Rnw 14 | cp realvignettes/*.Rnw . 15 | $(R_HOME)/bin/Rscript -e "library(knitr); knit2pdf('$*.Rnw')" 16 | 17 | -------------------------------------------------------------------------------- /R/AllGenerics.R: -------------------------------------------------------------------------------- 1 | setGeneric("rescale", function(x, ...) standardGeneric("rescale")) 2 | 3 | setGeneric("plotFragLength", function(data, model, ...) 4 | standardGeneric("plotFragLength")) 5 | 6 | 7 | setGeneric("plotSpliceSum", function(data, model, ...) 8 | standardGeneric("plotSpliceSum")) 9 | 10 | setGeneric("xlim",function(obj, ...) standardGeneric("xlim")) 11 | setGeneric("xlim<-", function(x, value) standardGeneric("xlim<-")) 12 | 13 | getGeneric("[") 14 | 15 | 16 | -------------------------------------------------------------------------------- /R/coord_genome-method.R: -------------------------------------------------------------------------------- 1 | ## simply wrapper 2 | theme_genome <- function(){ 3 | list(facet_grid(.~seqnames), 4 | theme_pack_panels(), 5 | scale_x_continuous(breaks = NULL)) 6 | } 7 | 8 | 9 | ## setGeneric("coord_genome", function(data,...) 10 | ## standardGeneric("coord_genome")) 11 | 12 | ## setMethod("coord_genome", "GRanges", function(data, space.skip = 0.1){ 13 | ## object <- transformToGenome(object, space.skip = space.skip) 14 | ## object <- biovizBase:::rescaleGr(object) 15 | ## }) 16 | 17 | -------------------------------------------------------------------------------- /man/scale_fill_fold_change.Rd: -------------------------------------------------------------------------------- 1 | \name{scale_fill_fold_change} 2 | \alias{scale_fill_fold_change} 3 | \title{scale color for fold change values} 4 | \description{ 5 | In biology, lots of data are scaled to value around 0, and people like 6 | to show them as blue-white-red scale color, where negative value are 7 | blue, 0 is white and positive value is red, and they are scaled for 8 | continuous variables. 9 | } 10 | \usage{ 11 | scale_fill_fold_change() 12 | } 13 | \value{ 14 | a list. 15 | } 16 | \examples{ 17 | p1 <- autoplot(volcano - 150) 18 | p1 19 | p1 + scale_fill_fold_change() 20 | } 21 | \author{Tengfei Yin} 22 | 23 | -------------------------------------------------------------------------------- /man/scale_fill_giemsa.Rd: -------------------------------------------------------------------------------- 1 | \name{scale_fill_giemsa} 2 | \alias{scale_fill_giemsa} 3 | \title{scale filled color to customized giemsa color.} 4 | \description{ 5 | scale filled color to customized giemsa color. 6 | } 7 | \usage{ 8 | scale_fill_giemsa(fill = getOption("biovizBase")$cytobandColor) 9 | } 10 | \arguments{ 11 | \item{fill}{ 12 | a character vector to indicate colors, and names of vector mapped to 13 | gieStain name. 14 | } 15 | } 16 | \value{ 17 | a list. 18 | } 19 | \examples{ 20 | getOption("biovizBase")$cytobandColor 21 | library(biovizBase) 22 | data(hg19IdeogramCyto) 23 | p1 <- autoplot(hg19IdeogramCyto, layout = "karyogram", aes(fill = 24 | gieStain)) 25 | p1 26 | p1 + scale_fill_giemsa() 27 | } 28 | \author{Tengfei Yin} 29 | 30 | -------------------------------------------------------------------------------- /inst/CITATION: -------------------------------------------------------------------------------- 1 | citHeader("To cite package 'ggbio' in publications use:") 2 | citEntry( 3 | entry = "article", 4 | title = "ggbio: an R package for extending the grammar of graphics for genomic data", 5 | author = personList(as.person("Tengfei Yin"), 6 | as.person("Dianne Cook"), 7 | as.person("Michael Lawrence")), 8 | journal = "Genome Biology", 9 | volume = "13", 10 | number = "8", 11 | pages = "R77", 12 | year = "2012", 13 | publisher = "BioMed Central Ltd", 14 | textVersion = 15 | paste("Tengfei Yin, Dianne Cook and Michael Lawrence (2012):", 16 | "ggbio: an R package for extending the grammar of graphics for genomic data", 17 | "Genome Biology 13:R77")) 18 | 19 | -------------------------------------------------------------------------------- /man/Plot-class.Rd: -------------------------------------------------------------------------------- 1 | \name{Plot} 2 | \alias{Plot} 3 | \alias{Plot-class} 4 | \alias{ggplotPlot-class} 5 | \alias{latticePlot-class} 6 | \alias{ggbioPlot-class} 7 | \alias{Plot,gg-method} 8 | \alias{Plot,trellis-method} 9 | \alias{Plot,GGbio-method} 10 | \alias{Plot,Ideogram-method} 11 | \title{Plot class} 12 | \description{ 13 | genealize a graphic object to a Plot object. 14 | } 15 | \usage{ 16 | \S4method{Plot}{gg}(x) 17 | \S4method{Plot}{trellis}(x, mutable = FALSE) 18 | \S4method{Plot}{GGbio}(x) 19 | \S4method{Plot}{Ideogram}(x) 20 | } 21 | \arguments{ 22 | \item{x}{ 23 | object of gg, GGbio, trellis, Ideogram. 24 | } 25 | \item{mutable}{ 26 | whether a plot repsonse to \code{+} method or not. 27 | } 28 | } 29 | \value{ 30 | A Plot object. 31 | } 32 | \author{Tengfei Yin} 33 | 34 | -------------------------------------------------------------------------------- /man/scale_x_sequnit.Rd: -------------------------------------------------------------------------------- 1 | \name{scale_x_sequnit} 2 | \alias{scale_x_sequnit} 3 | \title{scale x by unit} 4 | \description{ 5 | scale x by unit 'Mb','kb', 'bp'. 6 | } 7 | \usage{ 8 | scale_x_sequnit(unit = c("Mb", "kb", "bp"), append = NULL) 9 | } 10 | \arguments{ 11 | \item{unit}{ 12 | unit to scale x. Default is Mb. 13 | } 14 | \item{append}{ 15 | default \code{NULL}. If pass a character, it disalbe unit and arbitrarily append a 16 | text behind the original x scale numbers. 17 | } 18 | 19 | } 20 | \value{ 21 | 'position_c' 22 | } 23 | \examples{ 24 | library(ggplot2) 25 | p <- qplot(x = seq(1, to = 10000, length.out = 40), y = rnorm(40), geom 26 | = "point") 27 | ## default mb 28 | p + scale_x_sequnit() 29 | p + scale_x_sequnit("kb") 30 | p + scale_x_sequnit("bp") 31 | } 32 | \author{Tengfei Yin} 33 | 34 | -------------------------------------------------------------------------------- /R/stat_stepping-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("stat_stepping", function(data, ...) standardGeneric("stat_stepping")) 2 | 3 | setMethod("stat_stepping", "GRanges", function(data, ..., 4 | xlab, ylab, main, 5 | facets = NULL, 6 | geom = c("rect", 7 | "alignment", "segment")){ 8 | 9 | 10 | geom <- match.arg(geom) 11 | args <- list(...) 12 | args$facets <- facets 13 | args$stat <- "stepping" 14 | args$data <- data 15 | if(length(data)){ 16 | p <- switch(geom, 17 | rect = do.call(geom_rect, args), 18 | alignment = do.call(geom_alignment, args), 19 | segment = do.call(geom_segment, args)) 20 | 21 | }else{ 22 | p <- NULL 23 | } 24 | labels <- Labels(xlab, ylab, main, fallback = c(x = "", y = "")) 25 | p <- c(p, labels) 26 | p <- setStat(p) 27 | p 28 | }) 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /man/Grob-class.Rd: -------------------------------------------------------------------------------- 1 | \name{Grob-class} 2 | \alias{Grob-class} 3 | \alias{Grob} 4 | \alias{Grob-method} 5 | \alias{Grob,gg-method} 6 | \alias{Grob,gtable-method} 7 | \alias{Grob,trellis-method} 8 | \alias{Grob,lattice-method} 9 | \alias{Grob,GGbio-method} 10 | \alias{GrobList-class} 11 | \alias{ggplotGrob-class} 12 | \alias{latticeGrob-class} 13 | \alias{GrobList} 14 | \title{Grob getter} 15 | \description{ 16 | 'Grob' class is a container for 'grob' based object defined with grid 17 | system. Generic function \code{Grob} gets grob object supported by grid system, and make an instance of 18 | subclass of class 'Grob'. 19 | 20 | 'GrobList' is a container of list of 'Grob' object. 21 | } 22 | \usage{ 23 | \S4method{Grob}{gg}(x) 24 | \S4method{Grob}{gtable}(x) 25 | \S4method{Grob}{trellis}(x) 26 | \S4method{Grob}{lattice}(x) 27 | \S4method{Grob}{GGbio}(x) 28 | } 29 | \arguments{ 30 | \item{x}{ 31 | object of class: gg, gtable, trellis, lattice, GGbio. 32 | } 33 | } 34 | \value{ 35 | A \code{Grob} object. 36 | } 37 | \author{Tengfei Yin} 38 | 39 | -------------------------------------------------------------------------------- /man/nav.Rd: -------------------------------------------------------------------------------- 1 | \name{zoom} 2 | \alias{zoom} 3 | \alias{zoom_in} 4 | \alias{zoom_out} 5 | \alias{nextView} 6 | \alias{prevView} 7 | \title{Simple navigation for ggbio object.} 8 | \description{ 9 | A set of simple navigation API apply to ggbio object, let you move 10 | along the genome and zoom in/out. 11 | } 12 | \usage{ 13 | zoom(fac = 1/2) 14 | zoom_in(fac = 1/2) 15 | zoom_out(fac = 2) 16 | nextView(unit = c("view", "gene", "exon", "utr")) 17 | prevView(unit = c("view", "gene", "exon", "utr")) 18 | } 19 | \arguments{ 20 | \item{fac}{ 21 | numeric value to indicate zoom factor, multiple of current view 22 | width. If it's smaller than 1, then it's zoom-in operation; if it's bigger 23 | than 1, then it's zoom-out operation. 24 | } 25 | \item{unit}{ 26 | only support 'view' unit now. 27 | } 28 | } 29 | \value{ 30 | A special class of navigation. 31 | } 32 | \details{ 33 | \code{zoom_in} and \code{zoom_out} are just simple wrapper around 34 | \code{zoom} function. 35 | 36 | For more convenient, gene features based jumpting we will support it 37 | in the future. 38 | } 39 | \author{Tengfei Yin} 40 | 41 | -------------------------------------------------------------------------------- /man/Tracked-class.Rd: -------------------------------------------------------------------------------- 1 | \name{Tracked} 2 | \alias{Tracked} 3 | \alias{Tracked-class} 4 | \title{Tracked class} 5 | \description{ 6 | Create a tracked object, designed for tracks function. 7 | } 8 | \usage{ 9 | Tracked(mutable = TRUE, fixed = FALSE, labeled = TRUE, 10 | hasAxis = FALSE, bgColor = "white", height = unit(1, "null")) 11 | } 12 | \arguments{ 13 | \item{mutable}{ 14 | logical value, default \code{TRUE}. To control whether a track is 15 | updatable by applying \code{+} on it. 16 | } 17 | \item{fixed}{ 18 | logical value, default \code{FALSE}. To control whether the scale 19 | response to a xlim change or not. 20 | } 21 | \item{labeled}{ 22 | logical value, default \code{TRUE}. To control whether to label it 23 | all not. 24 | } 25 | \item{hasAxis}{ 26 | logical value, default \code{FALSE}. To control whether to show axis 27 | for that track or not. 28 | } 29 | \item{bgColor}{ 30 | character to control background color of a track. 31 | } 32 | \item{height}{ 33 | unit, to control track height. 34 | } 35 | } 36 | \value{ 37 | a \code{Tracked} object. 38 | } 39 | \author{Tengfei Yin} 40 | 41 | -------------------------------------------------------------------------------- /man/arrangeGrobByParsingLegend.Rd: -------------------------------------------------------------------------------- 1 | \name{arrangeGrobByParsingLegend} 2 | \alias{arrangeGrobByParsingLegend} 3 | \title{Arrange grobs by parse their legend.} 4 | \description{ 5 | Arrange grobs and parse their legend, then put it together on the 6 | right. 7 | } 8 | \usage{ 9 | arrangeGrobByParsingLegend(..., nrow = NULL, ncol = NULL, 10 | widths = c(4, 1), legend.idx = NULL) 11 | } 12 | \arguments{ 13 | \item{...}{ggplot graphics.} 14 | \item{nrow}{number of row for layout.} 15 | \item{ncol}{number of columns for layout} 16 | \item{widths}{width ratio for plot group and legend group.} 17 | \item{legend.idx}{legend index you want to keep.} 18 | } 19 | \value{ 20 | a 21 | } 22 | \examples{ 23 | library(ggplot2) 24 | p1 <- qplot(x = mpg, y= cyl, data = mtcars, color = carb) 25 | p2 <- qplot(x = mpg, y= cyl, data = mtcars, color = wt) 26 | p3 <- qplot(x = mpg, y= cyl, data = mtcars, color = qsec) 27 | p4 <- qplot(x = mpg, y= cyl, data = mtcars, color = gear) 28 | arrangeGrobByParsingLegend(p1, p2, p3, p4) 29 | arrangeGrobByParsingLegend(p1, p2, p3, p4, ncol = 1) 30 | arrangeGrobByParsingLegend(p1, p2, p3, p4, legend.idx = 2) 31 | } 32 | \author{Tengfei Yin} 33 | 34 | -------------------------------------------------------------------------------- /R/ggplot-method.R: -------------------------------------------------------------------------------- 1 | ggbio_ggplot <- function(data, mapping = aes(), ..., 2 | environment = parent.frame()) { 3 | gg <- ggplot(mapping = mapping, ..., environment=environment) 4 | GGbio(gg, data = data) 5 | } 6 | 7 | ggbio_ggplot_mold <- function(data, mapping = aes(), ..., 8 | environment = parent.frame()) { 9 | gg <- ggplot(mold(data), mapping, ..., environment=environment) 10 | GGbio(gg, data = data) 11 | } 12 | 13 | ggplot.Vector <- ggbio_ggplot_mold 14 | ggplot.Seqinfo <- ggbio_ggplot_mold 15 | ggplot.matrix <- ggbio_ggplot_mold # highly questionable 16 | ggplot.ExpressionSet <- ggbio_ggplot_mold 17 | ggplot.RsamtoolsFile <- ggbio_ggplot 18 | ggplot.character <- ggbio_ggplot # highly questionable 19 | ggplot.TxDbOREnsDb <- ggbio_ggplot 20 | ggplot.BSgenome <- ggbio_ggplot 21 | ggplot.GAlignments <- ggbio_ggplot 22 | ggplot.VCF <- ggbio_ggplot 23 | 24 | ggplot.SummarizedExperiment <- function(data, mapping = aes(), assay.id = 1L, 25 | ..., environment = parent.frame()) { 26 | df <- mold(data, assay.id=assay.id) 27 | g <- ggplot(df, mapping, ..., environment=environment) 28 | g <- GGbio(g, data = data) 29 | g 30 | } 31 | -------------------------------------------------------------------------------- /R/AllClasses.R: -------------------------------------------------------------------------------- 1 | if (!isClass("unit")) setOldClass("unit") 2 | if (!isClass("simpleUnit")) setOldClass(c("simpleUnit", "unit")) 3 | if (!isClass("gtable")) setOldClass("gtable") 4 | if (!isClass("theme")) setOldClass("theme") 5 | if (!isClass("gTree")) setOldClass("gTree") 6 | if (!isClass("grob")) setOldClass("grob") 7 | setClassUnion("theme_OR_NULL", c("theme", "NULL")) 8 | setClassUnion("numericORunit", c("numeric", "unit")) 9 | setClassUnion("numeric_OR_NULL", c("numeric", "NULL")) 10 | 11 | setClassUnion("GRanges_OR_NULL", c("GRanges", "NULL")) 12 | 13 | setClassUnion("TxDbOREnsDb", c("TxDb", "EnsDb")) 14 | ## setClassUnion("GRangesORANY", c("GRanges", "ANY")) 15 | ## setClassUnion("GRangesORBasicFilterORlistORNULL", 16 | setClassUnion("GRanges_OR_BasicFilter_OR_list_OR_NULL", 17 | c("GRanges", "AnnotationFilter", "AnnotationFilterList", 18 | "formula", "list", "NULL")) 19 | setClassUnion("BasicFilterORlist", 20 | c("AnnotationFilter", "AnnotationFilterList", "formula", "list")) 21 | 22 | setOldClass(c("ggplot2::ggplot", "ggplot", "ggplot2::gg", "gg")) 23 | setClassUnion("ggplot_OR_NULL", c("ggplot", "NULL")) 24 | setClassUnion("gg_OR_NULL", c("gg", "NULL")) 25 | 26 | setOldClass("grob") 27 | setOldClass("trellis") 28 | setOldClass("lattice") 29 | 30 | 31 | -------------------------------------------------------------------------------- /R/geom_bar-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("geom_bar", function(data, ...) standardGeneric("geom_bar")) 2 | 3 | setMethod("geom_bar", "ANY", function(data, ...){ 4 | ggplot2::geom_bar(data = data, ...) 5 | }) 6 | 7 | ## alignment should be convenient toggle with chevron... 8 | setMethod("geom_bar", "GRanges", function(data,..., xlab, ylab, main){ 9 | 10 | args <- list(...) 11 | args.aes <- parseArgsForAes(args) 12 | args.non <- parseArgsForNonAes(args) 13 | facet <- build_facet(data, args) 14 | if(length(data)){ 15 | if(!"y" %in% names(args.aes)){ 16 | if("score" %in% colnames(values(data))){ 17 | message("use score as y by default") 18 | args.aes$y <- as.name("score") 19 | }else{ 20 | stop("missing y values in aes(), or please provide a column named 'score'") 21 | } 22 | } 23 | .y <- quo_name(args.aes$y) 24 | if (missing(ylab)) 25 | ylab <- .y 26 | args.aes <- remove_args(args.aes, "y") 27 | args.aes$xmin <- as.name("start") 28 | args.aes$xmax <- as.name("end") 29 | args.aes$ymin <- 0 30 | args.aes$ymax <- as.name(.y) 31 | aes.res <- do.call(aes, args.aes) 32 | p <- list(do.call(geom_rect, c(list(data = mold(data)), list(aes.res), args.non))) 33 | }else{ 34 | p <- NULL 35 | } 36 | p <- c(p, list(facet)) 37 | labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 38 | p <- c(p, labels) 39 | p 40 | }) 41 | -------------------------------------------------------------------------------- /man/ggbio-class.Rd: -------------------------------------------------------------------------------- 1 | \name{GGbio} 2 | \alias{ggbio} 3 | \alias{GGbio} 4 | \alias{GGbio-class} 5 | \alias{ggbio-class} 6 | \alias{+,GGbio,ANY-method} 7 | \alias{$,GGbio-method} 8 | \alias{$<-,GGbio-method} 9 | \title{class ggbio} 10 | \description{ 11 | a sub class of ggplot and gg class defined in ggplot2 package, used for ggbio specific methods. 12 | } 13 | \usage{ 14 | GGbio(ggplot = NULL, data = NULL, fetchable = FALSE, blank = 15 | FALSE, ...) 16 | } 17 | \arguments{ 18 | \item{ggplot}{ 19 | a ggplot or gg object. 20 | } 21 | \item{data}{ 22 | raw data 23 | } 24 | \item{fetchable}{ 25 | logical value, default \code{FALSE}, is there any fetch method available. 26 | } 27 | \item{blank}{ 28 | logical value, default \code{FALSE}, is this plot a blank plot. 29 | } 30 | \item{...}{ 31 | More properties passed to class like \code{Cache}. 32 | } 33 | } 34 | \value{ 35 | a ggbio object. 36 | } 37 | \details{ 38 | This class is defined to facilitate the ggbio-specific visualization 39 | method, especially when using \code{\link{ggplot}} to construct ggbio 40 | supported object, that will return a ggbio class. And internals tricks 41 | will help a lazy evaluation for following \code{+} method. 42 | } 43 | \seealso{ 44 | \code{\link{ggplot}} 45 | } 46 | \examples{ 47 | p1 <- qplot() 48 | g1 <- ggbio(p1) 49 | class(g1) 50 | } 51 | \author{Tengfei Yin} 52 | 53 | -------------------------------------------------------------------------------- /R/rescale-method.R: -------------------------------------------------------------------------------- 1 | ## ====================================================================== 2 | ## For "Granges" 3 | ## ====================================================================== 4 | setMethod("rescale", signature(x = "numeric"), function(x, to = c(0, 1), 5 | from = range(x, na.rm = TRUE)){ 6 | scales::rescale(x, to = to , from = from) 7 | }) 8 | 9 | setMethod("rescale", "gg", function(x, xlim, ylim, sx = 1, sy = 1){ 10 | if(!missing(xlim) & sx != 1) 11 | stop("You can only rescale by one of xlim or sx") 12 | if(!missing(ylim) & sy != 1) 13 | stop("You can only rescale by one of ylim or sy") 14 | if(!missing(xlim)) 15 | res <- x + coord_cartesian(xlim = xlim) 16 | ## res <- x + scale_x_continuous(limits = xlim) 17 | if(!missing(ylim)) 18 | res <- x + coord_cartesian(ylim = ylim) 19 | ## res <- x + scale_x_continuous(limits = ylim) 20 | if(sx != 1){ 21 | xlim <- .getLimits(x)$xlim 22 | xlim.mean <- mean(xlim) 23 | extra.new <- diff(xlim) * sx/2 24 | xlim <- c(xlim.mean - extra.new, xlim.mean + extra.new) 25 | res <- x + coord_cartesian(xlim = xlim) 26 | } 27 | if(sy != 1){ 28 | ylim <- .getLimits(x)$ylim 29 | ylim.mean <- mean(ylim) 30 | extra.new <- diff(ylim) * sy/2 31 | ylim <- c(ylim.mean - extra.new, ylim.mean + extra.new) 32 | res <- x + coord_cartesian(ylim = ylim) 33 | } 34 | res 35 | }) 36 | -------------------------------------------------------------------------------- /man/stat_mismatch-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_mismatch} 2 | \alias{stat_mismatch} 3 | \alias{stat_mismatch,missing-method} 4 | \alias{stat_mismatch,uneval-method} 5 | \alias{stat_mismatch,GRanges-method} 6 | \alias{stat_mismatch,BamFile-method} 7 | \title{Calculate mismatch summary} 8 | \description{ 9 | Calculate mismatch summary 10 | } 11 | \usage{ 12 | ## for GRanges 13 | \S4method{stat_mismatch}{GRanges}(data, ..., bsgenome, 14 | xlab, ylab, main, 15 | geom = c("segment", "bar"), 16 | show.coverage = TRUE) 17 | ## for BamFile 18 | \S4method{stat_mismatch}{BamFile}(data, ..., bsgenome, which, 19 | xlab, ylab, main, 20 | geom = c("segment", "bar"), 21 | show.coverage = TRUE) 22 | } 23 | \arguments{ 24 | \item{data}{ 25 | A \code{GRanges} or \code{BamFile} object. 26 | } 27 | \item{...}{ 28 | Extra parameters such as aes() passed to \code{geom_rect}, 29 | \code{geom_alignment}, or \code{geom_segment}. 30 | } 31 | \item{bsgenome}{ 32 | \code{BSgenome} object. 33 | } 34 | \item{which}{ 35 | \code{GRanges} object to subset the data. 36 | } 37 | \item{xlab}{ 38 | Label for x 39 | } 40 | \item{ylab}{ 41 | Label for y 42 | } 43 | \item{main}{ 44 | Title for plot. 45 | } 46 | \item{geom}{ 47 | The geometric object to use display the data. 48 | } 49 | \item{show.coverage}{ 50 | whether to show coverage as background or not. 51 | } 52 | } 53 | \value{ 54 | A 'Layer'. 55 | } 56 | \author{Tengfei Yin} 57 | 58 | -------------------------------------------------------------------------------- /man/stat_gene-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_gene} 2 | \alias{stat_gene} 3 | \alias{stat_gene,TxDb-method} 4 | \title{Calculate gene structure} 5 | \description{ 6 | Calculate gene structure. 7 | } 8 | \usage{ 9 | \S4method{stat_gene}{TxDb}(data, ...) 10 | } 11 | \arguments{ 12 | \item{data}{ 13 | A \code{GRanges} or \code{data.frame} object. 14 | } 15 | \item{...}{ 16 | Extra parameters such as aes() passed to \code{geom_alignment}. 17 | } 18 | } 19 | \value{ 20 | A 'Layer'. 21 | } 22 | \seealso{\code{\link{geom_alignment}}} 23 | \examples{ 24 | \dontrun{ 25 | ## loading package 26 | ## Deprecated 27 | library(TxDb.Hsapiens.UCSC.hg19.knownGene) 28 | data(genesymbol, package = "biovizBase") 29 | txdb <- TxDb.Hsapiens.UCSC.hg19.knownGene 30 | 31 | ## made a track comparing full/reduce stat. 32 | p1 <- ggplot() + geom_alignment(txdb, which = genesymbol["RBM17"]) 33 | p1 <- ggplot() + stat_gene(txdb, which = genesymbol["RBM17"]) 34 | ## or 35 | p1 <- ggplot(txdb) + stat_gene(which = genesymbol["RBM17"]) 36 | 37 | p1 <- ggplot(txdb) + stat_gene(which = genesymbol["RBM17"]) 38 | p2 <- ggplot(txdb) + stat_gene(which = genesymbol["RBM17"], stat = 39 | "reduce") 40 | p2 <- ggplot(txdb) + stat_gene(which = genesymbol["RBM17"], stat = "reduce") 41 | ## ggplot(txdb) + geom_alignment(which = genesymbol["RBM17"]) + stat_reduce() 42 | ## ggplot(txdb) + geom_alignment(which = genesymbol["RBM17"]) 43 | tracks(full = p1, reduce = p2, heights = c(3, 1)) 44 | 45 | ## change y labels 46 | ggplot(txdb) + stat_gene(which = genesymbol["RBM17"], names.expr = 47 | "tx_id:::gene_id") 48 | } 49 | } 50 | \author{Tengfei Yin} 51 | 52 | -------------------------------------------------------------------------------- /man/rescale-method.Rd: -------------------------------------------------------------------------------- 1 | \name{rescale} 2 | \alias{rescale} 3 | \alias{rescale,numeric-method} 4 | \alias{rescale,ggplot-method} 5 | \alias{rescale,gg-method} 6 | \title{rescale ggplot object} 7 | \description{ 8 | Rescale a numeric vector or ggplot object, could be used for static 9 | zoom-in in ggbio. 10 | } 11 | \usage{ 12 | \S4method{rescale}{numeric}(x, to = c(0, 1), 13 | from = range(x, na.rm = TRUE)) 14 | 15 | \S4method{rescale}{ggplot}(x, xlim, ylim, sx = 1, sy = 1) 16 | \S4method{rescale}{gg}(x, xlim, ylim, sx = 1, sy = 1) 17 | } 18 | \arguments{ 19 | \item{x}{ 20 | A numeric object or ggplot object to be rescaled. 21 | } 22 | \item{to}{ 23 | For numeric object. it's a vector of two numeric values, specifying 24 | the range to be rescale. 25 | } 26 | \item{from}{ 27 | Range of x. 28 | } 29 | \item{xlim}{ 30 | For ggplot object. This specify the new limits on x-scale. 31 | } 32 | \item{ylim}{ 33 | For ggplot object. This specify the new limits on y-scale. 34 | } 35 | \item{sx}{ 36 | Scale fold for x-scale. Default is 1, no change. 37 | } 38 | \item{sy}{ 39 | Scale fold for y-scale. Default is 1, no change. 40 | } 41 | } 42 | \value{ 43 | Return the object of the same class as \code{x} after rescaling. 44 | } 45 | \details{ 46 | When \code{x} is numeric value, it's just call scales::rescale, please 47 | refer to the manual page to check more details. If \code{x} is ggplot 48 | object, it first try to estimate current x limits and y limits of the ggplot 49 | object, then rescale based on those information. 50 | } 51 | \examples{ 52 | library(ggbio) 53 | head(mtcars) 54 | range(mtcars$mpg) 55 | p <- qplot(data = mtcars, x = mpg, y = disp, geom = "point") 56 | p.new <- rescale(p, xlim = c(20, 25)) 57 | p.new 58 | } 59 | \author{Tengfei Yin} 60 | 61 | -------------------------------------------------------------------------------- /man/ggsave.Rd: -------------------------------------------------------------------------------- 1 | \name{ggsave} 2 | \alias{ggsave} 3 | \title{Save a ggplot object or tracks with sensible defaults} 4 | \usage{ 5 | ggsave(filename, plot = last_plot(), 6 | device = default_device(filename), path = NULL, 7 | scale = 1, width = par("din")[1], 8 | height = par("din")[2], units = c("in", "cm", "mm"), 9 | dpi = 300, limitsize = TRUE, ...) 10 | } 11 | \arguments{ 12 | \item{filename}{file name/filename of plot} 13 | 14 | \item{plot}{plot to save, defaults to last plot 15 | displayed} 16 | 17 | \item{device}{device to use, automatically extract from 18 | file name extension} 19 | 20 | \item{path}{path to save plot to (if you just want to set 21 | path and not filename)} 22 | 23 | \item{scale}{scaling factor} 24 | 25 | \item{width}{width (defaults to the width of current 26 | plotting window)} 27 | 28 | \item{height}{height (defaults to the height of current 29 | plotting window)} 30 | 31 | \item{units}{units for width and height when either one 32 | is explicitly specified (in, cm, or mm)} 33 | 34 | \item{dpi}{dpi to use for raster graphics} 35 | 36 | \item{limitsize}{when \code{TRUE} (the default), 37 | \code{ggsave} will not save images larger than 50x50 38 | inches, to prevent the common error of specifying 39 | dimensions in pixels.} 40 | 41 | \item{...}{other arguments passed to graphics device} 42 | } 43 | \description{ 44 | ggsave is a convenient function for saving a plot. It 45 | defaults to saving the last plot that you displayed, and 46 | for a default size uses the size of the current graphics 47 | device. It also guesses the type of graphics device from 48 | the extension. This means the only argument you need to 49 | supply is the filename. 50 | } 51 | \details{ 52 | \code{ggsave} currently recognises the extensions eps/ps, 53 | tex (pictex), pdf, jpeg, tiff, png, bmp, svg and wmf 54 | (windows only). 55 | } 56 | -------------------------------------------------------------------------------- /man/geom_bar-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_bar} 2 | \alias{geom_bar} 3 | \alias{geom_bar,ANY-method} 4 | \alias{geom_bar,GRanges-method} 5 | \alias{geom_bar,missing-method} 6 | \alias{geom_bar,chevron-method} 7 | \title{Segment geoms for GRanges object} 8 | \description{ 9 | Show interval data as vertical bar, width equals to interval width and 10 | use 'score' or specified 'y' as y scale. 11 | } 12 | \usage{ 13 | \S4method{geom_bar}{ANY}(data, ...) 14 | \S4method{geom_bar}{GRanges}(data,..., xlab, ylab, main) 15 | } 16 | \arguments{ 17 | \item{data}{ 18 | Typically a \code{GRanges} or \code{data.frame} object. 19 | } 20 | \item{...}{ 21 | Extra parameters such as aes() or \code{color, size} passed. 22 | } 23 | \item{xlab}{ 24 | Label for x 25 | } 26 | \item{ylab}{ 27 | Label for y 28 | } 29 | \item{main}{ 30 | Title for plot. 31 | } 32 | } 33 | \details{ 34 | Useful for showing bed like files, when imported as GRanges, have a 35 | extra 'score' column, use it as default y, you could also specify y by 36 | using aes(y = ). 37 | } 38 | \value{ 39 | A 'Layer'. 40 | } 41 | \examples{ 42 | ## load 43 | library(GenomicRanges) 44 | 45 | ## simul 46 | set.seed(123) 47 | gr.b <- GRanges(seqnames = "chr1", IRanges(start = seq(1, 100, by = 10), 48 | width = sample(4:9, size = 10, replace = TRUE)), 49 | score = rnorm(10, 10, 3), value = runif(10, 1, 100)) 50 | gr.b2 <- GRanges(seqnames = "chr2", IRanges(start = seq(1, 100, by = 10), 51 | width = sample(4:9, size = 10, replace = TRUE)), 52 | score = rnorm(10, 10, 3), value = runif(10, 1, 100)) 53 | gr.b <- c(gr.b, gr.b2) 54 | ## default use score as y 55 | 56 | ## bar 57 | ggplot(gr.b) + geom_bar(mapping = aes(fill = value)) 58 | ## or 59 | ggplot() + geom_bar(gr.b, mapping = aes(fill = value)) 60 | ggplot(gr.b) + geom_bar(mapping = aes(y = value)) 61 | ## equal to 62 | autoplot(gr.b, geom = "bar") 63 | } 64 | 65 | -------------------------------------------------------------------------------- /R/Grob-class.R: -------------------------------------------------------------------------------- 1 | .supportedPlots <- c("gg", "trellis", "GGbio") 2 | isSupportedPlots <- function(x){ 3 | sapply(x, function(z){ 4 | any(sapply(.supportedPlots, function(c){ 5 | extends(class(z), c) 6 | })) 7 | }) 8 | } 9 | 10 | setClass("Grob", contains = "VIRTUAL") 11 | ## setClass("ggplotGrob", contains = c("gtable", "grob", "Grob")) 12 | ## setClass("latticeGrob", contains = c("lattice", "grob", "Grob")) 13 | 14 | ## Grob creat instance of sub-class 15 | setGeneric("Grob", function(x, ...) standardGeneric("Grob")) 16 | setMethod("Grob", "gg", function(x){ 17 | ## new("ggplotGrob", ggplotGrob(x)) 18 | ggplotGrob(x) 19 | }) 20 | setMethod("Grob", "gtable", function(x){ 21 | ## new("ggplotGrob", x) 22 | x 23 | }) 24 | setMethod("Grob", "trellis", function(x){ 25 | ## new("latticeGrob", latticeGrob(x)) 26 | gridExtra:::latticeGrob(x) 27 | }) 28 | setMethod("Grob", "lattice", function(x){ 29 | x 30 | }) 31 | 32 | setMethod("Grob", "GGbio", function(x){ 33 | ## new("ggplotGrob", ggplotGrob(x@ggplot)) 34 | ggplotGrob(x@ggplot) 35 | }) 36 | 37 | 38 | ## setClass("GrobList", prototype = prototype(elementType = "Grob"), 39 | ## contains = "list") 40 | 41 | .validList <- function(object){ 42 | if(all(sapply(object, is, object@elementType))) 43 | return(TRUE) 44 | else 45 | paste("Class must be", object@elementType) 46 | } 47 | ## setValidity("GrobList", .validList) 48 | 49 | ## ## constructor for class 'grobList' 50 | GrobList <- function(...){ 51 | items <- list(...) 52 | items <- listOfGrobs(items) 53 | ## new("GrobList", items) 54 | items 55 | } 56 | 57 | reduceListOfPlots <- function(x){ 58 | firstElementIsListOfGrobs <- 59 | length(x) == 1 && is.list(x[[1L]]) && !extends(class(x[[1]]), "gg") 60 | if (firstElementIsListOfGrobs) 61 | x <- x[[1]] 62 | x 63 | } 64 | 65 | ## this return a list of 'grobs' from list of valided 'plots' which could have grobs returned 66 | listOfGrobs <- function(x) { 67 | x <- reduceListOfPlots(x) 68 | lapply(x, Grob) 69 | } 70 | -------------------------------------------------------------------------------- /R/scales.R: -------------------------------------------------------------------------------- 1 | trans_seq <- function(unit = c("Mb", "kb", "bp")) { 2 | unit <- match.arg(unit) 3 | function(x) { 4 | res <- switch(unit, Mb = {x/1e6}, 5 | kb = {x/1000}, 6 | bp = {x}) 7 | res 8 | } 9 | } 10 | 11 | trans_seq_rev <- function(unit = c("Mb", "kb", "bp")) { 12 | unit <- match.arg(unit) 13 | function(x) { 14 | res <- switch(unit, Mb = {x*1e6}, 15 | kb = {x*1000}, 16 | bp = {x}) 17 | res 18 | } 19 | } 20 | 21 | trans_seq_format <- function(unit = c("Mb", "kb", "bp")) { 22 | unit <- match.arg(unit) 23 | function(x) { 24 | res <- switch(unit, Mb = {x/1e6}, 25 | kb = {x/1000}, 26 | bp = {x}) 27 | paste(res, unit) 28 | } 29 | } 30 | 31 | .append_unit <- function(unit = "") { 32 | function(x) paste(x, unit) 33 | } 34 | 35 | scale_x_sequnit <- function(unit = c("Mb", "kb", "bp"), append = NULL) { 36 | unit <- match.arg(unit) 37 | if(is.null(append)) { 38 | scale_x_continuous(breaks = trans_breaks(trans_seq(unit), 39 | trans_seq_rev(unit)), 40 | labels = trans_format(trans_seq_format(unit), 41 | math_format(.x))) 42 | } else { 43 | stopifnot(is.character(append)) 44 | scale_x_continuous(labels = trans_format(.append_unit(append), 45 | math_format(.x))) 46 | } 47 | } 48 | 49 | scale_fill_giemsa <- function(fill = getOption("biovizBase")$cytobandColor) { 50 | list(scale_fill_manual(values = fill)) 51 | } 52 | 53 | ## matrix 54 | scale_fill_fold_change <- function() { 55 | scale_fill_gradient2(low = "blue", mid = "white", high = "red") 56 | } 57 | 58 | scale_by_xlim <- function(xlim, by.unit = TRUE) { 59 | if(by.unit) 60 | .d <- max(xlim) 61 | else 62 | .d <- diff(xlim) 63 | 64 | if(.d > 1e6) 65 | res <- scale_x_sequnit("Mb") 66 | else if (.d <= 1e6 & .d > 1e3) 67 | res <- scale_x_sequnit("kb") 68 | else 69 | res <- scale_x_sequnit("bp") 70 | 71 | res 72 | } 73 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check-and-coverage.yaml: -------------------------------------------------------------------------------- 1 | on: 2 | push: 3 | branches: [master] 4 | pull_request: 5 | branches: [master] 6 | 7 | name: R-CMD-check-and-coverage 8 | 9 | jobs: 10 | R-CMD-check-and-coverage: 11 | runs-on: ubuntu-latest 12 | container: bioconductor/bioconductor_docker:devel 13 | 14 | env: 15 | R_REMOTES_NO_ERRORS_FROM_WARNINGS: true 16 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 17 | 18 | steps: 19 | - name: Checkout repository 20 | uses: actions/checkout@v4 21 | 22 | - name: Install system dependencies & R deps 23 | uses: r-lib/actions/setup-r-dependencies@v2 24 | with: 25 | extra-packages: | 26 | any::rcmdcheck 27 | any::BiocCheck 28 | any::covr 29 | any::sessioninfo 30 | local::. 31 | needs: 32 | coverage 33 | check 34 | 35 | - name: Install LaTeX 36 | run: | 37 | apt-get update -y 38 | apt-get install -y \ 39 | texlive-latex-base \ 40 | texlive-fonts-recommended \ 41 | texlive-fonts-extra 42 | 43 | - name: Session info 44 | run: | 45 | options(width = 100) 46 | pkgs <- installed.packages()[, "Package"] 47 | sessioninfo::session_info(pkgs, include_base = TRUE) 48 | shell: Rscript {0} 49 | 50 | - name: Check 51 | env: 52 | _R_CHECK_CRAN_INCOMING_REMOTE_: false 53 | run: | 54 | rcmdcheck::rcmdcheck( 55 | args = c("--no-build-vignettes", "--no-manual", "--timings"), 56 | build_args = c("--no-manual", "--no-resave-data"), 57 | error_on = "error", 58 | check_dir = "check" 59 | ) 60 | shell: Rscript {0} 61 | 62 | - name: Reveal testthat details 63 | run: find . -name testthat.Rout -exec cat '{}' ';' 64 | 65 | - name: Test coverage 66 | run: | 67 | covr::codecov() 68 | shell: Rscript {0} 69 | 70 | - name: Upload check results 71 | if: failure() 72 | uses: actions/upload-artifact@master 73 | with: 74 | name: ${{ runner.os }}-biocversion-devel 75 | path: check 76 | -------------------------------------------------------------------------------- /R/plotSpliceSum-method.R: -------------------------------------------------------------------------------- 1 | setMethod("plotSpliceSum", c("character", "GRangesList"), 2 | function(data, model, ..., weighted = TRUE){ 3 | freq <- biovizBase:::spliceSummary(data, model, weighted = weighted) 4 | autoplot(model, freq = freq, ...) 5 | }) 6 | setMethod("plotSpliceSum", c("character", "TxDb"), 7 | function(data, model, which, ..., weighted = TRUE){ 8 | exons <- exonsBy(model, by = "tx") 9 | exons <- subsetByOverlaps(exons, which) 10 | freq <- biovizBase:::spliceSummary(data, exons, weighted = weighted) 11 | autoplot(exons, freq = freq, ...) 12 | }) 13 | 14 | ####============================================================ 15 | ## plotSpliceSum method from ggbio, R/plotSpliceSum-method.R 16 | ## 17 | ####------------------------------------------------------------ 18 | setMethod("plotSpliceSum", c("character", "EnsDb"), 19 | function(data, model, which, ..., weighted = TRUE){ 20 | if(is(which, "GRanges")){ 21 | if(length(which) != 1) 22 | stop("'which' has to be a single GRanges object.") 23 | if(!is.na(genome(which))){ 24 | if(unname(genome(which)) != unique(unname(genome(model)))) 25 | stop(paste0("Genome versions do not fit! Argument 'which' has ", 26 | unname(genome(which)), " argument 'model' ", 27 | unname(unique(genome(which))), "!")) 28 | } 29 | ## Check if we've got the seqnames. 30 | if(!(seqlevels(which) %in% seqlevels(model))) 31 | stop(paste0(seqlevels(which), " does not match any seqlevel ", 32 | "in argument 'model'!")) 33 | which <- GRangesFilter(which, condition="overlapping") 34 | } 35 | exons <- exonsBy(model, by="tx", filter=which) 36 | ## Check if features are all on one chromosome. 37 | if(length(seqlevels(unlist(exons))) > 1) 38 | stop(paste0("Got features from ", length(seqlevels(unlist(exons))), 39 | " different chromosomes. Please adjust 'which' such that", 40 | " only features from one chromosome are fetched.")) 41 | freq <- biovizBase:::spliceSummary(data, exons, weighted = weighted) 42 | autoplot(exons, freq = freq, ...) 43 | }) 44 | 45 | -------------------------------------------------------------------------------- /man/stat_table-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_table} 2 | \alias{stat_table} 3 | \alias{stat_table,missing-method} 4 | \alias{stat_table,uneval-method} 5 | \alias{stat_table,GRanges-method} 6 | \alias{stat_table,GRangesList-method} 7 | \title{Tabulate a GRanges object} 8 | \description{ 9 | Tabulate a GRanges object 10 | } 11 | \usage{ 12 | \S4method{stat_table}{GRanges}(data, ..., xlab, ylab, main, 13 | geom = NULL,stat = NULL) 14 | \S4method{stat_table}{GRangesList}(data, ..., xlab, ylab, main, 15 | facets = NULL, geom = NULL) 16 | 17 | } 18 | \arguments{ 19 | \item{data}{ 20 | A \code{GRanges} or \code{data.frame} object. 21 | } 22 | \item{...}{ 23 | Extra parameters such as aes() passed to \code{geom_rect}, 24 | \code{geom_alignment}, or \code{geom_segment}. 25 | } 26 | \item{xlab}{ 27 | Label for x 28 | } 29 | \item{ylab}{ 30 | Label for y 31 | } 32 | \item{main}{ 33 | Title for plot. 34 | } 35 | \item{facets}{ 36 | Faceting formula to use. 37 | } 38 | \item{geom}{ 39 | The geometric object to use display the data. 40 | } 41 | \item{stat}{ 42 | The geometric object to use display the data. 43 | } 44 | } 45 | \value{ 46 | A 'Layer'. 47 | } 48 | \examples{ 49 | ## load 50 | set.seed(1) 51 | N <- 100 52 | require(ggbio) 53 | require(GenomicRanges) 54 | ## simul 55 | ## ====================================================================== 56 | ## simmulated GRanges 57 | ## ====================================================================== 58 | gr <- GRanges(seqnames = 59 | sample(c("chr1", "chr2", "chr3"), 60 | size = N, replace = TRUE), 61 | IRanges( 62 | start = sample(1:300, size = N, replace = TRUE), 63 | width = sample(70:75, size = N,replace = TRUE)), 64 | strand = sample(c("+", "-", "*"), size = N, 65 | replace = TRUE), 66 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 67 | sample = sample(c("Normal", "Tumor"), 68 | size = N, replace = TRUE), 69 | pair = sample(letters, size = N, 70 | replace = TRUE)) 71 | 72 | gr <- c(gr[seqnames(gr) == "chr1"][sample(1:10, size = 1e4, replace = TRUE)],gr) 73 | 74 | ## default 75 | ggplot(gr) + stat_table() 76 | ggplot(gr) + stat_table(geom = "segment", mapping = aes(y = ..score.., color = ..score..)) 77 | ggplot(gr) + stat_table(mapping = aes(color = score)) 78 | } 79 | \author{Tengfei Yin} 80 | 81 | -------------------------------------------------------------------------------- /R/stat_reduce-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("stat_reduce", function(data, ...) standardGeneric("stat_reduce")) 2 | 3 | setMethod("stat_reduce", "GRanges", function(data, ..., 4 | xlab, ylab, main, 5 | drop.empty.ranges = FALSE, 6 | min.gapwidth = 1L, 7 | facets = NULL, 8 | geom = NULL){ 9 | 10 | 11 | data <- reduce(data, drop.empty.ranges = drop.empty.ranges, 12 | min.gapwidth = min.gapwidth) 13 | args <- list(...) 14 | args$facets <- facets 15 | args$geom <- geom 16 | args.aes <- parseArgsForAes(args) 17 | args.non <- parseArgsForNonAes(args) 18 | args.non$data <- data 19 | aes.res <- do.call(aes, args.aes) 20 | args.res <- c(list(aes.res), args.non) 21 | p <- list(do.call(stat_stepping, args.res)) 22 | 23 | labels <- Labels(xlab, ylab, main, fallback = c(x = "", y = "")) 24 | p <- c(p, labels) 25 | p <- setStat(p) 26 | p 27 | }) 28 | 29 | setMethod("stat_reduce", "IRanges", function(data, ..., 30 | xlab, ylab, main, 31 | drop.empty.ranges = FALSE, 32 | min.gapwidth = 1L, 33 | with.inframe.attrib=FALSE, 34 | facets = NULL, 35 | geom = NULL){ 36 | 37 | 38 | data <- reduce(data, drop.empty.ranges = drop.empty.ranges, 39 | min.gapwidth = min.gapwidth, 40 | with.inframe.attrib = with.inframe.attrib) 41 | df <- values(data) 42 | values(data) <- NULL 43 | data <- GRanges("chr_non", data) 44 | values(data) <- df 45 | 46 | args <- list(...) 47 | args$facets <- facets 48 | args$geom <- geom 49 | args.aes <- parseArgsForAes(args) 50 | args.non <- parseArgsForNonAes(args) 51 | args.non$data <- data 52 | aes.res <- do.call(aes, args.aes) 53 | args.res <- c(list(aes.res), args.non) 54 | p <- list(do.call(stat_stepping, args.res)) 55 | 56 | labels <- Labels(xlab, ylab, main, fallback = c(x = "Position", y = "")) 57 | p <- c(p, labels) 58 | p <- setStat(p) 59 | p 60 | }) 61 | 62 | 63 | setMethod("stat_reduce", "TxDbOREnsDb", function(data, ...){ 64 | p <- geom_alignment(data, ..., stat = "reduce") 65 | p <- setStat(p) 66 | p 67 | }) 68 | 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /NEWS: -------------------------------------------------------------------------------- 1 | CHANGES IN VERSION 1.19.1 2 | ------------------------- 3 | 4 | NEW FEATURES 5 | 6 | o autoplot method supports now EnsDb objects and related filter objects. 7 | 8 | 9 | 10 | CHANGES IN VERSION 1.5.16 11 | ------------------------ 12 | 13 | NEW FEATURES 14 | 15 | o ggplot generic method added. 16 | 17 | o mold generic method added for molding object to data.frame. 18 | 19 | o support ggplot(data) + stat_* style, original data being kept. 20 | 21 | o tracks function updated, API is enhenced, utilities could control attributes 22 | of plots and trakcs. 23 | 24 | o autoplot now support: VCF, SummarizedExperiments, matrix, where when genomic position is 25 | provided, options to visualize a heatmap sitting on the genomic position. 26 | 27 | o theme could define track based themes. 28 | 29 | o ideogram: support + xlim method, when embeded with tracks, automatically update zoomed region. 30 | 31 | o pheno.plot added to SuumarizedExperiemnts and ExpressionSet. 32 | 33 | 34 | SIGNIFICANT USER-LEVEL CHANGES 35 | 36 | o align.plots is deprecated, alignPlots created 37 | 38 | Notes 39 | 40 | o updated website for ggbio: 41 | http://tengfei.github.com/ggbio 42 | manuals and vignettes and paper added 43 | 44 | 45 | CHANGES IN VERSION 1.1.8 46 | ------------------------ 47 | 48 | NEW FEATURES 49 | 50 | o create lower level API and rewrite higher level API 51 | 52 | o new geom: geom_alignment, geom_chevron, geom_arch, geom_arrow, 53 | geom_arrowrect 54 | 55 | o redefined geom: geom_rect, geom_segment 56 | 57 | o new stat: stat_aggregate, stat_coverage, stat_mismatch, stat_gene, stat_table, 58 | stat_stepping 59 | 60 | o redefined stat: stat_identity 61 | 62 | o new layout: layout_circle, layout_karyogram 63 | 64 | o tracks function are more smart and with more accessors. 65 | 66 | o themes provided. 67 | 68 | o More supported object for autoplot: VCF, ExpressionSet, GenomicRangesList. 69 | 70 | SIGNIFICANT USER-LEVEL CHANGES 71 | 72 | o qplot changed to generic autoplot function. 73 | 74 | o argument use only "facets", no alias "facet_gr" or "facet" accepted. 75 | 76 | o plotMismatchSum will be replaced by stat_mismatch, or autoplot, BamFile. 77 | 78 | Notes 79 | 80 | o new website for ggbio: 81 | http://tengfei.github.com/ggbio 82 | hosting docs, tutorials and case study 83 | 84 | o pdf version vignette will not longer supported or just provide a short form. 85 | 86 | 87 | 88 | 89 | -------------------------------------------------------------------------------- /man/plotSingleChrom.Rd: -------------------------------------------------------------------------------- 1 | \name{Ideogram} 2 | \alias{Ideogram} 3 | \alias{Ideogram-class} 4 | \alias{plotIdeogram} 5 | \alias{+,Ideogram,ANY-method} 6 | \title{Plot single chromosome with cytobands} 7 | \usage{ 8 | 9 | plotIdeogram(obj, subchr = NULL, zoom.region = NULL, which = NULL, xlab, ylab, main, xlabel = 10 | FALSE, color = "red", fill = "red", alpha = 0.7, 11 | zoom.offset = 0.2, size = 1, 12 | cytobands = TRUE, aspect.ratio = 1/20, genome) 13 | 14 | ## constructor 15 | Ideogram(obj, subchr = NULL, which = NULL, xlabel = FALSE, 16 | cytobands = TRUE, color = "red", fill = "red", alpha = 17 | 0.7, zoom.region = NULL, zoom.offset = 0.2, size = 1, 18 | aspect.ratio = 1/20, ..., genome) 19 | } 20 | \description{ 21 | Plot single chromosome with cytobands. 22 | } 23 | \details{ 24 | User could provide the whole ideogram and use subchr to point to 25 | particular chromosome. 26 | } 27 | \value{ 28 | A \code{ggplot} object. 29 | } 30 | \author{Tengfei Yin} 31 | \arguments{ 32 | \item{obj}{ 33 | A \code{GenomicRanges} object, which include extra 34 | information about cytobands, check biovizBase::isIdeogram. 35 | } 36 | \item{subchr}{ 37 | A single character of chromosome names to show. 38 | } 39 | \item{which}{ 40 | \code{GRanges} object to subset and highlight the ideogram. 41 | } 42 | \item{zoom.region}{ 43 | A numeric vector of length 2 indicating zoomed region. 44 | } 45 | \item{xlab}{ 46 | Label for x 47 | } 48 | \item{ylab}{ 49 | Label for y 50 | } 51 | \item{main}{ 52 | Title for plot. 53 | } 54 | \item{xlabel}{ 55 | A logical value. Show the x label or not. 56 | } 57 | \item{color}{ 58 | color for highlight region. 59 | } 60 | \item{fill}{ 61 | fill color for highlight region. 62 | } 63 | \item{alpha}{ 64 | alpha for highlight regio. 65 | } 66 | \item{zoom.offset}{ 67 | zoomed highlights region offset around chromosome plotting region. 68 | } 69 | \item{size}{ 70 | size for zoomed region rectangle boundary. 71 | } 72 | \item{cytobands}{ 73 | If FALSE, plot just blank chromosome without cytobands. default is TRUE. 74 | es } 75 | \item{aspect.ratio}{ 76 | aspect ratio for the chromosome ideogram plot, default is NULL. 77 | } 78 | \item{genome}{ 79 | genome character passed to \code{\link{getIdeogram}} 80 | } 81 | \item{...}{ 82 | passed to ggbio constructor. 83 | } 84 | } 85 | \examples{ 86 | \dontrun{ 87 | library(biovizBase) 88 | p.ideo <- Ideogram(genome = "hg19") 89 | p.ideo 90 | library(GenomicRanges) 91 | p.ideo + xlim(GRanges("chr2", IRanges(1e8, 1e8+10000))) 92 | Ideogram(genome = "hg19", xlabel = TRUE) 93 | } 94 | } 95 | 96 | -------------------------------------------------------------------------------- /man/stat_stepping-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_stepping} 2 | \alias{stat_stepping} 3 | \alias{stat_stepping,missing-method} 4 | \alias{stat_stepping,uneval-method} 5 | \alias{stat_stepping,GRanges-method} 6 | \title{Calculate stepping levels} 7 | \description{ 8 | Calculate stepping levels. 9 | } 10 | \usage{ 11 | \S4method{stat_stepping}{GRanges}(data, ..., xlab, ylab, main, 12 | facets = NULL, 13 | geom = c("rect", "alignment", "segment")) 14 | } 15 | \arguments{ 16 | \item{data}{ 17 | A \code{GRanges} or \code{data.frame} object. 18 | } 19 | \item{...}{ 20 | Extra parameters such as aes() passed to \code{geom_rect}, 21 | \code{geom_alignment}, or \code{geom_segment}. 22 | } 23 | \item{xlab}{ 24 | Label for x 25 | } 26 | \item{ylab}{ 27 | Label for y 28 | } 29 | \item{main}{ 30 | Title for plot. 31 | } 32 | \item{facets}{ 33 | Faceting formula to use. 34 | } 35 | \item{geom}{ 36 | The geometric object used to display the data. For 'stepping', could 37 | be one of 'rect', 'alignment', 'segment'. 38 | } 39 | } 40 | \value{ 41 | A 'Layer'. 42 | } 43 | \examples{ 44 | 45 | set.seed(1) 46 | N <- 50 47 | 48 | require(GenomicRanges) 49 | ## simul 50 | ## ====================================================================== 51 | ## simmulated GRanges 52 | ## ====================================================================== 53 | gr <- GRanges(seqnames = 54 | sample(c("chr1", "chr2", "chr3"), 55 | size = N, replace = TRUE), 56 | IRanges( 57 | start = sample(1:300, size = N, replace = TRUE), 58 | width = sample(70:75, size = N,replace = TRUE)), 59 | strand = sample(c("+", "-", "*"), size = N, 60 | replace = TRUE), 61 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 62 | sample = sample(c("Normal", "Tumor"), 63 | size = N, replace = TRUE), 64 | pair = sample(letters, size = N, 65 | replace = TRUE)) 66 | 67 | ## default 68 | ggplot(gr) + stat_stepping() 69 | ## or 70 | ggplot() + stat_stepping(gr) 71 | 72 | ## facet_aes 73 | ggplot(gr) + stat_stepping(mapping = aes(color = strand, fill = strand), 74 | facets = sample ~ seqnames) 75 | 76 | ## geom_segment 77 | ggplot(gr) + stat_stepping(mapping = aes(color = strand), 78 | geom = "segment", xlab = "Genomic coord", ylab = "y", main = "hello") 79 | 80 | 81 | ## geom_alignment 82 | ## ggplot(gr) + stat_stepping(geom = "alignment") 83 | 84 | ## geom_alignment_group 85 | ## ggplot(gr) + stat_stepping(mapping = aes(group = pair),geom = "alignment") 86 | } 87 | \author{Tengfei Yin} 88 | 89 | -------------------------------------------------------------------------------- /R/stat_table-method.R: -------------------------------------------------------------------------------- 1 | ## ..score.. 2 | setGeneric("stat_table", function(data, ...) standardGeneric("stat_table")) 3 | 4 | setMethod("stat_table", "GRanges", function(data, ..., xlab, ylab, main, 5 | geom = NULL, stat = NULL){ 6 | 7 | args <- list(...) 8 | 9 | args.aes <- parseArgsForAes(args) 10 | args.non <- parseArgsForNonAes(args) 11 | 12 | if(length(data)){ 13 | tab <- table(paste(seqnames(data), start(data), end(data), strand(data), sep = ":")) 14 | key_mat <- matrix(unlist(strsplit(names(tab), ":", fixed=TRUE)), 4) 15 | gr <- GRanges(key_mat[1,], 16 | IRanges(as.integer(key_mat[2,]), as.integer(key_mat[3,])), 17 | key_mat[4,], score = as.integer(tab), 18 | seqlengths = seqlengths(data)) 19 | seqinfo(gr) <- seqinfo(data) 20 | args.non$data <- gr 21 | 22 | .ggbio.geom <- c("rect", "chevron", "alignment", "arrowrect", "arrow", "segment", "arch") 23 | .ggbio.stat <- c("identity", "coverage", "stepping", "aggregate") 24 | 25 | ## if(is.null(stat)){ 26 | ## } 27 | ## ------------------------------ 28 | ## geom/stat check 29 | ## ------------------------------ 30 | if(is.null(stat) & is.null(geom)){ 31 | stat <- "stepping" 32 | args.non$geom <- "rect" 33 | args.non$stat <- stat 34 | if(!"color" %in% names(args.aes) && !"colour" %in% names(args.aes)) 35 | args.aes$color <- args.aes$fill <- as.name("score") 36 | .fun <- stat_stepping 37 | }else{ 38 | .fun <- getDrawFunFromGeomStat(geom, stat) 39 | if(!is.null(geom)){ 40 | if(geom != "arch"){ 41 | if(is.null(stat)){ 42 | args.non$stat <- stat <- "identity" 43 | }else{ 44 | args.non$geom <- geom 45 | }}} 46 | } 47 | aes.res <- do.call(aes, args.aes) 48 | args.res <- c(args.non, list(aes.res)) 49 | p <- do.call(.fun, args.res) 50 | }else{ 51 | p <- NULL 52 | } 53 | 54 | labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 55 | p <- c(p, labels) 56 | p <- setStat(p) 57 | p 58 | }) 59 | 60 | 61 | setMethod("stat_table", "GRangesList", function(data, ..., 62 | xlab, ylab, main, 63 | facets = NULL, 64 | geom = NULL){ 65 | 66 | args <- list(...) 67 | 68 | args.aes <- parseArgsForAes(args) 69 | args.non <- parseArgsForNonAes(args) 70 | aes.res <- do.call(aes, args.aes) 71 | gr <- flatGrl(data) 72 | args.non$data <- gr 73 | p <- do.call(stat_table, c(list(aes.res), args.non)) 74 | labels <- Labels(xlab, ylab, main, fallback = 75 | c(x = "Genomic Coordinates", y = "Score")) 76 | p <- c(p, labels) 77 | p <- setStat(p) 78 | p 79 | }) 80 | -------------------------------------------------------------------------------- /tests/testthat/test_grob.R: -------------------------------------------------------------------------------- 1 | ## context("Test Grob Class") 2 | ## require(lattice) 3 | ## require(testthat) 4 | ## require(ggplot2) 5 | ## require(gridExtra) 6 | ## x = 1:3 7 | ## p1 <- qplot(x = mpg, y = wt, data = mtcars) 8 | ## p2 <- xyplot(1:10 ~ 1:10) 9 | ## require(ggbio) 10 | ## p3 <- GGbio(p1) 11 | ## p <- plot(1:10, 1:10) 12 | ## test_that("test grob", { 13 | ## expect_that(p1, is_a("gg")) 14 | ## expect_that(p2, is_a("trellis")) 15 | ## expect_that(x, is_a("integer")) 16 | ## expect_that(Grob(p1), is_a("Grob")) 17 | ## expect_that(Grob(p1), is_a("ggplotGrob")) 18 | ## expect_that(Grob(p2), is_a("Grob")) 19 | ## expect_that(Grob(p2), is_a("latticeGrob")) 20 | ## expect_that(Grob(p3), is_a("Grob")) 21 | ## expect_that(Grob(p3), is_a("ggplotGrob")) 22 | ## expect_that(Grob(p), throws_error()) 23 | ## expect_that(GrobList(p1, p2), is_a("GrobList")) 24 | ## expect_that(GrobList(p1, p2, x), gives_warning()) 25 | ## expect_that(length(GrobList(p1, p2, x)), equals(2)) 26 | ## }) 27 | 28 | 29 | ## context("Test Tracked Object") 30 | ## test_that("Test Tracked", { 31 | ## obj <- new("Tracked") 32 | ## height(obj) <- 1 33 | ## expect_that(obj, is_a("Tracked")) 34 | ## expect_that(height(obj), is_a("unit")) 35 | ## expect_that(mutable(obj), is_a("logical")) 36 | ## expect_that(fixed(obj), is_a("logical")) 37 | ## expect_that(bgColor(obj), is_a("character")) 38 | ## expect_that(labeled(obj), is_a("logical")) 39 | ## expect_that(hasAxis(obj), is_a("logical")) 40 | ## }) 41 | 42 | ## context("Test Cache Class") 43 | ## test_that("Test Cache Class", { 44 | ## obj <- new("Cache") 45 | ## expect_that(obj, is_a("Cache")) 46 | ## expect_that(Cache(), is_a("Cache")) 47 | ## cached_xlim(obj) <- 1 48 | ## expect_that(cached_xlim(obj), equals(c(1, 1))) 49 | ## cached_xlim(obj) <- c(1, 2, 3) 50 | ## expect_that(cached_xlim(obj), equals(c(1, 3))) 51 | 52 | ## cached_ylim(obj) <- 1 53 | ## expect_that(cached_ylim(obj), equals(c(1, 1))) 54 | ## cached_ylim(obj) <- c(1, 2, 3) 55 | ## expect_that(cached_ylim(obj), equals(c(1, 3))) 56 | ## }) 57 | 58 | ## context("Test Plot Class") 59 | ## test_that("test Plot", { 60 | ## expect_that(Plot(p1), is_a("Plot")) 61 | ## expect_that(Plot(p2), is_a("Plot")) 62 | ## expect_that(PlotList(p1, p2), is_a("PlotList")) 63 | ## expect_that(PlotList(p1, p2, x), gives_warning()) 64 | ## expect_that(length(PlotList(p1, p2, x)), equals(2)) 65 | ## }) 66 | 67 | 68 | ## context("Test GGbio Class") 69 | ## test_that("test Plot", { 70 | ## expect_that(Plot(p1), is_a("Plot")) 71 | ## expect_that(Plot(p2), is_a("Plot")) 72 | ## expect_that(Plot(p3), is_a("Plot")) 73 | ## expect_that(PlotList(p1, p2, p3), is_a("PlotList")) 74 | ## expect_that(PlotList(p1, p2, p3, x), gives_warning()) 75 | ## expect_that(length(PlotList(p1, p2, p3, x)), equals(3)) 76 | ## }) 77 | 78 | 79 | -------------------------------------------------------------------------------- /man/plotFragLength.Rd: -------------------------------------------------------------------------------- 1 | \name{plotFragLength} 2 | \alias{plotFragLength} 3 | \alias{plotFragLength,character,GRanges-method} 4 | \title{Plot estimated fragment length for paired-end RNA-seq data} 5 | \description{ 6 | Plot estimated fragment length for paired-end RNA-seq data against 7 | single reduced data model. 8 | } 9 | \usage{ 10 | \S4method{plotFragLength}{character,GRanges}(data, model, 11 | gap.ratio = 0.0025, 12 | geom = c("segment", "point", "line"), 13 | type = c("normal", "cut"), 14 | heights = c(400, 100), 15 | annotation = TRUE) 16 | } 17 | \arguments{ 18 | \item{data}{ 19 | A character indicate the bam file. 20 | } 21 | \item{model}{ 22 | A reduced model to compute estimated fragment length. please see 23 | details. 24 | } 25 | \item{gap.ratio}{ 26 | When type is set to "cut", it will provide a compact view, which cut 27 | the common gaps in a certain ratio. 28 | } 29 | \item{geom}{ 30 | One or all three geoms could be drawn at the same time. y value of 31 | "point" and "line" indicate the estimated fragment length. and if 32 | geom is set to "segment", the segment is from the left most position 33 | to paired right most position, should be equal to "isize". 34 | } 35 | \item{type}{ 36 | "normal" return a uncut view, loose but the coordinate is true 37 | genomic coordinates. "cut" cut the view in a compact way. 38 | } 39 | \item{heights}{ 40 | Numeric vector indicate the heights of tracks. 41 | } 42 | \item{annotation}{ 43 | A logical value. TRUE shows model, and FALSE shows only fragment 44 | length with labels. 45 | } 46 | } 47 | \value{ 48 | A ggplot object when \code{annotation = FALSE} and a frame grob if 49 | \code{annotation = TRUE} 50 | } 51 | \details{ 52 | We use a easy way to define this estimated fragment length, we 53 | collect all paired reads and model, reduce model first, then find 54 | common gaps, remove common gaps between paired-end reads, and compute 55 | the new estimated fragment length. 56 | } 57 | \examples{ 58 | \dontrun{ 59 | data(genesymbol) 60 | bamfile <- system.file("extdata", "SRR027894subRBM17.bam", package="biovizBase") 61 | library(TxDb.Hsapiens.UCSC.hg19.knownGene) 62 | txdb <- TxDb.Hsapiens.UCSC.hg19.knownGene 63 | model <- exonsBy(txdb, by = "tx") 64 | model.new <- subsetByOverlaps(model, genesymbol["RBM17"]) 65 | exons.rbm17 <- subsetByOverlaps(exons(txdb), genesymbol["RBM17"]) 66 | exons.new <- reduce(exons.rbm17) 67 | plotFragLength(bamfile, exons.new, geom = "line") 68 | plotFragLength(bamfile, exons.new, geom = c("point","segment")) 69 | plotFragLength(bamfile, exons.new, geom = c("point","segment"), annotation = FALSE) 70 | plotFragLength(bamfile, exons.new, geom = c("point","segment"), type = "cut", 71 | gap.ratio = 0.001) 72 | } 73 | } 74 | \author{Tengfei Yin} 75 | 76 | -------------------------------------------------------------------------------- /man/stat_reduce-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_reduce} 2 | \alias{stat_reduce} 3 | \alias{stat_reduce,missing-method} 4 | \alias{stat_reduce,uneval-method} 5 | \alias{stat_reduce,GRanges-method} 6 | \alias{stat_reduce,IRanges-method} 7 | \alias{stat_reduce,TxDbOREnsDb-method} 8 | \title{Reduce an object.} 9 | \description{ 10 | Reduce \code{GRanges}, \code{IRanges} or \code{TxDb} object. 11 | } 12 | \usage{ 13 | \S4method{stat_reduce}{GRanges}(data, ..., 14 | xlab, ylab, main, 15 | drop.empty.ranges = FALSE, 16 | min.gapwidth = 1L, 17 | facets = NULL, geom = NULL) 18 | 19 | \S4method{stat_reduce}{IRanges}(data, ..., 20 | xlab, ylab, main, 21 | drop.empty.ranges = FALSE, 22 | min.gapwidth = 1L, 23 | with.inframe.attrib=FALSE, 24 | facets = NULL, geom = NULL) 25 | 26 | \S4method{stat_reduce}{TxDbOREnsDb}(data, ...) 27 | } 28 | \arguments{ 29 | \item{data}{ 30 | \code{GRanges}, \code{IRanges} or \code{TxDb} object. 31 | } 32 | \item{...}{ 33 | passed to aesthetics mapping. 34 | } 35 | \item{xlab}{ 36 | x label. 37 | } 38 | \item{ylab}{ 39 | y label. 40 | } 41 | \item{main}{ 42 | title. 43 | } 44 | \item{drop.empty.ranges}{ 45 | pass to \code{\link[IRanges]{reduce}} function. 46 | } 47 | \item{min.gapwidth}{ 48 | pass to \code{\link[IRanges]{reduce}} function. 49 | } 50 | \item{with.inframe.attrib}{ 51 | pass to \code{\link[IRanges]{reduce}} function. 52 | } 53 | \item{facets}{ 54 | pass to \code{\link[IRanges]{reduce}} function. 55 | } 56 | \item{geom}{ 57 | geometric type. 58 | } 59 | } 60 | \value{ 61 | a ggplot object. 62 | } 63 | \seealso{ 64 | \code{\link[IRanges]{reduce}}. 65 | } 66 | \examples{ 67 | set.seed(1) 68 | N <- 1000 69 | library(GenomicRanges) 70 | 71 | gr <- GRanges(seqnames = 72 | sample(c("chr1", "chr2", "chr3"), 73 | size = N, replace = TRUE), 74 | IRanges( 75 | start = sample(1:300, size = N, replace = TRUE), 76 | width = sample(70:75, size = N,replace = TRUE)), 77 | strand = sample(c("+", "-", "*"), size = N, 78 | replace = TRUE), 79 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 80 | sample = sample(c("Normal", "Tumor"), 81 | size = N, replace = TRUE), 82 | pair = sample(letters, size = N, 83 | replace = TRUE)) 84 | 85 | ggplot(gr) + stat_reduce() 86 | autoplot(gr, stat = "reduce") 87 | strand(gr) <- "*" 88 | ggplot(gr) + stat_reduce() 89 | 90 | library(TxDb.Hsapiens.UCSC.hg19.knownGene) 91 | data(genesymbol, package = "biovizBase") 92 | txdb <- TxDb.Hsapiens.UCSC.hg19.knownGene 93 | ## made a track comparing full/reduce stat. 94 | ggplot(txdb) + stat_reduce(which = genesymbol["RBM17"]) 95 | 96 | } 97 | \author{Tengfei Yin} 98 | 99 | -------------------------------------------------------------------------------- /man/theme.Rd: -------------------------------------------------------------------------------- 1 | \name{theme} 2 | \alias{theme_null} 3 | \alias{theme_noexpand} 4 | \alias{theme_pack_panels} 5 | \alias{theme_alignment} 6 | \alias{theme_clear} 7 | \alias{theme_tracks_sunset} 8 | \alias{theme_genome} 9 | \title{theme in ggbio} 10 | \description{ 11 | Theme defined in ggbio for plot or tracks. 12 | } 13 | \details{Themes speciall designed for tracks, are named following naming 14 | schema theme_tracks_*} 15 | \usage{ 16 | theme_null() 17 | theme_noexpand() 18 | theme_alignment(ylabel = FALSE, base_size = 12, base_family = "", 19 | axis = TRUE, border = TRUE, grid = TRUE) 20 | theme_pack_panels(strip.bg = FALSE, strip.text.y = TRUE) 21 | theme_clear(grid.y = FALSE, grid.x.minor = FALSE, grid.x.major = FALSE, 22 | panel.background.fill = "white", panel.border.color = NA, 23 | axis.ticks.x = FALSE, axis.ticks.y = TRUE, grid.color = "gray95", 24 | axis.line.color = "gray80") 25 | theme_tracks_sunset(bg = "#fffedb", alpha = 1, ...) 26 | theme_genome() 27 | } 28 | \arguments{ 29 | 30 | \item{alpha}{ 31 | alpha blending from 0(transparent) to 1(solid). 32 | } 33 | \item{axis}{ 34 | logical value, show axis or not. 35 | } 36 | 37 | \item{axis.line.color}{ 38 | color for axis line . 39 | } 40 | \item{axis.ticks.x}{ 41 | show x ticks or not. 42 | } 43 | \item{axis.ticks.y}{ 44 | show y ticks or not. 45 | } 46 | \item{base_family}{ 47 | family for font. 48 | } 49 | 50 | \item{base_size}{ 51 | size for font. 52 | } 53 | 54 | \item{bg}{ 55 | background color for tracks. 56 | } 57 | 58 | \item{border}{ 59 | logical value, show border or not. 60 | } 61 | \item{grid}{ 62 | logical value, show background grid or not. 63 | } 64 | \item{grid.color}{ 65 | grid line color. 66 | } 67 | \item{grid.x.major}{ 68 | show x major grid line or not. 69 | } 70 | \item{grid.x.minor}{ 71 | show x minor grid line or not. 72 | } 73 | \item{grid.y}{ 74 | show y grid or not. 75 | } 76 | \item{panel.background.fill}{ 77 | panel background fill color. 78 | } 79 | \item{panel.border.color}{ 80 | panel border color. 81 | } 82 | \item{strip.bg}{ 83 | if strip background is removed. 84 | } 85 | \item{strip.text.y}{ 86 | if strip text is removed. 87 | } 88 | \item{ylabel}{ 89 | logical value. Show labels or not. 90 | } 91 | \item{...}{ 92 | passed to \code{theme_clear}. 93 | } 94 | } 95 | \value{ 96 | Return a theme. 97 | } 98 | \examples{ 99 | ## load 100 | library(ggbio) 101 | p <- qplot(data = mtcars, x = mpg, y = wt, facets = cyl ~ .) 102 | p + theme_null() 103 | p + theme_clear() 104 | p + theme_pack_panels() 105 | p + theme_alignment() 106 | p1 <- qplot(data = mtcars, x = mpg, y = wt) 107 | tracks(p1 = p, p2 = p1) 108 | tracks(p1 = p, p2 = p1) + theme_tracks_sunset() 109 | } 110 | \author{Tengfei Yin} 111 | 112 | -------------------------------------------------------------------------------- /R/geom_segment-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("geom_segment", function(data, ...) standardGeneric("geom_segment")) 2 | 3 | setMethod("geom_segment", "ANY", function(data, ...){ 4 | ggplot2::geom_segment(data = data, ...) 5 | }) 6 | 7 | setMethod("geom_segment", "GRanges", function(data,..., xlab, ylab, main, 8 | facets = NULL, 9 | stat = c("stepping", "identity"), 10 | group.selfish = TRUE){ 11 | 12 | args <- list(...) 13 | args$facets <- facets 14 | args.aes <- parseArgsForAes(args) 15 | args.non <- parseArgsForNonAes(args) 16 | args.non <- remove_args(args.non, "facets") 17 | facet <- build_facet(data, args) 18 | 19 | stat <- match.arg(stat) 20 | es <- ifelse("extend.size" %in% names(args.non), args.non$extend.size, 0) 21 | if(length(data)){ 22 | if(stat == "stepping"){ 23 | grl <- splitByFacets(data, facets) 24 | res <- endoapply(grl, make_addStepping, args.aes, group.selfish, extend.size = es) 25 | df <- mold(unlist(res)) 26 | 27 | args.aes <- remove_args(args.aes, c("x", "xend", "y", "yend", "data")) 28 | args.non <- remove_args(args.non, c("x", "xend", "yend", "yend", "data")) 29 | gpn <- ifelse("group" %in% names(args), quo_name(args$group), "stepping") 30 | args.aes <- remove_args(args.aes, "group") 31 | args.aes <- c(args.aes, list(x = substitute(start), 32 | xend = substitute(end), 33 | y = substitute(stepping), 34 | yend = substitute(stepping))) 35 | 36 | args.aes <- remove_args(args.aes, c("size", "fill")) 37 | aes.res <- do.call(aes, args.aes) 38 | args.res <- c(list(data = df), list(aes.res), args.non) 39 | p <- list(do.call(ggplot2::geom_segment,args.res)) 40 | p <- .changeStrandColor(p, args.aes) 41 | .df.sub <- group_df(df, gpn) 42 | y_scale <- scale_y_continuous_by_group(.df.sub, gpn, group.selfish) 43 | p <- c(p, y_scale) 44 | } 45 | 46 | if(stat == "identity"){ 47 | if(!"y" %in% names(args.aes)){ 48 | if(!all(c("y","yend", "x", "xend") %in% names(args.aes))){ 49 | stop("aes(x =, xend= , y =, yend= ) is required for stat 'identity', 50 | you could also specify aes(y =) only as alternative") 51 | } 52 | }else{ 53 | .y <- args.aes$y 54 | args.aes$x <- as.name("start") 55 | args.aes$xend <- as.name("end") 56 | args.aes$y <- args.aes$yend <- .y 57 | } 58 | df <- mold(data) 59 | args.aes <- remove_args(args.aes, c("group", "size", "fill")) 60 | 61 | aes.res <- do.call(aes, args.aes) 62 | args.res <- c(list(data = df), list(aes.res),args.non) 63 | p <- list(do.call(ggplot2::geom_segment,args.res)) 64 | p <- .changeStrandColor(p, args.aes) 65 | } 66 | }else{ 67 | p <- NULL 68 | } 69 | p <- c(list(p) , list(facet)) 70 | labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 71 | p <- c(p, labels) 72 | p 73 | }) 74 | -------------------------------------------------------------------------------- /R/stat_identity-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("stat_identity", function(data, ...) standardGeneric("stat_identity")) 2 | 3 | setMethod("stat_identity", "ANY", function(data, ...){ 4 | ggplot2::stat_identity(data = data, ...) 5 | }) 6 | 7 | setMethod("stat_identity", "GRanges", function(data, ..., geom = NULL){ 8 | args <- list(...) 9 | gr.geoms <- c("chevron", "arrow", "arrowrect", "segment", "rect", "alignment") 10 | args.facets <- subsetArgsByFormals(args, facet_grid, facet_wrap) 11 | facet <- .buildFacetsFromArgs(data, args.facets) 12 | if(is.null(geom)) 13 | geom <- "segment" 14 | if(!geom %in% gr.geoms){ 15 | args$geom <- geom 16 | data <- mold(data) 17 | args$data <- data 18 | p <- do.call(ggplot2::stat_identity, args) 19 | }else{ 20 | .geom.fun <- getGeomFun(geom) 21 | args$stat <- "identity" 22 | args$data <- data 23 | p <- do.call(.geom.fun, args) 24 | } 25 | p <- c(list(p), list(facet)) 26 | p <- setStat(p) 27 | p 28 | }) 29 | 30 | 31 | setMethod("stat_identity", "Rle", function(data, ..., 32 | xlab, ylab, main, geom = NULL){ 33 | args <- list(...) 34 | args.aes <- parseArgsForAes(args) 35 | args.non <- parseArgsForNonAes(args) 36 | if(is.null(geom)) 37 | geom <- "line" 38 | x <- 1:length(data) 39 | y <- as.numeric(data) 40 | df <- data.frame(x = x, y = y) 41 | args.non$geom <- geom 42 | args.non$data <- df 43 | args.aes <- list(x = substitute(x), 44 | y = substitute(y)) 45 | p <- do.call(ggplot2::stat_identity, c(args.non, list(do.call(aes, args.aes)))) 46 | labels <- Labels(xlab, ylab, main, fallback = c(x = "x", y = "y")) 47 | p <- c(p, labels) 48 | p <- setStat(p) 49 | p 50 | }) 51 | 52 | 53 | setMethod("stat_identity", "RleList", function(data, ..., 54 | xlab, ylab, main, 55 | geom = NULL, indName = "sample"){ 56 | args <- list(...) 57 | args.aes <- parseArgsForAes(args) 58 | args.non <- parseArgsForNonAes(args) 59 | if(is.null(geom)) 60 | geom <- "line" 61 | 62 | x <- do.call(c,lapply(elementNROWS(data),function(n) 1:n)) 63 | y <- as.numeric(unlist(data)) 64 | if(is.null(names(data))) 65 | nms <- rep(1:length(data), times = elementNROWS(data)) 66 | else 67 | nms <- rep(names(data), times = elementNROWS(data)) 68 | 69 | df <- data.frame(x = x, y = y, z = nms) 70 | colnames(df) <- c("x", "y", indName) 71 | 72 | facets <- as.formula(paste(indName, "~ .", sep = "")) 73 | facet <- facet_grid(facets) 74 | 75 | args.non$geom <- geom 76 | args.non$data <- df 77 | 78 | args.aes <- list(x = substitute(x), 79 | y = substitute(y)) 80 | p <- do.call(ggplot2::stat_identity, c(args.non, list(do.call(aes, args.aes)))) 81 | 82 | labels <- Labels(xlab, ylab, main, fallback = c(x = "x", y = "y")) 83 | p <- c(p, labels) 84 | 85 | p <- c(list(p), list(facet)) 86 | p <- setStat(p) 87 | p 88 | }) 89 | 90 | 91 | -------------------------------------------------------------------------------- /man/stat_bin-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_bin} 2 | \alias{stat_bin} 3 | \alias{stat_bin,missing-method} 4 | \alias{stat_bin,uneval-method} 5 | \alias{stat_bin,ANY-method} 6 | \alias{stat_bin,Rle-method} 7 | \alias{stat_bin,RleList-method} 8 | \title{Binning method} 9 | \description{ 10 | Binning method especially for \code{Rle} and \code{RleList}, for 11 | \code{data.frame} it's just calling \code{ggplot2::stat_bin}. 12 | } 13 | \usage{ 14 | \S4method{stat_bin}{ANY}(data, ...) 15 | 16 | \S4method{stat_bin}{Rle}(data, ..., binwidth, nbin = 30, 17 | xlab, ylab, main, geom = c("bar", "heatmap"), 18 | type = c("viewSums","viewMins", 19 | "viewMaxs", "viewMeans")) 20 | \S4method{stat_bin}{RleList}(data, ..., binwidth, nbin = 30, 21 | xlab, ylab, main, 22 | indName = "sample", 23 | geom = c("bar", "heatmap"), 24 | type = c("viewSums","viewMins", 25 | "viewMaxs", "viewMeans")) 26 | } 27 | \arguments{ 28 | \item{data}{ 29 | Typically a \code{data.frame} or \code{Rle} or \code{RleList} object. 30 | } 31 | \item{...}{ 32 | arguments passed to aesthetics mapping. 33 | } 34 | \item{binwidth}{ 35 | width of the bins. 36 | } 37 | \item{nbin}{ 38 | number of bins. 39 | } 40 | \item{xlab}{ 41 | x label. 42 | } 43 | \item{ylab}{ 44 | y label. 45 | } 46 | \item{main}{ 47 | title. 48 | } 49 | \item{indName}{ 50 | when faceted by a \code{RleList}, name used for labeling faceted 51 | factor. Default is 'sample'. 52 | } 53 | \item{geom}{ 54 | geometric types. 55 | } 56 | \item{type}{ 57 | statistical summary method used within bins, shown as bar height or 58 | heatmap colors. 59 | } 60 | } 61 | \value{ 62 | a ggplot object. 63 | } 64 | \examples{ 65 | library(IRanges) 66 | lambda <- c(rep(0.001, 4500), seq(0.001, 10, length = 500), 67 | seq(10, 0.001, length = 500)) 68 | xVector <- rpois(1e4, lambda) 69 | xRle <- Rle(xVector) 70 | xRleList <- RleList(xRle, 2L * xRle) 71 | 72 | ggplot() + stat_bin(xRle) 73 | ggplot(xRle) + stat_bin() 74 | ggplot(xRle) + stat_bin(nbin = 100) 75 | ggplot(xRle) + stat_bin(binwidth = 200) 76 | 77 | p1 <- ggplot(xRle) + stat_bin(type = "viewMeans") 78 | p2 <- ggplot(xRle) + stat_bin(type = "viewSums") 79 | ## y scale are different. 80 | tracks(viewMeans = p1, viewSums = p2) 81 | 82 | ggplot(xRle) + stat_bin(geom = "heatmap") 83 | ggplot(xRle) + stat_bin(nbin = 100, geom = "heatmap") 84 | ggplot(xRle) + stat_bin(binwidth = 200, geom = "heatmap") 85 | 86 | ## for RleList 87 | ggplot(xRleList) + stat_bin() 88 | ggplot(xRleList) + stat_bin(nbin = 100) 89 | ggplot(xRleList) + stat_bin(binwidth = 200) 90 | 91 | p1 <- ggplot(xRleList) + stat_bin(type = "viewMeans") 92 | p2 <- ggplot(xRleList) + stat_bin(type = "viewSums") 93 | ## y scale are different. 94 | tracks(viewMeans = p1, viewSums = p2) 95 | 96 | ggplot(xRleList) + stat_bin(geom = "heatmap") 97 | ggplot(xRleList) + stat_bin(nbin = 100, geom = "heatmap") 98 | ggplot(xRleList) + stat_bin(binwidth = 200, geom = "heatmap") 99 | } 100 | \author{Tengfei Yin} 101 | 102 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: ggbio 2 | Version: 1.57.1 3 | Title: Visualization tools for genomic data 4 | Description: The ggbio package extends and specializes the grammar of 5 | graphics for biological data. The graphics are designed to 6 | answer common scientific questions, in particular those often 7 | asked of high throughput genomics data. All core Bioconductor 8 | data structures are supported, where appropriate. The package 9 | supports detailed views of particular genomic regions, as well 10 | as genome-wide overviews. Supported overviews include ideograms 11 | and grand linear views. High-level plots include sequence 12 | fragment length, edge-linked interval to data view, mismatch 13 | pileup, and several splicing summaries. 14 | Authors@R: c(person("Tengfei", "Yin", role=c("aut"), 15 | email="yintengfei@gmail.com"), 16 | person("Michael", "Lawrence", role=c("aut", "ths", "cre"), 17 | email="lawremi@gmail.com"), 18 | person("Dianne", "Cook", role=c("aut", "ths")), 19 | person("Johannes", "Rainer", role="ctb")) 20 | Depends: methods, BiocGenerics, ggplot2 (>= 1.0.0) 21 | Imports: grid, grDevices, graphics, stats, utils, gridExtra, scales, reshape2, 22 | gtable, Hmisc, biovizBase (>= 1.29.2), Biobase, S4Vectors (>= 0.13.13), 23 | IRanges (>= 2.11.16), Seqinfo, GenomeInfoDb (>= 1.45.5), 24 | GenomicRanges (>= 1.61.1), SummarizedExperiment (>= 1.39.1), 25 | Biostrings (>= 2.77.2), Rsamtools (>= 2.25.1), 26 | GenomicAlignments (>= 1.45.1), BSgenome (>= 1.77.1), 27 | VariantAnnotation (>= 1.55.1), rtracklayer (>= 1.69.1), 28 | GenomicFeatures (>= 1.61.4), OrganismDbi, 29 | ensembldb (>= 2.33.1), AnnotationDbi, AnnotationFilter, rlang 30 | VignetteBuilder: knitr 31 | Suggests: vsn, BSgenome.Hsapiens.UCSC.hg19, Homo.sapiens, 32 | TxDb.Hsapiens.UCSC.hg19.knownGene, 33 | TxDb.Mmusculus.UCSC.mm9.knownGene, knitr, BiocStyle, testthat, 34 | EnsDb.Hsapiens.v75, tinytex 35 | URL: https://lawremi.github.io/ggbio/ 36 | BugReports: https://github.com/lawremi/ggbio/issues 37 | License: Artistic-2.0 38 | LazyLoad: Yes 39 | Collate: AllClasses.R AllGenerics.R Cache-class.R GGbio-class.R 40 | Grob-class.R ideogram.R Tracked-class.R Plot-class.R 41 | ggplot-method.R theme.R Tracks-class.R 42 | geom_chevron-method.R geom_alignment-method.R 43 | geom_arch-method.R geom_arrow-method.R geom_arrowrect-method.R 44 | geom_rect-method.R geom_segment-method.R geom_bar-method.R 45 | layout_circle-method.R layout_karyogram-method.R 46 | layout_linear-method.R stat_aggregate-method.R 47 | stat_coverage-method.R stat_identity-method.R 48 | stat_mismatch-method.R stat_stepping-method.R 49 | stat_gene-method.R stat_table-method.R stat_bin-method.R 50 | stat_slice-method.R stat_reduce-method.R coord_genome-method.R 51 | autoplot-method.R hack.R 52 | plotGrandLinear.R plotRangesLinkedToData.R 53 | plotFragLength-method.R plotSpliceSum-method.R rescale-method.R 54 | scales.R utils.R zzz.R 55 | biocViews: Infrastructure, Visualization 56 | -------------------------------------------------------------------------------- /man/plotSpliceSum.Rd: -------------------------------------------------------------------------------- 1 | \name{plotSpliceSum} 2 | \alias{plotSpliceSum} 3 | \alias{plotSpliceSum,character,GRangesList-method} 4 | \alias{plotSpliceSum,character,TxDb-method} 5 | \alias{plotSpliceSum,character,EnsDb-method} 6 | \title{Plot Splice Summary from RNA-seq data} 7 | \description{ 8 | Plot splice summary by simply counting overlaped junction read in 9 | weighted way or not. 10 | } 11 | \usage{ 12 | ## For character,GRangesList 13 | \S4method{plotSpliceSum}{character,GRangesList}(data, model, ..., weighted = TRUE) 14 | ## For character,TxDb 15 | \S4method{plotSpliceSum}{character,TxDb}(data, model, which, 16 | ..., weighted = TRUE) 17 | ## For character,EnsDb 18 | \S4method{plotSpliceSum}{character,EnsDb}(data, model, which, 19 | ..., weighted = TRUE) 20 | } 21 | \arguments{ 22 | \item{data}{ 23 | A character specifying the bam file path of RNA-seq data. 24 | } 25 | \item{model}{ 26 | A GRangesList which represting different isoforms, a TxDb or an 27 | \code{\link[ensembldb]{EnsDb}} object. For the latter cases, users 28 | need to pass "which" argument which, for TxDb, is a GRanges object 29 | to specify the region and for \code{EnsDb} can be a GRanges object, 30 | an object extending 31 | \code{\link[AnnotationFilter]{AnnotationFilter}}, an 32 | \code{\link[AnnotationFilter]{AnnotationFilterList}} combining such 33 | filter objects or a filter expression in form of a \code{formula}. 34 | } 35 | \item{which}{ 36 | A GRanges object specifying the region you want to get model from 37 | the TxDb object. 38 | For \code{\link[ensembldb]{EnsDb}}: can be a GRanges object, an 39 | object extending \code{\link[AnnotationFilter]{AnnotationFilter}}, an 40 | \code{\link[AnnotationFilter]{AnnotationFilterList}} combining such 41 | filter objects or a filter expression in form of a \code{formula}. 42 | } 43 | \item{weighted}{ 44 | If \code{TRUE}, weighted by simply add 1/cases matched to each model 45 | and if \code{FALSE}, simply add 1 to every case. 46 | } 47 | \item{...}{ 48 | Extra arugments passed to \code{qplot} function. such as, 49 | \code{offset} which control the height of chevron. 50 | } 51 | } 52 | \value{ 53 | A ggplot object. 54 | } 55 | \details{ 56 | Internally we use biovizBase:::spliceSummary for simple counting, but 57 | we encourage users to use their own robust way to make slicing summary 58 | and store it as GRangesList, then plot the summary by \code{qplot} 59 | function. 60 | } 61 | \seealso{ 62 | \code{\link{qplot}} 63 | } 64 | \examples{ 65 | \dontrun{ 66 | bamfile <- system.file("extdata", "SRR027894subRBM17.bam", package="biovizBase") 67 | library(TxDb.Hsapiens.UCSC.hg19.knownGene) 68 | txdb <- TxDb.Hsapiens.UCSC.hg19.knownGene 69 | data(genesymbol) 70 | exons <- exonsBy(txdb, by = "tx") 71 | exons.rbm17 <- subsetByOverlaps(exons, genesymbol["RBM17"]) 72 | plotSpliceSum(bamfile, exons.rbm17) 73 | plotSpliceSum(bamfile, exons.rbm17, weighted = FALSE, offset = 0.01) 74 | plotSpliceSum(bamfile, txdb, which = genesymbol["RBM17"]) 75 | plotSpliceSum(bamfile, txdb, which = genesymbol["RBM17"], offset = 0.01) 76 | plotSpliceSum(bamfile, txdb, which = genesymbol["RBM17"], 77 | show.label = TRUE, 78 | label.type = "count") 79 | } 80 | } 81 | \author{Tengfei Yin} 82 | -------------------------------------------------------------------------------- /R/plotFragLength-method.R: -------------------------------------------------------------------------------- 1 | ## default show y axis of the first track and hide others 2 | setMethod("plotFragLength", c("character", "GRanges"), 3 | function(data, model, 4 | gap.ratio = 0.0025, 5 | geom = c("segment", "point", "line"), 6 | type = c("normal", "cut"), 7 | heights = c(400, 100), 8 | annotation = TRUE){ 9 | ## default show it, but only keep first one 10 | show.axis.text.y <- FALSE 11 | ## geom <- match.arg(geom) 12 | type <- match.arg(type) 13 | message("Compute fragment length...") 14 | lst <- biovizBase:::getFragLength(data, model) 15 | message("Plotting...") 16 | gr.fraglength <- lst$gr 17 | if(type == "cut"){ 18 | frag <- lst$fragLength 19 | reads <- lst$reads # combinded paried reads 20 | g.gap <- gaps(c(ranges(reads), ranges(model))) 21 | chr <- unique(as.character(seqnames(model))) 22 | cut.fun <- shrinkageFun(g.gap, maxGap(GRanges(chr, g.gap), gap.ratio)) 23 | reads.cut <- cut.fun(reads) 24 | grl <- split(reads.cut, values(reads.cut)$mapid) 25 | grl.r <- range(grl) 26 | gr.res <- unlist(grl.r) 27 | names(gr.res) <- names(grl) 28 | values(gr.res)$.fragLength <- frag[names(gr.res)] 29 | gr.fraglength <- gr.res 30 | model <- cut.fun(model) 31 | } 32 | ## since model is always there 33 | ## so make sure it's overlaped 34 | gr.fraglength <- keepSeqlevels(gr.fraglength, 35 | unique(as.character(seqnames(gr.fraglength)))) 36 | gr.fraglength <- subsetByOverlaps(gr.fraglength, range(model), type = "within") 37 | if(is(model, "GRanges")) 38 | model <- GRangesList(model) 39 | names(model) <- "1" 40 | p.exon <- autoplot(model) + ylab(" ") + theme_bw() +theme(panel.grid.minor=element_blank(), 41 | panel.grid.major=element_blank()) 42 | ## scale_y_continuous(breaks = c(0), 43 | ## labels = " x") 44 | ## theme(axis.text.y = element_blank()) 45 | 46 | df <- as.data.frame(gr.fraglength) 47 | p <- ggplot(df) 48 | if("segment" %in% geom){ 49 | p <- p + geom_segment(aes(x = start, 50 | y = .fragLength, 51 | xend = end, 52 | yend = .fragLength), color = "gray") 53 | 54 | if(annotation) 55 | p <- p + theme(panel.grid.minor=element_blank()) + theme_bw() 56 | } 57 | if("point" %in% geom){ 58 | p <- p + geom_point(aes(x = (start + end)/2, y = .fragLength), size = 1.2, 59 | color = "gray30") + theme_bw() 60 | if(annotation) 61 | p <- p + theme(panel.grid.minor=element_blank()) 62 | } 63 | if("line" %in% geom){ 64 | p <- p + geom_line(aes(x = (start + end)/2, y = .fragLength), 65 | linewidth = 1.2, 66 | color = "gray30") + theme_bw() 67 | if(annotation) 68 | p <- p + theme(panel.grid.minor=element_blank()) 69 | } 70 | p <- p + ylab("Estimated Fragmeng Length") 71 | if(annotation) 72 | tracks(p, p.exon, heights = heights, show.axis.text.y = show.axis.text.y) 73 | else{ 74 | p <- p + xlab("Genomic Coordinates") 75 | p 76 | } 77 | }) 78 | -------------------------------------------------------------------------------- /man/stat_coverage-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_coverage} 2 | \alias{stat_coverage} 3 | \alias{stat_coverage,missing-method} 4 | \alias{stat_coverage,uneval-method} 5 | \alias{stat_coverage,GRanges-method} 6 | \alias{stat_coverage,GRangesList-method} 7 | \alias{stat_coverage,BamFile-method} 8 | \title{Calculate coverage} 9 | \description{ 10 | Calculate coverage. 11 | } 12 | \usage{ 13 | # for GRanges 14 | \S4method{stat_coverage}{GRanges}(data, ..., xlim, xlab, ylab, main, 15 | facets = NULL, geom = NULL) 16 | # for GRangesList 17 | \S4method{stat_coverage}{GRangesList}(data, ..., xlim, xlab, ylab, main, 18 | facets = NULL, geom = NULL) 19 | 20 | # for Bamfile 21 | \S4method{stat_coverage}{BamFile}(data, ..., maxBinSize = 2^14, 22 | xlim, which, xlab, ylab, 23 | main, facets = NULL, geom = NULL, 24 | method = c("estimate", "raw"), 25 | space.skip = 0.1, coord = c("linear", "genome")) 26 | } 27 | \arguments{ 28 | \item{data}{ 29 | A \code{GRanges} or \code{data.frame} object. 30 | } 31 | \item{...}{ 32 | Extra parameters such as aes() passed to \code{geom_rect}, 33 | \code{geom_alignment}, or \code{geom_segment}. 34 | } 35 | \item{xlim}{ 36 | Limits for x. 37 | } 38 | \item{xlab}{ 39 | Label for x 40 | } 41 | \item{ylab}{ 42 | Label for y 43 | } 44 | \item{main}{ 45 | Title for plot. 46 | } 47 | \item{facets}{ 48 | Faceting formula to use. 49 | } 50 | \item{geom}{ 51 | The geometric object to use display the data. 52 | } 53 | \item{maxBinSize}{ 54 | maxBinSize. 55 | } 56 | \item{method}{ 57 | 'estimate' for parsing estimated coverage(fast), 'raw' is slow and 58 | parse the accurate coverage. 59 | } 60 | \item{which}{ 61 | \code{GRanges} which defines region to subset the results. 62 | } 63 | \item{space.skip}{ 64 | used for coordinate genome, skip between chromosomes. 65 | } 66 | \item{coord}{ 67 | coordinate system. 68 | } 69 | } 70 | \value{ 71 | A 'Layer'. 72 | } 73 | \examples{ 74 | library(ggbio) 75 | ## ====================================================================== 76 | ## simmulated GRanges 77 | ## ====================================================================== 78 | set.seed(1) 79 | N <- 1000 80 | library(GenomicRanges) 81 | 82 | gr <- GRanges(seqnames = 83 | sample(c("chr1", "chr2", "chr3"), 84 | size = N, replace = TRUE), 85 | IRanges( 86 | start = sample(1:300, size = N, replace = TRUE), 87 | width = sample(70:75, size = N,replace = TRUE)), 88 | strand = sample(c("+", "-", "*"), size = N, 89 | replace = TRUE), 90 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 91 | sample = sample(c("Normal", "Tumor"), 92 | size = N, replace = TRUE), 93 | pair = sample(letters, size = N, 94 | replace = TRUE)) 95 | 96 | ggplot(gr) + stat_coverage() 97 | ggplot() + stat_coverage(gr) 98 | 99 | ggplot(gr) + stat_coverage(geom = "point") 100 | ggplot(gr) + stat_coverage(geom = "area") 101 | ggplot(gr) + stat_coverage(mapping = aes(y = ..coverage..), geom = "bar") 102 | 103 | ggplot(gr) + stat_coverage(mapping = aes(y = ..coverage..)) + geom_point() 104 | 105 | ## for bam file 106 | ## TBD 107 | } 108 | \author{Tengfei Yin} 109 | 110 | -------------------------------------------------------------------------------- /man/geom_arch-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_arch} 2 | \alias{geom_arch} 3 | \alias{geom_arch,data.frame-method} 4 | \alias{geom_arch,GRanges-method} 5 | \alias{geom_arch,missing-method} 6 | \alias{geom_arch,uneval-method} 7 | \title{Arch geoms for GRanges object} 8 | \description{ 9 | Show interval data as arches. 10 | } 11 | \usage{ 12 | % for data.frame 13 | \S4method{geom_arch}{data.frame}(data, ..., n = 25, max.height = 10) 14 | 15 | % for GRanges 16 | \S4method{geom_arch}{GRanges}(data, ..., xlab, ylab, main, facets = NULL, 17 | rect.height = 0, n = 25, max.height = 10) 18 | 19 | } 20 | \arguments{ 21 | \item{data}{ 22 | A \code{GRanges} or \code{data.frame} object. 23 | } 24 | \item{...}{ 25 | Extra parameters passed to autoplot function, \code{aes} mapping 26 | support \code{height, x, xend}. 27 | \itemize{ 28 | \item{x}{start of the arches} 29 | \item{xend}{end of the arches} 30 | \item{height}{height of arches} 31 | } 32 | } 33 | \item{xlab}{ 34 | Label for x 35 | } 36 | \item{ylab}{ 37 | Label for y 38 | } 39 | \item{main}{ 40 | Title for plot. 41 | } 42 | \item{n}{ 43 | Integer values at which interpolation takes place to create 'n' 44 | equally spaced points spanning the interval ['min(x)', 'max(x)']. 45 | } 46 | \item{facets}{ 47 | Faceting formula to use. 48 | } 49 | \item{rect.height}{ 50 | When data is \code{GRanges}, this padding the arches from original y 51 | value to allow users putting arches 'around' the interval rectangles. 52 | } 53 | \item{max.height}{ 54 | Max height of all arches. 55 | } 56 | } 57 | \value{ 58 | A 'Layer'. 59 | } 60 | \details{ 61 | To draw a interval data as arches, we need to provide a special geom for 62 | this purpose. Arches is popular in gene viewer or genomoe browser, 63 | when they try to show isoforms or gene model.\code{geom_arch}, 64 | just like any other \code{geom_*} function in ggplot2, you can pass 65 | aes() to it to map variable to height of arches. 66 | } 67 | 68 | \examples{ 69 | set.seed(1) 70 | N <- 100 71 | library(GenomicRanges) 72 | 73 | ## ======================================= 74 | ## simmulated GRanges 75 | ## ======================================= 76 | gr <- GRanges(seqnames = 77 | sample(c("chr1", "chr2", "chr3"), 78 | size = N, replace = TRUE), 79 | IRanges( 80 | start = sample(1:300, size = N, replace = TRUE), 81 | width = sample(70:75, size = N,replace = TRUE)), 82 | strand = sample(c("+", "-", "*"), size = N, 83 | replace = TRUE), 84 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 85 | sample = sample(c("Normal", "Tumor"), 86 | size = N, replace = TRUE), 87 | pair = sample(letters, size = N, 88 | replace = TRUE)) 89 | 90 | ## ======================================= 91 | ## default 92 | ## ======================================= 93 | ggplot(gr) + geom_arch() 94 | # or 95 | ggplot() + geom_arch(gr) 96 | 97 | ## ======================================= 98 | ## facetting and aesthetics 99 | ## ======================================= 100 | ggplot(gr) + geom_arch(mapping = aes(color = value, height = value, size = value), 101 | alpha = 0.2, facets = sample ~ seqnames) 102 | 103 | 104 | } 105 | \author{Tengfei Yin} 106 | 107 | -------------------------------------------------------------------------------- /man/stat_identity-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_identity} 2 | \alias{stat_identity} 3 | \alias{stat_identity,ANY-method} 4 | \alias{stat_identity,missing-method} 5 | \alias{stat_identity,uneval-method} 6 | \alias{stat_identity,GRanges-method} 7 | \alias{stat_identity,Rle-method} 8 | \alias{stat_identity,RleList-method} 9 | \title{Transform the data to a data.frame and for multiple geoms.} 10 | \description{ 11 | Transform the data to a suitable data.frame and then one could use 12 | multiple geom or even stat to re-plot the data. 13 | } 14 | \usage{ 15 | \S4method{stat_identity}{ANY}(data, ...) 16 | 17 | \S4method{stat_identity}{GRanges}(data, ..., geom = NULL) 18 | 19 | \S4method{stat_identity}{Rle}(data, ..., xlab, ylab, main, geom = NULL) 20 | 21 | \S4method{stat_identity}{RleList}(data, ..., xlab, ylab, main, 22 | geom = NULL, indName = "sample") 23 | } 24 | \arguments{ 25 | \item{data}{ 26 | Typically a \code{GRanges} or \code{data.frame} object. 27 | } 28 | \item{...}{ 29 | Extra parameters such as aes() passed to \code{geom_rect}, 30 | \code{geom_alignment}, or \code{geom_segment}. 31 | } 32 | \item{geom}{ 33 | The geometric object to use display the data. 34 | } 35 | \item{xlab}{ 36 | x label. 37 | } 38 | \item{ylab}{ 39 | y label. 40 | } 41 | \item{main}{ 42 | title of graphic.. 43 | } 44 | \item{indName}{ 45 | sample name. 46 | } 47 | } 48 | \value{ 49 | A 'Layer'. 50 | } 51 | \examples{ 52 | ## load 53 | set.seed(1) 54 | N <- 50 55 | 56 | require(GenomicRanges) 57 | ## simul 58 | ## ====================================================================== 59 | ## simmulated GRanges 60 | ## ====================================================================== 61 | gr <- GRanges(seqnames = 62 | sample(c("chr1", "chr2", "chr3"), 63 | size = N, replace = TRUE), 64 | IRanges( 65 | start = sample(1:300, size = N, replace = TRUE), 66 | width = sample(70:75, size = N,replace = TRUE)), 67 | strand = sample(c("+", "-", "*"), size = N, 68 | replace = TRUE), 69 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 70 | sample = sample(c("Normal", "Tumor"), 71 | size = N, replace = TRUE), 72 | pair = sample(letters, size = N, 73 | replace = TRUE)) 74 | 75 | ## geom_point_start 76 | ggplot() + stat_identity(gr, mapping = aes(x = start, y = value), geom = "point") 77 | ## or more formal 78 | ggplot(gr) + stat_identity(mapping = aes(x = start, y = value), geom = "point") 79 | 80 | ## geom_point_midpoint 81 | ggplot(gr) + stat_identity(mapping = aes(x = midpoint, y = value), geom = "point") 82 | 83 | ## geom_rect_all 84 | ggplot(gr) + stat_identity(mapping = aes(xmin = start, xmax = end, 85 | ymin = value - 0.5, ymax = value + 0.5), 86 | geom = "rect") 87 | 88 | ## geom_rect_y 89 | ggplot(gr) + stat_identity(mapping = aes(y = value), geom = "rect") 90 | 91 | ## geom_line 92 | ggplot(gr) + stat_identity(mapping = aes(x = start, y = value), geom = "line") 93 | 94 | ## geom_segment 95 | ggplot(gr) + stat_identity(mapping = aes(y = value), geom = "segment") 96 | 97 | ## Rle/RleList 98 | library(IRanges) 99 | lambda <- c(rep(0.001, 4500), seq(0.001, 10, length = 500), 100 | seq(10, 0.001, length = 500)) 101 | xVector <- rpois(1e4, lambda) 102 | xRle <- Rle(xVector) 103 | xRleList <- RleList(xRle, 2L * xRle) 104 | 105 | ggplot(xRle) + stat_identity(geom = "point") 106 | ggplot(xRleList) + stat_identity(geom = "point") 107 | } 108 | \author{Tengfei Yin} 109 | 110 | -------------------------------------------------------------------------------- /R/Plot-class.R: -------------------------------------------------------------------------------- 1 | setClass("Plot", contains = "Tracked") 2 | 3 | ## abstract, so different methods could dispatch on diiferent types of graphics 4 | ## instance 5 | setClass("ggplotPlot", contains = c("ggplot", "Plot")) 6 | setClass("latticePlot", contains = c("trellis","Plot")) 7 | setClass("ggbioPlot", contains = c("GGbio", "Plot")) 8 | setClass("ideogramPlot", contains = c("Ideogram", "Plot")) 9 | 10 | 11 | ## Generic function to get subclas instance of 'Plot' class 12 | setGeneric("Plot", function(x, ...) standardGeneric("Plot")) 13 | setMethod("Plot", "gg", function(x){ 14 | x <- ggbio(x) 15 | obj <- Plot(x) 16 | obj 17 | }) 18 | 19 | ## lattice doesn't now how to update itself yet, so mutalbe = FALSE 20 | setMethod("Plot", "trellis", function(x, mutable = FALSE){ 21 | idx <- names(attributes(x)) %in% c("fixed", "labeled", "bgColor", "hasAxis", "mutable", "height") 22 | if(sum(idx)){ 23 | lst <- attributes(x)[idx] 24 | lst$mutable <- mutable 25 | obj <- do.call("new", c("latticePlot", list(x), lst)) 26 | }else{ 27 | obj <- new("latticePlot", x, mutable = mutable) 28 | } 29 | obj 30 | }) 31 | 32 | setMethod("Plot", "GGbio", function(x){ 33 | idx <- names(attributes(x)) %in% c("fixed", "labeled", "bgColor", "hasAxis", "mutable", "height") 34 | if(sum(idx)){ 35 | lst <- attributes(x)[idx] 36 | obj <- do.call("new", c("ggbioPlot", list(x), lst)) 37 | }else{ 38 | obj <- new("ggbioPlot", x) 39 | } 40 | if("geom" %in% names(attributes(x))){ 41 | attr(obj, "geom") <- attr(x, "geom") 42 | } 43 | obj 44 | }) 45 | 46 | ## be careful with Ideogram object 47 | setMethod("Plot", "Ideogram", function(x){ 48 | res <- new("ideogramPlot", x) 49 | }) 50 | 51 | 52 | 53 | ## compare to grobList, plotList return a list of original plot 54 | ## supported grobs only 55 | setClass("PlotList", prototype = prototype(elementType = "Plot"), 56 | contains = "list") 57 | 58 | setValidity("PlotList", .validList) 59 | 60 | ## validate via constructor 61 | PlotList <- function(...){ 62 | items <- list(...) 63 | items <- reduceListOfPlots(items) 64 | items <- lapply(items, Plot) 65 | new("PlotList", items) 66 | } 67 | 68 | ## original list of plots 69 | plotList <- function(...){ 70 | items <- list(...) 71 | items <- reduceListOfPlots(items) 72 | } 73 | 74 | 75 | 76 | 77 | ## add tracks + plot 78 | setMethod("c", "PlotList", function(x, ...){ 79 | if (missing(x)) { 80 | args <- unname(list(...)) 81 | x <- args[[1L]] 82 | } else { 83 | args <- unname(list(x, ...)) 84 | } 85 | if (length(args) == 1L) 86 | return(x) 87 | arg_is_null <- sapply(args, is.null) 88 | if (any(arg_is_null)) 89 | args[arg_is_null] <- NULL # remove NULL elements by setting them to NULL! 90 | if (!all(sapply(args, is, class(x)))) 91 | stop("all arguments in '...' must be ", class(x), " objects (or NULLs)") 92 | do.call(PlotList, unlist(args, recursive = FALSE)) 93 | }) 94 | 95 | ## if raw data, generate plot 96 | genPlots <- function(dots){ 97 | lapply(dots, function(x){ 98 | isPlot <- any(sapply(.supportedPlots, function(c){ 99 | extends(class(x), c) 100 | })) 101 | if(!isPlot){ 102 | res <- autoplot(x) 103 | }else{ 104 | res <- x 105 | } 106 | res 107 | }) 108 | } 109 | 110 | 111 | 112 | 113 | setMethod("[", c("PlotList", "numeric", "missing"), 114 | function(x, i, j, ...){ 115 | i <- as.integer(i) 116 | nms <- names(x) 117 | x <- initialize(x, x@.Data[i]) 118 | names(x) <- nms[i] 119 | x 120 | }) 121 | 122 | 123 | -------------------------------------------------------------------------------- /man/stat_slice-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_slice} 2 | \alias{stat_slice} 3 | \alias{stat_slice,missing-method} 4 | \alias{stat_slice,uneval-method} 5 | \alias{stat_slice,Rle-method} 6 | \alias{stat_slice,RleList-method} 7 | \title{Slice Rle/RleList to view them as bar or heatmap.} 8 | \description{ 9 | Slice Rle/RleList to different view by set lower or other parameters, 10 | then view summary for all those viewed region. 11 | } 12 | \usage{ 13 | \S4method{stat_slice}{Rle}(data, ..., 14 | xlab, ylab, main, 15 | na.rm = FALSE, 16 | geom = NULL, 17 | lower=-Inf, upper=Inf, 18 | includeLower=TRUE, includeUpper=TRUE, 19 | rangesOnly = FALSE, 20 | type = c("viewSums","viewMins", 21 | "viewMaxs", "viewMeans")) 22 | 23 | \S4method{stat_slice}{RleList}(data, ..., 24 | xlab, ylab, main, 25 | indName = "sample", 26 | na.rm = FALSE, 27 | geom = NULL, 28 | lower=-Inf, upper=Inf, 29 | includeLower=TRUE, includeUpper=TRUE, 30 | rangesOnly = FALSE, 31 | type = c("viewSums","viewMins", 32 | "viewMaxs", "viewMeans")) 33 | } 34 | \arguments{ 35 | \item{data}{ 36 | a \code{data.frame} or \code{Rle} or \code{RleList} object. 37 | } 38 | \item{...}{ 39 | arguments passed to aesthetics mapping. 40 | } 41 | \item{xlab}{ 42 | x label. 43 | } 44 | \item{ylab}{ 45 | y label. 46 | } 47 | \item{main}{ 48 | title. 49 | } 50 | \item{indName}{ 51 | when faceted by a \code{RleList}, name used for labeling faceted 52 | factor. Default is 'sample'. 53 | } 54 | \item{geom}{ 55 | geometric types. 56 | } 57 | \item{type}{ 58 | statistical summary method used within bins, shown as bar height or 59 | heatmap colors. 60 | } 61 | \item{na.rm}{ 62 | logical value, default \code{FALSE}, passed to function like 63 | \code{viewMaxs} for statistical summary computation. 64 | } 65 | \item{lower}{ 66 | passed to \code{\link[IRanges]{slice}}. 67 | } 68 | \item{upper}{ 69 | passed to \code{\link[IRanges]{slice}}. 70 | } 71 | \item{includeLower}{ 72 | passed to \code{\link[IRanges]{slice}}. 73 | } 74 | \item{includeUpper}{ 75 | passed to \code{\link[IRanges]{slice}}. 76 | } 77 | \item{rangesOnly}{ 78 | passed to \code{\link[IRanges]{slice}}. 79 | } 80 | } 81 | \value{ 82 | a ggplot object. 83 | } 84 | \seealso{ 85 | \code{\link[IRanges]{slice}} 86 | } 87 | \examples{ 88 | library(IRanges) 89 | lambda <- c(rep(0.001, 4500), seq(0.001, 10, length = 500), 90 | seq(10, 0.001, length = 500)) 91 | xVector <- rpois(1e4, lambda) 92 | xRle <- Rle(xVector) 93 | xRleList <- RleList(xRle, 2L * xRle) 94 | 95 | ggplot(xRle) + stat_slice(lower = 5) 96 | ggplot(xRle) + stat_slice(lower = 5, geom = "bar") 97 | ggplot(xRle) + stat_slice(lower = 5, geom = "heatmap") 98 | 99 | p1 <- ggplot(xRle) + stat_slice(type = "viewMeans", lower = 5, 100 | geom = "bar") 101 | p2 <- ggplot(xRle) + stat_slice(type = "viewSums", lower = 5, 102 | geom = "bar") 103 | ## y scale are different. 104 | tracks(viewMeans = p1, viewSums = p2) 105 | 106 | ggplot(xRleList) + stat_slice(lower = 5) 107 | ggplot(xRleList) + stat_slice(lower = 5, geom = "bar") 108 | ggplot(xRleList) + stat_slice(lower = 5, geom = "heatmap") 109 | 110 | p1 <- ggplot(xRleList) + stat_slice(type = "viewMeans", lower = 5, 111 | geom = "bar") 112 | p2 <- ggplot(xRleList) + stat_slice(type = "viewSums", lower = 5, 113 | geom = "bar") 114 | ## y scale are different. 115 | tracks(viewMeans = p1, viewSums = p2) 116 | } 117 | \author{Tengfei Yin} 118 | -------------------------------------------------------------------------------- /man/geom_arrowrect-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_arrowrect} 2 | \alias{geom_arrowrect} 3 | \alias{geom_arrowrect,GRanges-method} 4 | \alias{geom_arrowrect,missing-method} 5 | \alias{geom_arrowrect,uneval-method} 6 | \title{Arrowrect geoms for GRanges object} 7 | \description{ 8 | Show interval data as rectangle with a arrow head. 9 | } 10 | \usage{ 11 | \S4method{geom_arrowrect}{GRanges}(data, ..., xlab, ylab, main, 12 | facets = NULL, stat = c("stepping", "identity"), 13 | rect.height = NULL, arrow.head = 0.06, 14 | arrow.head.rate = arrow.head, arrow.head.fix = NULL, 15 | group.selfish = TRUE) 16 | 17 | } 18 | \arguments{ 19 | \item{data}{ 20 | A \code{GRanges} object. 21 | } 22 | \item{...}{ 23 | Extra parameters such as aes() passed. 24 | } 25 | \item{xlab}{ 26 | Label for x 27 | } 28 | \item{ylab}{ 29 | Label for y 30 | } 31 | \item{main}{ 32 | Title for plot. 33 | } 34 | \item{facets}{ 35 | Faceting formula to use. 36 | } 37 | \item{stat}{ 38 | Character vector specifying statistics to use. "stepping" with 39 | randomly assigned stepping levels as y varialbe. "identity" allow 40 | users to specify \code{y} value in \code{aes}. 41 | } 42 | \item{rect.height}{ 43 | Half height of the arrow body. 44 | } 45 | \item{arrow.head}{ 46 | Arrow head to body ratio. 47 | } 48 | \item{arrow.head.rate}{ 49 | Arrow head to body ratio. same with arrow.head. 50 | } 51 | \item{arrow.head.fix}{ 52 | fixed length of arrow head. 53 | } 54 | \item{group.selfish}{ 55 | Passed to \code{addStepping}, control whether to show each group as 56 | unique level or not. If set to \code{FALSE}, if two groups are not 57 | overlapped with each other, they will probably be layout in the same 58 | level to save space. 59 | } 60 | } 61 | \value{ 62 | A 'Layer'. 63 | } 64 | \examples{ 65 | set.seed(1) 66 | N <- 100 67 | require(GenomicRanges) 68 | ## ====================================================================== 69 | ## simmulated GRanges 70 | ## ====================================================================== 71 | gr <- GRanges(seqnames = 72 | sample(c("chr1", "chr2", "chr3"), 73 | size = N, replace = TRUE), 74 | IRanges( 75 | start = sample(1:300, size = N, replace = TRUE), 76 | width = sample(70:75, size = N,replace = TRUE)), 77 | strand = sample(c("+", "-", "*"), size = N, 78 | replace = TRUE), 79 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 80 | sample = sample(c("Normal", "Tumor"), 81 | size = N, replace = TRUE), 82 | pair = sample(letters, size = N, 83 | replace = TRUE)) 84 | 85 | 86 | ## ====================================================================== 87 | ## default 88 | ## ====================================================================== 89 | ggplot(gr) + geom_arrowrect() 90 | ## or 91 | ggplot() + geom_arrowrect(gr) 92 | 93 | ## ====================================================================== 94 | ## facetting and aesthetics 95 | ## ====================================================================== 96 | ggplot(gr) + geom_arrowrect(facets = sample ~ seqnames, mapping = aes(color = strand, fill = strand)) 97 | 98 | 99 | ## ====================================================================== 100 | ## stat:identity 101 | ## ====================================================================== 102 | ggplot(gr) + geom_arrowrect(stat = "identity", mapping = aes(y = value)) 103 | 104 | 105 | ## ====================================================================== 106 | ## stat:stepping 107 | ## ====================================================================== 108 | ggplot(gr) + geom_arrowrect(stat = "stepping", mapping = aes(y = value, group = pair)) 109 | 110 | 111 | ## ====================================================================== 112 | ## group.selfish controls when 113 | ## ====================================================================== 114 | ggplot(gr) + geom_arrowrect(gr, stat = "stepping", mapping = aes(y = value, group = pair), group.selfish = FALSE) 115 | } 116 | \author{Tengfei Yin} 117 | 118 | -------------------------------------------------------------------------------- /man/geom_segment-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_segment} 2 | \alias{geom_segment} 3 | \alias{geom_segment,ANY-method} 4 | \alias{geom_segment,GRanges-method} 5 | \alias{geom_segment,missing-method} 6 | \alias{geom_segment,uneval-method} 7 | \title{Segment geoms for GRanges object} 8 | \description{ 9 | Show interval data as segments. 10 | } 11 | \usage{ 12 | \S4method{geom_segment}{ANY}(data, ...) 13 | % for GRanges 14 | \S4method{geom_segment}{GRanges}(data,..., xlab, ylab, main, 15 | facets = NULL, stat = c("stepping", "identity"), 16 | group.selfish = TRUE) 17 | } 18 | \arguments{ 19 | \item{data}{ 20 | A \code{GRanges} or \code{data.frame} object. 21 | } 22 | \item{...}{ 23 | Extra parameters such as aes() or \code{color, size} passed. 24 | } 25 | \item{xlab}{ 26 | Label for x 27 | } 28 | \item{ylab}{ 29 | Label for y 30 | } 31 | \item{main}{ 32 | Title for plot. 33 | } 34 | \item{facets}{ 35 | Faceting formula to use. 36 | } 37 | \item{stat}{ 38 | Character vector specifying statistics to use. "stepping" with 39 | randomly assigned stepping levels as y varialbe. "identity" allow 40 | users to specify \code{y} value in \code{aes}. 41 | } 42 | \item{group.selfish}{ 43 | Passed to \code{addStepping}, control whether to show each group as 44 | unique level or not. If set to \code{FALSE}, if two groups are not 45 | overlapped with each other, they will probably be layout in the same 46 | level to save space. 47 | } 48 | } 49 | \value{ 50 | A 'Layer'. 51 | } 52 | \examples{ 53 | 54 | set.seed(1) 55 | N <- 100 56 | require(GenomicRanges) 57 | 58 | ## ====================================================================== 59 | ## simmulated GRanges 60 | ## ====================================================================== 61 | gr <- GRanges(seqnames = 62 | sample(c("chr1", "chr2", "chr3"), 63 | size = N, replace = TRUE), 64 | IRanges( 65 | start = sample(1:300, size = N, replace = TRUE), 66 | width = sample(70:75, size = N,replace = TRUE)), 67 | strand = sample(c("+", "-", "*"), size = N, 68 | replace = TRUE), 69 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 70 | sample = sample(c("Normal", "Tumor"), 71 | size = N, replace = TRUE), 72 | pair = sample(letters, size = N, 73 | replace = TRUE)) 74 | 75 | 76 | ## ====================================================================== 77 | ## data.frame call ggplot2::geom_segment 78 | ## ====================================================================== 79 | ggplot() + geom_segment(data = mtcars, mapping = aes(x = mpg, y = wt, xend = mpg + 10, yend = wt + 0.2, 80 | color = cyl)) 81 | 82 | 83 | 84 | ## ====================================================================== 85 | ## default 86 | ## 87 | ## ====================================================================== 88 | ggplot(gr) + geom_segment() 89 | ## or 90 | ggplot() + geom_segment(gr) 91 | 92 | 93 | ## ====================================================================== 94 | ## facetting and aesthetics 95 | ## ====================================================================== 96 | ggplot(gr) + geom_segment(facets = sample ~ seqnames, mapping = aes(color = strand)) 97 | 98 | 99 | ## ====================================================================== 100 | ## stat:identity 101 | ## ====================================================================== 102 | ggplot(gr) + geom_segment(stat = "identity", mapping = aes(y = value)) 103 | 104 | 105 | ## ====================================================================== 106 | ## stat:stepping 107 | ## ====================================================================== 108 | ggplot(gr) + geom_segment(stat = "stepping", mapping = aes(y = value, group = pair)) 109 | 110 | 111 | ## ====================================================================== 112 | ## group.selfish controls when 113 | ## ====================================================================== 114 | ggplot(gr) + geom_segment(stat = "stepping", mapping = aes(y = value, group = pair), group.selfish = FALSE) 115 | } 116 | \author{Tengfei Yin} 117 | 118 | -------------------------------------------------------------------------------- /man/geom_rect-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_rect} 2 | \alias{geom_rect} 3 | \alias{geom_rect,ANY-method} 4 | \alias{geom_rect,GRanges-method} 5 | \alias{geom_rect,missing-method} 6 | \alias{geom_rect,uneval-method} 7 | \title{Rect geoms for GRanges object} 8 | \description{ 9 | Show interval data as rectangle. 10 | } 11 | \usage{ 12 | \S4method{geom_rect}{ANY}(data, ...) 13 | \S4method{geom_rect}{GRanges}(data,..., xlab, ylab, main, 14 | facets = NULL, stat = c("stepping", "identity"), 15 | rect.height = NULL, 16 | group.selfish = TRUE) 17 | } 18 | \arguments{ 19 | \item{data}{ 20 | Typically a \code{GRanges} or \code{data.frame} object. When it's 21 | \code{data.frame}, it's simply calling ggplot2::geom_rect. 22 | } 23 | \item{...}{ 24 | Extra parameters such as aes() or \code{color, size} passed. 25 | } 26 | \item{xlab}{ 27 | Label for x 28 | } 29 | \item{ylab}{ 30 | Label for y 31 | } 32 | \item{main}{ 33 | Title for plot. 34 | } 35 | \item{facets}{ 36 | Faceting formula to use. 37 | } 38 | \item{stat}{ 39 | Character vector specifying statistics to use. "stepping" with 40 | randomly assigned stepping levels as y varialbe. "identity" allow 41 | users to specify \code{y} value in \code{aes}. 42 | } 43 | \item{rect.height}{ 44 | Half height of the arrow body. 45 | } 46 | \item{group.selfish}{ 47 | Passed to \code{addStepping}, control whether to show each group as 48 | unique level or not. If set to \code{FALSE}, if two groups are not 49 | overlapped with each other, they will probably be layout in the same 50 | level to save space. 51 | } 52 | } 53 | \value{ 54 | A 'Layer'. 55 | } 56 | \examples{ 57 | set.seed(1) 58 | N <- 100 59 | require(GenomicRanges) 60 | 61 | ## ====================================================================== 62 | ## simmulated GRanges 63 | ## ====================================================================== 64 | gr <- GRanges(seqnames = 65 | sample(c("chr1", "chr2", "chr3"), 66 | size = N, replace = TRUE), 67 | IRanges( 68 | start = sample(1:300, size = N, replace = TRUE), 69 | width = sample(70:75, size = N,replace = TRUE)), 70 | strand = sample(c("+", "-", "*"), size = N, 71 | replace = TRUE), 72 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 73 | sample = sample(c("Normal", "Tumor"), 74 | size = N, replace = TRUE), 75 | pair = sample(letters, size = N, 76 | replace = TRUE)) 77 | 78 | 79 | 80 | ## ====================================================================== 81 | ## data.frame call ggplot2::geom_rect 82 | ## ====================================================================== 83 | ggplot() + geom_rect(data = mtcars, mapping = aes(xmin = mpg, ymin = wt, xmax = mpg + 10, ymax = wt + 0.2, 84 | fill = cyl)) 85 | 86 | 87 | 88 | ## ====================================================================== 89 | ## default 90 | ## ====================================================================== 91 | ggplot(gr) + geom_rect() 92 | # or 93 | ggplot() + geom_rect(gr) 94 | 95 | 96 | ## ====================================================================== 97 | ## facetting and aesthetics 98 | ## ====================================================================== 99 | ggplot(gr) + geom_rect(facets = sample ~ seqnames, mapping = aes(color = strand, fill = strand)) 100 | 101 | 102 | ## ====================================================================== 103 | ## stat:identity 104 | ## ====================================================================== 105 | ggplot(gr) + geom_rect(stat = "identity", mapping = aes(y = value)) 106 | 107 | 108 | ## ====================================================================== 109 | ## stat:stepping 110 | ## ====================================================================== 111 | ggplot(gr) + geom_rect(stat = "stepping", mapping = aes(y = value, group = pair)) 112 | 113 | 114 | ## ====================================================================== 115 | ## group.selfish controls when 116 | ## ====================================================================== 117 | ggplot(gr) + geom_rect(stat = "stepping", mapping = aes(y = value, group = pair), group.selfish = FALSE) 118 | } 119 | \author{Tengfei Yin} 120 | 121 | -------------------------------------------------------------------------------- /R/Cache-class.R: -------------------------------------------------------------------------------- 1 | setClass("Cache", 2 | slots = list( 3 | cached = "logical", 4 | cached_xlim = "numeric_OR_NULL", 5 | cached_ylim = "numeric_OR_NULL", 6 | ## That's bad; would be better to have something like GRanges_OR_BasicFilter_OR_NULL, 7 | ## but that's not working as we're also adding stuff extending BasicFilter. 8 | cached_which = "GRanges_OR_BasicFilter_OR_list_OR_NULL", 9 | cached_item = "list" 10 | ), 11 | prototype = list(cached = TRUE, 12 | cached_xlim = 1, 13 | cached_ylim = NULL, 14 | cached_which = NULL, 15 | cached_item = list() 16 | )) 17 | 18 | ## cached always equal TRUE 19 | ## only for 'fetchable' object, set it to FALSE 20 | Cache <- function(..., cached = TRUE, cached_xlim = NULL, cached_ylim = NULL, 21 | cached_which = NULL, cached_item = list()){ 22 | new("Cache", cached = cached, 23 | cached_xlim = cached_xlim, 24 | cached_ylim = cached_ylim, 25 | cached_which = cached_which, 26 | cached_item = cached_item, ...) 27 | } 28 | 29 | setGeneric("cached", function(x, ...) standardGeneric("cached")) 30 | setMethod("cached", "Cache", function(x){ 31 | x@cached 32 | }) 33 | setGeneric("cached<-", function(x, value) standardGeneric("cached<-")) 34 | setReplaceMethod("cached", c("Cache", "logical"), function(x, value){ 35 | x@cached <- value 36 | x 37 | }) 38 | 39 | 40 | setGeneric("cached_xlim", function(x, ...) standardGeneric("cached_xlim")) 41 | setMethod("cached_xlim", "Cache", function(x){ 42 | x@cached_xlim 43 | }) 44 | setGeneric("cached_xlim<-", function(x, value) standardGeneric("cached_xlim<-")) 45 | setReplaceMethod("cached_xlim", c("Cache", "numeric"), function(x, value){ 46 | if(length(value) == 1) 47 | value <- rep(value, 2) 48 | if(length(value) > 1) 49 | value <- range(value) 50 | x@cached_xlim <- value 51 | x 52 | }) 53 | 54 | 55 | setGeneric("cached_ylim", function(x, ...) standardGeneric("cached_ylim")) 56 | setMethod("cached_ylim", "Cache", function(x){ 57 | x@cached_ylim 58 | }) 59 | setGeneric("cached_ylim<-", function(x, value) standardGeneric("cached_ylim<-")) 60 | setReplaceMethod("cached_ylim", c("Cache", "numeric"), function(x, value){ 61 | if(length(value) == 1) 62 | value <- rep(value, 2) 63 | if(length(value) > 1) 64 | value <- range(value) 65 | x@cached_ylim<- value 66 | x 67 | }) 68 | 69 | setGeneric("cached_item", function(x, ...) standardGeneric("cached_item")) 70 | setMethod("cached_item", "Cache", function(x){ 71 | x@cached_item 72 | }) 73 | setGeneric("cached_item<-", function(x, value) standardGeneric("cached_item<-")) 74 | setReplaceMethod("cached_item", c("Cache", "list"), function(x, value){ 75 | x@cached_item <- value 76 | x 77 | }) 78 | 79 | setGeneric("addItem", function(x, ...) standardGeneric("addItem")) 80 | setMethod("addItem", c("Cache"), function(x, ...){ 81 | x@cached_item <- c(x@cached_item, list(...)) 82 | x 83 | }) 84 | 85 | 86 | 87 | setGeneric("cached_which", function(x, ...) standardGeneric("cached_which")) 88 | setMethod("cached_which", "Cache", function(x){ 89 | x@cached_which 90 | }) 91 | setGeneric("cached_which<-", function(x, value) standardGeneric("cached_which<-")) 92 | setReplaceMethod("cached_which", c("Cache", "GRanges_OR_BasicFilter_OR_list_OR_NULL"), function(x, value){ 93 | x@cached_which<- value 94 | x 95 | }) 96 | 97 | 98 | setGeneric("addWhich", function(x, value, ...) standardGeneric("addWhich")) 99 | setMethod("addWhich", c("Cache", "GRanges"), function(x, value){ 100 | if(is.null(x@cached_which)){ 101 | x@cached_which <- value 102 | }else{ 103 | x@cached_which <- c(x@cached_which, value) 104 | } 105 | x 106 | }) 107 | setMethod("addWhich", c("Cache", "BasicFilterORlist"), function(x, value){ 108 | if(is.null(x@cached_which)){ 109 | x@cached_which <- value 110 | }else{ 111 | if(is(x@cached_which, "GRanges")) 112 | stop("Shouldn't mix GRanges with BasicFilter objects!") 113 | x@cached_which <- c(x@cached_which, value) 114 | } 115 | x 116 | }) 117 | 118 | ## cacheSet cache item and which at the same time, make sure the lengths equals 119 | setGeneric("cacheSet", function(x, value, ...) standardGeneric("cacheSet")) 120 | setMethod("cacheSet", c("Cache", "GRanges"), function(x, value){ 121 | x <- addItem(x, x) 122 | x <- addWhich(x, value) 123 | x 124 | }) 125 | setMethod("cacheSet", c("Cache", "BasicFilterORlist"), function(x, value){ 126 | x <- addItem(x, x) 127 | x <- addWhich(x, value) 128 | x 129 | }) 130 | 131 | 132 | 133 | 134 | 135 | 136 | -------------------------------------------------------------------------------- /man/geom_arrow-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_arrow} 2 | \alias{geom_arrow} 3 | \alias{geom_arrow,GRanges-method} 4 | \alias{geom_arrow,missing-method} 5 | \alias{geom_arrow,uneval-method} 6 | \title{Arrow geoms for GRanges object} 7 | \description{ 8 | Show interval data as arrows. 9 | } 10 | \usage{ 11 | \S4method{geom_arrow}{GRanges}(data, ..., xlab, ylab, main, 12 | angle = 30, length = unit(0.12, "cm"), type = "open", 13 | stat = c("stepping", "identity"), facets = NULL, 14 | arrow.rate = 0.03, group.selfish = TRUE) 15 | 16 | } 17 | \arguments{ 18 | \item{data}{ 19 | A \code{GRanges} object. 20 | } 21 | \item{...}{ 22 | Extra parameters such as aes() passed. 23 | } 24 | \item{xlab}{ 25 | Label for x 26 | } 27 | \item{ylab}{ 28 | Label for y 29 | } 30 | \item{main}{ 31 | Title for plot. 32 | } 33 | \item{angle}{ 34 | The angle of the arrow head in degrees (smaller numbers produce 35 | narrower, pointier arrows). Essentially describes the width of the 36 | arrow head. 37 | } 38 | \item{length}{ 39 | A unit specifying the length of the arrow head (from tip to base). 40 | } 41 | \item{type}{ 42 | One of "open" or "closed" indicating whether the arrow head should 43 | be a closed triangle. 44 | } 45 | \item{stat}{ 46 | Character vector specifying statistics to use. "stepping" with 47 | randomly assigned stepping levels as y varialbe. "identity" allow 48 | users to specify \code{y} value in \code{aes}. 49 | } 50 | \item{facets}{ 51 | Faceting formula to use. 52 | } 53 | \item{arrow.rate}{ 54 | Arrow density of the arrow body. 55 | } 56 | \item{group.selfish}{ 57 | Passed to \code{addStepping}, control whether to show each group as 58 | unique level or not. If set to \code{FALSE}, if two groups are not 59 | overlapped with each other, they will probably be layout in the same 60 | level to save space. 61 | } 62 | } 63 | \value{ 64 | A 'Layer'. 65 | } 66 | \examples{ 67 | set.seed(1) 68 | N <- 100 69 | require(GenomicRanges) 70 | ## ====================================================================== 71 | ## simmulated GRanges 72 | ## ====================================================================== 73 | gr <- GRanges(seqnames = 74 | sample(c("chr1", "chr2", "chr3"), 75 | size = N, replace = TRUE), 76 | IRanges( 77 | start = sample(1:300, size = N, replace = TRUE), 78 | width = sample(70:75, size = N,replace = TRUE)), 79 | strand = sample(c("+", "-", "*"), size = N, 80 | replace = TRUE), 81 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 82 | sample = sample(c("Normal", "Tumor"), 83 | size = N, replace = TRUE), 84 | pair = sample(letters, size = N, 85 | replace = TRUE)) 86 | 87 | 88 | ## ====================================================================== 89 | ## default 90 | ## ====================================================================== 91 | ggplot(gr) + geom_arrow() 92 | # or 93 | ggplot() + geom_arrow(gr) 94 | 95 | ## ====================================================================== 96 | ## facetting and aesthetics 97 | ## ====================================================================== 98 | ggplot(gr) + geom_arrow(facets = sample ~ seqnames, mapping = aes(color = strand, fill = strand)) 99 | 100 | ## ====================================================================== 101 | ## stat:identity 102 | ## ====================================================================== 103 | ggplot(gr) + geom_arrow(stat = "identity", mapping = aes(y = value)) 104 | 105 | 106 | ## ====================================================================== 107 | ## stat:stepping 108 | ## ====================================================================== 109 | ggplot(gr) + geom_arrow(stat = "stepping", mapping = aes(y = value, group = pair)) 110 | 111 | ## ====================================================================== 112 | ## group.selfish 113 | ## ====================================================================== 114 | ggplot(gr) + geom_arrow(stat = "stepping", mapping = aes(y = value, group = pair), group.selfish = FALSE) 115 | 116 | 117 | 118 | ## ====================================================================== 119 | ## other options to control arrow angle, density, ... 120 | ## ====================================================================== 121 | library(grid) 122 | ggplot(gr) + geom_arrow(stat = "stepping", mapping = aes(y = value, group = pair), 123 | arrow.rate = 0.01, length = unit(0.3, "cm"), angle = 45, 124 | group.selfish = FALSE) 125 | 126 | } 127 | \author{Tengfei Yin} 128 | 129 | -------------------------------------------------------------------------------- /R/hack.R: -------------------------------------------------------------------------------- 1 | ### hack at automaticaly generating method for IRanges and Granges 2 | ### to avoid get global .method, use a closure. 3 | setOldClass("uneval") 4 | .geoms.ggbio <- paste0("geom_", .ggbio.geom) 5 | .stats.ggbio <- paste0("stat_", .ggbio.stat) 6 | .geoms.ggplot <- paste0("geom_", .ggplot.geom) 7 | .stats.ggplot <- paste0("stat_", .ggplot.stat) 8 | 9 | .layouts <- c("layout_circle", "layout_karyogram") 10 | 11 | .gr.name.ggbio <- c(.geoms.ggbio, .stats.ggbio, .layouts) 12 | .gr.name.ggbio <- setdiff(.gr.name.ggbio, c(.geoms.ggplot, .stats.ggplot)) 13 | .gr.name.ggplot <- c(.geoms.ggplot, .stats.ggplot) 14 | 15 | 16 | for(method in .gr.name.ggbio){ 17 | ## for IRanges 18 | ifun <- function(method){ 19 | .method <- method 20 | if(hasMethod(.method, "GRanges") && !hasMethod(.method, "IRanges")){ 21 | setMethod(.method, "IRanges", function(data, ...){ 22 | .fun <- selectMethod(.method, signature = "GRanges") 23 | df <- values(data) 24 | values(data) <- NULL 25 | gr <- GRanges("chr_non", data) 26 | values(gr) <- df 27 | .fun(gr, ...) 28 | }) 29 | } 30 | } 31 | ifun(method) 32 | 33 | ## for GRangesList 34 | 35 | gfun <- function(method){ 36 | .method <- method 37 | if(hasMethod(.method, "GRanges") && !hasMethod(.method, "GRangesList")){ 38 | setMethod(.method, "GRangesList", function(data, ...){ 39 | .fun <- selectMethod(.method, signature = "GRanges") 40 | gr <- biovizBase:::flatGrl(data) 41 | .fun(gr, ...) 42 | }) 43 | } 44 | } 45 | gfun(method) 46 | 47 | ## hacking for ggplot2-like API without using proto 48 | ## is data is missing, return a call and parse the data 49 | mfun <- function(method){ 50 | .method <- method 51 | setMethod(.method, "missing", function(data,...){ 52 | mc <- match.call() 53 | mc[-1L] <- list(...) 54 | return(mc) 55 | }) 56 | } 57 | mfun(method) 58 | 59 | ufun <- function(method){ 60 | .method <- method 61 | setMethod(.method, "uneval", function(data, ...){ 62 | lst <- as.list(match.call()) 63 | idx <- names(lst) != "data" 64 | aes.u <- unname(lst[!idx]) 65 | res <- lst[idx] 66 | res <- c(res, aes.u) 67 | return(as.call(res)) 68 | }) 69 | } 70 | ufun(method) 71 | } 72 | 73 | 74 | 75 | for(method in .gr.name.ggplot){ 76 | ## for IRanges 77 | ifun <- function(method){ 78 | .method <- method 79 | if(hasMethod(.method, "GRanges")) { 80 | setMethod(.method, "IRanges", function(data, ...){ 81 | .fun <- selectMethod(.method, signature = "GRanges") 82 | df <- values(data) 83 | values(data) <- NULL 84 | gr <- GRanges("chr_non", data) 85 | values(gr) <- df 86 | .fun(gr, ...) 87 | }) 88 | } 89 | } 90 | ifun(method) 91 | 92 | ## for GRangesList 93 | 94 | gfun <- function(method){ 95 | .method <- method 96 | if(hasMethod(.method, "GRanges")) { 97 | setMethod(.method, "GRangesList", function(data, ...){ 98 | .fun <- selectMethod(.method, signature = "GRanges") 99 | gr <- biovizBase::flatGrl(data) 100 | .fun(gr, ...) 101 | }) 102 | } 103 | } 104 | gfun(method) 105 | 106 | ## hacking for ggplot2-like API without using proto 107 | mfun <- function(method){ 108 | .method <- method 109 | 110 | setMethod(.method, "missing", function(data, ...){ 111 | method0 <- getFromNamespace(method, "ggplot2") 112 | args <- list(...) 113 | args.aes <- parseArgsForAes(args) 114 | args.non <- parseArgsForNonAes(args) 115 | args.non <- remove_args(args.non, "nbin") 116 | args <- c(args.non, list(args.aes)) 117 | tm <- try({res <- do.call(method0, args)}, silent = TRUE) 118 | if(inherits(tm, "try-error")){ 119 | res <- match.call() 120 | }else{ 121 | mc <- match.call() 122 | attr(res, "call") <- TRUE 123 | attr(res, "mc") <- mc 124 | } 125 | return(res) 126 | }) 127 | } 128 | mfun(method) 129 | 130 | ufun <- function(method){ 131 | .method <- method 132 | setMethod(.method, "uneval", function(data, ...){ 133 | method0 <- getFromNamespace(method, "ggplot2") 134 | args <- list(...) 135 | args.non <- remove_args(args, "facets") 136 | args.aes <- data 137 | args <- c(args.non, list(args.aes)) 138 | tm <- try({res <- do.call(method0, args)}, silent = TRUE) 139 | if(inherits(tm, "try-error")){ 140 | res <- match.call() 141 | }else{ 142 | mc <- match.call() 143 | attr(res, "call") <- TRUE 144 | attr(res, "mc") <- mc 145 | } 146 | return(res) 147 | }) 148 | } 149 | ufun(method) 150 | } 151 | 152 | -------------------------------------------------------------------------------- /R/geom_arrowrect-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("geom_arrowrect", function(data, ...) standardGeneric("geom_arrowrect")) 2 | 3 | setMethod("geom_arrowrect", "GRanges", function(data, ..., 4 | xlab, ylab, main, 5 | facets = NULL, 6 | stat = c("stepping", "identity"), 7 | rect.height = NULL, 8 | arrow.head = 0.06, 9 | arrow.head.rate = arrow.head, 10 | arrow.head.fix = NULL, 11 | group.selfish = TRUE){ 12 | 13 | stat <- match.arg(stat) 14 | ## shape <- match.arg(shape) 15 | args <- list(...) 16 | args$facets <- facets 17 | 18 | args.aes <- parseArgsForAes(args) 19 | args.non <- remove_args(parseArgsForNonAes(args), "facets") 20 | 21 | facet <- build_facet(data, args) 22 | if(length(data)){ 23 | if(stat == "stepping"){ 24 | if(is.null(rect.height)) rect.height <- 0.4 25 | 26 | grl <- splitByFacets(data, facets) 27 | res <- endoapply(grl, make_addStepping, args.aes, group.selfish) 28 | res <- unlist(res) 29 | df <- breakGrTo5polyDf(res, y = "stepping", rect.height = rect.height, 30 | arrow.head = arrow.head, arrow.head.rate = arrow.head.rate, arrow.head.fix = arrow.head.fix) 31 | args.aes$x <- as.name(".temp.x") 32 | args.aes$y <- as.name(".temp.y") 33 | args.aes$group <- as.name(".id") 34 | aes.temp <- do.call(aes, args.aes) 35 | p <- do.call(geom_polygon, c(list(data = df), list(aes.temp), args.non)) 36 | } 37 | if(stat == "identity"){ 38 | if(!"y" %in% names(args.aes)) 39 | stop("aes(y = ) is requried for stat identity") 40 | if(is.null(rect.height)){ 41 | rect.height <- diff(range(values(data)[,quo_name(args.aes$y)]))/20 42 | if (rect.height == 0) rect.height <- 1L 43 | } 44 | df <- breakGrTo5polyDf(data, y = quo_name(args.aes$y), rect.height = rect.height, 45 | arrow.head = arrow.head, arrow.head.rate = arrow.head.rate, arrow.head.fix = arrow.head.fix) 46 | args.aes$x <- as.name(".temp.x") 47 | args.aes$y <- as.name(".temp.y") 48 | args.aes$group <- as.name(".id") 49 | aes.temp <- do.call(aes, args.aes) 50 | p <- do.call(geom_polygon, c(list(data = df), list(aes.temp), args.non)) 51 | }}else{ 52 | p <- NULL 53 | } 54 | p <- c(list(p) , list(facet)) 55 | 56 | 57 | labels <- Labels(xlab, ylab, main, fallback = c(x = "", y = "")) 58 | p <- c(p, labels) 59 | p 60 | }) 61 | 62 | 63 | getArrowLen <- function(object, arrow.head.rate = 0.4){ 64 | width(range(ranges(object))) * arrow.head.rate 65 | } 66 | 67 | breakGrTo5polyDf <- function(object, arrow.head = 0.02, 68 | arrow.head.rate = arrow.head, 69 | arrow.head.fix = NULL, 70 | rect.height = 0.4, y){ 71 | if(!length(arrow.head.fix)){ 72 | ah <- getArrowLen(object, arrow.head.rate) 73 | }else{ 74 | ah <- arrow.head.fix 75 | } 76 | df <- mold(object) 77 | df$.id <- seq_len(nrow(df)) 78 | res <- do.call(rbind,lapply(1:5, function(i) df)) 79 | res <- res[order(res$.id), ] 80 | lst <- lapply(1:nrow(df), function(i){ 81 | x <- df[i,, drop = FALSE] 82 | std <- x$strand 83 | if(x$width > ah){ 84 | if(std == "+"){ 85 | .x <- c(x$start, x$end-ah, x$end) 86 | .x <- c(.x, rev(.x)[-1]) 87 | .y <- c(rep(x[, y] - rect.height, 2), x[, y], rep(x[, y] + rect.height, 2)) 88 | } 89 | if(std == "-"){ 90 | .x <- c(x$start, x$start+ah, x$end) 91 | .x <- c(.x, rev(.x)[-3]) 92 | .y <- c(x[, y], rep(x[, y] - rect.height, 2), rep(x[, y] + rect.height, 2)) 93 | } 94 | if(std == "*"){ 95 | .x <- c(x$start, x$end, x$end) 96 | .x <- c(.x, rev(.x)[-1]) 97 | .y <- c(rep(x[, y] - rect.height, 2), x[, y], rep(x[, y] + rect.height, 2)) 98 | } 99 | }else{ 100 | if(std == "+"){ 101 | .x <- c(x$start, x$start, x$end) 102 | .x <- c(.x, rev(.x)[-1]) 103 | .y <- c(rep(x[, y] - rect.height, 2), x[, y], rep(x[, y] + rect.height, 2)) 104 | } 105 | if(std == "-"){ 106 | .x <- c(x$start, x$end, x$end) 107 | .x <- c(.x, rev(.x)[-3]) 108 | .y <- c(x[, y], rep(x[, y] - rect.height, 2), rep(x[, y] + rect.height, 2)) 109 | } 110 | if(std == "*"){ 111 | .x <- c(x$start, x$end, x$end) 112 | .x <- c(.x, rev(.x)[-1]) 113 | .y <- c(rep(x[, y] - rect.height, 2), x[, y], rep(x[, y] + rect.height, 2)) 114 | } 115 | } 116 | data.frame(.temp.x = .x, .temp.y = .y) 117 | }) 118 | temp <- do.call(rbind, lst) 119 | res <- cbind(res, temp) 120 | res 121 | } 122 | 123 | -------------------------------------------------------------------------------- /R/stat_bin-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("stat_bin", function(data, ...) standardGeneric("stat_bin")) 2 | setMethod("stat_bin", "ANY", function(data, ...){ 3 | ggplot2::stat_bin(data = data, ...) 4 | }) 5 | 6 | 7 | stat_bin_geom_bar <- function(args.aes, args.non) { 8 | args.non$stat <- "identity" 9 | aes.args <- do.call(aes, args.aes) 10 | p <- do.call(geom_bar, c(list(aes.args), args.non)) 11 | } 12 | 13 | stat_bin_geom_heatmap <- function(args.aes, args.non, binwidth) { 14 | args.aes$xmin <- substitute(x - binwidth / 2, list(binwidth = binwidth)) 15 | args.aes$xmax <- substitute(x + binwidth / 2, list(binwidth = binwidth)) 16 | args.aes$ymin <- 0 17 | args.aes$ymax <- 5 18 | args.aes$color <- as.name("y") 19 | args.aes$fill <- as.name("y") 20 | args.aes <- args.aes[!names(args.aes) %in% c("x", "y")] 21 | aes.args <- do.call(aes, args.aes) 22 | p <- do.call(geom_rect, c(list(aes.args), args.non)) 23 | } 24 | 25 | setMethod("stat_bin", "Rle", function(data, ..., binwidth, nbin = 30, 26 | xlab, ylab, main, geom = c("bar", "heatmap"), 27 | type = c("viewSums","viewMins", 28 | "viewMaxs", "viewMeans")){ 29 | 30 | geom <- match.arg(geom) 31 | type <- match.arg(type) 32 | args <- list(...) 33 | args.aes <- parseArgsForAes(args) 34 | args.non <- parseArgsForNonAes(args) 35 | if(!"x" %in% names(args.aes)) 36 | args.aes$x <- substitute(x) 37 | 38 | if(!"y" %in% names(args.aes)) 39 | args.aes$y <- substitute(y) 40 | 41 | if(geom == "bar"){ 42 | args.non$stat <- "identity" 43 | } 44 | if(missing(binwidth)){ 45 | binwidth <- length(data)/nbin 46 | message("Default use binwidth: range/", nbin) 47 | } 48 | vs <- Views(data, start = seq(from = 1, to = length(data), by = binwidth), 49 | width = binwidth) 50 | x <- seq(from = 1, to = length(data), by = binwidth) + binwidth/2 51 | y <- switch(type, viewMaxs = viewMaxs(vs), 52 | viewMins = viewMins(vs), 53 | viewSums = viewSums(vs), 54 | viewMeans = viewMeans(vs)) 55 | args.non$data <- data.frame(x = x, y = y) 56 | if(geom == "bar") 57 | p <- stat_bin_geom_bar(args.aes, args.non) 58 | if(geom == "heatmap") 59 | p <- stat_bin_geom_heatmap(args.aes, args.non, binwidth) 60 | labels <- Labels(xlab, ylab, main, fallback = c(x = "x", y = "y")) 61 | p <- c(p, labels) 62 | p 63 | }) 64 | 65 | 66 | setMethod("stat_bin", "RleList", function(data, ..., binwidth, nbin = 30, 67 | xlab, ylab, main, 68 | indName = "sample", 69 | geom = c("bar", "heatmap"), 70 | type = c("viewSums","viewMins", 71 | "viewMaxs", "viewMeans")){ 72 | 73 | geom <- match.arg(geom) 74 | type <- match.arg(type) 75 | args <- list(...) 76 | args.aes <- parseArgsForAes(args) 77 | args.non <- parseArgsForNonAes(args) 78 | if(!"x" %in% names(args.aes)) 79 | args.aes$x <- substitute(x) 80 | 81 | if(!"y" %in% names(args.aes)) 82 | args.aes$y <- substitute(y) 83 | 84 | if(geom == "bar"){ 85 | args.non$stat <- "identity" 86 | } 87 | 88 | ## facets <- as.formula(paste(indName, "~ .", sep = "")) 89 | ## facet <- facet_grid(facets) 90 | 91 | mn <- mean(unlist(lapply(data, length))) 92 | if(missing(binwidth)){ 93 | binwidth <- mn/nbin 94 | message("Default use binwidth: range/", nbin) 95 | } 96 | vs <- lapply(data, function(x) { 97 | Views(x, start = seq(from = 1, to = length(x), by = binwidth), 98 | width = binwidth) 99 | }) 100 | x <- lapply(data, function(x) { 101 | seq(from = 1, to = length(x), by = binwidth) + binwidth/2 102 | }) 103 | y <- switch(type, viewMaxs = lapply(vs, viewMaxs), 104 | viewMins = lapply(vs, viewMins), 105 | viewSums = lapply(vs, viewSums), 106 | viewMeans = lapply(vs, viewMeans)) 107 | if(is.null(names(x))) 108 | nms <- rep(1:length(x), times = elementNROWS(x)) 109 | else 110 | nms <- rep(names(x), times = elementNROWS(x)) 111 | df <- data.frame(x = unlist(x), y = unlist(y), listName = nms) 112 | colnames(df) <- c("x", "y", indName) 113 | if(is.null(names(x))) 114 | levels(df[, indName]) <- 1:length(x) 115 | else 116 | levels(df[, indName]) <- unique(names(x)) 117 | 118 | facets <- as.formula(paste(indName, "~ .", sep = "")) 119 | 120 | args$row <- facets 121 | args.facets <- subsetArgsByFormals(args, facet_grid, facet_wrap) 122 | facet <- do.call(facet_grid, args.facets) 123 | 124 | args.non$data <- df 125 | if(geom == "bar") 126 | p <- stat_bin_geom_bar(args.aes, args.non) 127 | if(geom == "heatmap") 128 | p <- stat_bin_geom_heatmap(args.aes, args.non, binwidth) 129 | labels <- Labels(xlab, ylab, main, fallback = c(x = "x", y = "y")) 130 | p <- c(p, labels) 131 | p <- c(list(p), list(facet)) 132 | p <- setStat(p) 133 | p 134 | }) 135 | -------------------------------------------------------------------------------- /man/plotRangesLinkedToData.Rd: -------------------------------------------------------------------------------- 1 | \name{plotRangesLinkedToData} 2 | \alias{plotRangesLinkedToData} 3 | \alias{plotRangesLinkedToData,RangedSummarizedExperiment-method} 4 | \alias{plotRangesLinkedToData,GenomicRanges_OR_GRangesList-method} 5 | \title{Plot Ranges Linked with Data} 6 | \description{ 7 | Plot GRanges object structure and linked to a even spaced paralell 8 | coordinates plot which represting the data in elementeMetadata. 9 | } 10 | \usage{ 11 | \S4method{plotRangesLinkedToData}{RangedSummarizedExperiment}(data, ..., 12 | stat.y = seq_len(ncol(data)), stat.ylab = names(assays(data)[stat.assay]), 13 | stat.assay = 1L) 14 | 15 | \S4method{plotRangesLinkedToData}{GenomicRanges_OR_GRangesList}(data, ..., 16 | stat.y = seq_len(ncol(mcols(data))), 17 | stat.ylab, sig, sig.col = c("black", "red"), 18 | stat.coord.trans = coord_trans(), 19 | annotation = list(), width.ratio = 0.8, 20 | theme.stat = theme_gray(), theme.align = theme_gray(), 21 | linetype = 3, heights) 22 | 23 | 24 | 25 | 26 | } 27 | \arguments{ 28 | \item{data}{ 29 | GRanges object with a DataFrame as elementMetadata. 30 | } 31 | \item{...}{ 32 | Parameters passed to control lines in top plot. 33 | } 34 | \item{stat.y}{ 35 | integer (variable position starting in DataFrame of data, start from 36 | 1) or strings (variable names) which indicate the column names. 37 | } 38 | \item{stat.ylab}{ 39 | y label for stat track(the top track). 40 | } 41 | \item{stat.assay}{ 42 | default 1L, element of assays. 43 | } 44 | \item{sig}{ 45 | a character of element meta data column of logical value, indicates 46 | which row is signficant. and will be shown in link lines and rectangle. 47 | } 48 | \item{sig.col}{ 49 | colors for significant, valid when you specify "sig" argument, the 50 | first color indicates \code{FALSE}, non-significant, the second 51 | color indicates \code{TRUE}. 52 | } 53 | \item{stat.coord.trans}{ 54 | transformation used for top plot. 55 | } 56 | \item{annotation}{ 57 | A list of ggplot object. 58 | } 59 | \item{width.ratio}{ 60 | Control the segment length of statistic layer. 61 | } 62 | \item{theme.stat}{ 63 | top plot theme. 64 | } 65 | \item{theme.align}{ 66 | alignment themes. 67 | } 68 | \item{linetype}{ 69 | linetype 70 | } 71 | \item{heights}{ 72 | Heights of each track. 73 | } 74 | } 75 | \value{ 76 | return a frame grob; side-effect (plotting) if plot=T. 77 | } 78 | \details{ 79 | Inspired by some graphics produced in some other packages, for example 80 | in package DEXseq, the author provides graphics with gene 81 | models and linked to an even spaced statistics summary. This is useful 82 | because we always plot everything along the genomic coordinates, but 83 | genomic features like exons are not evenly distributed, so we could 84 | actually treat the statistics associated with exons like categorical 85 | data, and show them as "Paralell Coordinates Plots". This is one 86 | special layout which represent the data in a nice manner and also keep 87 | the genomic structure information. With abliity of \code{tracks}, 88 | it's possible to generate such type of a graphic along with other 89 | annotations. 90 | 91 | The data we want is a normal \code{GRanges} object, and make sure 92 | the intervals are not overlaped with each other(currently), and you 93 | may have multiple columns which store the statistics for multiple 94 | samples, then we produce the graphic we introduced above and users 95 | could pass other annotation track in the function which will be shown 96 | below the main linked track. 97 | 98 | The reason you need to pass annotation into the function instead of 99 | binding them by \code{tracks} later is because binding manually 100 | with annotation tracks is tricky and this function doesn't return a 101 | ggplot object. 102 | } 103 | \examples{ 104 | library(TxDb.Hsapiens.UCSC.hg19.knownGene) 105 | library(ggbio) 106 | data(genesymbol, package = "biovizBase") 107 | txdb <- TxDb.Hsapiens.UCSC.hg19.knownGene 108 | model <- exonsBy(txdb, by = "tx") 109 | model17 <- subsetByOverlaps(model, genesymbol["RBM17"]) 110 | exons <- exons(txdb) 111 | exon17 <- subsetByOverlaps(exons, genesymbol["RBM17"]) 112 | ## reduce to make sure there is no overlap 113 | ## just for example 114 | exon.new <- reduce(exon17) 115 | ## suppose 116 | values(exon.new)$sample1 <- rnorm(length(exon.new), 10, 3) 117 | values(exon.new)$sample2 <- rnorm(length(exon.new), 10, 10) 118 | values(exon.new)$score <- rnorm(length(exon.new)) 119 | values(exon.new)$significant <- sample(c(TRUE,FALSE), size = length(exon.new),replace = TRUE) 120 | 121 | plotRangesLinkedToData(exon.new, stat.y = c("sample1", "sample2")) 122 | plotRangesLinkedToData(exon.new, stat.y = 1:2) 123 | plotRangesLinkedToData(exon.new, stat.y = 1:2, size = 3, linetype = 4) 124 | plotRangesLinkedToData(exon.new, stat.y = 1:2, size = 3, linetype = 4, 125 | sig = "significant") 126 | plotRangesLinkedToData(exon.new, stat.y = 1:2, size = 3, linetype = 4, 127 | sig = "significant", sig.col = c("gray90","red")) 128 | } 129 | \author{Tengfei Yin} 130 | 131 | -------------------------------------------------------------------------------- /R/plotGrandLinear.R: -------------------------------------------------------------------------------- 1 | plotGrandLinear <- function(obj, ..., facets, space.skip = 0.01, geom = NULL, 2 | cutoff = NULL, cutoff.color = "red", 3 | cutoff.size = 1, legend = FALSE, xlim, ylim, 4 | xlab, ylab, main, 5 | highlight.gr = NULL, 6 | highlight.name = NULL, 7 | highlight.col = "red", 8 | highlight.label = TRUE, 9 | highlight.label.size = 5, 10 | highlight.label.offset = 0.05, 11 | highlight.label.col = "black", 12 | spaceline = FALSE){ 13 | 14 | if(is.null(geom)) 15 | geom <- "point" 16 | 17 | 18 | args <- list(...) 19 | args.aes <- parseArgsForAes(args) 20 | args.non <- parseArgsForNonAes(args) 21 | two.color <- c("#0080FF", "#4CC4FF") 22 | ## two.color <- c("gray20", "gray50") 23 | .is.seq <- FALSE 24 | if(!"colour" %in% names(args.aes)){ 25 | if(!any(c("color", "colour") %in% names(args.non))){ 26 | .color <- two.color 27 | args.aes$color <- as.name("seqnames") 28 | .is.seq <- TRUE 29 | }else{ 30 | if(length(args.non$color) > 1){ 31 | .color <- args.non$color 32 | args.aes$color <- as.name("seqnames") 33 | .is.seq <- TRUE 34 | args.non <- args.non[!names(args.non) %in% c("colour", "color")] 35 | } 36 | } 37 | }else{ 38 | if(quo_name(args.aes$colour) == "seqnames") 39 | args.aes$colour <- as.name("seqnames") 40 | } 41 | 42 | 43 | if(!"y" %in% names(args.aes)) 44 | stop("need to provide y") 45 | 46 | args.non$coord <- "genome" 47 | args.non$space.skip <- space.skip 48 | args.non$geom <- geom 49 | args.non$object <- obj 50 | 51 | 52 | aes.res <- do.call(aes, args.aes) 53 | p <- do.call(autoplot, c(list(aes.res), args.non)) 54 | 55 | if(!legend) 56 | p <- p + theme(legend.position = "none") 57 | 58 | if(!missing(ylab)) 59 | p <- p + ylab(ylab) 60 | if(!is.null(cutoff)) 61 | p <- p + geom_hline(yintercept = cutoff, color = cutoff.color, 62 | size = cutoff.size) 63 | 64 | chrs <- names(seqlengths(obj)) 65 | if(.is.seq){ 66 | N <- length(chrs) 67 | cols <- rep(.color, round(N/length(.color)) + 1)[1:N] 68 | names(cols) <- chrs 69 | p <- p + scale_color_manual(values = cols) 70 | } 71 | 72 | if(!missing(facets)){ 73 | args$facets <- facets 74 | args.facets <- subsetArgsByFormals(args, facet_grid, facet_wrap) 75 | facet <- .buildFacetsFromArgs(obj, args.facets) 76 | p <- p + facet 77 | } 78 | p <- p + theme(panel.grid.minor=element_blank()) 79 | ## highlights 80 | 81 | if(!is.null(highlight.gr)){ 82 | idx <- findOverlaps(obj, highlight.gr) 83 | .h.pos <- lapply(split(queryHits(idx), subjectHits(idx)), function(id){ 84 | gr <- GRanges(as.character(seqnames(p@data))[id][1], 85 | IRanges(start = min(start(p@data[id])), 86 | end = max(end(p@data[id])))) 87 | val <- max(as.numeric(values(p@data[id])[,quo_name(args.aes$y)])) 88 | val <- val * (1 + highlight.label.offset) 89 | values(gr)$val <- val 90 | gr 91 | }) 92 | .h.pos <- suppressWarnings(do.call("c", unname(.h.pos))) 93 | if(length(.h.pos)){ 94 | if(is.null(highlight.name)){ 95 | highlight.name <- names(highlight.gr) 96 | }else{ 97 | highlight.name <- values(highlight.gr)[,highlight.name] 98 | } 99 | p <- p + geom_point(data = mold(p@data[queryHits(idx)]), 100 | do.call(aes, list(x = substitute(midpoint), 101 | y = args.aes$y)), 102 | color = highlight.col) 103 | 104 | if(!is.null(highlight.name)){ 105 | 106 | 107 | seqlevels(.h.pos, pruning.mode="coarse") <- seqlevels(obj) 108 | suppressWarnings(seqinfo(.h.pos) <- seqinfo(obj)) 109 | .trans <- transformToGenome(.h.pos, space.skip = space.skip) 110 | values(.trans)$mean <- (start(.trans) + end(.trans))/2 111 | values(.trans)$names <- highlight.name 112 | p <- p + geom_text(data = mold(.trans), size = highlight.label.size, 113 | vjust = 0, color = highlight.label.col, 114 | do.call(aes, list(x = substitute(mean), 115 | y = as.name("val"), 116 | label = as.name("names")))) 117 | } 118 | 119 | }} 120 | if(spaceline){ 121 | vline.df <- p@ggplot$data 122 | vline.df <- do.call(rbind, by(vline.df, vline.df$seqnames, function(dd){ 123 | data.frame(start = min(dd$start), 124 | end = max(dd$end)) 125 | })) 126 | ## compute gap 127 | gap <- (vline.df$start[-1] + vline.df$end[-nrow(vline.df)])/2 128 | p <- p + geom_vline(xintercept = gap, alpha = 0.5, color = 'gray70') + theme(panel.grid = element_blank()) 129 | } 130 | if(!missing(main)) 131 | p <- p + labs(title = main) 132 | if(!missing(xlim)) 133 | p <- p + xlim(xlim) 134 | if(!missing(ylim)) 135 | p <- p + ylim(ylim) 136 | if(missing(xlab)) 137 | xlab <- "" 138 | p <- p + ggplot2::xlab(xlab) 139 | p 140 | } 141 | 142 | 143 | -------------------------------------------------------------------------------- /R/geom_rect-method.R: -------------------------------------------------------------------------------- 1 | ## TODO:: 2 | ## Let's load a RefSeq data 3 | ## naming the interval 4 | ## two mode? packed, full with name (default) 5 | ## reduce is just a stat transformation at lower level 6 | setGeneric("geom_rect", function(data, ...) standardGeneric("geom_rect")) 7 | 8 | setMethod("geom_rect", "ANY", function(data, ...){ 9 | ggplot2::geom_rect(data = data, ...) 10 | }) 11 | 12 | ## alignment should be convenient toggle with chevron... 13 | setMethod("geom_rect", "GRanges", function(data,..., 14 | xlab, ylab, main, 15 | facets = NULL, 16 | stat = c("stepping", "identity"), 17 | rect.height = NULL, 18 | group.selfish = TRUE){ 19 | 20 | 21 | ## make this by hand 22 | args <- list(...) 23 | args$facets <- facets 24 | args.aes <- parseArgsForAes(args) 25 | args.non <- remove_args(parseArgsForNonAes(args), "facets") 26 | es <- ifelse("extend.size" %in% names(args.non), args.non$extend.size, 0) 27 | facet <- build_facet(data, args) 28 | stat <- match.arg(stat) 29 | if(length(data)){ 30 | if(stat == "stepping"){ 31 | if(is.null(rect.height)) rect.height <- 0.4 32 | grl <- splitByFacets(data, facets) 33 | res <- endoapply(grl, make_addStepping, args.aes, group.selfish, extend.size = es) 34 | df <- mold(unlist(res)) 35 | 36 | args.aes <- remove_args(args.aes, c("xmin", "xmax", "ymin", "ymax", "data")) 37 | args.non <- remove_args(args.non, c("xmin", "xmax", "ymax", "ymax", "data", "facets")) 38 | gpn <- ifelse("group" %in% names(args), quo_name(args$group), "stepping") 39 | args.aes <- remove_args(args.aes, c("group", "size")) 40 | ## overcome 1 pixel problem 41 | args.aes.seg <- remove_args(args.aes, c("fill", "y", "xend", "yend", "x")) 42 | args.aes.seg <- c(args.aes.seg, list(x = substitute(start), 43 | xend = substitute(start), 44 | y = substitute(stepping - rect.height), 45 | yend = substitute(stepping + rect.height))) 46 | aes.res.seg <- do.call(aes, args.aes.seg) 47 | args.non.seg <- remove_args(args.non, "fill") 48 | args.res.seg <- c(list(data = df), list(aes.res.seg), args.non.seg) 49 | p <- list(do.call(ggplot2::geom_segment, args.res.seg)) 50 | args.aes <- c(args.aes, list(xmin = substitute(start), 51 | xmax = substitute(end), 52 | ymin = substitute(stepping - rect.height), 53 | ymax = substitute(stepping + rect.height))) 54 | aes.res <- do.call(aes, args.aes) 55 | aes.res <- remove_args(aes.res, "y") 56 | args.res <- c(list(data = df), list(aes.res), args.non) 57 | p <- c(p, list(do.call(ggplot2::geom_rect, args.res))) 58 | p <- .changeStrandColor(p, args.aes) 59 | .df.sub <- group_df(df, gpn) 60 | ## FIXME: 61 | y_scale <- scale_y_continuous_by_group(.df.sub, gpn, group.selfish) 62 | p <- c(p, y_scale) 63 | } 64 | 65 | if(stat == "identity"){ 66 | if(!"y" %in% names(args.aes)){ 67 | if(!all(c("ymin","ymax", "xmin", "xmax") %in% names(args.aes))){ 68 | stop("aes(xmin =, xmax= , ymin =, ymax= ) is required for stat 'identity', 69 | you could also specify aes(y =) only as alternative") 70 | }else{ 71 | args.aes.seg <- args.aes 72 | args.aes.seg$x <- args.aes$xmin 73 | args.aes.seg$xend <- args.aes$xmax 74 | args.aes.seg$y <- args.aes$ymin 75 | args.aes.seg$yend <- args.aes$ymax 76 | } 77 | }else{ 78 | .y <- quo_squash(args.aes$y) 79 | if(is.null(rect.height)){ 80 | rect.height <- diff(range(values(data)[,as.character(.y)]))/20 81 | } 82 | args.aes.seg <- args.aes 83 | mapping <- list(y = .y, rect.height = rect.height) 84 | args.aes.seg$x <- as.name("start") 85 | args.aes.seg$xend <- as.name("start") 86 | args.aes.seg$y <- substitute(y + rect.height, mapping) 87 | args.aes.seg$yend <- substitute(y - rect.height , mapping) 88 | 89 | args.aes$xmin <- as.name("start") 90 | args.aes$xmax <- as.name("end") 91 | args.aes$ymin <- substitute(y + rect.height, mapping) 92 | args.aes$ymax <- substitute(y - rect.height , mapping) 93 | } 94 | df <- mold(data) 95 | 96 | ## overcome 1 pixel problem 97 | args.aes.seg <- remove_args(args.aes.seg, c("group", "size", "fill", "xmin", "xmax", "ymin", "ymax")) 98 | aes.res.seg <- do.call(aes, args.aes.seg) 99 | args.non.seg <- remove_args(args.non, "fill") 100 | args.res.seg <- c(list(data = df), list(aes.res.seg), args.non.seg) 101 | p <- list(do.call(ggplot2::geom_segment, args.res.seg)) 102 | 103 | args.aes <- remove_args(args.aes, c("group", "size", "y")) 104 | aes.res <- do.call(aes, args.aes) 105 | 106 | args.res <- c(list(data = df), list(aes.res), args.non) 107 | p <- c(p, list(do.call(ggplot2::geom_rect, args.res))) 108 | p <- .changeStrandColor(p, args.aes) 109 | } 110 | }else{ 111 | p <- NULL 112 | } 113 | 114 | p <- c(list(p), list(facet)) 115 | 116 | if(identical(stat, "stepping")) 117 | labels <- Labels(xlab, ylab, main, fallback = c(x = "", y = "")) 118 | else labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 119 | 120 | p <- c(p, labels) 121 | p 122 | }) 123 | 124 | -------------------------------------------------------------------------------- /man/stat_aggregate-method.Rd: -------------------------------------------------------------------------------- 1 | \name{stat_aggregate} 2 | \alias{stat_aggregate} 3 | \alias{stat_aggregate,GRanges-method} 4 | \alias{stat_aggregate,missing-method} 5 | \alias{stat_aggregate,uneval-method} 6 | \title{Generates summaries on the specified windows} 7 | \description{ 8 | Generates summaries on the specified windows 9 | } 10 | \usage{ 11 | % for GRanges 12 | \S4method{stat_aggregate}{GRanges}(data, ..., xlab, ylab, main, by, FUN, 13 | maxgap=-1L, minoverlap=0L, 14 | type=c("any", "start", "end", "within", "equal"), 15 | select=c("all", "first", "last", "arbitrary"), 16 | y = NULL, window = NULL, facets = NULL, 17 | method = c("mean", "median","max", 18 | "min", "sum", "count", "identity"), 19 | geom = NULL) 20 | 21 | 22 | } 23 | \arguments{ 24 | \item{data}{ 25 | A \code{GRanges} or \code{data.frame} object. 26 | } 27 | \item{...}{ 28 | Arguments passed to plot function. such as aes() and color. 29 | } 30 | \item{xlab}{ 31 | Label for x 32 | } 33 | \item{ylab}{ 34 | Label for y 35 | } 36 | \item{main}{ 37 | Title for plot. 38 | } 39 | \item{by}{ 40 | An object with 'start', 'end', and 'width' methods. Passed to \code{aggreagate}. 41 | } 42 | \item{FUN}{ 43 | The function, found via 'match.fun', to be applied to each window of 44 | 'x'. Passed to \code{aggreagate}. 45 | } 46 | \item{maxgap, minoverlap, type}{ 47 | Used in the internal call to \code{findOverlaps()} to detect overlaps. 48 | See \code{?\link[IRanges]{findOverlaps}} in the \pkg{IRanges} package 49 | for a description of these arguments. 50 | } 51 | \item{select}{ 52 | It passed to \code{findOverlaps}. 53 | 54 | When \code{select} is \code{"all"} (the default), the results are 55 | returned as a \link{Hits} object. When \code{select} is \code{"first"}, 56 | \code{"last"}, or \code{"arbitrary"} the results are returned as an 57 | integer vector of length \code{query} containing the first, last, 58 | or arbitrary overlapping interval in \code{subject}, with \code{NA} 59 | indicating intervals that did not overlap any intervals in \code{subject}. 60 | 61 | If \code{select} is \code{"all"}, a \link{Hits} object is returned. 62 | For all other \code{select} the return value depends on the \code{drop} 63 | argument. When \code{select != "all" && !drop}, an \link{IntegerList} 64 | is returned, where each element of the result corresponds to a space in 65 | \code{query}. When\code{select != "all" && drop}, an integer vector is 66 | returned containing indices that are offset to align with the unlisted 67 | \code{query}. 68 | } 69 | \item{y}{ 70 | A character indicate the varialbe column for which aggregation is 71 | taken on, same as aes(y = ). 72 | } 73 | \item{window}{ 74 | Integer value indicate window size. 75 | } 76 | \item{facets}{ 77 | Faceting formula to use. 78 | } 79 | 80 | \item{method}{ 81 | customized method for aggregating, if FUN is not provided. 82 | } 83 | \item{geom}{ 84 | The geometric object to use display the data. 85 | } 86 | } 87 | \value{ 88 | A 'Layer'. 89 | } 90 | \examples{ 91 | library(GenomicRanges) 92 | set.seed(1) 93 | N <- 1000 94 | ## ====================================================================== 95 | ## simmulated GRanges 96 | ## ====================================================================== 97 | gr <- GRanges(seqnames = 98 | sample(c("chr1", "chr2", "chr3"), 99 | size = N, replace = TRUE), 100 | IRanges( 101 | start = sample(1:300, size = N, replace = TRUE), 102 | width = sample(70:75, size = N,replace = TRUE)), 103 | strand = sample(c("+", "-", "*"), size = N, 104 | replace = TRUE), 105 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 106 | sample = sample(c("Normal", "Tumor"), 107 | size = N, replace = TRUE), 108 | pair = sample(letters, size = N, 109 | replace = TRUE)) 110 | 111 | 112 | ggplot(gr) + stat_aggregate(mapping = aes(y = value)) 113 | ## or 114 | ## ggplot(gr) + stat_aggregate(y = "value") 115 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), window = 36) 116 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), select = "first") 117 | \dontrun{ 118 | ## no hits 119 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), select = "first", type = "within") 120 | } 121 | ggplot(gr) + stat_aggregate(window = 30, mapping = aes(y = value),fill = "gray40", geom = "bar") 122 | ggplot(gr) + stat_aggregate(window = 100, fill = "gray40", mapping = aes(y = value), 123 | method = "max", geom = "bar") 124 | 125 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), geom = "boxplot") 126 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), geom = "boxplot", window = 60) 127 | ## now facets need to take place inside stat_* geom_* for an accurate computation 128 | ggplot(gr) + stat_aggregate(mapping = aes(y = value), geom = "boxplot", window = 30, 129 | facets = sample ~ seqnames) 130 | ## FIXME: 131 | ## autoplot(gr, stat = "aggregate", aes(y = value), window = 36) 132 | ## autoplot(gr, stat = "aggregate", geom = "boxplot", aes(y = value), window = 36) 133 | } 134 | \author{Tengfei Yin} 135 | 136 | 137 | -------------------------------------------------------------------------------- /man/plotStackedOverview.Rd: -------------------------------------------------------------------------------- 1 | \name{plotStackedOverview} 2 | \alias{plotStackedOverview} 3 | \alias{plotKaryogram} 4 | \title{Plot stacked overview} 5 | \usage{ 6 | plotStackedOverview(obj, ..., xlab, ylab, main, geom = "rect", 7 | cytobands = FALSE, rescale = TRUE, 8 | rescale.range = c(0, 10)) 9 | plotKaryogram(obj, ..., xlab, ylab, main, geom = "rect", 10 | cytobands = FALSE, rescale = TRUE, 11 | rescale.range = c(0, 10)) 12 | } 13 | \description{ 14 | Plot stacked overview for genome with or without cytobands. It's a 15 | wrapper around \code{layout_karyogram}. 16 | } 17 | \arguments{ 18 | \item{obj}{ 19 | a \code{GRanges} object, which could contain extra 20 | information about cytobands. If it's missing, will ask user to 21 | provide species information and download proper data set from UCSC. 22 | If you want an accurate genome mapping, please provide 23 | \code{seqlengths} with this \code{GRanges} object,otherwise it will 24 | emit a warning and use data space to estimate the chromosome space 25 | which is very rough. 26 | } 27 | \item{...}{ 28 | arguments passed to graphic functions to control aesthetics. For 29 | example, if you use geom "point", you need to provide "y" in 30 | \code{aes()}, and if can also pass \code{color, fill, size} etc. to 31 | control graphics. 32 | } 33 | \item{xlab}{ 34 | label for x 35 | } 36 | \item{ylab}{ 37 | label for y 38 | } 39 | \item{main}{ 40 | title for plot. 41 | } 42 | \item{geom}{ 43 | geom plotted on the stacked layout. Default is "rect", which showing 44 | interval data as rectangles. It automatically figures out boundary 45 | so you don't have to provide information in \code{aes}, users could specify other supported 46 | geom works for \code{data.frame}. 47 | } 48 | \item{cytobands}{ 49 | logical value. Default is \code{FALSE}. If \code{TRUE}, plotting cytobands, this 50 | require your data have arbitrary column as \code{name} and 51 | \code{gieStain}. the easiest way is to use \code{getIdeogram} to get 52 | your data. Notice for this function, when cytobands is \code{TRUE}, 53 | it will only plot cytobands without overlaying your data. If you 54 | really need to overlay extra data on cytobands, please plus 55 | \code{layout_karyogram} for that purpose. 56 | } 57 | \item{rescale}{ 58 | logical value. Default is \code{TRUE}, which rescale your data into 59 | the \code{rescale.range}, this make sure your data will not be 60 | plotted outside the stacked overview box. 61 | } 62 | \item{rescale.range}{ 63 | Numeric range of length 2. Default is (0, 10), because stacked 64 | layout draws a white background as chromosome space and this space 65 | is of height 10. We hide the y-axis since we don't need it for 66 | stacked overview. Sometime users may want to leave some margin for 67 | their data, they can use this arguments to control the rescale. 68 | } 69 | } 70 | \details{ 71 | Stacked overview is just a arbitrary layout for karyogram 72 | layout, it use facets seqnaems ~ . as default to stack the genome. For 73 | accurate mapping, you need to provide \code{seqlengths} information in 74 | your \code{GRanges} object. Otherwise, data space will be computed for 75 | stacked overview chromosome background, this is _NOT_ the actual 76 | chromosome space!. 77 | } 78 | \value{ 79 | A \code{ggplot} object. 80 | } 81 | \author{Tengfei Yin} 82 | \examples{ 83 | \dontrun{ 84 | library(biovizBase) 85 | data(hg19IdeogramCyto, package = "biovizBase") 86 | library(GenomicRanges) 87 | 88 | ## you can also get ideogram by biovizBase::getIdeogram 89 | 90 | ## make shorter and clean labels 91 | old.chrs <- seqnames(seqinfo(hg19IdeogramCyto)) 92 | new.chrs <- gsub("chr", "", old.chrs) 93 | ## lst <- as.list(new.chrs) 94 | names(new.chrs) <- old.chrs 95 | library(GenomeInfoDb) # for renameSeqlevels() and keepSeqlevels() 96 | new.ideo <- renameSeqlevels(hg19IdeogramCyto, new.chrs) 97 | new.ideo <- keepSeqlevels(new.ideo, c(as.character(1:22) , "X", "Y")) 98 | new.ideo 99 | 100 | 101 | ## sample data 102 | data(darned_hg19_subset500, package = "biovizBase") 103 | idx <- is.na(values(darned_hg19_subset500)$exReg) 104 | values(darned_hg19_subset500)$exReg[idx] <- "unknown" 105 | 106 | ## you need to add seqlengths for accruate mapping 107 | chrnames <- unique(as.character(seqnames(darned_hg19_subset500))) 108 | data(hg19Ideogram, package = "biovizBase") 109 | seqlengths(darned_hg19_subset500) <- seqlengths(hg19Ideogram)[sort(chrnames)] 110 | 111 | 112 | dn <- darned_hg19_subset500 113 | values(dn)$score <- rnorm(length(dn)) 114 | 115 | ## plotStackedOverview is a simple wrapper around this functions to 116 | create a stacked layout 117 | plotStackedOverview(new.ideo, cytobands = TRUE) 118 | 119 | plotStackedOverview(dn) 120 | plotStackedOverview(dn, aes(color = exReg, fill = exReg)) 121 | ## this will did the trick for you to rescale the space 122 | plotStackedOverview(dn, aes(x = midpoint, y = score), geom = "line") 123 | plotStackedOverview(dn, aes(x = midpoint, y = score), geom = "line", rescale.range = c(4, 6)) 124 | ## no rescale 125 | plotStackedOverview(dn, aes(x = midpoint, y = score), geom = "line", rescale = FALSE, 126 | xlab = "xlab", ylab = "ylab", main = "main") + ylab("ylab") 127 | 128 | ## no object? will ask you for species and query the data on the fly 129 | plotStackedOverview() 130 | plotStackedOverview(cytobands = TRUE) 131 | } 132 | } 133 | 134 | -------------------------------------------------------------------------------- /R/geom_arrow-method.R: -------------------------------------------------------------------------------- 1 | ## FIXME: the group.selfish doesn't work 2 | setGeneric("geom_arrow", function(data, ...) standardGeneric("geom_arrow")) 3 | 4 | setMethod("geom_arrow", "GRanges", function(data, ..., 5 | xlab, ylab, main, 6 | angle = 30, 7 | length = unit(0.12, "cm"), 8 | type = "open", 9 | stat = c("stepping", "identity"), 10 | facets = NULL, arrow.rate = 0.03, 11 | group.selfish = TRUE){ 12 | 13 | 14 | 15 | ## remove width = 1 16 | idx <- width(data) > 1 17 | data <- data[idx] 18 | stat <- match.arg(stat) 19 | ## shape <- match.arg(shape) 20 | arrow.r <- max(1L, round(width(range(ranges(data))) * arrow.rate, 0)) 21 | 22 | args <- list(...) 23 | args$facets <- facets 24 | 25 | args.aes <- parseArgsForAes(args) 26 | args.non <- remove_args(parseArgsForNonAes(args), c("fill", "facets")) 27 | 28 | 29 | facet <- build_facet(data, args) 30 | 31 | if(length(data)){ 32 | ## small arrow 33 | if(stat == "stepping"){ 34 | if(!"stepping" %in% colnames(values(data))){ 35 | grl <- splitByFacets(data, facets) 36 | res <- endoapply(grl, make_addStepping, args.aes, group.selfish) 37 | data <- unlist(res) 38 | } 39 | df <- mold(data) 40 | lst <- apply(df, 1, function(x){ 41 | x <- as.data.frame(t(x)) 42 | x.s <- as.numeric(as.character(x$start)) 43 | x.e <- as.numeric(as.character(x$end)) 44 | N <- (x.e - x.s) %/% arrow.r 45 | N <- ifelse(N <= 2, 2, N ) 46 | res <- approx(c(x.s, x.e), 47 | rep(as.numeric(as.character(x$stepping)), 2),n = N) 48 | res.df <- do.call(rbind,lapply(1:N, function(i){ 49 | x 50 | })) 51 | res.df$temp.x <- res$x 52 | .res <- res.df[-N,] 53 | .res$temp.x2 <- res.df[-1, "temp.x"] 54 | .res 55 | }) 56 | res <- do.call(rbind,lst) 57 | res$stepping <- as.numeric(res$stepping) 58 | args.aes$x <- as.name("temp.x") 59 | args.aes$xend <- as.name("temp.x2") 60 | args.aes$y <- args.aes$yend <- as.name("stepping") 61 | 62 | ## need to split to two direction/maybe three? 63 | p <- by2(res, res$strand, function(x){ 64 | s <- unique(as.character(x$strand)) 65 | aes.temp <- do.call(aes, args.aes) 66 | aes.temp <- remove_args(aes.temp, "fill") 67 | if (identical(s, "+")) { 68 | args.non$arrow <- arrow(length = length, ends = "last", 69 | type = type, angle = angle) 70 | } else if (identical(s, "-")) { 71 | args.non$arrow <- arrow(length = length, ends = "first", 72 | type = type, angle = angle) 73 | } 74 | p <- do.call(ggplot2::geom_segment, c(list(data = x), list(aes.temp), args.non)) 75 | p 76 | }) 77 | } 78 | if(stat == "identity"){ 79 | if(!"y" %in% names(args.aes)){ 80 | if(!all(c("x","xend", "y", "yend") %in% names(args.aes))){ 81 | stop("aes(x =, xend= , y =, yend= ) is required for stat 'identity', 82 | you could also specify aes(y =) only as alternative") 83 | } 84 | }else{ 85 | .y <- args.aes$y 86 | args.aes$x <- as.name("start") 87 | args.aes$xend <- as.name("end") 88 | args.aes$y <- args.aes$yend <- .y 89 | } 90 | 91 | df <- mold(data) 92 | 93 | lst <- lapply(split(df, seq_len(nrow(df))), function(x){ 94 | x.s <- x$start 95 | x.e <- x$end 96 | N <- (x.e - x.s) %/% arrow.r 97 | N <- ifelse(N <= 2, 2, N ) 98 | res <- approx(c(x.s, x.e ), 99 | rep(0, 2),n = N) 100 | res.df <- x[rep(1L, N),] 101 | res.df$start <- res$x 102 | .res <- res.df[-N,] 103 | .res$end <- res.df[-1L, "start"] 104 | .res 105 | }) 106 | res <- do.call(rbind,lst) 107 | 108 | p <- by2(res, res$strand, function(x){ 109 | s <- unique(as.character(x$strand)) 110 | p <- switch(s, 111 | "+" = { 112 | args.non$arrow <- arrow(length = length, ends = "last", 113 | type = type, angle = angle) 114 | aes.temp <- do.call(aes, args.aes) 115 | do.call(ggplot2::geom_segment, c(list(data = x), list(aes.temp), args.non)) 116 | 117 | }, 118 | "-" = { 119 | args.non$arrow <- arrow(length = length, ends = "first", 120 | type = type, angle = angle) 121 | aes.temp <- do.call(aes, args.aes) 122 | do.call(ggplot2::geom_segment, c(list(data = x), list(aes.temp), args.non)) 123 | }, 124 | "*" = { 125 | aes.temp <- do.call(aes, args.aes) 126 | do.call(ggplot2::geom_segment, c(list(data = x), list(aes.temp), args.non)) 127 | }) 128 | p 129 | }) 130 | } 131 | }else{ 132 | p <- NULL 133 | } 134 | p <- c(list(p) , list(facet)) 135 | 136 | labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 137 | p <- c(p, labels) 138 | p 139 | 140 | }) 141 | 142 | 143 | -------------------------------------------------------------------------------- /man/layout_circle-method.Rd: -------------------------------------------------------------------------------- 1 | \name{layout_circle} 2 | \alias{circle} 3 | \alias{layout_circle} 4 | \alias{layout_circle,GRanges-method} 5 | \alias{layout_circle,missing-method} 6 | \alias{layout_circle,uneval-method} 7 | \title{Create a circle layout} 8 | \description{ 9 | Create a circle layout. 10 | } 11 | \usage{ 12 | \S4method{layout_circle}{GRanges}(data, ..., geom = c("point", "line", "link", "ribbon", 13 | "rect", "bar", "segment", "hist", "scale", "heatmap", "ideogram", 14 | "text"), linked.to, radius = 10, trackWidth = 5, 15 | space.skip = 0.015, direction = c("clockwise", 16 | "anticlockwise"), link.fun = function(x, y, n = 30) 17 | bezier(x, y, evaluation = n), rect.inter.n = 60, rank, 18 | ylim = NULL, 19 | scale.n = 60, scale.unit = NULL, scale.type = c("M", 20 | "B", "sci"), grid.n = 5, grid.background = "gray70", 21 | grid.line = "white", grid = FALSE, chr.weight = NULL) 22 | 23 | \S4method{layout_circle}{missing}(data, ...) 24 | circle(...) 25 | } 26 | \arguments{ 27 | \item{data}{ 28 | A \code{GRanges} object. 29 | } 30 | \item{...}{ 31 | Extra parameters such as aesthetics mapping in aes(), or 32 | \code{color, size}, etc. For circle function, it passed to \code{layout_circle}. 33 | } 34 | \item{geom}{ 35 | The geometric object to use display the data. 36 | } 37 | \item{linked.to}{ 38 | Character indicates column that specifying end of the linking lines, 39 | that column should be a \code{GRanges} object. 40 | } 41 | \item{radius}{ 42 | Numeric value indicates radius. Default is 10. 43 | } 44 | \item{trackWidth}{ 45 | Numeric value indicates the track width. 46 | } 47 | \item{space.skip}{ 48 | Numeric value indicates the ratio of skipped region between chunks(chromosomes 49 | in \code{GRanges}) to the whole track space. 50 | } 51 | \item{direction}{ 52 | Space layout orders. 53 | } 54 | \item{link.fun}{ 55 | Function used for interpolate the linking lines. Default is Hmisc::bezier. 56 | } 57 | \item{rect.inter.n}{ 58 | n passed to interpolate function in rectangle transformation(from a 59 | rectangle) to a section in circular view. 60 | } 61 | \item{rank}{ 62 | For default equal trackWidth, use rank to specify the circle orders. 63 | } 64 | \item{ylim}{ 65 | Numeric range to control y limits. 66 | } 67 | \item{scale.n}{ 68 | Approximate number of ticks you want to show on the whole 69 | space. used when scale.unit is \code{NULL}. 70 | } 71 | \item{scale.unit}{ 72 | Unit used for computing scale. Default is \code{NULL}, 73 | } 74 | \item{scale.type}{ 75 | Scale type used for 76 | } 77 | \item{grid}{ 78 | logical value indicate showing grid background for track or not. 79 | } 80 | \item{grid.n}{ 81 | integer value indicate horizontal grid line number. 82 | } 83 | \item{grid.background}{ 84 | grid background color. 85 | } 86 | \item{grid.line}{ 87 | grid line color. 88 | } 89 | \item{chr.weight}{ 90 | numeric vectors which sum to <1, the names of vectors has to be 91 | matched with seqnames in seqinfo, and you can only specify part of the 92 | seqnames, other lengths of chromosomes will be assined proportionally 93 | to their seqlengths, for example, you could specify chr1 to be 0.5, so 94 | the chr1 will take half of the space and other chromosomes squeezed to 95 | take left of the space. 96 | } 97 | 98 | } 99 | \value{ 100 | A 'Layer'. 101 | } 102 | \examples{ 103 | N <- 100 104 | library(GenomicRanges) 105 | ## ====================================================================== 106 | ## simmulated GRanges 107 | ## ====================================================================== 108 | gr <- GRanges(seqnames = 109 | sample(c("chr1", "chr2", "chr3"), 110 | size = N, replace = TRUE), 111 | IRanges( 112 | start = sample(1:300, size = N, replace = TRUE), 113 | width = sample(70:75, size = N,replace = TRUE)), 114 | strand = sample(c("+", "-", "*"), size = N, 115 | replace = TRUE), 116 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 117 | sample = sample(c("Normal", "Tumor"), 118 | size = N, replace = TRUE), 119 | pair = sample(letters, size = N, 120 | replace = TRUE)) 121 | 122 | 123 | seqlengths(gr) <- c(400, 500, 700) 124 | values(gr)$to.gr <- gr[sample(1:length(gr), size = length(gr))] 125 | 126 | ## doesn't pass gr to the ggplot 127 | ggplot() + layout_circle(gr, geom = "ideo", fill = "gray70", radius = 7, trackWidth = 3) + 128 | layout_circle(gr, geom = "bar", radius = 10, trackWidth = 4, aes(fill = score, y = score)) + 129 | layout_circle(gr, geom = "point", color = "red", radius = 14, 130 | trackWidth = 3, grid = TRUE, aes(y = score)) + 131 | layout_circle(gr, geom = "link", linked.to = "to.gr", radius = 6, 132 | trackWidth = 1) 133 | 134 | ## more formal API 135 | ggplot(gr) + layout_circle(geom = "ideo", fill = "gray70", radius = 7, trackWidth = 3) + 136 | layout_circle(geom = "bar", radius = 10, trackWidth = 4, mapping = aes(fill = score, y = score)) + 137 | layout_circle(geom = "point", color = "red", radius = 14, 138 | trackWidth = 3, grid = TRUE, mapping = aes(y = score)) + 139 | layout_circle(geom = "link", linked.to = "to.gr", radius = 6, trackWidth = 1) 140 | 141 | } 142 | \author{Tengfei Yin} 143 | 144 | -------------------------------------------------------------------------------- /R/stat_mismatch-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("stat_mismatch", function(data, ...) standardGeneric("stat_mismatch")) 2 | 3 | setMethod("stat_mismatch", "GRanges", function(data, ..., bsgenome, 4 | xlab, ylab, main, 5 | geom = c("segment", "bar"), 6 | show.coverage = TRUE){ 7 | geom <- match.arg(geom) 8 | args <- list(...) 9 | 10 | ## args <- force(args) 11 | args.aes <- parseArgsForAes(args) 12 | args.non <- parseArgsForNonAes(args) 13 | args.facets <- subsetArgsByFormals(args, facet_grid, facet_wrap) 14 | 15 | isPileupSum <- function(obj){ 16 | if(is(obj, "GRanges")){ 17 | all(c("read", "ref", "count", "depth", "match") %in% colnames(values(obj))) 18 | }else if(is(obj, "data.frame")){ 19 | all(c("read", "ref", "count", "depth", "match") %in% colnames(obj)) 20 | }else{ 21 | FALSE 22 | } 23 | } 24 | if(length(data)){ 25 | if(!isPileupSum(data)) 26 | stop("For geom mismatch summary, data must returned from 27 | biovizBase::pileupGRangesAsVariantTable function. Or is a GRanges 28 | object including arbitrary columns: read, ref, count, depth, 29 | match") 30 | 31 | 32 | 33 | 34 | ## df <- as.data.frame(data) 35 | df <- mold(data) 36 | df.unmatch <- df[!df$match, ] 37 | ## add two end point? 38 | pos <- min(df$start):max(df$end) 39 | idx <- ! (pos %in% df$start) 40 | if(sum(idx)){ 41 | df.bg <- df[,c("seqnames", "start", "end", "width", "strand", "depth")] 42 | df.bg.extra <- data.frame(seqnames = unique(as.character(df.bg$seqnames)), 43 | start = pos[idx], 44 | end = pos[idx], 45 | width = 1, 46 | strand = "*", 47 | depth = 0) 48 | df.bg <- rbind(df.bg, df.bg.extra) 49 | }else{ 50 | df.bg <- df 51 | } 52 | df.bg <- df.bg[order(df.bg$start),] 53 | df.bg <- rbind(df.bg[1,], df.bg) 54 | df.bg <- rbind(df.bg, df.bg[nrow(df.bg),]) 55 | df.bg[c(1, nrow(df.bg)),]$depth <- 0 56 | addLevels <- function(x){ 57 | idx <- order(x$start, x$read) 58 | ## assumption: on the same chromosome 59 | x <- x[idx,] 60 | eds <- unlist(by(x$count, x$start, function(x){ 61 | cumsum(x) 62 | })) 63 | eds <- as.numeric(eds) 64 | sts <- unlist(by(x$count, x$start, function(x){ 65 | N <- length(x) 66 | c(0,cumsum(x)[-N]) 67 | })) 68 | sts <- as.numeric(sts) 69 | x$eds <- eds 70 | x$sts <- sts 71 | x 72 | } 73 | df.unmatch <- addLevels(df.unmatch) 74 | idx <- order(df.bg$start) 75 | df.bg <- df.bg[idx,] 76 | ## p <- ggplot(df.bg) 77 | args.aes$x <- as.name("start") 78 | args.aes$y <- as.name("depth") 79 | aes.res <- do.call(aes, args.aes) 80 | args.non$fill <- I("gray70") 81 | args.res <- c(list(data = df.bg), 82 | list(aes.res), 83 | args.non) 84 | if(show.coverage) 85 | p <- list(do.call(ggplot2::geom_polygon, args.res)) 86 | else 87 | p <- NULL 88 | DNABasesColor <- getBioColor("DNA_BASES_N") 89 | if(geom == "segment"){ 90 | p <- c(p, list(ggplot2::geom_segment(data = df.unmatch, aes(x = start, y = sts, 91 | xend = start, yend = eds, color = read))), 92 | list(scale_color_manual(values = DNABasesColor))) 93 | } 94 | if(geom == "bar"){ 95 | p <- c(p, list(ggplot2::geom_rect(data = df.unmatch, aes(xmin = start-0.5, ymin = sts, 96 | xmax = start+0.5, ymax = eds, color = read, 97 | fill = read))), 98 | list(scale_color_manual(values = DNABasesColor)), 99 | list(scale_fill_manual(values = DNABasesColor))) 100 | } 101 | }else{ 102 | p <- NULL 103 | } 104 | ## p <- c(p, list(xlab("Genomic Coordinates")), list(ylab("Counts"))) 105 | if(!missing(xlab)) 106 | p <- c(p, list(ggplot2::xlab(xlab))) 107 | else 108 | p <- c(p, list(ggplot2::xlab("Genomic Coordinates"))) 109 | 110 | if(!missing(ylab)) 111 | p <- c(p, list(ggplot2::ylab(ylab))) 112 | else 113 | p <- c(p, list(ggplot2::ylab("Counts"))) 114 | 115 | if(!missing(main)) 116 | p <- c(p, list(labs(title = main))) 117 | p <- setStat(p) 118 | p 119 | }) 120 | 121 | 122 | setMethod("stat_mismatch", "BamFile", function(data, ..., bsgenome, which, 123 | xlab, ylab, main, 124 | geom = c("segment", "bar"), 125 | show.coverage = TRUE){ 126 | if(missing(which)){ 127 | ## stop("missing which is not supported yet") 128 | p <- c(list(geom_blank()),list(ggplot2::ylim(c(0, 1))), 129 | list(ggplot2::xlim(c(0, 1)))) 130 | return(p) 131 | } 132 | 133 | geom <- match.arg(geom) 134 | if(missing(bsgenome)){ 135 | stop("For geom mismatch.summary, please provide bsgenome(A BSgenome object)") 136 | }else 137 | if(!is(bsgenome, "BSgenome")){ 138 | stop("bsgenome must be A BSgenome object") 139 | } 140 | data <- data$path 141 | pgr <- pileupAsGRanges(data, regions = which) 142 | if(length(pgr)){ 143 | pgr.match <- pileupGRangesAsVariantTable(pgr, bsgenome) 144 | p <- stat_mismatch(pgr.match, ..., show.coverage = show.coverage, geom = geom) 145 | }else{ 146 | p <- NULL 147 | } 148 | if(!missing(xlab)) 149 | p <- c(p, list(ggplot2::xlab(xlab))) 150 | else 151 | p <- c(p, list(ggplot2::xlab("Genomic Coordinates"))) 152 | 153 | if(!missing(ylab)) 154 | p <- c(p, list(ggplot2::ylab(ylab))) 155 | else 156 | p <- c(p, list(ggplot2::ylab("Counts"))) 157 | 158 | if(!missing(main)) 159 | p <- c(p, list(labs(title = main))) 160 | p <- setStat(p) 161 | p 162 | 163 | }) 164 | 165 | -------------------------------------------------------------------------------- /R/theme.R: -------------------------------------------------------------------------------- 1 | theme_null <- function(){theme_bw() + theme( 2 | axis.text.x=element_blank(), 3 | axis.text.y=element_blank(), 4 | axis.ticks=element_blank(), 5 | axis.title.x=element_blank(), 6 | axis.title.y=element_blank(), 7 | legend.background=element_rect(fill="white", colour=NA), 8 | legend.key=element_rect(colour="white"), 9 | panel.background=element_blank(), 10 | panel.border=element_blank(), 11 | panel.grid.major=element_blank(), 12 | panel.grid.minor=element_blank(), 13 | plot.background=element_blank(), 14 | strip.background = element_blank(), 15 | strip.text.y = element_blank(), 16 | strip.text.x = element_blank() 17 | )} 18 | 19 | 20 | 21 | ## TODO: with axis? 22 | 23 | theme_alignment <- function (ylabel = FALSE, base_size = 12, 24 | base_family = "", 25 | axis = TRUE, border = TRUE, grid = TRUE) 26 | { 27 | res <- theme_gray() + 28 | theme( 29 | axis.line = element_blank(), 30 | axis.text.y = {if(ylabel) 31 | element_text(family = base_family, size = base_size * 0.8, 32 | lineheight = 0.9, hjust = 1) 33 | else 34 | element_blank()}, 35 | axis.title.x = element_text(family = base_family, size = base_size, vjust = 1), 36 | axis.title.y = element_text(family = base_family, size = base_size, 37 | angle = 90, vjust = 0.5, colour = "white"), 38 | axis.ticks.length = unit(0.3, "lines"), 39 | axis.text = element_text(margin=margin_auto(0.5, unit = "lines")), 40 | panel.background = element_blank(), 41 | panel.border = {if(border) 42 | element_rect(fill = NA, colour = "grey50") 43 | else 44 | element_blank()}, 45 | panel.grid.major = {if(grid) 46 | element_line(colour = "grey90", linewidth = 0.2) 47 | else 48 | element_blank()}, 49 | panel.grid.minor = element_blank(), 50 | panel.spacing = unit(0.25, "lines"), 51 | strip.background = element_rect(fill = "grey80", colour = "grey50"), 52 | strip.text.x = element_text(family = base_family, size = base_size * 0.8), 53 | strip.text.y = element_text(family = base_family, 54 | size = base_size * 0.8, angle = -90), 55 | plot.background = element_rect(colour = NA), 56 | plot.title = element_text(family = base_family, size = base_size * 57 | 1.2), 58 | plot.margin = unit(c(1, 1, 0.5, 0.5), "lines")) 59 | if(!ylabel){ 60 | res <- list(res, list(scale_y_continuous(breaks = NULL))) 61 | } 62 | res 63 | } 64 | 65 | theme_pack_panels <- function(strip.bg = FALSE, strip.text.y = TRUE){ 66 | res <- theme(panel.background = element_blank(), 67 | panel.grid.major = element_blank(), 68 | panel.grid.minor = element_blank(), 69 | axis.text.y = element_blank(), 70 | strip.background = if(strip.bg){ 71 | element_rect(fill = "grey80", colour = NA) 72 | }else{ 73 | element_blank() 74 | }, 75 | strip.text.y = if(strip.text.y){element_text(angle = 0)}else{element_blank()}, 76 | panel.spacing = grid::unit(0, "lines")) 77 | res <- c(list(res), 78 | list(scale_y_continuous(breaks = NULL))) 79 | } 80 | 81 | theme_noexpand <- function(){ 82 | c(list(scale_x_continuous(expand = c(0, 0))), 83 | list(scale_y_continuous(expand = c(0, 0)))) 84 | } 85 | 86 | 87 | 88 | theme_clear <- function(grid.y = FALSE, 89 | grid.x.minor = FALSE, 90 | grid.x.major = FALSE, 91 | panel.background.fill = "white", 92 | panel.border.color = NA, 93 | axis.ticks.x = FALSE, 94 | axis.ticks.y = TRUE, 95 | grid.color = "gray95", 96 | axis.line.color = "gray80"){ 97 | 98 | res <- theme_gray() + theme(panel.background = element_rect(fill = NA, color = NA), 99 | panel.border = element_rect(fill = NA, color = panel.border.color)) 100 | if(!grid.y) 101 | res <- res + theme(panel.grid.major.y = element_blank(), 102 | panel.grid.minor.y = element_blank()) 103 | 104 | if(!grid.x.minor) 105 | res <- res + theme(panel.grid.minor.x = element_blank()) 106 | 107 | if(!grid.x.major) 108 | res <- res + theme(panel.grid.major.x = element_blank()) 109 | else 110 | res <- res + theme(panel.grid.major.x = element_line(color = grid.color)) 111 | 112 | if(!axis.ticks.x) 113 | res <- res + theme(axis.ticks.x = element_blank()) 114 | else 115 | res <- res + theme(axis.ticks.x = element_line(colour = "grey50")) 116 | if(!axis.ticks.y) 117 | res <- res + theme(axis.ticks.y = element_blank()) 118 | else 119 | res <- res + theme(axis.ticks.x = element_line(colour = "grey50")) 120 | 121 | res <- res + theme(axis.line = element_line(color = axis.line.color)) 122 | 123 | res 124 | } 125 | 126 | 127 | theme_tracks_sunset <- function(bg = "#fffedb", alpha = 1, ...){ 128 | res <- theme_clear(grid.x.major = FALSE, ...) 129 | attr(res, "track.plot.color") <- sapply(bg, scales::alpha, alpha) 130 | attr(res, "track.bg.color") <- bg 131 | attr(res, "label.text.color") <- "white" 132 | attr(res, "label.bg.fill") <- "#a52a2a" 133 | res 134 | } 135 | 136 | 137 | theme_tracks_fancy <- function(bg = c("white", "#F2C545"), alpha = 0.3, 138 | label.bg.fill = c("gray80", "darkblue"), 139 | label.text.color = "white"){ 140 | res <- theme_clear(grid.x.major = FALSE) 141 | attr(res, "track.plot.color") <- sapply(bg, scales::alpha, alpha) 142 | attr(res, "label.bg.fill") <- label.bg.fill 143 | attr(res, "label.text.color") <- label.text.color 144 | res 145 | } 146 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | ## Import 2 | ## ============================================================ 3 | 4 | import(methods) 5 | 6 | ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 7 | ### base packages 8 | ### 9 | 10 | importFrom(grid, convertUnit, editGrob, gList, gTree, gpar, grid.draw, 11 | grid.newpage, grobTree, is.unit, rectGrob, textGrob, unit.c) 12 | importFrom(grDevices, dev.off, png) 13 | importFrom(graphics, par) 14 | importFrom(stats, approx, as.formula, df) 15 | importFrom(utils, capture.output, getFromNamespace) 16 | 17 | ### 18 | import(ggplot2, except=Position) 19 | import(gtable) 20 | ### importFrom(gtable, gtable, gtable_add_grob, gtable_add_cols, gtable_add_rows, gtable_filter) 21 | importFrom(reshape2, melt) 22 | importFrom(scales, cbreaks, rescale, expand_range, math_format, 23 | scientific_format, trans_breaks, trans_format) 24 | importFrom(gridExtra, grid.arrange, arrangeGrob) 25 | importFrom(Hmisc, bezier) 26 | importFrom(rlang, eval_tidy, is_quosure, quo_name, quo_squash) 27 | 28 | ### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 29 | ### Bioconductor packages 30 | ### 31 | 32 | import(BiocGenerics) 33 | import(S4Vectors) 34 | import(IRanges) 35 | import(Seqinfo) 36 | import(GenomeInfoDb) 37 | import(GenomicRanges) 38 | import(SummarizedExperiment) 39 | import(biovizBase) 40 | 41 | ## Biobase 42 | importClassesFrom(Biobase, ExpressionSet, eSet, AssayData) 43 | importMethodsFrom(Biobase, exprs, pData, phenoData, varLabels) 44 | 45 | ## Biostrings 46 | importMethodsFrom(Biostrings, getSeq) 47 | 48 | ## Rsamtools 49 | importFrom(Rsamtools, BamFile) 50 | importMethodsFrom(Rsamtools, ScanBamParam, scanBamHeader) 51 | importClassesFrom(Rsamtools, BamFile, BamFileList) 52 | 53 | ## GenomicAlignments 54 | importMethodsFrom(GenomicAlignments, readGAlignments) 55 | importClassesFrom(GenomicAlignments, GAlignments) 56 | 57 | ## BSgenome 58 | importClassesFrom(BSgenome, BSgenome) 59 | 60 | ## rtracklayer 61 | importMethodsFrom(rtracklayer, import) 62 | importClassesFrom(rtracklayer, BigWigFile, UCSCData) 63 | 64 | ## GenomicFeatures 65 | importClassesFrom(GenomicFeatures, TxDb) 66 | importMethodsFrom(GenomicFeatures, exonsBy) 67 | 68 | ## VariantAnnotation 69 | importClassesFrom(VariantAnnotation, VCF) 70 | importMethodsFrom(VariantAnnotation, fixed, "fixed<-", ref, 71 | alt, info, geno) 72 | importFrom(VariantAnnotation, readVcf) 73 | 74 | ## OrganismDb 75 | importClassesFrom(OrganismDbi, OrganismDb) 76 | 77 | ## AnnotationDbi 78 | importFrom(AnnotationDbi, select) 79 | 80 | ## ensembldb 81 | importClassesFrom(ensembldb, EnsDb) 82 | ## Filter classes... 83 | importMethodsFrom(ensembldb, listColumns, exons, exonsBy) 84 | ## importFrom(ensembldb, GRangesFilter) 85 | 86 | ## AnnotationFilter 87 | importClassesFrom(AnnotationFilter, AnnotationFilter, AnnotationFilterList, 88 | CharacterFilter, IntegerFilter, GRangesFilter, ExonIdFilter, 89 | ExonNameFilter, GeneIdFilter, GeneNameFilter, GenenameFilter, 90 | GeneBiotypeFilter, EntrezFilter, SymbolFilter, TxIdFilter, 91 | TxNameFilter, TxBiotypeFilter, ProteinIdFilter, UniprotFilter, 92 | SeqNameFilter, SeqStrandFilter, CdsStartFilter, CdsEndFilter, 93 | ExonStartFilter, ExonRankFilter, ExonEndFilter, 94 | GeneStartFilter, GeneEndFilter, TxStartFilter, TxEndFilter, 95 | DoubleFilter) 96 | importFrom(AnnotationFilter, GRangesFilter) 97 | 98 | ## tools 99 | importFrom(tools, file_ext, file_path_sans_ext) 100 | 101 | ## ============================================================ 102 | ## Export 103 | ## ============================================================ 104 | ## utils 105 | exportMethods(autoplot, rescale, fixed, "fixed<-", 106 | xlim, "xlim<-", reset, backup, 107 | bgColor, "bgColor<-", labeled, "labeled<-", 108 | mutable, "mutable<-", height, "height<-", 109 | hasAxis, "hasAxis<-") 110 | 111 | 112 | export(arrangeGrobByParsingLegend, ggbio, GGbio) 113 | 114 | ## scale 115 | export(scale_x_sequnit, scale_fill_giemsa, scale_fill_fold_change) 116 | 117 | ## geom 118 | exportMethods(geom_chevron, 119 | geom_arch, 120 | geom_alignment, 121 | geom_arrow, 122 | geom_arrowrect, 123 | geom_rect, 124 | geom_bar, 125 | geom_segment) 126 | 127 | ## stat 128 | exportMethods(stat_aggregate, 129 | stat_coverage, 130 | stat_identity, 131 | stat_mismatch, 132 | stat_stepping, 133 | stat_gene, 134 | stat_table, 135 | stat_slice, 136 | stat_bin, 137 | stat_reduce) 138 | 139 | ## layout 140 | exportMethods(layout_karyogram, 141 | layout_circle) 142 | 143 | export(circle) 144 | ## coord 145 | ## exportMethods(coord_genome) 146 | export(tracks, 147 | align.plots, 148 | alignPlots, 149 | plotFragLength, 150 | plotSpliceSum, 151 | plotStackedOverview, 152 | plotKaryogram, 153 | plotIdeogram, 154 | Ideogram, 155 | plotGrandLinear, 156 | plotRangesLinkedToData) 157 | 158 | export(theme_null, theme_alignment, theme_clear, theme_tracks_sunset, 159 | theme_pack_panels, theme_noexpand, theme_genome) 160 | 161 | export(ggsave) 162 | exportMethods(cbind, rbind) 163 | exportClasses(GGbio, Ideogram, Plot, Tracked, Tracks, Grob) 164 | ## export(btextGrob, geom_text2, zoom, zoom_in, zoom_out, nextView, prevView) 165 | export(zoom, zoom_in, zoom_out, nextView, prevView) 166 | ## exportMethods(Grob, Plot, get_gtable, cached, "cached<-", 167 | ## cached_xlim, "cached_xlim<-", 168 | ## cached_ylim, "cached_ylim<-", 169 | ## cached_item, "cached_item<-", addItem, addWhich, 170 | ## cached_which, cbind, rbind) 171 | ## export(PlotList, Tracked, Plot, Grob) 172 | 173 | 174 | S3method(ggplot, Vector) 175 | S3method(ggplot, matrix) 176 | S3method(ggplot, ExpressionSet) 177 | S3method(ggplot, RsamtoolsFile) 178 | S3method(ggplot, character) 179 | S3method(ggplot, TxDbOREnsDb) 180 | S3method(ggplot, BSgenome) 181 | S3method(ggplot, SummarizedExperiment) 182 | S3method(ggplot, GAlignments) 183 | S3method(ggplot, VCF) 184 | S3method(ggplot, Seqinfo) 185 | -------------------------------------------------------------------------------- /man/geom_chevron-method.Rd: -------------------------------------------------------------------------------- 1 | \name{geom_chevron} 2 | \alias{geom_chevron} 3 | \alias{geom_chevron,GRanges-method} 4 | \alias{geom_chevron,missing-method} 5 | \alias{geom_chevron,uneval-method} 6 | \title{Chevron geoms for GRanges object} 7 | \description{ 8 | Break normal intervals stroed in \code{GRanges} object and show them 9 | as chevron, useful for showing model or splice summary. 10 | } 11 | \usage{ 12 | \S4method{geom_chevron}{GRanges}(data, ..., xlab, ylab, main, 13 | offset = 0.1, 14 | facets = NULL, 15 | stat = c("stepping", "identity"), 16 | chevron.height.rescale = c(0.1, 0.8), 17 | group.selfish = TRUE) 18 | } 19 | \arguments{ 20 | \item{data}{ 21 | A GRanges object. 22 | } 23 | \item{...}{ 24 | Extra parameters passed to autoplot function. 25 | } 26 | \item{xlab}{ 27 | Label for x 28 | } 29 | \item{ylab}{ 30 | Label for y 31 | } 32 | \item{main}{ 33 | Title for plot. 34 | } 35 | \item{offset}{ 36 | A nunmeric value or characters. If it's numeric value, indicate how 37 | much you want the chevron to wiggle, usually the rectangle for 38 | drawing \code{GRanges} is of height unit 1, so it's better between 39 | -0.5 and 0.5 to make it nice looking. Unless you specify offset as 40 | one of those columns, this will use height of the chevron to 41 | indicate the columns. Of course you could use size of the chevron to 42 | indicate the column variable easily, please see the examples. 43 | } 44 | \item{facets}{ 45 | faceting formula to use. 46 | } 47 | \item{stat}{ 48 | character vector specifying statistics to use. "stepping" with 49 | randomly assigned stepping levels as y varialbe. "identity" allow 50 | users to specify \code{y} value in \code{aes}. 51 | } 52 | \item{chevron.height.rescale}{ 53 | A numeric vector of length 2. When the offset parameters is a 54 | character which is one of the data columns, this parameter rescale 55 | the offset. 56 | } 57 | \item{group.selfish}{ 58 | Passed to \code{addStepping}, control whether to show each group as 59 | unique level or not. If set to \code{FALSE}, if two groups are not 60 | overlapped with each other, they will probably be layout in the same 61 | level to save space. 62 | } 63 | } 64 | \value{ 65 | A 'Layer'. 66 | } 67 | \details{ 68 | To draw a normal GRanges as Chevron, we need to provide a special geom for 69 | this purpose. Chevron is popular in gene viewer or genomoe browser, 70 | when they try to show isoforms or gene model.\code{geom_chevron}, 71 | just like any other \code{geom_*} function in ggplot2, you can pass 72 | aes() to it to use height of chevron or width 73 | of chevron to show statistics summary. 74 | } 75 | 76 | \examples{ 77 | set.seed(1) 78 | N <- 100 79 | require(GenomicRanges) 80 | 81 | ## ====================================================================== 82 | ## simmulated GRanges 83 | ## ====================================================================== 84 | gr <- GRanges(seqnames = 85 | sample(c("chr1", "chr2", "chr3"), 86 | size = N, replace = TRUE), 87 | IRanges( 88 | start = sample(1:300, size = N, replace = TRUE), 89 | width = sample(70:75, size = N,replace = TRUE)), 90 | strand = sample(c("+", "-", "*"), size = N, 91 | replace = TRUE), 92 | value = rnorm(N, 10, 3), score = rnorm(N, 100, 30), 93 | sample = sample(c("Normal", "Tumor"), 94 | size = N, replace = TRUE), 95 | pair = sample(letters, size = N, 96 | replace = TRUE)) 97 | 98 | 99 | 100 | ## ====================================================================== 101 | ## default 102 | ## 103 | ## ====================================================================== 104 | ggplot(gr) + geom_chevron() 105 | ## or 106 | ggplot() + geom_chevron(gr) 107 | 108 | 109 | ## ====================================================================== 110 | ## facetting and aesthetics 111 | ## ====================================================================== 112 | ggplot(gr) + geom_chevron(facets = sample ~ seqnames, mapping = aes(color = strand)) 113 | 114 | 115 | ## ====================================================================== 116 | ## stat:identity 117 | ## ====================================================================== 118 | ggplot(gr) + geom_chevron(stat = "identity", mapping = aes(y = value)) 119 | 120 | 121 | ## ====================================================================== 122 | ## stat:stepping 123 | ## ====================================================================== 124 | ggplot(gr) + geom_chevron(stat = "stepping", mapping = aes(group = pair)) 125 | 126 | 127 | ## ====================================================================== 128 | ## group.selfish controls when 129 | ## ====================================================================== 130 | ggplot(gr) + geom_chevron(stat = "stepping", mapping = aes(group = pair), group.selfish = FALSE, 131 | xlab = "xlab", ylab = "ylab", main = "main") 132 | 133 | p <- qplot(x = mpg, y = cyl, data = mtcars) 134 | 135 | ## ====================================================================== 136 | ## offset 137 | ## ====================================================================== 138 | gr2 <- GRanges("chr1", IRanges(c(1, 10, 20), width = 5)) 139 | gr2.p <- gaps(gr2) 140 | ## resize to connect them 141 | gr2.p <- resize(gr2.p, fix = "center", width = width(gr2.p)+2) 142 | 143 | ggplot(gr2) + geom_rect() + geom_chevron(gr2.p) 144 | 145 | 146 | ## notice the rectangle height is 0.8 147 | ## offset = 0 just like a line 148 | ggplot(gr2) + geom_rect() + geom_chevron(gr2.p, offset = 0) 149 | 150 | 151 | ## equal height 152 | ggplot(gr2) + geom_rect() + geom_chevron(gr2.p, offset = 0.4) 153 | 154 | 155 | ## ====================================================================== 156 | ## chevron.height 157 | ## ====================================================================== 158 | values(gr2.p)$score <- c(100, 200) 159 | ggplot(gr2) + geom_rect() + geom_chevron(gr2.p, offset = "score") 160 | ## chevron.height 161 | ggplot(gr2) + geom_rect() + geom_chevron(gr2.p, offset = "score", 162 | chevron.height.rescale = c(0.4, 10)) 163 | 164 | } 165 | \author{Tengfei Yin} 166 | 167 | -------------------------------------------------------------------------------- /R/geom_chevron-method.R: -------------------------------------------------------------------------------- 1 | setGeneric("geom_chevron", function(data, ...) standardGeneric("geom_chevron")) 2 | 3 | setMethod("geom_chevron", "GRanges", 4 | function(data, ..., 5 | xlab, ylab, main, 6 | offset = 0.1, facets = NULL, 7 | stat = c("stepping", "identity"), 8 | chevron.height.rescale = c(0.1, 0.8), 9 | group.selfish = TRUE){ 10 | 11 | stat <- match.arg(stat) 12 | 13 | args <- list(...) 14 | args$facets <- facets 15 | 16 | args.aes <- parseArgsForAes(args) 17 | args.non <- remove_args(parseArgsForNonAes(args), "facets") 18 | facet <- build_facet(data, args) 19 | if(length(data)) { 20 | if(stat == "stepping"){ 21 | group.name <- NULL 22 | if("group" %in% names(args.aes)) 23 | group.name <- quo_name(args.aes$group) 24 | if(!"stepping" %in% colnames(values(data))){ 25 | if(length(group.name)) 26 | data <- addStepping(data, group.name = group.name, 27 | group.selfish = group.selfish) 28 | else 29 | data <- addStepping(data) 30 | } 31 | aes.lst <- args.aes 32 | data.new <- breakGr(data) 33 | names(data.new) <- NULL 34 | df <- as.data.frame(data.new) 35 | 36 | if(!is.numeric(offset)){ 37 | offset <- as.character(offset) 38 | if(offset %in% colnames(values(data))) 39 | ydf <- getY2(df, offset, chevron.height.rescale) 40 | else 41 | stop("offset must be a numeric value or one of the colnames") 42 | }else{ 43 | ydf <- do.call("rbind", lapply(df$.bioviz.chevron, getY, offset)) 44 | } 45 | df <- cbind(df, ydf) 46 | args <- c(aes.lst, list(x = substitute(start), 47 | xend = substitute(end), 48 | y = substitute(stepping + y.offset), 49 | yend = substitute(stepping + yend.offset))) 50 | 51 | args.res <- c(list(data = df), list(do.call(aes, args)), 52 | args.non) 53 | p <- c(list(do.call(ggplot2::geom_segment, args.res)), list(ggplot2::ylab(""))) 54 | 55 | gpn <- ifelse("group" %in% names(args.aes), quo_name(args.aes$group), "stepping") 56 | 57 | .df.sub <- group_df(df, gpn) 58 | y_scale <- scale_y_continuous_by_group(.df.sub, gpn, group.selfish) 59 | p <- c(p, y_scale) 60 | } 61 | if(stat == "identity"){ 62 | if(!"y" %in% names(args.aes)){ 63 | if(!all(c("y","yend", "x", "xend") %in% names(args.aes))){ 64 | stop("aes(x =, xend= , y =, yend= ) is required for stat 'identity', 65 | you could also specify aes(y =) only as alternative") 66 | } 67 | }else{ 68 | .y <- args.aes$y 69 | args.aes$x <- as.name("start") 70 | args.aes$xend <- as.name("end") 71 | args.aes$y <- substitute(y + offset, 72 | list(y = .y, offset = as.name("y.offset"))) 73 | args.aes$yend <- substitute(yend + offset , 74 | list(yend = .y, offset = as.name("yend.offset"))) 75 | 76 | } 77 | 78 | data.new <- breakGr(data) 79 | names(data.new) <- NULL 80 | df <- as.data.frame(data.new) 81 | if(!is.numeric(offset)){ 82 | offset <- as.character(offset) 83 | if(offset %in% colnames(values(data))) 84 | ydf <- getY2(df, offset, chevron.height.rescale) 85 | else 86 | stop("offset must be a numeric value or one of the colnames") 87 | }else{ 88 | ydf <- do.call("rbind", lapply(df$.bioviz.chevron, getY, offset)) 89 | } 90 | df <- cbind(df, ydf) 91 | .y <- args.aes$y 92 | .yend <- args.aes$yend 93 | args.aes$y <- substitute(y + y.offset, list(y = .y)) 94 | args.aes$yend <- substitute(yend + yend.offset, list(yend = .yend)) 95 | args.res <- c(list(data = df), list(do.call(aes, args.aes)), args.non) 96 | p <- c(list(do.call(ggplot2::geom_segment, args.res)), 97 | list(ggplot2::ylab(""))) 98 | 99 | }}else{ 100 | p <- NULL 101 | } 102 | p <- c(list(p) , list(facet)) 103 | labels <- Labels(xlab, ylab, main, fallback = c(x = "")) 104 | p <- c(p, labels) 105 | p 106 | }) 107 | 108 | 109 | getY <- function(n, offset){ 110 | switch(n, 111 | { 112 | y.offset <- 0 113 | yend.offset <- offset 114 | data.frame(y.offset = y.offset, 115 | yend.offset = yend.offset) 116 | }, 117 | { 118 | y.offset <- offset 119 | yend.offset <- 0 120 | data.frame(y.offset = y.offset, 121 | yend.offset = yend.offset) 122 | }) 123 | } 124 | 125 | getY2 <- function(df, offset, chevron.height.rescale){ 126 | res <- df[,offset] 127 | os <- rescale(res, chevron.height.rescale) 128 | lst <- lapply(1:nrow(df), function(i){ 129 | n <- df[i,".bioviz.chevron"] 130 | switch(n, 131 | { 132 | y.offset <- 0 133 | yend.offset <- os[i] 134 | data.frame(y.offset = y.offset, 135 | yend.offset = yend.offset) 136 | }, 137 | { 138 | y.offset <- os[i] 139 | yend.offset <- 0 140 | data.frame(y.offset = y.offset, 141 | yend.offset = yend.offset) 142 | }) 143 | }) 144 | do.call("rbind", lst) 145 | } 146 | 147 | ## 148 | breakGr <- function(gr){ 149 | mids <- start(gr) + width(gr)/2 150 | res1 <- res2 <- gr 151 | end(res1) <- mids 152 | values(res1)$.bioviz.chevron <- 1 153 | start(res2) <- mids 154 | values(res2)$.bioviz.chevron <- 2 155 | res <- c(res1, res2) 156 | } 157 | 158 | --------------------------------------------------------------------------------