interactiveDisplayBase/DESCRIPTION0000644000175400017540000000160113175736476017765 0ustar00biocbuildbiocbuildPackage: interactiveDisplayBase Type: Package Title: Base package for enabling powerful shiny web displays of Bioconductor objects Version: 1.16.0 Date: 2014-09-09 Author: Shawn Balcome, Marc Carlson Maintainer: Shawn Balcome 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: 2017-10-31 00:01:02 UTC; biocbuild interactiveDisplayBase/NAMESPACE0000644000175400017540000000015313175714555017471 0ustar00biocbuildbiocbuildimport(methods) import(BiocGenerics) import(shiny) export(.runApp) export(display) exportMethods(display) interactiveDisplayBase/R/0000755000175400017540000000000013175714555016454 5ustar00biocbuildbiocbuildinteractiveDisplayBase/R/dataframe.R0000644000175400017540000001755113175714555020534 0ustar00biocbuildbiocbuild##########################################################################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( '',summaryMessage[1],' ', '
', '',summaryMessage[2],' ', '
', '',summaryMessage[3],' ', '
', '',summaryMessage[4],' ' , '
', '',summaryMessage[5],' ' , '
', '',summaryMessage[6],' ' , '
' )) }) } 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( '', '', '', '', '', '', '') 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( '',summaryMessage[1],' ', '
', '',summaryMessage[2],' ', '
', '',summaryMessage[3],' ', '
', '',summaryMessage[4],' ' , '
', '',summaryMessage[5],' ' , '
', '',summaryMessage[6],' ' , '
' )) }) } 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) interactiveDisplayBase/R/dot_runApp.R0000644000175400017540000000042513175714555020713 0ustar00biocbuildbiocbuild.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, ...) } } interactiveDisplayBase/R/interactiveDisplayBase.R0000644000175400017540000001007613175714555023241 0ustar00biocbuildbiocbuild################################################################################ ### 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 <- " # # " # 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("NA<","><",mysvg3) # htmlxml <- HTML(paste("",jscode,mysvg4,"",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) # } #} interactiveDisplayBase/R/zzz.R0000644000175400017540000000045313175714555017436 0ustar00biocbuildbiocbuild.onLoad <- function(libname, pkgname) { suppressMessages({ addResourcePath("js-interactiveDisplayBase", system.file("www", "js", package="interactiveDisplayBase")) addResourcePath("css-interactiveDisplayBase", system.file("www", "css", package="interactiveDisplayBase")) }) }interactiveDisplayBase/build/0000755000175400017540000000000013175736476017360 5ustar00biocbuildbiocbuildinteractiveDisplayBase/build/vignette.rds0000644000175400017540000000040313175736476021714 0ustar00biocbuildbiocbuild‹uQMK1Í~XmAz½äì(K/^¤*x“YÉ&%I[êÉ_nm»•Æv “™á½Ì{äu$„ÈEQæ"/¸,Æœ|nød¢C¾ïÈFô "-±¦07°ž@ÀjÖêùôȾËÓxÙ8/'䔳z¡"7îíU”K 0ô‘œ•`µl¦†Ôv¬¸?#æ#¶&ÞžÓÍ–Ç[ÜÏÁþÿxZ Éc—5ÎÑênüsšŸmÊÕ®WÎ÷œ#Ì`)§d°ßûLñÐõt_f³Tÿ÷ô½[U½‡ë9m8R£Ê@HŽ4D¨ÏüN÷/PcSÇ"interactiveDisplayBase/inst/0000755000175400017540000000000013175736476017236 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/NEWS.Rd0000644000175400017540000000100013175714555020262 0ustar00biocbuildbiocbuild\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. } } } interactiveDisplayBase/inst/doc/0000755000175400017540000000000013175736476020003 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/doc/interactiveDisplayBase.R0000644000175400017540000000162213175736476024565 0ustar00biocbuildbiocbuild## ----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) interactiveDisplayBase/inst/doc/interactiveDisplayBase.Rmd0000644000175400017540000000470113175714555025101 0ustar00biocbuildbiocbuild ```{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
Joe Cheng and Winston Chang
http://www.rstudio.com/shiny/
Force Layout
Jeff Allen
https://github.com/trestletech/shiny-sandbox/tree/master/grn
gridSVG
Simon Potter
http://sjp.co.nz/projects/gridsvg/
Zoom/Pan JavaScript libraries
John Krauss
https://github.com/talos/jquery-svgpan
Andrea Leofreddi
https://code.google.com/p/svgpan/
JavaScript Color Chooser
Jan Odvarko
http://jscolor.com/
Data-Driven Documents
Michael Bostock
http://d3js.org/
Javascript for returning values from data.frames
Kirill Savin
Help with the display method for data.frames
Dan Tenenbaum
interactiveDisplayBase/inst/doc/interactiveDisplayBase.html0000644000175400017540000003620113175736476025331 0ustar00biocbuildbiocbuild interactiveDisplayBase

