Commit 6478b1f4 authored by Andreas Tille's avatar Andreas Tille

Updated version 1.12.0 from 'upstream/1.12.0'

with Debian dir 077d40f2c72191e4f63c479c0d51127d6caa0de3
parents dd44f98b 3b36c29c
Package: interactiveDisplayBase
Type: Package
Title: Base package for enabling powerful shiny web displays of
Bioconductor objects
Version: 1.12.0
Date: 2014-09-09
Author: Shawn Balcome, Marc Carlson
Maintainer: Shawn Balcome <balc0022@umn.edu>
Imports: shiny
Depends: R (>= 2.10), methods, BiocGenerics
Suggests: knitr
Enhances: rstudioapi
Description: The interactiveDisplayBase package contains the the basic
methods needed to generate interactive Shiny based display
methods for Bioconductor objects.
License: Artistic-2.0
Collate: interactiveDisplayBase.R dataframe.R dot_runApp.R zzz.R
VignetteBuilder: knitr
biocViews: GO, GeneExpression, Microarray, Sequencing, Classification,
Network, QualityControl, Visualization, Visualization,
Genetics, DataRepresentation, GUI, AnnotationData
NeedsCompilation: no
Packaged: 2016-10-17 23:34:20 UTC; biocbuild
import(methods)
import(BiocGenerics)
import(shiny)
export(.runApp)
export(display)
exportMethods(display)
##########################################################################3
## experimental new(er) version of .dataFrame
## helper for rowname wrangling:
.rownamesAreUnique <- function(df){
length(rownames(df)) == length(unique(rownames(df)))
}
.dataFrame3 <-
function(df, ..., summaryMessage = "",
serverOptions = list(orderClasses=TRUE))
{
rowNames <- rownames(df)
## If the rownames are unique then just use the names as idx.
## but if not, then also also append supplementary idx
if(.rownamesAreUnique(df)){
dt <- data.frame(idx=rowNames,df)
}else{
dt <- data.frame(idx=1:dim(df)[1],rownames=rowNames,df)
}
## define the app
app <- list(
ui = fluidPage(
tags$head(tags$style(HTML("tfoot {display: table-header-group;}"))),
title = 'The data from your data.frame',
fluidRow(textOutput('rows_out'),
br(),
actionButton("btnSend", "Return rows to R session")),
hr(),
mainPanel(dataTableOutput('tbl'))
),
server = function(input, output) {
output$rows_out <- renderText({
paste(c('Selected rows:',
input$rows),
collapse = ' ')
})
output$tbl <- renderDataTable(
dt,
options = list(pageLength = 20),
callback = "function(table) {
table.on('click.dt', 'tr', function() {
$(this).toggleClass('selected');
var rownames = $.map(table.rows('.selected').data(),
function(x) { return(x[0]) });
Shiny.onInputChange('rows', rownames);
}); }",
serverOptions)
if (length(summaryMessage)!=1){
output$summary <- renderUI({
HTML(paste0(
'<span class="shiny-html-output" >',summaryMessage[1],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[2],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[3],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[4],'</span> ' ,
'<br>',
'<span class="shiny-html-output" >',summaryMessage[5],'</span> ' ,
'<br>',
'<span class="shiny-html-output" >',summaryMessage[6],'</span> ' ,
'<br>'
))
})
}
observe({
if(input$btnSend > 0)
isolate({
# print(input$rows)
idx <- input$rows
# message("the input size is: ", length(input$rows))
# message("the input class is: ", class(input$rows))
stopApp(returnValue = df[idx,])
})
})
})
.runApp(app, ...)
}
setMethod("display", signature(object = c("data.frame")),
function(object, ...)
{
.dataFrame3(df=object, ...)
})
##################################################################
## Older code follows
.selDataTableOutput <-
function(outputId, ... )
{
origStyle<- c(
'<script src="shared/datatables/js/jquery.dataTables.min.js"></script>',
'<script class="shiny-html-output"
src= "/js-interactiveDisplayBase/DTbinding.js"></script>',
'<link rel = "stylesheet",
type = "text/css",
href = "shared/datatables/css/DT_bootstrap.css"></link>',
'<style type="text/css">
.rowsSelected td{
background-color: rgba(112,164,255,0.2)
!important}) </style>',
'<style type="text/css"> .selectable div table tbody tr{
cursor: hand; cursor: pointer;}</style>',
'<style type="text/css"> .selectable div table tbody tr td{
-webkit-touch-callout: none;
-webkit-user-select: none;
-khtml-user-select: none;
-moz-user-select: none;
-ms-user-select: none;
user-select: none;} </style>',
'<style type="text/css">
#myTable tfoot {display:table-header-group;}</style>')
tagList(
singleton(
tags$head(HTML(origStyle)
)
),
div(id = outputId, class = "shiny-datatable-output selectable")
)
}
.dataFrame <-
function(df, ..., summaryMessage = "", serverOptions = list(orderClasses=TRUE))
{
colNames <- colnames(df)
app <- list(ui=pageWithSidebar(
headerPanel("Data Tables binding"),
sidebarPanel(
tags$head(
tags$style(type='text/css', ".span4 { max-width: 330px; }")
),
conditionalPanel(
condition= "output.summary",
strong(uiOutput('summary'))
),
br(),
actionButton("btnSend", "Send Rows"),
em(p("Shift-Click to select multiple rows.")),
br(),
tags$button("Select All Rows", class="btn", id="select_all_rows"),
em(p("Click to select all rows on page")),
br(),
tags$button("Deselect All Rows", class="btn", id="deselect_all_rows"),
em(p("Click to deselect all rows on page"))
),
mainPanel(
.selDataTableOutput(outputId="myTable",...)
)
), server=function(input, output) {
output$myTable <-
renderDataTable({df},
options = serverOptions
)
if (length(summaryMessage)!=1){
output$summary <- renderUI({
HTML(paste0(
'<span class="shiny-html-output" >',summaryMessage[1],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[2],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[3],'</span> ',
'<br>',
'<span class="shiny-html-output" >',summaryMessage[4],'</span> ' ,
'<br>',
'<span class="shiny-html-output" >',summaryMessage[5],'</span> ' ,
'<br>',
'<span class="shiny-html-output" >',summaryMessage[6],'</span> ' ,
'<br>'
))
})
}
observe({
if(input$btnSend > 0)
isolate({
#print(input$myTable)
dfVec <- input$myTable
df <- as.data.frame(matrix(data=dfVec, ncol=dim(df)[2],
byrow=TRUE))
names(df) <- colNames
stopApp(returnValue = df)
})
})
})
# runApp(app, ...)
.runApp(app, ...)
}
#################################################
## testing:
## library(interactiveDisplayBase); df <- mtcars;
## foo <- interactiveDisplayBase:::.dataFrame(df)
## foo <- display(df)
## TODO: add support for trapping last usage (for cases where user
## accidently calls it without assignment like this : display(df)
.runApp <- function(app, ...) {
## selectively use the RStudio viewer pane (if available)
viewer <- getOption("viewer")
if (!is.null(viewer) && is.function(viewer)) {
runApp(app, launch.browser = viewer, ...)
} else {
runApp(app, ...)
}
}
################################################################################
### Main
################################################################################
## declare the display generic
setGeneric("display", function(object, ...)
standardGeneric("display")
)
setMethod("display",
signature(object = "ANY"),
function(object){
message("Wrong object")
})
setMethod("display",
signature(object = "missing"),
function(object){
message("Missing object")
})
################################################################################
### Helper Functions
################################################################################
.usePackage <- function(p) {
source("http://bioconductor.org/biocLite.R")
if (!is.element(p, installed.packages()[,1])){
stop(paste("The required package, '",p,"', is missing. Please install it by
typing biocLite('",p,"') in the console", sep=""))
}
require(p, character.only = TRUE)
}
## helper for JS library tags
.jstags <- function(){
list(
tags$script(src="/js/jquery.min.js"),
tags$script(src="/js/d3.v2.js"))
}
#tags$script(src="/js/jquery-svgpan.js"),
#tags$script(src="/js/jscolor/jscolor.js"))
#.shiny-output-error { visibility: hidden; }
#.shiny-output-error:before { visibility: hidden; }
.csstags <- function(){
shiny::tags$head(
shiny::tags$style(type='text/css', "
.span4 {
width: 370px;
position: absolute;
z-index: 50;
}
.span8 {
position: absolute;
left: 400px;
right: 30px;
width: auto;
height: auto;
}
")
)
}
## The loading gif/panel
.loading_gif <- function(){
list(
conditionalPanel(condition="$('html').hasClass('shiny-busy')",
div("Loading...", style = "color:blue")),
conditionalPanel(condition="!($('html').hasClass('shiny-busy'))", br())
)
}
#selDataTableOutput <- function (outputId){
# tagList(singleton(tags$head(tags$link(rel = "stylesheet",
# type = "text/css", href = "shared/datatables/css/DT_bootstrap.css"),
# tags$style(type="text/css", ".rowsSelected td{background-color: rgba(112,164,255,0.2) !important}"),
# tags$style(type="text/css", ".selectable div table tbody tr{cursor: hand; cursor: pointer;}"),
# tags$style(type="text/css",".selectable div table tbody tr td{
# -webkit-touch-callout: none;
# -webkit-user-select: none;
# -khtml-user-select: none;
# -moz-user-select: none;
# -ms-user-select: none;
# user-select: none;}"),
# tags$script(src = "shared/datatables/js/jquery.dataTables.min.js"),
# tags$script(src = "shared/datatables/js/DT_bootstrap.js"),
# tags$script(src = "/js/DTbinding.js"))),
# div(id = outputId, class = "shiny-datatable-output selectable"))
#}
################################################################################
### Additional Functions
################################################################################
#grid2jssvg <- function(gp){
#
# jscode <- "
# <script type='text/javascript'>
# $(document).ready(function() {
# $('svg').svgPan('viewport');
# });
# </script>
# "
# png(filename = "myplot.png", bg = "transparent",height=1000,width=1000)
# print(gp)
#
# mysvg <- gridSVG::grid.export()
# dev.off()
# mysvg2 <- saveXML(mysvg$svg[["g"]])
# mysvg3 <- sub("<g transform=","<g id='viewport' transform=",mysvg2)
# mysvg4 <- sub(">NA<","><",mysvg3)
# htmlxml <- HTML(paste("<svg xmlns='http://www.w3.org/2000/svg'
# xmlns:xlink='http://www.w3.org/1999/xlink' version='1.1' width='100%'
# height='100%'>",jscode,mysvg4,"</svg>",sep=""))
# htmlxml
#}
# This pair of functions can be used in cases where it is desirable to
# give the user a choice between rendering a plot as svg or to use the default
# Shiny plot function.
#svgcheckout <- function(contents,sflag){
# if(sflag==TRUE){
# uiOutput(contents)
# }
# else{
# plotOutput(contents)
# }
#}
.onLoad <- function(libname, pkgname)
{
suppressMessages({
addResourcePath("js-interactiveDisplayBase", system.file("www", "js", package="interactiveDisplayBase"))
addResourcePath("css-interactiveDisplayBase", system.file("www", "css", package="interactiveDisplayBase"))
})
}
\ No newline at end of file
\name{interactiveDisplayBase-NEWS}
\title{interactiveDisplayBase News}
\section{CHANGES IN VERSION 1.7}{
\subsection{NEW FEATURES}{
\itemize{
\item \code{.runApp} runs the app in RStudio's 'viewer' pane (if
the app is launched under RStudio), or in the browser.
}
}
\subsection{BUG FIXES}{
\itemize{
\item Applications would only start under some versions of
shiny, due to a reference to either 'rstudio' or 'rstudioapp'
search path element.
}
}
}
## ----setup, echo=FALSE--------------------------------------------------------
suppressWarnings(suppressPackageStartupMessages(library(knitr)))
options(width=80)
## ----wrap-hook, echo=FALSE----------------------------------------------------
hook_output = knit_hooks$get('output')
knit_hooks$set(output = function(x, options) {
# this hook is used only when the linewidth option is not NULL
if (!is.null(n <- options$linewidth)) {
x = knitr:::split_lines(x)
# any lines wider than n should be wrapped
if (any(nchar(x) > n)) x = strwrap(x, width = n)
x = paste(x, collapse = '\n')
}
hook_output(x, options)
})
## ----interactiveDisplayBase-load, echo=FALSE----------------------------------
suppressWarnings(suppressPackageStartupMessages(library(interactiveDisplayBase)))
## ----dataframe_demo, eval=FALSE-----------------------------------------------
# mtcars2 <- display(mtcars)
<!--
%\VignetteEngine{knitr::knitr}
%\VignetteIndexEntry{Using interactiveDisplayBase for Bioconductor object visualization and modification}
-->
```{r setup, echo=FALSE}
suppressWarnings(suppressPackageStartupMessages(library(knitr)))
options(width=80)
```
```{r wrap-hook, echo=FALSE}
hook_output = knit_hooks$get('output')
knit_hooks$set(output = function(x, options) {
# this hook is used only when the linewidth option is not NULL
if (!is.null(n <- options$linewidth)) {
x = knitr:::split_lines(x)
# any lines wider than n should be wrapped
if (any(nchar(x) > n)) x = strwrap(x, width = n)
x = paste(x, collapse = '\n')
}
hook_output(x, options)
})
```
```{r interactiveDisplayBase-load, echo=FALSE}
suppressWarnings(suppressPackageStartupMessages(library(interactiveDisplayBase)))
```
# interactiveDisplayBase
[interactiveDisplayBase](http://bioconductor.org/packages/2.13/bioc/html/interactiveDisplayBase.html)
`interactiveDisplayBase` uses the function `display()` to host a browser based
application on the fly using the Shiny package. Shiny UI elements are available based on the
object passed to `display()`. These allow the user to modify how the plot is
displayed, and for some objects, modify or subset the data and send it back to
the console.
## Methods
Many of the display method will have a button that allows you return
subset values back to the R session. To use these, couple the intial
call with an assignment operator like this:
```{r dataframe_demo, eval=FALSE}
mtcars2 <- display(mtcars)
```
Once you leave the diplay web gui, the results of the above
interaction will be captured inside of mtcars2.
## Acknowledgments
Shiny <br/>
Joe Cheng and Winston Chang <br/>
http://www.rstudio.com/shiny/ <br/>
Force Layout <br/>
Jeff Allen <br/>
https://github.com/trestletech/shiny-sandbox/tree/master/grn <br/>
gridSVG <br/>
Simon Potter <br/>
http://sjp.co.nz/projects/gridsvg/ <br/>
Zoom/Pan JavaScript libraries <br/>
John Krauss <br/>
https://github.com/talos/jquery-svgpan <br/>
Andrea Leofreddi <br/>
https://code.google.com/p/svgpan/ <br/>
JavaScript Color Chooser <br/>
Jan Odvarko <br/>
http://jscolor.com/ <br/>
Data-Driven Documents <br/>
Michael Bostock <br/>
http://d3js.org/ <br/>
Javascript for returning values from data.frames <br/>
Kirill Savin <br/>
Help with the display method for data.frames <br/>
Dan Tenenbaum <br/>
This diff is collapsed.
## tests to check paging.
library(interactiveDisplayBase)
display(iris)
display(mtcars)
library(AnnotationHub)
ah = AnnotationHub()
df = as.data.frame(mcols(ah))
## This can be set up so that it's all on one page.
## But: this makes things painfully slow and the
## moment you do a search the indexing is all
## screwed up anyways...
## Esentially here I have a problem where the call back is retrieving relative
## indices instead of the absolute ones that I need from it.
\ No newline at end of file
<style>
.node text {
pointer-events: none;
font: 10px sans-serif;
}
.link {
stroke: #999;
stroke-opacity: .6;
}
</style>
$(function() {
$("#select_all_rows").click(function(){
$(".selectable div table tbody tr").addClass("rowsSelected");
$(".selectable div table").trigger("change");
});
$("#deselect_all_rows").click(function(){
$(".selectable div table tbody tr").removeClass("rowsSelected");
$(".selectable div table").trigger("change");
});
});
$(document).on('click', '.selectable div table tbody tr', function(e){
var el = $(this);
if (!e.shiftKey){
$(this).siblings().removeClass("rowsSelected");
}
$(this).addClass("rowsSelected", this.clicked);
el.trigger("change");
});
var isArray = function(someVar)
{
return(Object.prototype.toString.call( someVar ) === '[object Array]');
}
var selectRowBinding = new Shiny.InputBinding();
$.extend(selectRowBinding, {
find: function(scope) {
return $(scope).find(".selectable");
},
getValue: function(el){
tbl = $(el).find("table");
var out = [];
$rows = $(tbl).children().children('.rowsSelected');
if($rows.length == 0) return -1;
var oTable = $("#DataTables_Table_0").dataTable();
$rows.each(function(row,v) {
var aPos = oTable.fnGetPosition( this );
var data = oTable.fnGetData(this);
out[row] = [];
for (var i = 0; i < data.length; i++) {
var di = data[i];
if (isArray(di)) di = di.join(",");
out[row][i] = di;
console.log("i is " + i + " and di is " + di);
}
});
return out;
},
setValue: function(el, value) {
},
subscribe: function(el, callback) {
$(el).on("change.selectRowBinding", function(e) {
callback();
});
},
unsubscribe: function(el) {
$(el).off(".selectRowBinding");
}
});
Shiny.inputBindings.register(selectRowBinding);
\docType{methods}
\name{.runApp}
\alias{.runApp}
\title{Run a shiny app, capturing results to the R session}
\description{
This utility function launches a shiny visualization application,
either in the RStudio viewer pane (if run under RStudio) or in the
browser.
}
\usage{
.runApp(app, ...)
}
\arguments{
\item{app}{The shiny application definition, see \code{?shiny::runApp}.}
\item{...}{additional arguments passed to \code{shiny::runApp()}.}
}
\value{
The return value of \code{shiny::runApp}.
}
\author{Martin Morgan}
\examples{
if (interactive()) {
require(shiny)
app <- list(
ui = fluidPage(
title="Who Am I?",
sidebarLayout(
position="left",
sidebarPanel(
h1("Your name"),
textInput("your_name", "Your name?", "Anonymous"),
actionButton("done", "Done")),
mainPanel(
"Hi", textOutput("your_name", inline=TRUE))
)),
server = function(input, output) {
output$your_name <- renderText(input$your_name)
observe({
if (input$done > 0)
isolate(stopApp(returnValue = input$your_name))
})
})
.runApp(app)
}
}
\keyword{manip}
\docType{methods}
\name{display}
\alias{display}
\alias{display,ANY-method}
\alias{display,missing-method}
\alias{display,data.frame-method}
\title{display: Open a Shiny application for a Bioconductor object}
\description{
This opens a shiny visualization application in the browser
based on the submitted object.
}
\usage{
display(object, ...)
}
\arguments{
\item{object}{data object to display}
\item{...}{additional arguments passed to methods; currently unused.}
}
\value{
Usually some variation of the initial input object, but it may be
altered by the display widget (subset for example).
}
\seealso{
\url{http://bioconductor.org/packages/2.13/bioc/html/interactiveDisplayBase.html}
}
\author{Shawn Balcome and Marc Carlson}
\examples{
if(interactive()) {
## draw a data.frame
display(mtcars)