interactiveDisplayBase

interactiveDisplayBase

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:

mtcars2 <- display(mtcars)

Once you leave the diplay web gui, the results of the above interaction will be captured inside of mtcars2.

Acknowledgments

Shiny
Joe Cheng and Winston Chang
http://www.rstudio.com/shiny/

Force Layout
Jeff Allen
https://github.com/trestletech/shiny-sandbox/tree/master/grn

gridSVG
Simon Potter
http://sjp.co.nz/projects/gridsvg/

Zoom/Pan JavaScript libraries
John Krauss
https://github.com/talos/jquery-svgpan
Andrea Leofreddi
https://code.google.com/p/svgpan/

JavaScript Color Chooser
Jan Odvarko
http://jscolor.com/

Data-Driven Documents
Michael Bostock
http://d3js.org/

Javascript for returning values from data.frames
Kirill Savin

Help with the display method for data.frames
Dan Tenenbaum

interactiveDisplayBase/inst/script/0000755000175400017540000000000013175714555020534 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/script/test.R0000644000175400017540000000074213175714555021641 0ustar00biocbuildbiocbuild## 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.interactiveDisplayBase/inst/www/0000755000175400017540000000000013175714555020054 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/www/css/0000755000175400017540000000000013175714555020644 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/www/css/interactiveDisplayBase.css0000644000175400017540000000020413175714555026010 0ustar00biocbuildbiocbuild interactiveDisplayBase/inst/www/js/0000755000175400017540000000000013175714555020470 5ustar00biocbuildbiocbuildinteractiveDisplayBase/inst/www/js/DTbinding.js0000644000175400017540000000345713175714555022701 0ustar00biocbuildbiocbuild$(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); interactiveDisplayBase/man/0000755000175400017540000000000013175714555017026 5ustar00biocbuildbiocbuildinteractiveDisplayBase/man/dot_runApp.Rd0000644000175400017540000000242313175714555021431 0ustar00biocbuildbiocbuild\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} interactiveDisplayBase/man/interactiveDisplayBase-methods.Rd0000644000175400017540000000157613175714555025425 0ustar00biocbuildbiocbuild\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) ## subset a data.frame: mtcars2 <- display(mtcars) } } \keyword{methods} interactiveDisplayBase/vignettes/0000755000175400017540000000000013175736476020271 5ustar00biocbuildbiocbuildinteractiveDisplayBase/vignettes/interactiveDisplayBase.Rmd0000644000175400017540000000470113175714555025367 0ustar00biocbuildbiocbuild ```{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
Joe Cheng and Winston Chang
http://www.rstudio.com/shiny/
Force Layout
Jeff Allen
https://github.com/trestletech/shiny-sandbox/tree/master/grn
gridSVG
Simon Potter
http://sjp.co.nz/projects/gridsvg/
Zoom/Pan JavaScript libraries
John Krauss
https://github.com/talos/jquery-svgpan
Andrea Leofreddi
https://code.google.com/p/svgpan/
JavaScript Color Chooser
Jan Odvarko
http://jscolor.com/
Data-Driven Documents
Michael Bostock
http://d3js.org/
Javascript for returning values from data.frames
Kirill Savin
Help with the display method for data.frames
Dan Tenenbaum