├── .Rbuildignore ├── NAMESPACE ├── inst └── shinyDataApp │ ├── samples │ └── Sample1.sData │ ├── md │ ├── rmdInstructions.md │ └── about.md │ ├── color.r │ ├── project.r │ ├── data.r │ ├── docs.r │ ├── helpers.r │ ├── global.r │ ├── sheetsCustomize.r │ ├── ui.r │ ├── server.r │ └── sheets.r ├── .gitignore ├── man └── shinyData.Rd ├── .gitattributes ├── shinyData.Rproj ├── R └── main.r ├── DESCRIPTION ├── LICENSE └── README.md /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2 (4.1.0): do not edit by hand 2 | 3 | export(shinyData) 4 | -------------------------------------------------------------------------------- /inst/shinyDataApp/samples/Sample1.sData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yindeng/shinyData/HEAD/inst/shinyDataApp/samples/Sample1.sData -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | *.Rhistory 3 | .RData 4 | 5 | *~ 6 | *.swp 7 | inst/shinyDataApp/shinyapps/ 8 | inst/shinyDataApp/figure/ 9 | -------------------------------------------------------------------------------- /man/shinyData.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2 (4.1.0): do not edit by hand 2 | % Please edit documentation in R/main.r 3 | \name{shinyData} 4 | \alias{shinyData} 5 | \title{Run shinyData} 6 | \usage{ 7 | shinyData() 8 | } 9 | \description{ 10 | This will open your default browser and run shinyData locally on your computer. 11 | } 12 | 13 | -------------------------------------------------------------------------------- /inst/shinyDataApp/md/rmdInstructions.md: -------------------------------------------------------------------------------- 1 | All R Markdown formats are supported. In addition, data and sheet names, when quoted by backticks in an R code chunk, evaluate to the corresponding data frame (technically, a "data.table" object) and the sheet output, respectively. 2 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /shinyData.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /inst/shinyDataApp/color.r: -------------------------------------------------------------------------------- 1 | ## a simple color picker 2 | # AllColors <- rgb(t(col2rgb(colors())), maxColorValue=255) 3 | # names(AllColors) <- colors() 4 | AllColors <- colors() 5 | colorInput <- function(inputId, label, value=NULL){ 6 | selectInput(inputId, label, choices=c('Choose'='', AllColors), selected=value) 7 | } 8 | 9 | updateColorInput <- function(session, inputId, label = NULL, value = NULL){ 10 | updateSelectInput(session, inputId, label, selected=value) 11 | } 12 | 13 | #rgb(t(col2rgb(head(colors()))), maxColorValue=255) 14 | -------------------------------------------------------------------------------- /R/main.r: -------------------------------------------------------------------------------- 1 | #' Run shinyData 2 | #' 3 | #' This will open your default browser and run shinyData locally on your computer. 4 | #' 5 | #' @export 6 | shinyData <- function() { 7 | shiny::runApp(file.path(system.file("shinyDataApp", package = "shinyData"))) 8 | } 9 | 10 | # #' Print hello 11 | # #' 12 | # #' This function prints hello 13 | # #' 14 | # #' @param fname First name 15 | # #' @param lname Last name 16 | # #' @export 17 | # #' @examples 18 | # #' hello(fname="Tomas",lname="Greif") 19 | # #' hello(fname="Your",lname="Name") 20 | # 21 | # hello <- function(fname, lname) { 22 | # cat(paste("Hello",fname,lname,"!")) 23 | # } 24 | -------------------------------------------------------------------------------- /inst/shinyDataApp/md/about.md: -------------------------------------------------------------------------------- 1 | # Welcome to shinyData! 2 | 3 | With shinyData, you can easily load a data set from a file or with custom R code, manipulate its properties (change column formats, names, etc.), slice and dice it as you wish and visualize the results, all within a graphical user interface. The outputs are updated instantaneously with each input change. You can also create reports and presentations from your results, downloadable in a variety of different formats. Lastly, shinyData also supports saving and loading of projects so you can save your partial work to resume later, or share your work with others by simply sending them the project file. 4 | 5 | If this is your first time using the tool, we strongly recommend you explore some of the sample projects found on the top right corner of this page. 6 | 7 | ## Links 8 | 9 | shinyData Project on GitHub: https://github.com/yindeng/shinyData 10 | 11 | Feedback (bugs, questions, etc.): https://github.com/yindeng/shinyData/issues 12 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: shinyData 2 | Type: Package 3 | Title: A GUI application for interactive data analysis, visualization and presentation 4 | Version: 0.1.1 5 | Authors@R: "Yindeng Jiang [aut, cre]" 6 | Description: 7 | shinyData is an easy to use tool for interactive data analysis, visualization and presentation. 8 | It leverages the power of R and its vast collection of packages to allow users to efficiently perform common 9 | data tasks, such as slicing and dicing, aggregation, pattern recognition, visualization and more. 10 | Almost no knowledge of R programming is required to use shinyData. 11 | Depends: R (>= 3.1.2) 12 | Imports: 13 | shiny (>= 0.11.1), 14 | ggplot2 (>= 1.0.0), Hmisc (>= 3.14-6), 15 | uuid (>= 0.1-1), 16 | tables (>= 0.7.79), 17 | png (>= 0.1-7), data.table (>= 1.9.4), 18 | Cairo (>= 1.5-6), 19 | knitr (>= 1.9), rmarkdown (>= 0.4.2) 20 | Suggests: 21 | extrafont (>= 0.17) 22 | License: MIT + file LICENSE 23 | LazyData: true 24 | URL: https://github.com/yindeng/shinyData 25 | BugReports: https://github.com/yindeng/shinyData/issues 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014-2015 Yindeng Jiang 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /inst/shinyDataApp/project.r: -------------------------------------------------------------------------------- 1 | 2 | 3 | #################################################### 4 | ## Project saving and loading 5 | #################################################### 6 | shrink <- function(x){ 7 | if(is.list(x) && !is.data.frame(x)){ 8 | if(is.reactivevalues(x)){ 9 | x <- lapply(reactiveValuesToList(x), function(y){ 10 | if(typeof(y)!='closure') shrink(y) else NULL 11 | }) 12 | attr(x, 'wasReavtive') <- TRUE 13 | } else { 14 | ## x is an ordinary list 15 | ## need to preserve attributes 16 | attrs <- attributes(x) 17 | x <- lapply(x, shrink) 18 | attributes(x) <- attrs 19 | } 20 | } else { 21 | if(typeof(x)!='closure') x else NULL 22 | } 23 | x 24 | } 25 | 26 | wasReactivevalues <- function(x){ 27 | !is.null(attr(x, 'wasReavtive')) 28 | } 29 | 30 | output$downloadProject <- downloadHandler( 31 | filename = function() { 'MyProject.sData' }, 32 | content = function(file) { 33 | isolate({ 34 | 35 | allData <- list(pp=shrink(projProperties), 36 | dl=lapply(datList, function(d){ 37 | list('staticProperties'=d[['staticProperties']], 38 | 'dynamicProperties'=shrink(d[['dynamicProperties']])) 39 | }), 40 | sl=lapply(sheetList, function(d){ 41 | list('dynamicProperties'=shrink(d[['dynamicProperties']])) 42 | }), 43 | docl=shrink(docList)) 44 | save(allData, file=file) 45 | 46 | }) 47 | } 48 | ) 49 | 50 | 51 | loadProject <- function(file, replaceOrMerge='replace'){ 52 | load(file) 53 | 54 | if(replaceOrMerge=='replace'){ 55 | for(n in names(datList)) datList[[n]] <<- NULL; projProperties[['activeDat']] <<- NULL 56 | for(n in names(sheetList)) sheetList[[n]] <<- NULL; projProperties[['activeSheet']] <<- NULL 57 | for(n in names(docList)) docList[[n]] <<- NULL; projProperties[['activeDoc']] <<- NULL 58 | } 59 | 60 | for(n in names(allData$pp)){ 61 | if(is.null(projProperties[[n]]) || projProperties[[n]] != allData$pp[[n]]){ 62 | projProperties[[n]] <<- allData$pp[[n]] 63 | } 64 | } 65 | 66 | for(di in names(allData$dl)){ 67 | if(is.null(datList[[di]])){ # new data 68 | datList[[di]] <<- DatClass$new('staticProperties'=allData$dl[[di]][['staticProperties']]) 69 | datList[[di]][['dynamicProperties']] <<- reactiveValues() 70 | setDatReactives(di) 71 | } 72 | for(n in names(allData$dl[[di]][['dynamicProperties']])){ 73 | x <- allData$dl[[di]][['dynamicProperties']][[n]] 74 | if(n=='fieldsList'){ 75 | if(is.null(datList[[di]][['dynamicProperties']][[n]])) datList[[di]][['dynamicProperties']][[n]] <<- list() 76 | names1 <- names(x) 77 | for(n1 in names1){ 78 | if(wasReactivevalues(x[[n1]])){ 79 | if(is.null(datList[[di]][['dynamicProperties']][[n]][[n1]])) datList[[di]][['dynamicProperties']][[n]][[n1]] <<- reactiveValues() 80 | names2 <- names(x[[n1]]) 81 | for(n2 in names2){ 82 | datList[[di]][['dynamicProperties']][[n]][[n1]][[n2]] <<- x[[n1]][[n2]] 83 | } 84 | } else { 85 | datList[[di]][['dynamicProperties']][[n]][[n1]] <<- x[[n1]] 86 | } 87 | } 88 | } else { 89 | datList[[di]][['dynamicProperties']][[n]] <<- x 90 | } 91 | } 92 | } 93 | 94 | for(si in names(allData$sl)){ 95 | if(is.null(sheetList[[si]])){ # new sheet 96 | sheetList[[si]] <<- createNewSheetObj(withPlotLayer=FALSE) 97 | setSheetReactives(si) 98 | } 99 | for(n in names(allData$sl[[si]][['dynamicProperties']])){ 100 | x <- allData$sl[[si]][['dynamicProperties']][[n]] 101 | if(n=='layerList'){ 102 | if(is.null(sheetList[[si]][['dynamicProperties']][[n]])) sheetList[[si]][['dynamicProperties']][[n]] <<- list() 103 | names1 <- names(x) 104 | for(n1 in names1){ 105 | if(wasReactivevalues(x[[n1]])){ 106 | if(is.null(sheetList[[si]][['dynamicProperties']][[n]][[n1]])) 107 | sheetList[[si]][['dynamicProperties']][[n]][[n1]] <<- createNewLayer() 108 | names2 <- names(x[[n1]]) 109 | for(n2 in names2){ 110 | if(n2=='aesList'){ 111 | names3 <- names(x[[n1]][[n2]]) 112 | for(n3 in names3){ 113 | if(wasReactivevalues(x[[n1]][[n2]][[n3]])){ 114 | names4 <- names(x[[n1]][[n2]][[n3]]) 115 | for(n4 in names4){ 116 | sheetList[[si]][['dynamicProperties']][[n]][[n1]][[n2]][[n3]][[n4]] <<- x[[n1]][[n2]][[n3]][[n4]] 117 | } 118 | setAesReactives(si,n1,n3) 119 | } else { 120 | sheetList[[si]][['dynamicProperties']][[n]][[n1]][[n2]][[n3]] <<- x[[n1]][[n2]][[n3]] 121 | } 122 | } 123 | } else { 124 | sheetList[[si]][['dynamicProperties']][[n]][[n1]][[n2]] <<- x[[n1]][[n2]] 125 | } 126 | } 127 | } else { 128 | sheetList[[si]][['dynamicProperties']][[n]][[n1]] <<- x[[n1]] 129 | } 130 | } 131 | } else { 132 | sheetList[[si]][['dynamicProperties']][[n]] <<- x 133 | } 134 | } 135 | } 136 | 137 | for(di in names(allData$docl)){ 138 | if(is.null(docList[[di]])){ # new doc 139 | docList[[di]] <<- reactiveValues() 140 | 141 | } 142 | for(n in names(allData$docl[[di]])){ 143 | x <- allData$docl[[di]][[n]] 144 | docList[[di]][[n]] <<- x 145 | } 146 | } 147 | 148 | ## update all UI 149 | sapply(unique(c(names(input), names(updateInput))), triggerUpdateInput) 150 | updateTabsetPanel(session, 'mainNavBar', selected='Visualize') 151 | } 152 | 153 | observe({ 154 | inFile <- input[['loadProject']] 155 | isolate({ 156 | if (!is.null(inFile)){ 157 | loadProject(file=inFile$datapath, replaceOrMerge=input[['loadProjectAction']]) 158 | } 159 | }) 160 | 161 | }) 162 | 163 | observe({ 164 | v <- input$openSampleProj 165 | isolate({ 166 | file <- paste('samples', input[['sampleProj']], sep='/') 167 | if(v && file.exists(file)){ 168 | loadProject(file=file, 'replace') 169 | } 170 | }) 171 | }) 172 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![shinyData](http://i.imgur.com/hG7Ltn2.png) 2 | ========= 3 | 4 | [shinyData](https://github.com/yindeng/shinyData) is an easy to use tool for interactive data analysis, visualization and presentation. It leverages the power of R and its vast collection of packages to allow users to efficiently perform common data tasks, such as slicing and dicing, aggregation, visualization and more (usually referred to as "business intelligence"). Almost no knowledge of R programming is required to use shinyData. 5 | 6 | **Current stable version**: v0.1.1 7 | 8 | **Demo**: https://roose.shinyapps.io/shinyData/ 9 | 10 | ![](http://i.imgur.com/bkmylo0.png?1) 11 | 12 | # Installation 13 | To run the web based version of shinyData without installing anything, simply go to https://roose.shinyapps.io/shinyData/. 14 | To install the package locally, execute the following R code (you can use the same code to get updates as well): 15 | ``` 16 | if(!require(devtools)) install.packages("devtools") 17 | devtools::install_github("trestletech/shinyAce@a2268d545e0ea30eb44c9dca517aec1165b06a51") 18 | devtools::install_github("AnalytixWare/ShinySky@15c29bec4e7c5e694625e571656515a8ace7f376") 19 | devtools::install_github("trestletech/shinyTree@522f8a7e28565bec0f634faf5aa1e75da247de44") 20 | devtools::install_github("ebailey78/shinyBS", ref = "shinyBS3") 21 | devtools::install_github("yindeng/shinyData") 22 | ``` 23 | 24 | # Usage 25 | ``` 26 | shinyData::shinyData() 27 | ``` 28 | This will open your default browser and run shinyData locally on your computer. 29 | 30 | To quickly get a flavor of what shinyData can do, simply open one of the sample projects in the dropdown box on the "Project" page. 31 | 32 | # Feature Overview 33 | 34 | ## Data extraction and manipulation (Tab "Data") 35 | shinyData supports loading data from a text file. It can auto-detect the presence of header row and common text delimiters (such as comma or tab), as well as skipping banners at the beginning of the file if any, thus requiring minimal input from the user. 36 | 37 | The other option of loading is by writing some R code. This gives the user a tremendous amount of flexibility. For example, by using the RODBC library, one can submit a SQL query to a database using an ODBC connection and get results back as a R data frame, ready to be processed by shinyData. The R code can also include names (when quoted in backticks) of other data sources in the same project, which will be evaluated to the corresponding [`data.table`](https://rawgit.com/wiki/Rdatatable/data.table/vignettes/datatable-intro-vignette.html) objects. This makes it easy to pre-process (like adding a derived column) a data source or join two data sources together before creating the desired visualizations. Examples of these customizations will be added to the sample projects over time. 38 | 39 | >To load data from an Excel file, refer to this [blog post](http://www.milanor.net/blog/?p=779) for a good comparison of a variety of different approaches available. 40 | 41 | >We are working on adding more GUI support for loading data. 42 | 43 | After data is loaded, user can preview the data, customize the data source name and field names, and specify which fields should be considered measures. The implication of setting a field as measure is that it will allow for numerical aggregation on the field. 44 | 45 | ## Data aggregation (Tab "Visualize") 46 | It's often useful to aggregate numerical data (or measures). For example, one might be interested in the average store sales per region. shinyData integrates common data aggregations with visualization, so you can see the results quickly. When you map a visual element (like X, Y, Color, etc) to a field in the selected data source, you have the option to aggregate the field with a function selected from a dropdown list (or type in any R function that takes a vector and returns a single value). The aggregation is done conditional on all the fields that are mapped to in the current layer but not being aggregated, as well as any fields specified in facet columns or rows. Additionally, the data aggregation in each plot layer is independent of each other, so it is possible to have different levels of granularity in the same plot. Another special type of aggregation is sometimes also applied to a layer when "Stat" under Tab "Type" is not "Identity". This is useful for creating statistical charts like box plots, for which you need to aggregate the data to get the quartiles. This type of statistical aggregation is done after the previously mentioned aggregations are done. 47 | 48 | >Tip: if you need to create a type of aggregation that's not supported by either of the techniques mentioned above, you can create an intermediate data source with R code under Tab "Data" (see above), do whatever aggregation there, and use that data source for your visualization instead. 49 | 50 | When there is any aggregation done in the base "Plot" layer, the aggregated data table is automatically added to the list of data sources, and it will be kept in sync with the changes made to the "Plot" layer. This is useful when a secondary aggregation is desired. 51 | 52 | ## Visualization (Tab "Visualize") 53 | The following chart types are supported: Text (for adding data labels), bar chart, line chart, area chart, scatter plot, path plot, polygon plot, box plot, density plot, and smoother (or trend line with confidence bands). Visual elements can either be mapped to a field or set to a fixed value. You can add as many layers to the plot as you want, and they will be plotted on top of each other in the order shown. To make sure a layer is not hidden behind other layers (ie, plotted last), click on "Bring to Top" when that layer is selected. 54 | 55 | The appearance of the plot is fully customizable. Customization can be specified at different levels and inherit through a tree-like structure. For example, "axis.title" inherits from "title", which in turn inherits from "text", so fonts set for "text" will automatically apply to "title" and "axis.title", but can be overwritten. More information can be found [here](http://docs.ggplot2.org/current/theme.html). 56 | 57 | >If you are familiar with the R library [ggplot2](http://docs.ggplot2.org/current/index.html), you should recognize the semantics right away since the back end of shinyData visualization is exactly ggplot2. 58 | 59 | ## Presentation (Tab "Presentation") 60 | Thanks to the simplicity and flexibility of [R Markdown](http://rmarkdown.rstudio.com/), user can easily combine the plots to create beautiful reports and presentations. And if you are a R programmer, you can add arbitrary R scripts to include analysis results that are not supported by the shinyData UI. Again see the sample projects for examples of creating presentations. 61 | 62 | ## Project management (Tab "Project") 63 | By saving the project to a file, user can pick up where he left off. User can also merge two projects together by selecting "Merge with existing work" when loading a project file. 64 | 65 | >Due to the web-based nature of shinyData, currently you cannot save changes to an existing project file. Instead you need to download the project as a new file. We are working on overcoming this inconvenience when shinyData is run locally, so it essentially behaves more like a desktop application. 66 | 67 | 68 | 69 | # Links 70 | shinyData Blog: https://shinydata.wordpress.com/ 71 | 72 | ggplot2 Online Reference: http://docs.ggplot2.org/current/index.html 73 | 74 | # To Potential Contributors 75 | Please make your changes to the "develop" branch since we intend to keep the "master" branch only for stable releases. Feel free to submit your pull requests! 76 | 77 | -------------------------------------------------------------------------------- /inst/shinyDataApp/data.r: -------------------------------------------------------------------------------- 1 | 2 | ## switching data source 3 | observe({ 4 | v <- input$datList 5 | isolate({ 6 | if(!isEmpty(input$datList)) projProperties[['activeDat']] <<- v 7 | }) 8 | }) 9 | observe({ 10 | updateInput[['activeDat']] 11 | updateSelectInput(session, 'datList', choices=(datListNames()), 12 | selected=isolate(projProperties[['activeDat']])) 13 | }) 14 | 15 | output$currentDatType <- reactive({ 16 | currentDat <- projProperties[['activeDat']] 17 | s <- if(!isEmpty(currentDat)){ 18 | isolate(datList[[currentDat]][['staticProperties']][['type']]) 19 | } else '' 20 | null2String(s) 21 | }) 22 | outputOptions(output, "currentDatType", suspendWhenHidden=FALSE) 23 | 24 | 25 | ## R code 26 | observeEvent(input$datCode, { 27 | v <- input$datCode 28 | currentDat <- (projProperties[['activeDat']]) 29 | if(!isEmpty(currentDat)){ 30 | datList[[currentDat]][['dynamicProperties']][['datCode']] <<- v 31 | } 32 | }) 33 | observe({ 34 | updateInput[['datCode']] 35 | currentDat <- projProperties[['activeDat']] 36 | s <- if(!isEmpty(currentDat)){ 37 | isolate(datList[[currentDat]][['dynamicProperties']][['datCode']]) 38 | } else '' 39 | updateAceEditor(session, 'datCode', value=ifempty(s, '\n')) # bug in updateAceEditor: won't update with "" 40 | }) 41 | observeEvent(input$runDatCode, { 42 | ## invalidate datList[[currentDat]][['datRaw']] 43 | sessionProperties[['runDatCode']] <- sessionProperties[['runDatCode']] + 1 44 | 45 | currentDat <- (projProperties[['activeDat']]) 46 | if(!isEmpty(currentDat)){ 47 | datUpdated(currentDat) 48 | } 49 | }) 50 | 51 | 52 | ## modify dat source name 53 | observe({ 54 | v <- input$datName 55 | isolate({ 56 | currentDat <- (projProperties[['activeDat']]) 57 | if(!isEmpty(currentDat)){ 58 | if(!isEmpty(v) && isEmpty(datListNames()[v])){ 59 | ## the second condition makes sure v is different 60 | 61 | ## update doc's rmd 62 | oldName <- paste('`', datList[[currentDat]][['dynamicProperties']][['name']], '`', sep='') 63 | newName <- paste('`', v, '`', sep='') 64 | sapply(names(docList), function(currentDoc){ 65 | docList[[currentDoc]][['rmd']] <<- gsub(oldName, newName, docList[[currentDoc]][['rmd']], fixed=TRUE) 66 | }) 67 | triggerUpdateInput('docRmd') 68 | ## update dat R code 69 | sapply(names(datList), function(currentDat){ 70 | datList[[currentDat]][['dynamicProperties']][['datCode']] <<- 71 | gsub(oldName, newName, datList[[currentDat]][['dynamicProperties']][['datCode']], fixed=TRUE) 72 | }) 73 | triggerUpdateInput('datCode') 74 | 75 | datList[[currentDat]][['dynamicProperties']][['name']] <<- v 76 | } 77 | } 78 | }) 79 | 80 | }) 81 | observe({ 82 | updateInput[['datName']] 83 | currentDat <- projProperties[['activeDat']] 84 | s <- if(!isEmpty(currentDat)){ 85 | isolate(datList[[currentDat]][['dynamicProperties']][['name']]) 86 | } else '' 87 | updateTextInput(session, 'datName', value=null2String(s)) 88 | }) 89 | 90 | ## Selecting fields 91 | observe({ 92 | activeField <- input$fieldsList 93 | isolate({ 94 | currentDat <- (projProperties[['activeDat']]) 95 | if(!isEmpty(currentDat)){ 96 | datList[[currentDat]][['dynamicProperties']][['activeField']] <<- activeField 97 | } 98 | }) 99 | 100 | }) 101 | observe({ 102 | updateInput[['activeField']] 103 | currentDat <- projProperties[['activeDat']] 104 | s <- if(!isEmpty(currentDat)){ 105 | isolate(datList[[currentDat]][['dynamicProperties']][['activeField']]) 106 | } else '' 107 | choices <- if(!isEmpty(currentDat)) datList[[currentDat]][['fieldNames']]() 108 | updateSelectizeInput(session, "fieldsList", choices=null2String(choices), 109 | selected=null2String(s)) 110 | }) 111 | 112 | ## modify field name 113 | observe({ 114 | v <- (input$fieldName) #make.names 115 | isolate({ 116 | currentDat <- (projProperties[['activeDat']]) 117 | if(!isEmpty(currentDat)){ 118 | currentField <- (datList[[currentDat]][['dynamicProperties']][['activeField']]) 119 | if(!isEmpty(currentField)){ 120 | if(!isEmpty(v) && isEmpty((datList[[currentDat]][['fieldNames']]())[v])){ 121 | datList[[currentDat]][['dynamicProperties']][['fieldsList']][[currentField]][['name']] <<- v 122 | if(v!=input$fieldName) triggerUpdateInput('fieldName') 123 | } 124 | } 125 | } 126 | }) 127 | 128 | }) 129 | observe({ 130 | updateInput[['fieldName']] 131 | currentDat <- projProperties[['activeDat']] 132 | s <- '' 133 | if(!isEmpty(currentDat)){ 134 | currentField <- datList[[currentDat]][['dynamicProperties']][['activeField']] 135 | if(!isEmpty(currentField)){ 136 | s <- isolate(datList[[currentDat]][['dynamicProperties']][['fieldsList']][[currentField]][['name']]) 137 | } 138 | } 139 | updateTextInput(session, 'fieldName', value=null2String(s)) 140 | }) 141 | 142 | ## Manipulating set of measures 143 | observe({ 144 | newMeasures <- input$measures 145 | isolate({ 146 | currentDat <- (projProperties[['activeDat']]) 147 | if(!isEmpty(currentDat)){ 148 | datList[[currentDat]][['dynamicProperties']][['measures']] <<- newMeasures 149 | } 150 | }) 151 | }) 152 | observe({ 153 | updateInput[['measures']] 154 | currentDat <- projProperties[['activeDat']] 155 | s <- if(!isEmpty(currentDat)){ 156 | isolate(datList[[currentDat]][['dynamicProperties']][['measures']]) 157 | } else '' 158 | choices <- if(!isEmpty(currentDat)) datList[[currentDat]][['fieldNames']]() 159 | updateSelectizeInput(session, "measures", choices=null2String(choices), 160 | selected=null2String(s)) 161 | }) 162 | 163 | ## Add data source from text file 164 | observe({ 165 | # input$file1 will be NULL initially. After the user selects 166 | # and uploads a file, it will be a data frame with 'name', 167 | # 'size', 'type', and 'datapath' columns. The 'datapath' 168 | # column will contain the local filenames where the data can 169 | # be found. 170 | inFile <- input[['file']] 171 | isolate({ 172 | if (!is.null(inFile)){ 173 | dat <- fread(inFile$datapath, header="auto", sep="auto") 174 | addDat(dat, name=inFile$name, type='file') 175 | } 176 | }) 177 | 178 | }) 179 | 180 | ## add with R code 181 | observeEvent(input$addDatCode, { 182 | addDat(type='code') 183 | }) 184 | 185 | output$uploadingTextFile <- reactive({ 186 | TRUE 187 | }) 188 | outputOptions(output, "uploadingTextFile", suspendWhenHidden=FALSE) 189 | 190 | output$datPreview <- renderDataTable({ 191 | currentDat <- projProperties[['activeDat']] 192 | if(!isEmpty(currentDat)){ 193 | dat <- datList[[currentDat]][['datR']]() 194 | if(!is.null(dat)){ 195 | datPrev <- copy(dat) # use of copy is necessary since setnames modify by reference 196 | setnames(datPrev, names(datList[[currentDat]][['fieldNames']]())) 197 | datPrev 198 | } 199 | } 200 | }) 201 | 202 | 203 | ## Text file import calibration 204 | 205 | # observe({ 206 | # hh <- input[['header']]; ss <- input[['sep']]; qq <- input[['quote']] 207 | # if(uploadingData){ 208 | # inFile <- isolate(input[['file']]) 209 | # 210 | # if (!is.null(inFile)){ 211 | # 212 | # dat <- read.csv(inFile$datapath, header=hh, sep=ss, quote=qq) 213 | # fileN <- isolate(input$datList) 214 | # datList[[fileN]] <<- dat 215 | # 216 | # defaultMeasures <- colnames(dat)[apply(dat,2,is.numeric)] 217 | # updateSelectizeInput(session, "measures", choices=colnames(dat), selected=defaultMeasures) 218 | # 219 | # output$datPreview <- renderDataTable({ 220 | # (dat) 221 | # }) 222 | # 223 | # metaDataSources[[fileN]][['data']] <<- dat 224 | # metaDataSources[[fileN]][['measures']] <<- defaultMeasures 225 | # 226 | # } 227 | # } 228 | # }) 229 | 230 | -------------------------------------------------------------------------------- /inst/shinyDataApp/docs.r: -------------------------------------------------------------------------------- 1 | ## Switching doc 2 | observe({ 3 | v <- input$docList 4 | isolate({ 5 | if(!isEmpty(v)) projProperties[['activeDoc']] <<- v 6 | }) 7 | 8 | }) 9 | observe({ 10 | updateInput[['activeDoc']] 11 | updateSelectInput(session, 'docList', choices=(docListNames()), 12 | selected=isolate(projProperties[['activeDoc']])) 13 | }) 14 | 15 | ## modify doc name 16 | observe({ 17 | v <- input$docName 18 | isolate({ 19 | currentDoc <- (projProperties[['activeDoc']]) 20 | if(!isEmpty(currentDoc)){ 21 | if(!isEmpty(v) && isEmpty(isolate(docListNames())[v])){ 22 | docList[[currentDoc]][['name']] <<- v 23 | } 24 | } 25 | }) 26 | 27 | }) 28 | observe({ 29 | updateInput[['docName']] 30 | currentDoc <- projProperties[['activeDoc']] 31 | s <- if(!isEmpty(currentDoc)){ 32 | isolate(docList[[currentDoc]][['name']]) 33 | } else '' 34 | updateTextInput(session, 'docName', value=null2String(s)) 35 | }) 36 | 37 | 38 | ## modify output format 39 | observe({ 40 | v <- input$rmdOuputFormat 41 | isolate({ 42 | currentDoc <- (projProperties[['activeDoc']]) 43 | if(!isEmpty(currentDoc)){ 44 | docList[[currentDoc]][['rmdOuputFormat']] <<- v 45 | } 46 | }) 47 | 48 | }) 49 | observe({ 50 | updateInput[['rmdOuputFormat']] 51 | currentDoc <- projProperties[['activeDoc']] 52 | s <- if(!isEmpty(currentDoc)){ 53 | isolate(docList[[currentDoc]][['rmdOuputFormat']]) 54 | } else '' 55 | updateSelectInput(session, 'rmdOuputFormat', selected=null2String(s)) 56 | }) 57 | 58 | ## modify rmd 59 | observe({ 60 | v <- input$rmd 61 | isolate({ 62 | currentDoc <- (projProperties[['activeDoc']]) 63 | if(!isEmpty(currentDoc)){ 64 | docList[[currentDoc]][['rmd']] <<- v 65 | } 66 | }) 67 | 68 | }) 69 | observe({ 70 | updateInput[['docRmd']] 71 | currentDoc <- projProperties[['activeDoc']] 72 | s <- if(!isEmpty(currentDoc)){ 73 | isolate(docList[[currentDoc]][['rmd']]) 74 | } else '' 75 | updateAceEditor(session, 'rmd', value=ifempty(s, '\n')) # bug in updateAceEditor: won't update with "" 76 | }) 77 | 78 | 79 | # substituteSheetName <- function(text){ 80 | # nn <- sheetListNames() 81 | # for(n in names(nn)){ 82 | # text <- gsub(paste('[',n,']',sep=''), 83 | # paste('sheetList[["',nn[n],'"]][["plotR"]]()',sep=''), text, fixed=TRUE) 84 | # } 85 | # text 86 | # } 87 | 88 | 89 | 90 | ## preview output 91 | output$rmdOutput <- renderUI({ 92 | currentDoc <- (projProperties[['activeDoc']]) 93 | if(input$rmdTabs=='Preview' && !isEmpty(currentDoc)){ 94 | isolate({ 95 | srcCode <- docList[[currentDoc]][['rmd']] 96 | if(!isEmpty(srcCode)){ 97 | HTML(knit2html(text = srcCode, fragment.only = TRUE, quiet = TRUE, 98 | envir=getDatSheetEnv())) 99 | } 100 | }) 101 | } 102 | }) 103 | 104 | getOutputExtension <- function (outputFormat) { 105 | switch(outputFormat, 106 | 'html_document'=, 'ioslides_presentation'=, 'slidy_presentation'='html', 107 | 'pdf_document'=, 'beamer_presentation'='pdf', 108 | 'word_document'='docx', 'md_document'='md', '') 109 | } 110 | 111 | output$downloadRmdOutput <- downloadHandler( 112 | filename = function() { 113 | isolate({ 114 | currentDoc <- projProperties[['activeDoc']] 115 | s <- if(!isEmpty(currentDoc)){ 116 | getOutputExtension(docList[[currentDoc]][['rmdOuputFormat']]) 117 | } else '' 118 | paste(docList[[currentDoc]][['name']], s, sep='.') 119 | }) 120 | }, 121 | content = function(file) { 122 | ## file is a temp file without extension 123 | ## unfortunately pandoc assumes it's html when no extension and not explicit format option is specified. 124 | ## this causes problems when the intended output is a pdf. 125 | isolate({ 126 | inputFile <- tempfile(fileext='.Rmd') 127 | on.exit(file.remove(inputFile), add=TRUE) 128 | currentDoc <- projProperties[['activeDoc']] 129 | if(!isEmpty(currentDoc) && !isEmpty(docList[[currentDoc]][['rmd']])){ 130 | cat(docList[[currentDoc]][['rmd']], file=inputFile) 131 | 132 | ## latex runs into problem with short form path, so use normalizePath to convert file to long form 133 | cat(" ", file=file) # just to create file so normalizePath can work 134 | file <- normalizePath(file) 135 | file.remove(file) 136 | outFile <- paste(file, 137 | getOutputExtension(docList[[currentDoc]][['rmdOuputFormat']]), sep='.') 138 | 139 | rmarkdown::render(normalizePath(inputFile), output_format=docList[[currentDoc]][['rmdOuputFormat']], 140 | output_file=outFile, envir=getDatSheetEnv(), quiet = TRUE, clean=TRUE) 141 | 142 | file.rename(outFile, file) 143 | } 144 | }) 145 | } 146 | ) 147 | 148 | #' Insert string into text at the cursor position 149 | #' 150 | #' @param insert The string to insert 151 | #' @param text The text to insert into 152 | #' @param cursor A list with row and column given as 0-based indexes indicating the cursor position in text 153 | #' 154 | #' @examples 155 | #' insertAtCursor('ss', 'ab\nc', list(row=1, column=1)) 156 | #' insertAtCursor('ss', 'aa\n', list(row=1, column=0)) 157 | insertAtCursor <- function(insert, text, cursor){ 158 | textLines <- unlist(strsplit(text, "\n", fixed=TRUE)) 159 | ## note strsplit doesn't capture the last line if it's empty 160 | if(text=='' || substring(text, nchar(text))=="\n") textLines <- c(textLines, "") 161 | row <- cursor$row + 1 162 | ans <- text 163 | if(row<=length(textLines)){ 164 | nn <- nchar(textLines[row]) 165 | if(cursor$column<=nn){ 166 | sub1 <- if(cursor$column==0) "" else substr(textLines[row], 1, cursor$column) 167 | sub2 <- if(cursor$column==nn) "" else substr(textLines[row], cursor$column+1, nn) 168 | textLines[row] <- paste0(sub1, insert, sub2) 169 | ans <- paste(textLines, collapse="\n") 170 | } 171 | } 172 | ans 173 | } 174 | 175 | observe({ 176 | v <- input$insertDatName 177 | if(v){ 178 | isolate({ 179 | if(!isEmpty(input$datNameToInsert) && !is.null(input$rmdCursor)){ 180 | sNames <- datListNames() 181 | sheetName <- paste0('`', names(sNames)[match(input$datNameToInsert, sNames)], '`') 182 | if(input$withRChunk){ 183 | sheetName <- paste('```{r, echo=FALSE}', sheetName, '```', sep='\n') 184 | } 185 | rmdNew <- insertAtCursor(sheetName, input$rmd, input$rmdCursor) 186 | updateAceEditor(session, 'rmd', value=rmdNew) 187 | } 188 | }) 189 | } 190 | }) 191 | observe({ 192 | updateSelectInput(session, 'datNameToInsert', choices=datListNames()) 193 | }) 194 | observe({ 195 | v <- input$insertSheetName 196 | if(v){ 197 | isolate({ 198 | if(!isEmpty(input$sheetNameToInsert) && !is.null(input$rmdCursor)){ 199 | sNames <- sheetListNames() 200 | sheetName <- paste0('`', names(sNames)[match(input$sheetNameToInsert, sNames)], '`') 201 | if(input$withRChunk){ 202 | sheetName <- paste('```{r, echo=FALSE}', sheetName, '```', sep='\n') 203 | } 204 | rmdNew <- insertAtCursor(sheetName, input$rmd, input$rmdCursor) 205 | updateAceEditor(session, 'rmd', value=rmdNew) 206 | } 207 | }) 208 | } 209 | }) 210 | observe({ 211 | updateSelectInput(session, 'sheetNameToInsert', choices=sheetListNames()) 212 | }) 213 | 214 | 215 | ## add doc 216 | observe({ 217 | v <- input$addDoc 218 | isolate({ 219 | if(v){ 220 | addDoc() 221 | } 222 | }) 223 | }) 224 | ## delete doc 225 | observe({ 226 | v <- input$deleteDoc 227 | isolate({ 228 | if(v){ 229 | currentDoc <- (projProperties[['activeDoc']]) 230 | if(!isEmpty(currentDoc)){ 231 | docs <- names(docList) 232 | i <- match(currentDoc, docs) 233 | docList[[currentDoc]] <<- NULL 234 | projProperties[['activeDoc']] <<- ifelse(length(docs)>i, docs[i+1], 235 | ifelse(i>1, docs[i-1], '')) 236 | } 237 | } 238 | }) 239 | }) 240 | 241 | -------------------------------------------------------------------------------- /inst/shinyDataApp/helpers.r: -------------------------------------------------------------------------------- 1 | ## see: http://stackoverflow.com/questions/9298765/print-latex-table-directly-to-an-image-png-or-other 2 | ## also maybe useful: http://tex.stackexchange.com/questions/11866/compile-a-latex-document-into-a-png-image-thats-as-short-as-possible 3 | make.png <- function(obj, resolution=NULL) { 4 | name <- tempfile('x') 5 | texFile <- paste(name,".tex",sep="") 6 | pngFile <- paste(name,".png",sep="") 7 | sink(file=texFile) 8 | cat(' 9 | \\documentclass[12pt]{report} 10 | \\usepackage[paperwidth=11in,paperheight=8in,noheadfoot,margin=0in]{geometry} 11 | \\usepackage[T1]{fontenc} 12 | \\usepackage{booktabs} 13 | \\begin{document}\\pagestyle{empty} 14 | {\\Large 15 | ') 16 | save <- booktabs(); on.exit(table_options(save), add=TRUE) 17 | latex(obj) 18 | 19 | cat(' 20 | }\\end{document} 21 | ') 22 | sink() 23 | wd <- setwd(tempdir()); on.exit(setwd(wd), add=TRUE) 24 | texi2dvi(file=texFile, index=FALSE) 25 | 26 | cmd <- paste("dvipng -T tight -o", 27 | shQuote(pngFile), 28 | if(!is.null(resolution)) paste("-D",resolution) else "", 29 | shQuote(paste(name,".dvi",sep=""))) 30 | invisible(sys(cmd)) 31 | cleaner <- c(".tex",".aux",".log",".dvi") 32 | invisible(file.remove(paste(name,cleaner,sep=""))) 33 | pngFile 34 | } 35 | 36 | newGuid <- function(){ 37 | gsub("-", "_", UUIDgenerate(), fixed=TRUE) 38 | 39 | #paste(sample(c(letters[1:6],0:9),30,replace=TRUE),collapse="") 40 | } 41 | 42 | ## preserve names of x 43 | setdiff.c <<- function(x, y){ 44 | z <- setdiff(x, y) 45 | x1 <- names(x) 46 | if(!is.null(x1)){ 47 | names(x1) <- x 48 | names(z) <- x1[z] 49 | z 50 | } else z 51 | } 52 | 53 | #' Check if an object is empty 54 | #' @examples 55 | #' isEmpty(NULL) 56 | #' isEmpty(c()) 57 | #' isEmpty(list(x=NA)) 58 | #' isEmpty(list(x='', y='')) 59 | isEmpty <<- function(x){ 60 | if(is.list(x)) x <- unlist(x) 61 | is.null(x) || length(x)==0 || all(is.na(x) | x=='') 62 | } 63 | 64 | ifnull <- function(x, d){ 65 | if(is.null(x)) d else x 66 | } 67 | ifempty <- function(x, d){ 68 | if(isEmpty(x)) d else x 69 | } 70 | 71 | null2String <- function(x){ 72 | ifnull(x,"") 73 | } 74 | empty2NULL <- function(x){ 75 | ifempty(x,NULL) 76 | } 77 | empty2FALSE <- function(x){ 78 | ifempty(x,FALSE) 79 | } 80 | empty2TRUE <- function(x){ 81 | ifempty(x,TRUE) 82 | } 83 | 84 | getDefaultMeasures <- function(dat, fields=NULL){ 85 | if(is.null(fields)) fields <- names(dat) 86 | fields[sapply(dat, function(x) typeof(x)=="double")] 87 | } 88 | 89 | getDefaultFieldsList <- function(dat){ 90 | x <- lapply(names(dat), function(n) reactiveValues('name'=n, 'type'=typeof(dat[[n]]))) 91 | names(x) <- names(dat) 92 | x 93 | } 94 | 95 | convertSheetNameToDatName <- function(sheetName){ 96 | paste(sheetName, '(Aggregated Data)', sep=' ') 97 | } 98 | 99 | names2formula <- function(nms){ 100 | if(!isEmpty(nms)){ 101 | paste(nms, collapse=" + ") 102 | } else " . " 103 | } 104 | 105 | isFieldUninitialized <- function(obj, field){ 106 | class(obj[[field]])=="uninitializedField" 107 | } 108 | 109 | are.vectors.different <- function(x, y){ 110 | if(isEmpty(x)){ 111 | !isEmpty(y) 112 | } else { 113 | isEmpty(y) || any(x!=y) 114 | } 115 | } 116 | 117 | ## convert d so that the specified columns of d are measures and the rest are dims 118 | ## measures: can be either logical or charecter vector 119 | forceMeasures <<- function(d, measures){ 120 | if(!is.logical(measures)) measures <- names(d) %in% measures 121 | for(n in seq_along(measures)){ 122 | if(measures[n]){ 123 | if(!is.numeric(d[[n]])) d[[n]] <- as.numeric(d[[n]]) 124 | } else { 125 | if(!is.factor(d[[n]])) d[[n]] <- as.factor(d[[n]]) 126 | } 127 | } 128 | d 129 | } 130 | 131 | ## list with reference semantics 132 | ## for later use (challenge: how to delete a field dynamically similarly to deleting a list item by setting it to NULL) 133 | refList <- setRefClass("refList") 134 | names.refList <- function(x) ls(x)[-1] # get rid of "getClass" 135 | 136 | DatClass <- setRefClass("DatClass", fields=c("staticProperties","dynamicProperties", 137 | "datRaw", "datR","fieldNames","moltenDat","moltenNames")) 138 | 139 | createNewDatClassObj <- function(dat=NULL, name='Data', nameOriginal=NULL, type='file'){ 140 | DatClass$new('staticProperties'=list('type'=type, 'nameOriginal'=nameOriginal), 141 | 'dynamicProperties'=reactiveValues('dat'=dat, 'name'=name)) 142 | } 143 | 144 | 145 | SheetClass <- setRefClass("SheetClass", 146 | fields=c("dynamicProperties","datR", 147 | "fieldNames","measuresR","plotCore","plotR", 148 | "tableR","layerNames")) 149 | createNewLayer <- function(){ 150 | geom <- 'point' 151 | stat <- 'identity' 152 | reactiveValues('geom'=geom, 'statType'=stat, 'yFun'='sum', 'layerPositionType'='identity', 153 | 'activeAes'='aesX', 154 | 'aesChoices'=getAesChoices(geom, stat), 155 | 'aesList'=sapply(AesChoicesSimpleList, 156 | function(x) reactiveValues('aesAggregate'=FALSE,'aesDiscrete'=TRUE,'aesMapOrSet'='map'), simplify=FALSE)) 157 | } 158 | createNewSheetObj <- function(name='Sheet', withPlotLayer=TRUE){ 159 | SheetClass$new( 160 | 'dynamicProperties'=reactiveValues( 161 | 'name'=name, 162 | 'datId'='', 'combineMeasures'=FALSE, 'outputType'='plot', 163 | 'columns'='', 'colChoices'='', 164 | 'rows'='', 'rowChoices'='', 165 | 'outputTable'=NULL, 166 | 'outputDataframe'=NULL, 167 | 'layerList'=if(withPlotLayer) list('Plot'=createNewLayer()) else list(), 168 | 'activeLayer'='Plot')) 169 | } 170 | 171 | updateInput <- function(session, inputType, inputId, value){ 172 | value <- null2String(value) 173 | switch(inputType, 174 | 'numeric'=updateNumericInput(session, inputId, value=value), 175 | 'text'=updateTextInput(session, inputId, value=value), 176 | 'slider'=updateSliderInput(session, inputId, value=value), 177 | 'color'=updateColorInput(session, inputId, value=value), 178 | 'checkbox'=updateCheckboxInput(session, inputId, value=value), 179 | 'tabsetPanel'=updateTabsetPanel(session, inputId, selected=value), 180 | 'select'=updateSelectInput(session, inputId, selected=value)) 181 | } 182 | 183 | 184 | 185 | # http://www.cookbook-r.com/Graphs/Multiple_graphs_on_one_page_(ggplot2)/ 186 | # Multiple plot function 187 | # 188 | # ggplot objects can be passed in ..., or to plotlist (as a list of ggplot objects) 189 | # - cols: Number of columns in layout 190 | # - layout: A matrix specifying the layout. If present, 'cols' is ignored. 191 | # 192 | # If the layout is something like matrix(c(1,2,3,3), nrow=2, byrow=TRUE), 193 | # then plot 1 will go in the upper left, 2 will go in the upper right, and 194 | # 3 will go all the way across the bottom. 195 | # 196 | multiplot <<- function(..., plotlist=NULL, file, cols=1, layout=NULL) { 197 | require(grid) 198 | 199 | # Make a list from the ... arguments and plotlist 200 | plots <- c(list(...), plotlist) 201 | 202 | numPlots = length(plots) 203 | 204 | # If layout is NULL, then use 'cols' to determine layout 205 | if (is.null(layout)) { 206 | # Make the panel 207 | # ncol: Number of columns of plots 208 | # nrow: Number of rows needed, calculated from # of cols 209 | layout <- matrix(seq(1, cols * ceiling(numPlots/cols)), 210 | ncol = cols, nrow = ceiling(numPlots/cols)) 211 | } 212 | 213 | if (numPlots==1) { 214 | print(plots[[1]]) 215 | 216 | } else { 217 | # Set up the page 218 | grid.newpage() 219 | pushViewport(viewport(layout = grid.layout(nrow(layout), ncol(layout)))) 220 | 221 | # Make each plot, in the correct location 222 | for (i in 1:numPlots) { 223 | # Get the i,j matrix positions of the regions that contain this subplot 224 | matchidx <- as.data.frame(which(layout == i, arr.ind = TRUE)) 225 | 226 | print(plots[[i]], vp = viewport(layout.pos.row = matchidx$row, 227 | layout.pos.col = matchidx$col)) 228 | } 229 | } 230 | } 231 | 232 | 233 | -------------------------------------------------------------------------------- /inst/shinyDataApp/global.r: -------------------------------------------------------------------------------- 1 | ProductionMode <- TRUE 2 | ## conditional calculated field: mutate and ddply; see documentation for ddply 3 | ## groups: use selectInput with multiple=TRUE and selectize = FALSE 4 | ## http://stackoverflow.com/questions/3418128/how-to-convert-a-factor-to-an-integer-numeric-without-a-loss-of-information 5 | 6 | ## GitHub Hosting example: https://gist.github.com/mattbrehmer/5645155 7 | ## Alternative to ggplot2: https://github.com/ramnathv/rCharts 8 | 9 | #options(error = browser) 10 | # NULL, browser, etc. 11 | #options(shiny.error=NULL) 12 | if(ProductionMode){ 13 | options(shiny.error=NULL) 14 | } else { 15 | options(shiny.error=function() { 16 | ## skip validation errors 17 | if(!inherits(eval.parent(expression(e)), "validation")) browser() 18 | }) 19 | } 20 | 21 | #options(shiny.trace = FALSE) # change to TRUE for trace 22 | #options(shiny.reactlog=TRUE) 23 | options(shiny.maxRequestSize = 100*1024^2) # Set the upload limit to 100MB 24 | ## see https://groups.google.com/forum/#!topic/shiny-discuss/2wgIG3dOEZI 25 | 26 | library(grid); library(shiny); library(ggplot2); library(Hmisc); library(uuid); 27 | library(tables); library(tools); library(png); library(data.table); 28 | library(shinysky); library(shinyBS); require(Cairo) 29 | library(knitr); library(rmarkdown); library(shinyAce); library(shinyTree) 30 | 31 | options(shiny.usecairo=TRUE) 32 | 33 | 34 | MoltenMeasuresName <- 'value' 35 | lengthUnique <<- function(x) { length(unique(x)) } 36 | YFunChoices <- c('Sum'='sum','Mean'='mean','Median'='median','Min'='min','Max'='max', 37 | 'Standard Deviation'='sd','Variance'='var','Count'='length', 'Count (Distinct)'='lengthUnique') 38 | AggFunChoicesDimension <- c('Min'='min','Max'='max', 39 | 'Count'='length', 'Count (Distinct)'='lengthUnique') 40 | InternalY <- '..y..' 41 | 42 | 43 | GeomChoices <- c('Text'='text', 'Bar'='bar','Line'='line', 44 | 'Area'='area', 'Point'='point', 45 | 'Path'='path', 'Polygon'='polygon', 46 | 'Boxplot'='boxplot', 'Density Curve'='density', 47 | 'Smoother'='smooth') 48 | StatChoices <- c('Identity'='identity','Count'='bin','Summary'='summary','Boxplot'='boxplot','Density'='density', 49 | 'Smoother'='smooth') 50 | UnitChoices <- c('Normalized Parent Coordinates'='npc', 'Centimeters'='cm', 'Inches'='inches', 51 | 'Millimeters'='mm', 'Points'='points', 'Lines of Text'='lines', 52 | 'Font Height'='char') 53 | 54 | getAesChoices <- function(geom, stat='identity'){ 55 | switch(geom, 56 | 'text'=switch(stat, 57 | 'bin'=list('Coordinates'=c('X'='aesX'), 58 | 'Common'=c('Label'='aesLabel','Color'='aesColor','Size'='aesSize', 59 | 'Shape'='aesShape','Line Type'='aesLineType','Angle'='aesAngle'), 60 | 'Color'=c('Alpha'='aesAlpha'), 61 | 'Label'=c('Font Family'='aesFamily','Font Face'='aesFontface','Line Height'='aesLineheight'), 62 | 'Justification'=c('Horizontal Adjustment'='aesHjust','Vertical Adjustment'='aesVjust') 63 | ), 64 | 'identity'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 65 | 'Common'=c('Label'='aesLabel','Color'='aesColor','Size'='aesSize', 66 | 'Shape'='aesShape','Line Type'='aesLineType','Angle'='aesAngle'), 67 | 'Color'=c('Alpha'='aesAlpha'), 68 | 'Label'=c('Font Family'='aesFamily','Font Face'='aesFontface','Line Height'='aesLineheight'), 69 | 'Justification'=c('Horizontal Adjustment'='aesHjust','Vertical Adjustment'='aesVjust') 70 | ) 71 | ), 72 | 73 | 'bar'=switch(stat, 74 | 'bin'=list('Coordinates'=c('X'='aesX'), 75 | 'Common'=c('Color'='aesColor','Size'='aesSize', 76 | 'Line Type'='aesLineType','Weight'='aesWeight'), 77 | 'Color'=c('Border Color'='aesBorderColor', 78 | 'Alpha'='aesAlpha') 79 | ), 80 | 'identity'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 81 | 'Common'=c('Color'='aesColor','Size'='aesSize', 82 | 'Line Type'='aesLineType','Weight'='aesWeight'), 83 | 'Color'=c('Border Color'='aesBorderColor', 84 | 'Alpha'='aesAlpha') 85 | ) 86 | ), 87 | 88 | 'line'=switch(stat, 89 | 'bin'=list('Coordinates'=c('X'='aesX'), 90 | 'Common'=c('Color'='aesColor','Size'='aesSize', 91 | 'Line Type'='aesLineType', 92 | 'Grouping'='aesGroup'), 93 | 'Color'=c('Alpha'='aesAlpha') 94 | ), 95 | 'identity'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 96 | 'Common'=c('Color'='aesColor','Size'='aesSize', 97 | 'Line Type'='aesLineType', 98 | 'Grouping'='aesGroup'), 99 | 'Color'=c('Alpha'='aesAlpha') 100 | ), 101 | 'density'=list('Coordinates'=c('X'='aesX'), 102 | 'Common'=c('Color'='aesColor','Size'='aesSize', 103 | 'Line Type'='aesLineType', 104 | 'Grouping'='aesGroup'), 105 | 'Color'=c('Alpha'='aesAlpha') 106 | ) 107 | ), 108 | 109 | 'area'=switch(stat, 110 | 'bin'=list('Coordinates'=c('X'='aesX'), 111 | 'Common'=c('Color'='aesColor','Size'='aesSize', 112 | 'Line Type'='aesLineType'), 113 | 'Color'=c('Border Color'='aesBorderColor', 114 | 'Alpha'='aesAlpha') 115 | ), 116 | 'identity'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 117 | 'Common'=c('Color'='aesColor','Size'='aesSize', 118 | 'Line Type'='aesLineType'), 119 | 'Color'=c('Border Color'='aesBorderColor', 120 | 'Alpha'='aesAlpha') 121 | ), 122 | 'density'=list('Coordinates'=c('X'='aesX'), 123 | 'Common'=c('Color'='aesColor','Size'='aesSize', 124 | 'Line Type'='aesLineType'), 125 | 'Color'=c('Border Color'='aesBorderColor', 126 | 'Alpha'='aesAlpha') 127 | ) 128 | ), 129 | 130 | 'point'=switch(stat, 131 | 'bin'=list('Coordinates'=c('X'='aesX'), 132 | 'Common'=c('Color'='aesColor','Size'='aesSize', 133 | 'Shape'='aesShape'), 134 | 'Color'=c('Border Color'='aesBorderColor','Alpha'='aesAlpha') 135 | ), 136 | 'identity'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 137 | 'Common'=c('Color'='aesColor','Size'='aesSize', 138 | 'Shape'='aesShape'), 139 | 'Color'=c('Border Color'='aesBorderColor','Alpha'='aesAlpha') 140 | ) 141 | ), 142 | 143 | 'boxplot'=switch(stat, 144 | 'boxplot'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 145 | 'Common'=c('Color'='aesColor','Size'='aesSize', 146 | 'Shape'='aesShape','Line Type'='aesLineType','Weight'='aesWeight'), 147 | 'Color'=c('Border Color'='aesBorderColor', 148 | 'Alpha'='aesAlpha') 149 | ), 150 | 'identity'=list('Coordinates'=c('X'='aesX','Y Middle'='aesMiddle', 151 | 'Y Lower'='aesLower','Y Upper'='aesUpper', 152 | 'Y Min'='aesYmin','Y Max'='aesYmax'), 153 | 'Common'=c('Color'='aesColor','Size'='aesSize', 154 | 'Shape'='aesShape','Line Type'='aesLineType','Weight'='aesWeight'), 155 | 'Color'=c('Border Color'='aesBorderColor', 156 | 'Alpha'='aesAlpha') 157 | ) 158 | ), 159 | 160 | 'density'=switch(stat, 161 | 'density'=list('Coordinates'=c('X'='aesX'), 162 | 'Common'=c('Color'='aesColor','Size'='aesSize', 163 | 'Line Type'='aesLineType'), 164 | 'Color'=c('Border Color'='aesBorderColor', 165 | 'Alpha'='aesAlpha') 166 | ) 167 | ), 168 | 169 | 'smooth'=switch(stat, 170 | 'smooth'=list('Coordinates'=c('X'='aesX','Y'='aesY'), 171 | 'Common'=c('Color'='aesColor','Size'='aesSize', 172 | 'Line Type'='aesLineType','Grouping'='aesGroup'), 173 | 'Color'=c('Border Color'='aesBorderColor', 174 | 'Alpha'='aesAlpha') 175 | ) 176 | ) 177 | 178 | ) 179 | } 180 | 181 | AesChoicesSimpleList <- unique(unlist(lapply(GeomChoices, getAesChoices), use.names=FALSE)) 182 | 183 | extrafontsImported <- (system.file("fontmap/fonttable.csv", package = "extrafontdb")!="") 184 | FontFamilyChoices <- c("AvantGarde", "Bookman", "Courier", "Helvetica", 185 | "Helvetica-Narrow", "NewCenturySchoolbook", "Palatino", "Times") 186 | if(extrafontsImported) FontFamilyChoices <- extrafont::fonts() 187 | FontFamilyChoices <- c('Choose'='', FontFamilyChoices) 188 | 189 | 190 | FontFaceChoices <- c('Choose'='', "Plain"="plain","Bold"="bold","Italic"="italic","Bold & Italic"="bold.italic") 191 | 192 | getLegendLabelPositionChoices <- function(legend.layout.direction){ 193 | if(!is.null(legend.layout.direction) && legend.layout.direction=='horizontal') { 194 | c('Default'='', 'Top'='top', 'Bottom'='bottom') 195 | } else { 196 | c('Default'='', 'Left'='left', 'Right'='right') 197 | } 198 | } 199 | 200 | brewer.mat <- RColorBrewer::brewer.pal.info 201 | palettes.all <- rownames(brewer.mat) 202 | BrewerPaletteChoices <- list('Choose'='', 203 | 'Sequential'=palettes.all[brewer.mat[,'category']=='seq'], 204 | 'Diverging'=palettes.all[brewer.mat[,'category']=='div'], 205 | 'Qualitative'=palettes.all[brewer.mat[,'category']=='qual']) 206 | 207 | source('color.r', local=TRUE) 208 | -------------------------------------------------------------------------------- /inst/shinyDataApp/sheetsCustomize.r: -------------------------------------------------------------------------------- 1 | gg_element_tree <- ggplot2:::.element_tree 2 | 3 | observe({ 4 | v <- get_selected(input[['customizeItem']]) 5 | isolate({ 6 | if(!isEmpty(v)){ 7 | v <- v[[1]] 8 | currentSheet <- (projProperties[['activeSheet']]) 9 | if(!isEmpty(currentSheet)){ 10 | if(are.vectors.different(v, sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']])){ 11 | sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']] <<- v 12 | 13 | if(is.null(sheetList[[currentSheet]][['dynamicProperties']][['formatting']])){ 14 | sheetList[[currentSheet]][['dynamicProperties']][['formatting']] <<- list() 15 | } 16 | if(is.null(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[v]])){ 17 | formats <- structure(list(), 'type'=gg_element_tree[[v]][['class']]) 18 | if(attr(formats, 'type')=='unit'){ 19 | ## set default unit 20 | formats[['unitUnits']] <- 'char' 21 | } 22 | sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[v]] <<- formats 23 | } 24 | } 25 | } 26 | } 27 | }) 28 | }) 29 | output$customizeItem <- renderTree({ 30 | updateInput[['customizeItem']] 31 | currentSheet <- projProperties[['activeSheet']] 32 | s <- if(!isEmpty(currentSheet)){ 33 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']]) 34 | } else '' 35 | 36 | get_children <- function(node){ 37 | children <- gg_element_tree[sapply(gg_element_tree, function(x) !are.vectors.different(node, x$inherit))] 38 | if(length(children)){ 39 | sapply(names(children), simplify = FALSE, USE.NAMES = TRUE, 40 | function(n){ 41 | ans <- get_children(n) 42 | if(n==null2String(s)) attr(ans, 'stselected') <- TRUE 43 | ans 44 | }) 45 | } else { 46 | '' 47 | } 48 | } 49 | get_children(NULL) 50 | }) 51 | 52 | 53 | ## upsert sheet dynamicProperties 54 | lapply(list(list(inputId='plotTitle', inputType='text'), 55 | list(inputId='plotXlab', inputType='text'), 56 | list(inputId='plotYlab', inputType='text')), 57 | function(x){ 58 | assign(paste0('observer_', x$inputId, '_push'), 59 | observe({ 60 | v <- input[[x$inputId]] 61 | isolate({ 62 | currentSheet <- (projProperties[['activeSheet']]) 63 | if(!isEmpty(currentSheet)){ 64 | if(are.vectors.different(v, sheetList[[currentSheet]][['dynamicProperties']][[x$inputId]])){ 65 | sheetList[[currentSheet]][['dynamicProperties']][[x$inputId]] <<- v 66 | } 67 | } 68 | }) 69 | }), 70 | sessionEnv) 71 | assign(paste0('observer_', x$inputId, '_pull'), 72 | observe({ 73 | updateInput[[x$inputId]] 74 | currentSheet <- projProperties[['activeSheet']] 75 | s <- if(!isEmpty(currentSheet)){ 76 | isolate(sheetList[[currentSheet]][['dynamicProperties']][[x$inputId]]) 77 | } else '' 78 | updateInput(session, x$inputType, x$inputId, s) 79 | }), 80 | sessionEnv) 81 | }) 82 | 83 | 84 | output$ggElementType <- reactive({ 85 | currentSheet <- projProperties[['activeSheet']] 86 | s <- '' 87 | if(!isEmpty(currentSheet)){ 88 | customizeItem <- (sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']]) 89 | isolate({ 90 | if(!isEmpty(customizeItem) && !is.null(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]])){ 91 | s <- attr(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]], 'type') 92 | } 93 | }) 94 | } 95 | null2String(s) 96 | }) 97 | outputOptions(output, "ggElementType", suspendWhenHidden=FALSE) 98 | 99 | ########################### 100 | ## Formatting 101 | 102 | output$charSetting <- renderUI({ 103 | currentSheet <- projProperties[['activeSheet']] 104 | if(!isEmpty(currentSheet)){ 105 | s <- (sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']]) 106 | isolate({ 107 | vMain <- sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[s]][['charMainValue']] 108 | v1 <- sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[s]][['charAltValue1']] 109 | v2 <- sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[s]][['charAltValue2']] 110 | switch(s, 111 | 'legend.text.align'=, 'legend.title.align'=list( 112 | selectInput('charMainValue', 'Alignment', selected=vMain, 113 | choices=c('Choose'='', 'Left'=0, 'Right'=1,'Center'=0.5, 114 | 'Custom'='custom_')), 115 | conditionalPanel('input.charMainValue=="custom_"', 116 | sliderInput('charAltValue1', 'Anchor', min=0, max=1, value=v1)) 117 | ), 118 | 'legend.direction'=list( 119 | helpText('Layout of items in legends:'), 120 | selectInput('charMainValue', '', selected=vMain, 121 | choices=c('Choose'='', 'Horizontal'='horizontal', 'Vertical'='vertical')) 122 | ), 123 | 'legend.box'=list( 124 | helpText('Arrangement of multiple legends:'), 125 | selectInput('charMainValue', '', selected=vMain, 126 | choices=c('Choose'='', 'Horizontal'='horizontal', 'Vertical'='vertical')) 127 | ), 128 | 'legend.position'=list( 129 | selectInput('charMainValue', '', selected=vMain, 130 | choices=c('Choose'='', 'Right'='right','Bottom'='bottom', 131 | 'Top'='top','Left'='left','Custom'='custom_')), 132 | conditionalPanel('input.charMainValue=="custom_"', 133 | sliderInput('charAltValue1', 'X', min=0, max=1, value=v1), 134 | sliderInput('charAltValue2', 'Y', min=0, max=1, value=v2)) 135 | ), 136 | 'legend.justification'=list( 137 | helpText('Anchor point for positioning legend inside plot:'), 138 | selectInput('charMainValue', '', selected=vMain, 139 | choices=c('Choose'='', 'Center'='center','Custom'='custom_')), 140 | conditionalPanel('input.charMainValue=="custom_"', 141 | sliderInput('charAltValue1', 'X', min=0, max=1, value=v1), 142 | sliderInput('charAltValue2', 'Y', min=0, max=1, value=v2)) 143 | ), 144 | 'legend.box.just'=list( 145 | helpText('Justification of each legend within the overall bounding box, when there are multiple legends.'), 146 | selectInput('charMainValue', '', selected=vMain, 147 | choices=c('Choose'='', 'Right'='right','Bottom'='bottom', 148 | 'Top'='top','Left'='left')) 149 | ), 150 | 'aspect.ratio'=list( 151 | numericInput('charMainValue', 'Plot Aspect Ratio', value=vMain, step=0.1) 152 | ) 153 | ) 154 | }) 155 | } 156 | }) 157 | 158 | lapply(list(list(inputId='textFamily', inputType='select'), 159 | list(inputId='textFace', inputType='select'), 160 | list(inputId='textColor', inputType='color'), 161 | list(inputId='textSize', inputType='numeric'), 162 | list(inputId='textHjust', inputType='numeric'), 163 | list(inputId='textVjust', inputType='numeric'), 164 | list(inputId='textAngle', inputType='numeric'), 165 | list(inputId='textLineheight', inputType='numeric'), 166 | 167 | list(inputId='rectColor', inputType='color'), 168 | list(inputId='rectFill', inputType='color'), 169 | list(inputId='rectSize', inputType='numeric'), 170 | list(inputId='rectLinetype', inputType='numeric'), 171 | 172 | list(inputId='lineColor', inputType='color'), 173 | list(inputId='lineSize', inputType='numeric'), 174 | list(inputId='lineLinetype', inputType='numeric'), 175 | list(inputId='lineLineend', inputType='numeric'), 176 | 177 | list(inputId='unitX', inputType='numeric'), 178 | list(inputId='unitUnits', inputType='select'), 179 | 180 | list(inputId='charMainValue', inputType='dynamic'), # no updating for dynamic UIs 181 | list(inputId='charAltValue1', inputType='dynamic'), 182 | list(inputId='charAltValue2', inputType='dynamic'), 183 | 184 | list(inputId='elementBlank', inputType='checkbox') 185 | ), 186 | function(x){ 187 | assign(paste0('observer_', x$inputId, '_push'), 188 | observe({ 189 | v <- input[[x$inputId]] 190 | isolate({ 191 | if(!is.null(v)){ 192 | currentSheet <- (projProperties[['activeSheet']]) 193 | if(!isEmpty(currentSheet)) { 194 | customizeItem <- sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']] 195 | if(!isEmpty(customizeItem)){ 196 | if(x$inputId=='elementBlank'){ 197 | if(!isEmpty(v)) attr(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]], 198 | 'elementBlank') <<- v 199 | } else { 200 | if(are.vectors.different(v, sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][[x$inputId]])){ 201 | sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][[x$inputId]] <<- v 202 | 203 | if(x$inputId=='charMainValue' && !isEmpty(v) && v=='custom_' && 204 | isEmpty(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][['charAltValue1']])){ 205 | sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][['charAltValue1']] <<- 0 206 | if(customizeItem %in% c('legend.position','legend.justification')){ 207 | sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][['charAltValue2']] <<- 0 208 | } 209 | } 210 | } 211 | } 212 | } 213 | } 214 | } 215 | }) 216 | }), 217 | sessionEnv) 218 | if(x$inputType=='dynamic') return() 219 | assign(paste0('observer_', x$inputId, '_pull'), 220 | observe({ 221 | updateInput[[x$inputId]] 222 | currentSheet <- projProperties[['activeSheet']] 223 | s <- '' 224 | if(!isEmpty(currentSheet)){ 225 | customizeItem <- (sheetList[[currentSheet]][['dynamicProperties']][['customizeItem']]) 226 | isolate({ 227 | if(!isEmpty(customizeItem) && !is.null(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]])){ 228 | if(x$inputId=='elementBlank'){ 229 | s <- attr(sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]], 230 | 'elementBlank') 231 | } else { 232 | s <- sheetList[[currentSheet]][['dynamicProperties']][['formatting']][[customizeItem]][[x$inputId]] 233 | } 234 | } 235 | }) 236 | } 237 | 238 | updateInput(session, x$inputType, x$inputId, s) 239 | }), 240 | sessionEnv) 241 | }) 242 | 243 | 244 | ## End of Formatting 245 | ########################### 246 | 247 | -------------------------------------------------------------------------------- /inst/shinyDataApp/ui.r: -------------------------------------------------------------------------------- 1 | ## No upload progress bar 2 | fileInput1 <- 3 | function (inputId, label, multiple = FALSE, accept = NULL) 4 | { 5 | inputTag <- tags$input(id = inputId, name = inputId, type = "file") 6 | if (multiple) 7 | inputTag$attribs$multiple <- "multiple" 8 | if (length(accept) > 0) 9 | inputTag$attribs$accept <- paste(accept, collapse = ",") 10 | tagList(tags$label(label), inputTag) 11 | } 12 | 13 | textareaInput <- function(inputId, label, value="", placeholder="", rows=2){ 14 | tagList( 15 | div(strong(label), style="margin-top: 5px;"), 16 | tags$style(type="text/css", "textarea {width:100%; margin-top: 5px;}"), 17 | tags$textarea(id = inputId, placeholder = placeholder, rows = rows, value)) 18 | } 19 | 20 | 21 | shinyUI(navbarPage( 22 | id='mainNavBar', 23 | title=img(src="http://i.imgur.com/hG7Ltn2.png", alt="shinyData"), 24 | windowTitle="shinyData", 25 | 26 | tabPanel(title='Project', 27 | 28 | div(selectInput('sampleProj', 29 | list(actionButton('openSampleProj', 'Open', styleclass="primary", size="small"), 'Sample Project:'), 30 | choices=list.files('samples')), 31 | class = "pull-right"), 32 | br(), 33 | 34 | downloadButton('downloadProject', 'Save Project to File'), 35 | 36 | tags$hr(), 37 | 38 | fileInput1('loadProject', 'Import Project from File', accept=c('.sData')), 39 | radioButtons('loadProjectAction', '', 40 | choices=c('Replace existing work'='replace', 41 | 'Merge with existing work'='merge'), 42 | selected='replace', inline=FALSE), 43 | 44 | tags$hr(), 45 | includeMarkdown('md/about.md') 46 | ), 47 | 48 | 49 | 50 | tabPanel(title="Data", 51 | 52 | sidebarLayout( 53 | sidebarPanel( 54 | 55 | selectInput(inputId="datList", label=NULL, choices=NULL), 56 | 57 | tags$hr(), 58 | fileInput1('file', 'Add Data Source from Text File', 59 | accept=c('text/csv', 60 | 'text/comma-separated-values,text/plain', 61 | '.csv')), 62 | 63 | tags$hr(), 64 | actionButton('addDatCode', 'Add Data Source with R Code', styleclass="primary") 65 | ), 66 | mainPanel( 67 | textInput('datName', 'Data Source Name'), 68 | 69 | tags$hr(), 70 | 71 | conditionalPanel('output.currentDatType=="code"', 72 | bsAlert('datCodeAlert'), 73 | aceEditor('datCode', mode='r', value='', cursorId="datCodeCursor", 74 | selectionId='datCodeSelection', wordWrap=TRUE), 75 | actionButton('runDatCode', 'Run', styleclass="primary"), 76 | tags$hr() 77 | ), 78 | 79 | selectizeInput(inputId="measures", label="Measures", 80 | choices=NULL, multiple=TRUE, 81 | options=list( 82 | placeholder = '', 83 | plugins = I("['remove_button']"))), 84 | 85 | tags$hr(), 86 | 87 | selectizeInput(inputId="fieldsList", label="Fields Details", 88 | choices=NULL), 89 | textInput('fieldName', 'Field Name'), 90 | 91 | tags$hr(), 92 | 93 | h4('Preview'), 94 | dataTableOutput('datPreview') 95 | 96 | 97 | 98 | ) 99 | ) 100 | ), 101 | 102 | tabPanel(title='Visualize', 103 | 104 | sidebarLayout( 105 | sidebarPanel( 106 | fluidRow( 107 | column(6, selectInput(inputId='sheetList', label=NULL, choices=NULL, selected='')), 108 | column(6, fluidRow( 109 | actionButton(inputId='addSheet', label='Add Sheet', styleclass="primary", size="small", css.class='btn-aligned-select'), 110 | actionButton(inputId='deleteSheet', label='Delete Sheet', styleclass="danger", size="small", css.class='btn-aligned-select') 111 | )) 112 | ), 113 | fluidRow( 114 | column(6, selectInput(inputId='layerList', label=NULL, choices=NULL, selected='', selectize=FALSE, size=3)), 115 | column(6, fluidRow( 116 | actionButton(inputId='addLayer', label='Add Overlay', styleclass="primary", size="small", css.class='btn-aligned-select'), 117 | actionButton(inputId='bringToTop', label='Bring to Top', styleclass="primary", size="small", css.class='btn-aligned-select'), 118 | conditionalPanel('input.layerList!="Plot"', 119 | actionButton(inputId='deleteLayer', label='Delete Overlay', styleclass="danger", size="small", css.class='btn-aligned-select') 120 | ) 121 | )) 122 | ), 123 | 124 | tabsetPanel(id='sheetControlTab', 125 | tabPanel('Type', value='sheetTabType', 126 | fluidRow( 127 | column(6, 128 | selectInput(inputId='markList', label='Mark Type', 129 | choices=GeomChoices, selected='point'), 130 | selectInput(inputId='layerPositionType', label='Positioning', 131 | choices=c('Stack'='stack','Dodge'='dodge','Fill'='fill', 132 | 'Identity'='identity','Jitter'='jitter'), 133 | selected='identity'), 134 | fluidRow( 135 | column(6, 136 | textInput('layerPositionWidth', label='Width') 137 | ), 138 | column(6, 139 | textInput('layerPositionHeight', label='Height') 140 | ) 141 | ) 142 | ), 143 | column(6, 144 | selectInput(inputId='statTypeList', label='Stat', 145 | choices=StatChoices, selected='identity'), 146 | conditionalPanel('input.statTypeList=="summary"', 147 | selectizeInput(inputId='yFunList', label='Summarize Y with', 148 | choices=YFunChoices, 149 | selected='sum', multiple=FALSE, 150 | options = list(create = TRUE))) 151 | ) 152 | ), 153 | br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br() 154 | ), 155 | tabPanel('Mapping', value='sheetTabMapping', 156 | 157 | fluidRow( 158 | column(4, 159 | selectInput(inputId='aesList', label=NULL, 160 | choices=NULL, selectize=FALSE, size=15) 161 | ), 162 | column(8, 163 | conditionalPanel('input.layerList != "Plot" || 164 | (input.aesList!="aesX" && input.aesList!="aesY")', 165 | radioButtons('aesMapOrSet', '', choices=c('Map to variable'='map', 166 | 'Set to fixed value'='set'), 167 | selected='', inline=TRUE) 168 | ), 169 | 170 | uiOutput('mapOrSetUI') 171 | ) 172 | ), 173 | br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br() 174 | ), 175 | # tabPanel('Filters', value='sheetTabFilters', 176 | # selectizeInput(inputId='filterField', label='Field', 177 | # choices=NULL, multiple=FALSE), 178 | # br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br() 179 | # ), 180 | 181 | tabPanel('Customize', value='sheetTabCustomize', 182 | textareaInput(inputId = 'plotTitle', label="Plot Title", value="", 183 | placeholder = 'Enter Plot Title here', rows = 2), 184 | fluidRow( 185 | column(6, 186 | textInput('plotXlab', 'X Axis Title') 187 | ), 188 | column(6, 189 | textInput('plotYlab', 'Y Axis Title') 190 | )), 191 | h4('Formatting'), 192 | fluidRow( 193 | column(6, 194 | shinyTree('customizeItem', search=TRUE) 195 | ), 196 | column(6, 197 | conditionalPanel('output.ggElementType!="unit" && output.ggElementType!="character" && output.ggElementType!=""', 198 | checkboxInput('elementBlank', 'Hide Element', value=FALSE)), 199 | conditionalPanel('output.ggElementType=="element_text"', 200 | selectInput('textFamily','Font Family', choices=FontFamilyChoices), 201 | selectInput('textFace', 'Font Face', choices=FontFaceChoices), 202 | colorInput('textColor', 'Font Color'), 203 | numericInput('textSize', 'Font Size (pts)', value=NULL, step=0.1), 204 | numericInput('textHjust', 'Horizontal Adjustment', value=NULL, step=0.1), 205 | numericInput('textVjust', 'Vertical Adjustment', value=NULL, step=0.1), 206 | numericInput('textAngle', 'Angle (in [0,360])', value=NULL, step=1), 207 | numericInput('textLineheight', 'Text Line Height', value=NULL, step=0.1) 208 | ), 209 | conditionalPanel('output.ggElementType=="element_rect"', 210 | colorInput('rectColor', 'Border Color'), 211 | colorInput('rectFill', 'Fill'), 212 | numericInput('rectSize', 'Border Line Width (pts)', value=NULL, step=0.1), 213 | numericInput('rectLinetype', 'Border Line Type', value=NULL, step=1) 214 | ), 215 | conditionalPanel('output.ggElementType=="element_line"', 216 | colorInput('lineColor', 'Line Color'), 217 | numericInput('lineSize', 'Line Width (pts)', value=NULL, step=0.1), 218 | numericInput('lineLinetype', 'Line Type', value=NULL, step=1), 219 | numericInput('lineLineend', 'Line End', value=NULL, step=1) 220 | ), 221 | conditionalPanel('output.ggElementType=="unit"', 222 | numericInput('unitX', 'Value', value=NULL, step=0.1), 223 | selectInput('unitUnits', 'Unit', choices=UnitChoices) 224 | ), 225 | conditionalPanel('output.ggElementType=="character"', 226 | uiOutput('charSetting') 227 | ) 228 | ) 229 | ), 230 | br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br() 231 | ) 232 | ) 233 | ), 234 | mainPanel( 235 | textInput('sheetName', label=''), 236 | tags$hr(), 237 | fluidRow( 238 | column(4, 239 | #selectInput(inputId='outputTypeList', label='Output Type', 240 | # choices=c('Table'='table','Plot'='plot'), selected='plot'), 241 | radioButtons('autoRefresh', label='', 242 | choices=c('Auto Refresh'='refresh','Pause Refreshing'='pause'), selected='refresh') 243 | ), 244 | column(4, 245 | selectInput(inputId='sheetDatList', label='Data', choices=NULL), 246 | checkboxInput('combineMeasures', label='Combine Measures') 247 | ), 248 | column(4, 249 | selectizeInput(inputId="columns", label="Facet Columns", 250 | choices=NULL, multiple=TRUE, 251 | options=list( 252 | placeholder = '', 253 | plugins = I("['remove_button','drag_drop']"))), 254 | selectizeInput(inputId="rows", label="Facet Rows", 255 | choices=NULL, multiple=TRUE, 256 | options=list( 257 | placeholder = '', 258 | plugins = I("['remove_button','drag_drop']"))) 259 | ) 260 | ), 261 | tags$hr(), 262 | uiOutput('sheetOutput') 263 | ) 264 | ) 265 | ), 266 | 267 | 268 | tabPanel(title='Presentation', 269 | 270 | sidebarLayout( 271 | sidebarPanel( 272 | fluidRow( 273 | column(3, selectInput(inputId='docList', label=NULL, choices=NULL, selected='')), 274 | column(9, fluidRow( 275 | actionButton(inputId='addDoc', label='Add Document', styleclass="primary", size="small", css.class='btn-aligned-select'), 276 | actionButton(inputId='deleteDoc', label='Delete Document', styleclass="danger", size="small", css.class='btn-aligned-select') 277 | )) 278 | ), 279 | 280 | tabsetPanel( 281 | tabPanel('Instructions', 282 | 283 | br(), 284 | includeMarkdown('md/rmdInstructions.md'), 285 | 286 | checkboxInput('withRChunk', label='Insert with R chunk enclosure', value=TRUE), 287 | fluidRow( 288 | column(6, selectInput(inputId='datNameToInsert', label=NULL, choices=NULL, selected='')), 289 | column(6, fluidRow( 290 | actionButton(inputId='insertDatName', label='Insert Data', styleclass="primary", size="small", css.class='btn-aligned-select') 291 | )) 292 | ), 293 | fluidRow( 294 | column(6, selectInput(inputId='sheetNameToInsert', label=NULL, choices=NULL, selected='')), 295 | column(6, fluidRow( 296 | actionButton(inputId='insertSheetName', label='Insert Sheet', styleclass="primary", size="small", css.class='btn-aligned-select') 297 | )) 298 | ), 299 | br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br(), br() 300 | ) 301 | ) 302 | ), 303 | mainPanel( 304 | textInput('docName', label=''), 305 | tags$hr(), 306 | div(downloadButton('downloadRmdOutput', 'Generate Output'), class = "pull-right"), 307 | selectInput('rmdOuputFormat','Output Format', 308 | choices=c('HTML'='html_document', 'PDF'='pdf_document', 309 | 'Word'='word_document', 'Markdown'='md_document', 310 | 'ioslides'='ioslides_presentation', 311 | 'Slidy'='slidy_presentation', 312 | 'Beamer'='beamer_presentation'), 313 | selected='pdf_document'), 314 | 315 | tags$hr(), 316 | tabsetPanel(id='rmdTabs', 317 | tabPanel('R_Markdown', 318 | aceEditor('rmd', mode='markdown', value='', cursorId="rmdCursor", 319 | selectionId='rmdSelection', wordWrap=TRUE) 320 | ), 321 | tabPanel('Preview', 322 | uiOutput('rmdOutput') 323 | ) 324 | ) 325 | ) 326 | ) 327 | ), 328 | 329 | 330 | # tabPanel(title='Settings', 331 | # 332 | # if(!extrafontsImported){ 333 | # list(actionButton('importFonts', 'Import System Fonts', styleclass="primary"), 334 | # helpText('Import fonts from the operating system so that they are available for shinyData. This can take a few minutes.')) 335 | # } 336 | # 337 | # ), 338 | 339 | # 340 | 341 | tags$head(tags$script(src="https://ajax.googleapis.com/ajax/libs/jqueryui/1.10.3/jquery-ui.min.js"), 342 | tags$style(type='text/css', ".btn-aligned-select { margin-bottom: 10px; } .btn-small {font-size:13px; padding:5px;}") 343 | ) 344 | 345 | 346 | )) 347 | 348 | -------------------------------------------------------------------------------- /inst/shinyDataApp/server.r: -------------------------------------------------------------------------------- 1 | 2 | source('helpers.r', local=TRUE) 3 | 4 | shinyServer(function(input, output, session) { 5 | 6 | sessionEnv <- environment() 7 | projProperties <- reactiveValues('activeDat'='') 8 | sessionProperties <- reactiveValues('runDatCode'=0) 9 | updateInput <- reactiveValues('activeDat'=0,'datName'=0,'activeField'=0,'fieldName'=0,'measures'=0, 10 | 'activeSheet'=0,'sheetName'=0,'sheetDatId'=0,'combineMeasures'=0, 11 | 'sheetColumns'=0,'sheetRows'=0,'sheetOutput'=0,'sheetPlotLayer'=0, 12 | 'sheetLayerAes'=0,'aesField'=0,'aesAggregate'=0,'aesAggFun'=0,'aesDiscrete'=0, 13 | 'layerGeom'=0,'layerStatType'=0,'layerYFun'=0, 14 | 'layerPositionType'=0, 'layerPositionWidth'=0, 'layerPositionHeight'=0, 15 | 'activeDoc'=0,'docName'=0,'docRmd'=0,'rmdOuputFormat'=0, 16 | 'customizeItem'=0, 'plotXlab'=0, 'plotYlab'=0, 'plotTitle'=0, 17 | 'textFamily'=0, 'textFace'=0, 'textColor'=0,'textSize'=0, 'textHjust'=0, 'textVjust'=0, 18 | 'textAngle'=0, 'textLineheight'=0) 19 | 20 | triggerUpdateInput <- function(inputId){ 21 | if(is.null(updateInput[[inputId]])) updateInput[[inputId]] <- 0 22 | updateInput[[inputId]] <- updateInput[[inputId]] + 1 23 | } 24 | 25 | datList <- list() 26 | makeReactiveBinding('datList') 27 | datListNames <- reactive({ 28 | if(length(datList)){ 29 | x <- names(datList) 30 | names(x) <- sapply(datList, function(y) y[['dynamicProperties']][['name']]) 31 | x 32 | } else c('') 33 | }) 34 | 35 | docList <- list() 36 | makeReactiveBinding('docList') 37 | docListNames <- reactive({ 38 | if(length(docList)){ 39 | x <- names(docList) 40 | names(x) <- sapply(docList, function(y) y[['name']]) 41 | x 42 | } else c('') 43 | }) 44 | addDoc <- function(){ 45 | newDoc <- paste("Doc_",newGuid(),sep="") 46 | existingNames <- names(docListNames()) 47 | ## make sure the new name is different 48 | newName <- make.unique(c(existingNames, 'Doc'), sep='_')[length(existingNames)+1] 49 | 50 | docObj <- reactiveValues('name'=newName, 'rmdOuputFormat'='pdf_document') 51 | docList[[newDoc]] <<- docObj 52 | projProperties[['activeDoc']] <- newDoc 53 | } 54 | isolate(addDoc()) 55 | 56 | 57 | 58 | sheetList <- list() 59 | makeReactiveBinding('sheetList') 60 | 61 | sheetListNames <- reactive({ 62 | if(length(sheetList)){ 63 | x <- names(sheetList) 64 | names(x) <- sapply(sheetList, function(y) y[['dynamicProperties']][['name']]) 65 | x 66 | } else c('') 67 | }) 68 | 69 | getDatSheetEnv <- function(excludeDat=NULL){ 70 | env <- new.env(parent = globalenv()) 71 | nn <- sheetListNames() 72 | for(n in names(nn)){ 73 | ## using local is essential to make delayedAssign work 74 | local({ 75 | nId <- nn[n] 76 | local(delayedAssign(n, sheetList[[nId]][['plotR']](), assign.env=env)) 77 | }) 78 | } 79 | nn <- setdiff.c(datListNames(), excludeDat) 80 | for(n in names(nn)){ 81 | local({ 82 | nId <- nn[n] 83 | local(delayedAssign(n, datList[[nId]][['datR']](), assign.env=env)) 84 | }) 85 | } 86 | env 87 | } 88 | 89 | 90 | datUpdated <- function(currentDat){ 91 | dat <- datList[[currentDat]][['datRaw']]() 92 | if(!isEmpty(dat)){ 93 | ## need to adjust fieldsList to be consistent with the new dat 94 | newFields <- names(dat) 95 | if(length(newFields)){ 96 | fieldsList <- datList[[currentDat]][['dynamicProperties']][['fieldsList']] 97 | measures <- datList[[currentDat]][['dynamicProperties']][['measures']] 98 | if(is.null(fieldsList)) fieldsList <- list() 99 | if(is.null(measures)) measures <- c() 100 | 101 | # delete deprecated fields 102 | deleted <- setdiff(names(fieldsList), newFields) 103 | for(nn in deleted){ 104 | fieldsList[[nn]] <- NULL 105 | } 106 | measures <- setdiff(measures, deleted) 107 | 108 | # add new fields 109 | added <- setdiff(newFields, names(fieldsList)) 110 | for(nn in added){ 111 | fieldsList[[nn]] <- reactiveValues('name'=nn, 'type'=typeof(dat[[nn]])) 112 | } 113 | measures <- c(measures, getDefaultMeasures(dat, added)) 114 | 115 | datList[[currentDat]][['dynamicProperties']][['fieldsList']] <<- fieldsList 116 | datList[[currentDat]][['dynamicProperties']][['measures']] <<- measures 117 | 118 | activeField <- datList[[currentDat]][['dynamicProperties']][['activeField']] 119 | if(isEmpty(activeField) || !(activeField %in% newFields)){ 120 | datList[[currentDat]][['dynamicProperties']][['activeField']] <<- names(fieldsList)[1] 121 | } 122 | } 123 | } 124 | } 125 | 126 | setDatReactives <- function(currentDat){ 127 | datList[[currentDat]][['fieldNames']] <<- reactive({ 128 | if(length(datList[[currentDat]][['dynamicProperties']][['fieldsList']])){ 129 | x <- names(datList[[currentDat]][['dynamicProperties']][['fieldsList']]) 130 | names(x) <- make.unique(sapply(datList[[currentDat]][['dynamicProperties']][['fieldsList']], 131 | function(y) y[['name']]), sep='_') 132 | x 133 | } else c() 134 | }) 135 | 136 | datList[[currentDat]][['datRaw']] <<- reactive({ 137 | dat <- NULL 138 | if(datList[[currentDat]][['staticProperties']][['type']]=='code'){ 139 | sessionProperties$runDatCode 140 | isolate({ 141 | code <- datList[[currentDat]][['dynamicProperties']][['datCode']] 142 | if(!isEmpty(code)){ 143 | dat <- tryCatch(eval(parse(text=code), envir=getDatSheetEnv(excludeDat=currentDat)), 144 | error=function(e) { 145 | createAlert(session,'datCodeAlert', 146 | title='Error in R code:', 147 | message=e$message, 148 | type='warning', dismiss=TRUE, append=FALSE) 149 | NULL 150 | }) 151 | } 152 | }) 153 | } else { 154 | dat <- datList[[currentDat]][['dynamicProperties']][['dat']] 155 | } 156 | dat 157 | }) 158 | datList[[currentDat]][['datR']] <<- reactive({ 159 | dat <- datList[[currentDat]][['datRaw']]() 160 | if(!is.null(dat)){ 161 | dat <- forceMeasures(dat, 162 | datList[[currentDat]][['dynamicProperties']][['measures']]) 163 | label(dat, self=FALSE) <- names(datList[[currentDat]][['fieldNames']]()) 164 | if(is.data.table(dat)) dat else as.data.table(dat) 165 | } 166 | }) 167 | 168 | measureName <- 'MeasureNames' 169 | datList[[currentDat]][['moltenDat']] <<- reactive({ 170 | if(!isEmpty(datList[[currentDat]][['dynamicProperties']][['measures']])){ 171 | melt(datList[[currentDat]][['datR']](), 172 | measure.vars=datList[[currentDat]][['dynamicProperties']][['measures']], 173 | variable.name=measureName) 174 | } 175 | }) 176 | datList[[currentDat]][['moltenNames']] <<- reactive({ 177 | x <- setdiff.c(datList[[currentDat]][['fieldNames']](), 178 | datList[[currentDat]][['dynamicProperties']][['measures']]) 179 | x[measureName] <- measureName 180 | x['MeasureValues'] <- MoltenMeasuresName 181 | x 182 | }) 183 | } 184 | 185 | setAesReactives <- function(currentSheet, currentLayer, currentAes){ 186 | sheetList[[currentSheet]][['dynamicProperties' 187 | ]][['layerList']][[currentLayer]][['aesList']][[currentAes]][['canFieldBeContinuous']] <<- reactive({ 188 | aes <- sheetList[[currentSheet]][['dynamicProperties' 189 | ]][['layerList']][[currentLayer]][['aesList']][[currentAes]] 190 | measures <- sheetList[[currentSheet]][['measuresR']]() 191 | field <- aes[['aesField']] 192 | if(isEmpty(field)){ 193 | field <- sheetList[[currentSheet]][['dynamicProperties' 194 | ]][['layerList']][['Plot']][['aesList']][[currentAes]][['aesField']] 195 | } 196 | aes[['aesAggregate']] || (!isEmpty(field) && field %in% measures) 197 | }) 198 | } 199 | 200 | 201 | ## create sheet reactives and defaults 202 | setSheetReactives <- function(currentSheet){ 203 | if(isFieldUninitialized(sheetList[[currentSheet]],'layerNames')){ 204 | sheetList[[currentSheet]][['layerNames']] <<- reactive({ 205 | sl <- isolate(sheetList) 206 | if(!isEmpty(sl[[currentSheet]][['dynamicProperties']][['layerList']])){ 207 | names(sl[[currentSheet]][['dynamicProperties']][['layerList']]) 208 | } else c() 209 | }) 210 | } 211 | 212 | 213 | if(isFieldUninitialized(sheetList[[currentSheet]],'fieldNames')){ 214 | sheetList[[currentSheet]][['fieldNames']] <<- reactive({ 215 | sl <- isolate(sheetList) 216 | dl <- isolate(datList) 217 | currentDat <- sl[[currentSheet]][['dynamicProperties']][['datId']] 218 | combineMeasures <- sl[[currentSheet]][['dynamicProperties']][['combineMeasures']] 219 | 220 | if(!isEmpty(currentDat)){ 221 | currentDatObj <- dl[[currentDat]] 222 | if(combineMeasures) currentDatObj[['moltenNames']]() else currentDatObj[['fieldNames']]() 223 | } 224 | }) 225 | } 226 | 227 | if(isFieldUninitialized(sheetList[[currentSheet]],'measuresR')){ 228 | sheetList[[currentSheet]][['measuresR']] <<- reactive({ 229 | sl <- isolate(sheetList) 230 | dl <- isolate(datList) 231 | currentDat <- sl[[currentSheet]][['dynamicProperties']][['datId']] 232 | combineMeasures <- sl[[currentSheet]][['dynamicProperties']][['combineMeasures']] 233 | 234 | if(!isEmpty(currentDat)){ 235 | currentDatObj <- dl[[currentDat]] 236 | if(combineMeasures) c(MoltenMeasuresName) else currentDatObj[['dynamicProperties']][['measures']] 237 | } 238 | }) 239 | } 240 | 241 | if(isFieldUninitialized(sheetList[[currentSheet]],'datR')){ 242 | sheetList[[currentSheet]][['datR']] <<- reactive({ 243 | sl <- isolate(sheetList) 244 | dl <- isolate(datList) 245 | currentDat <- sl[[currentSheet]][['dynamicProperties']][['datId']] 246 | combineMeasures <- sl[[currentSheet]][['dynamicProperties']][['combineMeasures']] 247 | 248 | if(!isEmpty(currentDat)){ 249 | currentDatObj <- dl[[currentDat]] 250 | if(combineMeasures) currentDatObj[['moltenDat']]() else currentDatObj[['datR']]() 251 | } 252 | }) 253 | } 254 | 255 | if(isFieldUninitialized(sheetList[[currentSheet]],'tableR')){ 256 | sheetList[[currentSheet]][['tableR']] <<- reactive({ 257 | sl <- isolate(sheetList) 258 | tabular( (Species + 1) ~ (n=1) + Format(digits=2)* 259 | (Sepal.Length + Sepal.Width)*(mean + sd), data=iris ) 260 | }) 261 | } 262 | 263 | 264 | 265 | if(isFieldUninitialized(sheetList[[currentSheet]],'plotCore')){ 266 | ## Helpful ggplot references: 267 | ## http://zevross.com/blog/2014/08/04/beautiful-plotting-in-r-a-ggplot2-cheatsheet-3/ 268 | ## http://www.ling.upenn.edu/~joseff/rstudy/summer2010_ggplot2_intro.html 269 | ## http://learnr.wordpress.com/2009/03/17/ggplot2-barplots/ 270 | ## http://sape.inf.usi.ch/quick-reference/ggplot2 271 | ## http://ggplot2.org/book/ 272 | 273 | ## http://stackoverflow.com/questions/20249653/insert-layer-underneath-existing-layers-in-ggplot2-object 274 | 275 | ## current solutions: 276 | ## http://blog.ouseful.info/2011/08/03/working-visually-with-the-ggplot2-web-interface/ (no support for saving project) 277 | ## Deducer 278 | 279 | 280 | sheetList[[currentSheet]][['plotCore']] <<- reactive({ 281 | sl <- isolate(sheetList) 282 | layerList <- sl[[currentSheet]][['dynamicProperties']][['layerList']] 283 | cc <- empty2NULL(sl[[currentSheet]][['dynamicProperties']][['columns']]) 284 | rr <- empty2NULL(sl[[currentSheet]][['dynamicProperties']][['rows']]) 285 | datSheet <- sl[[currentSheet]][['datR']]() 286 | validate(need(!isEmpty(datSheet), label='Data')) 287 | 288 | gg <- NULL 289 | for(i in c('bar','line','point')) update_geom_defaults(i, list(colour = "darkblue", fill = "darkblue")) 290 | 291 | aes.base <- layerList[['Plot']][['aesList']] 292 | for(currentLayer in names(layerList)){ 293 | layer.current <- layerList[[currentLayer]] 294 | 295 | stat <- empty2NULL(layer.current[['statType']]) 296 | geom <- empty2NULL(layer.current[['geom']]) 297 | fun.y <- empty2NULL(layer.current[['yFun']]) 298 | position <- empty2NULL(layer.current[['layerPositionType']]) 299 | pWidth <- empty2NULL(layer.current[['layerPositionWidth']]) 300 | pHeight <- empty2NULL(layer.current[['layerPositionHeight']]) 301 | 302 | if(!is.null(geom) && !is.null(stat) && !is.null(position)){ 303 | ## get effective aesthetics taking into account of inheritance 304 | aes.current <- layer.current[['aesList']][isolate(unlist(layer.current[['aesChoices']], use.names=FALSE))] 305 | aes.current <- sapply(names(aes.current), function(n){ 306 | temp <- reactiveValuesToList(aes.current[[n]]) # converting to list so we can modify it 307 | if(are.vectors.different(temp[['aesMapOrSet']],'set')){ 308 | temp[['aesField']] <- ifempty(temp[['aesField']], empty2NULL(aes.base[[n]][['aesField']])) 309 | if(!is.null(temp[['aesField']])){ 310 | if(temp[['aesAggregate']]){ 311 | temp[['aesFieldOriginal']] <- temp[['aesField']] 312 | temp[['aesField']] <- paste(temp[['aesFieldOriginal']], temp[['aesAggFun']], sep='_') 313 | } 314 | } 315 | } 316 | temp 317 | }, simplify=FALSE) 318 | #browser() 319 | aes.current <- aes.current[sapply(aes.current, 320 | function(x) { 321 | isSetting <- !are.vectors.different(x[['aesMapOrSet']],'set') 322 | (isSetting && !isEmpty(x[['aesValue']])) || (!isSetting && !isEmpty(x[['aesField']])) 323 | })] 324 | 325 | borderColor <- aes.current[['aesBorderColor']] 326 | aes.current[['aesBorderColor']] <- NULL 327 | if(geom %in% c('bar','area','boxplot','density','smooth')){ 328 | aes.current[['aesFill']] <- aes.current[['aesColor']] 329 | aes.current[['aesColor']] <- borderColor 330 | } 331 | 332 | ## aesthetics validation 333 | validate( 334 | need(!is.null(aes.current[['aesX']]), label='X') 335 | ) 336 | if(stat %in% c('identity', 'boxplot', 'smooth')){ 337 | validate( 338 | need(!is.null(aes.current[['aesY']]), label='Y') 339 | ) 340 | } 341 | if(geom=='text'){ 342 | validate( 343 | need(!is.null(aes.current[['aesLabel']]), label='Label') 344 | ) 345 | } 346 | if(geom=='boxplot' && stat=='identity'){ 347 | validate( 348 | need(!is.null(aes.current[['aesYmin']]), label='Y Min') 349 | ) 350 | validate( 351 | need(!is.null(aes.current[['aesYmax']]), label='Y Max') 352 | ) 353 | validate( 354 | need(!is.null(aes.current[['aesLower']]), label='Y Lower') 355 | ) 356 | validate( 357 | need(!is.null(aes.current[['aesMiddle']]), label='Y Middle') 358 | ) 359 | validate( 360 | need(!is.null(aes.current[['aesUpper']]), label='Y Upper') 361 | ) 362 | } 363 | if(position=='fill'){ 364 | validate( 365 | need(!is.null(aes.current[['aesYmax']]), label='Y Max') 366 | ) 367 | } 368 | 369 | i.map <- sapply(aes.current, function(x) are.vectors.different(x[['aesMapOrSet']],'set')) 370 | aes.map <- aes.current[i.map] 371 | aes.set <- aes.current[!i.map] 372 | 373 | ## aggregate data for layer 374 | datLayer <- datSheet 375 | aes.toAgg <- aes.map[sapply(aes.map, function(x) x[['aesAggregate']])] 376 | if(length(aes.toAgg)){ 377 | # get rid of duplicates to avoid aggregating the same field the same way twice 378 | dups <- duplicated(sapply(aes.toAgg, function(x) x[['aesField']])) 379 | aes.toAgg <- aes.toAgg[!dups] 380 | 381 | # some validation 382 | agg.fields <- sapply(aes.toAgg, function(x) x[['aesFieldOriginal']]) 383 | overlaps <- intersect(agg.fields, c(rr,cc)) 384 | validate(need(isEmpty(overlaps), 'Can not aggregate fields used in faceting.')) 385 | 386 | # build the j-expression from string; there may be a better way 387 | agg.str <- sapply(aes.toAgg, function(x) paste(x[['aesAggFun']], '(', x[['aesFieldOriginal']], ')', sep='')) 388 | agg.str <- paste(sapply(aes.toAgg, function(x) x[['aesField']]), agg.str, sep='=', collapse=', ') 389 | agg.str <- paste0('list(', agg.str, ')') 390 | agg.exp <- parse(text=agg.str)[[1]] 391 | groupBy <- unique(c(rr,cc,sapply(aes.map[sapply(aes.map, function(x) !(x[['aesAggregate']]))], 392 | function(x) x[['aesField']]))) 393 | #validate(need(!isEmpty(groupBy), 'Please provide at least one field that is not being aggregated.')) 394 | datLayer <- eval(bquote(datSheet[, .(agg.exp), by=.(groupBy)])) 395 | 396 | if(currentLayer=='Plot'){ 397 | ## add to dataList 398 | outDf <- datLayer 399 | isolate({ 400 | sheetNameDat <- convertSheetNameToDatName(sheetList[[currentSheet]][['dynamicProperties']][['name']]) 401 | if(is.null(datList[[currentSheet]])){ 402 | addDat(outDf, name=sheetNameDat, type='sheet', id=currentSheet) 403 | } else { 404 | datList[[currentSheet]][['dynamicProperties']][['dat']] <<- outDf 405 | datUpdated(currentSheet) 406 | } 407 | }) 408 | } 409 | } 410 | 411 | 412 | ## get ready to ggplot 413 | if(stat=='summary'){ # need to re-point all the other aesthetics to ..y.. 414 | sapply(setdiff(names(aes.map), 'aesY'), 415 | function(x){ 416 | if(aes.map[[x]][['aesField']]==aes.map[['aesY']][['aesField']]){ 417 | aes.map[[x]][['aesField']] <<- InternalY 418 | } 419 | }) 420 | } 421 | 422 | 423 | ## list of set values 424 | aes.set.args <- list() 425 | if(length(aes.set)){ 426 | aes.set.args <- lapply(aes.set, 427 | function(x) { 428 | x[['aesValue']] 429 | } 430 | ) 431 | names(aes.set.args) <- tolower(substring(names(aes.set), 4)) # get rid of the 'aes' prefix 432 | } 433 | 434 | aes.args <- lapply(aes.map, 435 | function(x) { 436 | if(x[['canFieldBeContinuous']]()){ 437 | paste(ifelse(x[['aesDiscrete']], 'as.factor(', 'as.numeric('), 438 | x[['aesField']], ')', sep='') 439 | } else { 440 | x[['aesField']] 441 | } 442 | } 443 | ) 444 | names(aes.args) <- tolower(substring(names(aes.map), 4)) # get rid of the 'aes' prefix 445 | 446 | aess <- do.call('aes_string', aes.args) 447 | position <- do.call(paste('position', position, sep='_'), 448 | list(width=pWidth, height=pHeight)) 449 | #browser() 450 | if(is.null(gg)) gg <- ggplot() 451 | gg <- gg + do.call(paste('geom',geom,sep='_'), 452 | c(aes.set.args, list(mapping=aess, data=datLayer, stat=stat, fun.y=fun.y, position=position))) 453 | 454 | ## scales 455 | allScales <- lapply(aes.map, function(x) x[['scale']]) 456 | if(!isEmpty(allScales)){ 457 | allScales <- allScales[!sapply(allScales, isEmpty)] 458 | for(a in names(allScales)){ 459 | scale.args.mandatory <- list('name'=null2String(allScales[[a]][['legendTitle']])) 460 | legend.type <- null2String(allScales[[a]][['legendType']]) 461 | scale.args.optional <- list('guide'=if(legend.type != 'custom') legend.type else { 462 | guide <- allScales[[a]][['legend']] 463 | if(!isEmpty(guide)){ 464 | guide <- guide[!sapply(guide, isEmpty)] 465 | names(guide) <- make.names(names(guide), allow_=FALSE) # convert _ to . 466 | guide.name <- if((a=='aesColor' || a=='aesFill') && !aes.map[[a]][['aesDiscrete']]) 'guide_colorbar' else 'guide_legend' 467 | do.call(guide.name, guide) 468 | } 469 | }) 470 | call.name <- '' 471 | call.name12 <- paste('scale', tolower(substring(a, 4)), sep='_') 472 | call.name.default <- paste(call.name12, if(aes.map[[a]][['aesDiscrete']]) 'discrete' else 'continuous', sep='_') 473 | switch(a, 474 | 'aesLineType'={call.name <- call.name.default}, 475 | 'aesShape'={call.name <- call.name.default 476 | scale.args.optional <- c(scale.args.optional, list('solid'=allScales[[a]][['shapeSolid']]))}, 477 | 'aesSize'={call.name <- call.name.default 478 | scale.args.optional <- c(scale.args.optional, list('range'=allScales[[a]][['sizeRange']]))}, 479 | 'aesColor'=, 'aesFill'= 480 | if(aes.map[[a]][['aesDiscrete']]){ # discrete 481 | call.name <- paste(call.name12, 482 | if(isEmpty(allScales[[a]][['discreteColorScaleType']])) 'discrete' else allScales[[a]][['discreteColorScaleType']], 483 | sep='_') 484 | switch(null2String(allScales[[a]][['discreteColorScaleType']]), 485 | 'brewer'={ 486 | scale.args.optional <- c(scale.args.optional, list('palette'=allScales[[a]][['colorBrewerPallete']])) 487 | } 488 | ) 489 | } else { # continuous 490 | diverging <- allScales[[a]][['colorDiverging']] 491 | call.name <- paste(call.name12, if(diverging) 'gradient2' else 'gradient', sep='_') 492 | scale.args.optional <- c(scale.args.optional, list('low'=allScales[[a]][['colorLow']], 'high'=allScales[[a]][['colorHigh']], 493 | 'na.value'=allScales[[a]][['colorNA_value']])) 494 | if(diverging) scale.args.optional <- c(scale.args.optional, list('mid'=allScales[[a]][['colorMid']], 495 | 'midpoint'=allScales[[a]][['colorMidpoint']])) 496 | 497 | } 498 | ) 499 | 500 | if(call.name!=''){ 501 | scale.args.optional <- scale.args.optional[!sapply(scale.args.optional, isEmpty)] 502 | scale.call <- do.call(call.name, c(scale.args.mandatory, scale.args.optional)) 503 | gg <- gg + scale.call 504 | } 505 | } 506 | } 507 | 508 | 509 | } 510 | } 511 | if(!is.null(gg)){ 512 | if(!isEmpty(cc) || !isEmpty(rr)){ 513 | gg <- gg + facet_grid(as.formula(paste(names2formula(rr), names2formula(cc), sep=" ~ "))) 514 | } 515 | gg <- gg + theme_bw() 516 | } 517 | gg 518 | }) 519 | } 520 | 521 | if(isFieldUninitialized(sheetList[[currentSheet]],'plotR')){ 522 | sheetList[[currentSheet]][['plotR']] <<- reactive({ 523 | sl <- isolate(sheetList) 524 | layerList <- sl[[currentSheet]][['dynamicProperties']][['layerList']] 525 | aes.base <- layerList[['Plot']][['aesList']] 526 | 527 | fieldNames <- sl[[currentSheet]][['fieldNames']]() 528 | 529 | gg <- sl[[currentSheet]][['plotCore']]() 530 | if(!is.null(gg)){ 531 | themeElementCalls <- 532 | sapply(sheetList[[currentSheet]][['dynamicProperties']][['formatting']], 533 | simplify = FALSE, USE.NAMES = TRUE, 534 | function(cus){ 535 | eleBlank <- attr(cus, 'elementBlank') 536 | if(!is.null(eleBlank) && eleBlank) return(element_blank()) 537 | if(!isEmpty(cus)){ 538 | cus1 <- cus[!sapply(cus, isEmpty)] 539 | names(cus1) <- tolower(substring(names(cus1), 5)) # get rid of the 4-char prefix like 'text', 'rect', etc. 540 | switch(attr(cus, 'type'), 541 | 'unit'=if(!isEmpty(cus1$x) && !isEmpty(cus1$units)) do.call('unit', cus1), 542 | 'character'=if(!isEmpty(cus1$mainvalue)){ 543 | if(cus1$mainvalue!='custom_'){ 544 | cus1$mainvalue 545 | } else { 546 | c(cus1$altvalue1, cus1$altvalue2) 547 | } 548 | }, 549 | do.call(attr(cus, 'type'), cus1)) 550 | } 551 | }) 552 | themeElementCalls <- themeElementCalls[!sapply(themeElementCalls, is.null)] 553 | 554 | 555 | gg <- gg + xlab(sheetList[[currentSheet]][['dynamicProperties']][['plotXlab']]) + 556 | ylab(sheetList[[currentSheet]][['dynamicProperties']][['plotYlab']]) + 557 | ggtitle(sheetList[[currentSheet]][['dynamicProperties']][['plotTitle']]) 558 | if(length(themeElementCalls)){ 559 | gg <- gg + do.call('theme', themeElementCalls) 560 | } 561 | 562 | } 563 | gg 564 | }) 565 | } 566 | 567 | } 568 | 569 | addDat <- function(dat=NULL, name=NULL, type='file', id=NULL){ 570 | currentDat <- ifnull(id, paste('dat_',newGuid(),sep='')) 571 | existingNames <- names(datListNames()) 572 | ## make sure the new name is different 573 | newName <- make.unique(c(existingNames, ifempty(name, 'Data')), sep='_')[length(existingNames)+1] 574 | 575 | datList[[currentDat]] <<- createNewDatClassObj(dat, name=newName, 576 | nameOriginal=name, type=type) 577 | setDatReactives(currentDat) 578 | datUpdated(currentDat) 579 | if(is.null(id)){ 580 | projProperties[['activeDat']] <<- currentDat 581 | triggerUpdateInput('activeDat') 582 | } 583 | } 584 | addSheet <- function(){ 585 | newSheet <- paste("Sheet_",newGuid(),sep="") 586 | existingNames <- names(sheetListNames()) 587 | ## make sure the new name is different 588 | newName <- make.unique(c(existingNames, 'Sheet'), sep='_')[length(existingNames)+1] 589 | 590 | sheetObj <- createNewSheetObj(newName) 591 | sheetList[[newSheet]] <<- sheetObj 592 | setSheetReactives(newSheet) 593 | projProperties[['activeSheet']] <- newSheet 594 | 595 | for(currentLayer in names(sheetObj[['dynamicProperties']][['layerList']])){ 596 | for(currentAes in names(sheetObj[['dynamicProperties']][['layerList']][[currentLayer]][['aesList']])){ 597 | setAesReactives(newSheet, currentLayer, currentAes) 598 | } 599 | } 600 | } 601 | 602 | 603 | 604 | isDatBasedonSheet <- function(datId, sheetId){ 605 | if(!is.null(datList[[datId]])){ 606 | while(datList[[datId]][['staticProperties']][['type']] == 'sheet'){ 607 | if(datId==sheetId) return(TRUE) 608 | datId <- sheetList[[datId]][['dynamicProperties']][['datId']] 609 | } 610 | } 611 | FALSE 612 | } 613 | 614 | 615 | 616 | source('data.r', local=TRUE) 617 | source('sheets.r', local=TRUE) 618 | source('sheetsCustomize.r', local=TRUE) 619 | isolate(addSheet()) 620 | source('project.r', local=TRUE) 621 | source('docs.r', local=TRUE) 622 | 623 | observe({ 624 | v <- input$importFonts 625 | isolate({ 626 | if(!is.null(v) && v==1){ # so it's executed the first time the button is clicked 627 | if(!require(extrafont)) install.packages('extrafont') 628 | extrafont::font_import(prompt=FALSE) # this only needs run once but takes a long time 629 | # todo: alert user 630 | } 631 | }) 632 | }) 633 | 634 | }) 635 | 636 | 637 | -------------------------------------------------------------------------------- /inst/shinyDataApp/sheets.r: -------------------------------------------------------------------------------- 1 | 2 | #################################################### 3 | ## Reshaping data 4 | #################################################### 5 | 6 | 7 | ## Sheet input interdependence 8 | observe({ 9 | currentSheet <- projProperties[['activeSheet']] 10 | if(!isEmpty(currentSheet)){ 11 | currentLayer <- sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']] 12 | if(!isEmpty(currentLayer)){ 13 | markType <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['geom']] 14 | stat <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statType']] 15 | isolate({ 16 | # control stat choices 17 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statChoices']] <<- 18 | StatChoices[sapply(StatChoices, function(n) !is.null(getAesChoices(geom=markType, stat=n)))] 19 | # control aesthetics choices 20 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesChoices']] <<- 21 | getAesChoices(markType, stat) 22 | }) 23 | } 24 | 25 | cc <- sheetList[[currentSheet]][['dynamicProperties']][['columns']] 26 | rr <- sheetList[[currentSheet]][['dynamicProperties']][['rows']] 27 | mDat <- sheetList[[currentSheet]][['datR']]() 28 | fields <- sheetList[[currentSheet]][['fieldNames']]() 29 | measures <- sheetList[[currentSheet]][['measuresR']]() 30 | 31 | cc1 <- ''; rr1 <- ''; cChoices <- ''; rChoices <- '' 32 | outTable <- NULL; outDf <- NULL; 33 | cc.measures <- ''; cc.dims <- ''; 34 | rr.measures <- ''; rr.dims <- '' 35 | if(!is.null(fields)){ 36 | dims <- setdiff.c(fields, measures) 37 | cc1 <- intersect(cc,dims); rr1 <- intersect(rr,dims) 38 | # cc.measures <- intersect(cc1,measures); rr.measures <- intersect(rr1,measures) 39 | # cc.dims <- setdiff(cc1,cc.measures); rr.dims <- setdiff(rr1,rr.measures) 40 | 41 | # cc1 <- c(cc.dims,cc.measures); rr1 <- c(rr.dims,rr.measures) 42 | 43 | all.x <- sapply(sheetList[[currentSheet]][['dynamicProperties']][['layerList']], 44 | function(z) z[['aesList']][['aesX']][['aesField']]) 45 | all.y <- sapply(sheetList[[currentSheet]][['dynamicProperties']][['layerList']], 46 | function(z) z[['aesList']][['aesY']][['aesField']]) 47 | 48 | cChoices <- setdiff.c(dims, c(all.x, all.y, rr1)) 49 | rChoices <- setdiff.c(dims, c(all.x, all.y, cc1)) 50 | if(!isEmpty(currentLayer)){ 51 | isolate({ 52 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][['aesX']][['fieldChoices']] <<- 53 | setdiff.c(fields, c(rr1, cc1)) 54 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][['aesY']][['fieldChoices']] <<- 55 | setdiff.c(fields, c(rr1, cc1)) 56 | }) 57 | } 58 | 59 | 60 | if(!is.null(mDat)){ 61 | outType <- ifnull(sheetList[[currentSheet]][['dynamicProperties']][['outputType']], 'plot') 62 | if(outType=='table'){ 63 | # if(combineMeasures && !is.null(facets)){ 64 | # outTable <- cast(mDat, facets, sum) 65 | # outDf <- as.data.frame(outTable) 66 | # } 67 | 68 | } else { 69 | 70 | } 71 | 72 | if(!is.null(outDf)){ 73 | ## add to dataList 74 | isolate({ 75 | sheetNameDat <- convertSheetNameToDatName(sheetList[[currentSheet]][['dynamicProperties']][['name']]) 76 | if(is.null(datList[[currentSheet]])){ 77 | datList[[currentSheet]] <<- createNewDatClassObj(outDf, name=sheetNameDat, type='sheet') 78 | } else { 79 | datList[[currentSheet]][['dynamicProperties']][['dat']] <<- outDf 80 | datList[[currentSheet]][['dynamicProperties']][['measures']] <<- intersect(datList[[currentSheet]][['dynamicProperties']][['measures']], 81 | getDefaultMeasures(outDf)) 82 | ## add new fields, delete outdated fields, leave common fields alone since they might have user customizations 83 | newFields <- getDefaultFieldsList(outDf) 84 | oldList <- names(datList[[currentSheet]][['dynamicProperties']][['fieldsList']]) 85 | newList <- names(newFields) 86 | for(n in setdiff(newList, oldList)){ 87 | datList[[currentSheet]][['dynamicProperties']][['fieldsList']][[n]] <<- newFields[[n]] 88 | } 89 | for(n in setdiff(oldList, newList)){ 90 | datList[[currentSheet]][['dynamicProperties']][['fieldsList']][[n]] <<- NULL 91 | } 92 | } 93 | }) 94 | } 95 | } 96 | 97 | } 98 | isolate({ 99 | # sheetList[[currentSheet]][['dynamicProperties']][['dat']] <<- mDat 100 | # sheetList[[currentSheet]][['dynamicProperties']][['cMeasures']] <<- cc.measures 101 | # sheetList[[currentSheet]][['dynamicProperties']][['cDims']] <<- cc.dims 102 | # sheetList[[currentSheet]][['dynamicProperties']][['rMeasures']] <<- rr.measures 103 | # sheetList[[currentSheet]][['dynamicProperties']][['rDims']] <<- rr.dims 104 | if(are.vectors.different(cc1, sheetList[[currentSheet]][['dynamicProperties']][['columns']])){ 105 | triggerUpdateInput('sheetColumns') 106 | } 107 | if(are.vectors.different(rr1, sheetList[[currentSheet]][['dynamicProperties']][['rows']])){ 108 | triggerUpdateInput('sheetRows') 109 | } 110 | sheetList[[currentSheet]][['dynamicProperties']][['columns']] <<- cc1 111 | sheetList[[currentSheet]][['dynamicProperties']][['rows']] <<- rr1 112 | sheetList[[currentSheet]][['dynamicProperties']][['colChoices']] <<- cChoices 113 | sheetList[[currentSheet]][['dynamicProperties']][['rowChoices']] <<- rChoices 114 | sheetList[[currentSheet]][['dynamicProperties']][['outputTable']] <<- outTable 115 | sheetList[[currentSheet]][['dynamicProperties']][['outputDataframe']] <<- outDf 116 | }) 117 | } 118 | }, priority=1) 119 | 120 | 121 | 122 | 123 | ## Switching sheet 124 | observe({ 125 | v <- input$sheetList 126 | isolate({ 127 | if(!isEmpty(v)) projProperties[['activeSheet']] <<- v 128 | }) 129 | 130 | }) 131 | observe({ 132 | updateInput[['activeSheet']] 133 | updateSelectInput(session, 'sheetList', choices=(sheetListNames()), 134 | selected=isolate(projProperties[['activeSheet']])) 135 | }) 136 | 137 | 138 | ## modify sheet name 139 | observe({ 140 | v <- input$sheetName 141 | isolate({ 142 | currentSheet <- (projProperties[['activeSheet']]) 143 | if(!isEmpty(currentSheet)){ 144 | if(!isEmpty(v) && isEmpty(sheetListNames()[v])){ 145 | ## the second condition makes sure v is different 146 | ## update doc's rmd 147 | oldName <- paste('`', sheetList[[currentSheet]][['dynamicProperties']][['name']], '`', sep='') 148 | newName <- paste('`', v, '`', sep='') 149 | sapply(names(docList), function(currentDoc){ 150 | docList[[currentDoc]][['rmd']] <<- gsub(oldName, newName, docList[[currentDoc]][['rmd']], fixed=TRUE) 151 | NULL 152 | }) 153 | triggerUpdateInput('docRmd') 154 | 155 | sheetList[[currentSheet]][['dynamicProperties']][['name']] <<- v 156 | } 157 | } 158 | }) 159 | 160 | }) 161 | observe({ 162 | updateInput[['sheetName']] 163 | currentSheet <- projProperties[['activeSheet']] 164 | s <- if(!isEmpty(currentSheet)){ 165 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['name']]) 166 | } else '' 167 | updateTextInput(session, 'sheetName', value=null2String(s)) 168 | }) 169 | 170 | ## link sheet name to corresponding data name 171 | observe({ 172 | currentSheet <- projProperties[['activeSheet']] 173 | if(!isEmpty(currentSheet)){ 174 | s <- sheetList[[currentSheet]][['dynamicProperties']][['name']] 175 | isolate({ 176 | if(!is.null(datList[[currentSheet]])){ 177 | datList[[currentSheet]][['dynamicProperties']][['name']] <<- convertSheetNameToDatName(s) 178 | triggerUpdateInput('datName') 179 | } 180 | }) 181 | } 182 | }) 183 | 184 | ## sheet control tab 185 | observe({ 186 | v <- input$sheetControlTab 187 | isolate({ 188 | currentSheet <- (projProperties[['activeSheet']]) 189 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['sheetControlTab']] <<- v 190 | }) 191 | 192 | }) 193 | observe({ 194 | updateInput[['sheetControlTab']] 195 | currentSheet <- projProperties[['activeSheet']] 196 | s <- if(!isEmpty(currentSheet)){ 197 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['sheetControlTab']]) 198 | } else '' 199 | updateTabsetPanel(session, 'sheetControlTab', selected=ifempty(s, 'sheetTabType')) 200 | }) 201 | 202 | ## Selecting data for sheet 203 | observe({ 204 | v <- input$sheetDatList 205 | isolate({ 206 | currentSheet <- (projProperties[['activeSheet']]) 207 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['datId']] <<- v 208 | }) 209 | 210 | }) 211 | observe({ 212 | updateInput[['sheetDatId']] 213 | currentSheet <- projProperties[['activeSheet']] 214 | s <- if(!isEmpty(currentSheet)){ 215 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['datId']]) 216 | } else '' 217 | choices <- datListNames() 218 | choices <- choices[!sapply(choices, isDatBasedonSheet, sheetId=currentSheet)] 219 | updateSelectInput(session, 'sheetDatList', choices=null2String(choices), 220 | selected=null2String(s)) 221 | }) 222 | 223 | ## whether use molten data? 224 | observe({ 225 | v <- input$combineMeasures 226 | isolate({ 227 | currentSheet <- (projProperties[['activeSheet']]) 228 | if(!isEmpty(currentSheet)){ 229 | sheetList[[currentSheet]][['dynamicProperties']][['combineMeasures']] <<- as.logical(v) 230 | } 231 | }) 232 | 233 | }) 234 | observe({ 235 | updateInput[['combineMeasures']] 236 | currentSheet <- projProperties[['activeSheet']] 237 | s <- if(!isEmpty(currentSheet)){ 238 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['combineMeasures']]) 239 | } else FALSE 240 | updateCheckboxInput(session, 'combineMeasures', value=null2String(s)) 241 | }) 242 | 243 | ## Manipulating columns 244 | observe({ 245 | v <- input$columns 246 | isolate({ 247 | currentSheet <- (projProperties[['activeSheet']]) 248 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['columns']] <<- v 249 | }) 250 | 251 | }) 252 | observe({ 253 | updateInput[['sheetColumns']] 254 | currentSheet <- projProperties[['activeSheet']] 255 | s <- if(!isEmpty(currentSheet)){ 256 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['columns']]) 257 | } else '' 258 | choices <- if(!isEmpty(currentSheet)){sheetList[[currentSheet]][['dynamicProperties']][['colChoices']]} else '' 259 | updateSelectizeInput(session, 'columns', choices=null2String(choices), selected=null2String(s)) 260 | }) 261 | 262 | ## Manipulating rows 263 | observe({ 264 | v <- input$rows 265 | isolate({ 266 | currentSheet <- (projProperties[['activeSheet']]) 267 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['rows']] <<- v 268 | }) 269 | 270 | }) 271 | observe({ 272 | updateInput[['sheetRows']] 273 | currentSheet <- projProperties[['activeSheet']] 274 | s <- if(!isEmpty(currentSheet)){ 275 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['rows']]) 276 | } else '' 277 | choices <- if(!isEmpty(currentSheet)){sheetList[[currentSheet]][['dynamicProperties']][['rowChoices']]} else '' 278 | updateSelectizeInput(session, 'rows', choices=null2String(choices), selected=null2String(s)) 279 | }) 280 | 281 | ## Manipulating output type 282 | observe({ 283 | v <- input$outputTypeList 284 | isolate({ 285 | currentSheet <- (projProperties[['activeSheet']]) 286 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['outputType']] <<- v 287 | }) 288 | 289 | }) 290 | observe({ 291 | updateInput[['sheetOutput']] 292 | currentSheet <- projProperties[['activeSheet']] 293 | s <- if(!isEmpty(currentSheet)){ 294 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['outputType']]) 295 | } else '' 296 | updateSelectInput(session, 'outputTypeList', selected=null2String(s)) 297 | }) 298 | 299 | ## Selecting ggplot layer for sheet 300 | observe({ 301 | v <- input$layerList 302 | isolate({ 303 | if(!isEmpty(v)){ 304 | currentSheet <- (projProperties[['activeSheet']]) 305 | if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']] <<- v 306 | } 307 | }) 308 | }) 309 | observe({ 310 | updateInput[['sheetPlotLayer']] 311 | currentSheet <- projProperties[['activeSheet']] 312 | s <- if(!isEmpty(currentSheet)){ 313 | isolate(sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 314 | } else '' 315 | choices <- if(!isEmpty(currentSheet)) sheetList[[currentSheet]][['layerNames']]() 316 | updateSelectInput(session, 'layerList', choices=null2String(choices), 317 | selected=null2String(s)) 318 | }) 319 | 320 | ## Selecting aesthetic 321 | observe({ 322 | v <- input$aesList 323 | isolate({ 324 | if(!isEmpty(v)){ 325 | currentSheet <- (projProperties[['activeSheet']]) 326 | if(!isEmpty(currentSheet)) { 327 | currentLayer <- sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']] 328 | if(!isEmpty(currentLayer)){ 329 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] <<- v 330 | } 331 | } 332 | } 333 | }) 334 | }) 335 | observe({ 336 | updateInput[['sheetLayerAes']] 337 | currentSheet <- projProperties[['activeSheet']] 338 | s <- choices <- '' 339 | if(!isEmpty(currentSheet)){ 340 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 341 | if(!isEmpty(currentLayer)){ 342 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']]) 343 | choices <- (sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesChoices']]) 344 | } 345 | } 346 | 347 | updateSelectInput(session, 'aesList', choices=null2String(choices), 348 | selected=null2String(s)) 349 | }) 350 | 351 | ## set aes map or set option 352 | observe({ 353 | v <- input$aesMapOrSet 354 | if(!is.null(v)){ 355 | isolate({ 356 | currentSheet <- (projProperties[['activeSheet']]) 357 | if(!isEmpty(currentSheet)){ 358 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 359 | if(!isEmpty(currentLayer)){ 360 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 361 | if(!isEmpty(currentAes)){ 362 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesMapOrSet']] <<- v 363 | 364 | ## set default value 365 | if(v=='set' && isEmpty(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesValue']])){ 366 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesValue']] <<- 367 | switch(currentAes, 368 | 'aesLabel'='My Label', 'aesFamily'='Times', 'aesFontface'='plain', 369 | 'aesColor'=, 'aesBorderColor'='', 370 | 'aesSize'=8, 'aesLineheight'=1, 371 | 0 372 | ) 373 | 374 | triggerUpdateInput('aesValue') 375 | } 376 | } 377 | } 378 | } 379 | }) 380 | } 381 | 382 | }) 383 | observe({ 384 | updateInput[['aesMapOrSet']] 385 | currentSheet <- (projProperties[['activeSheet']]) 386 | s <- 'map' 387 | if(!isEmpty(currentSheet)){ 388 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 389 | if(!isEmpty(currentLayer)){ 390 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 391 | if(!isEmpty(currentAes)){ 392 | s1 <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesMapOrSet']]) 393 | if(!are.vectors.different('set', s1)) s <- 'set' 394 | } 395 | } 396 | } 397 | updateRadioButtons(session, 'aesMapOrSet', selected=s) 398 | }) 399 | 400 | ## map or set UI 401 | output$mapOrSetUI <- renderUI({ 402 | currentSheet <- (projProperties[['activeSheet']]) 403 | if(!isEmpty(currentSheet)){ 404 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 405 | if(!isEmpty(currentLayer)){ 406 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 407 | if(!isEmpty(currentAes)){ 408 | useMapping <- are.vectors.different('set', 409 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesMapOrSet']]) 410 | isolate({ 411 | aes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]] 412 | if(useMapping){ 413 | s <- null2String(aes[['aesField']]) 414 | choices <- if(currentAes %in% c('aesX','aesY')) { 415 | aes[['fieldChoices']] 416 | } else { 417 | sheetList[[currentSheet]][['fieldNames']]() 418 | } 419 | if(!(s %in% choices)) choices[s]=s ## this is needed when s="", otherwise selected will defaults to the first value 420 | 421 | aggFun <- null2String(aes[['aesAggFun']]) 422 | aggFunchoices <- YFunChoices 423 | if(!(aggFun %in% aggFunchoices)) aggFunchoices[aggFun]=aggFun 424 | 425 | list( 426 | fluidRow( 427 | column(4, 428 | selectizeInput(inputId='aesField', label='Field', 429 | choices=choices, selected=s, multiple=FALSE, 430 | options = list(create = TRUE)) 431 | ), 432 | column(4, 433 | checkboxInput(inputId='aesAggregate', label='Aggregate Field', 434 | value=aes[['aesAggregate']]), 435 | conditionalPanel('input.aesAggregate==true', 436 | selectizeInput(inputId='aesAggFun', label='By', 437 | choices=aggFunchoices, 438 | selected=aggFun, multiple=FALSE, 439 | options = list(create = TRUE)) 440 | ) 441 | 442 | ), 443 | column(4, 444 | conditionalPanel('output.canAesFieldBeContinuous==true', 445 | radioButtons('aesDiscrete', 'Treat Field as', 446 | choices=c('Continuous'='continuous', 447 | 'Discrete'='discrete'), 448 | selected=ifelse(aes[['aesDiscrete']], 'discrete', 'continuous'), 449 | inline=FALSE) 450 | ) 451 | 452 | 453 | ) 454 | ), 455 | 456 | tags$hr(), 457 | 458 | switch(currentAes, 459 | 'aesShape'=checkboxInput('shapeSolid', 'Solid Shapes', value=empty2TRUE(aes[['scale']][['shapeSolid']])), 460 | 'aesSize'=sliderInput('sizeRange', 'Size Range', min=0, max=50, value=ifempty(aes[['scale']][['sizeRange']], c(1,6))), 461 | 'aesBorderColor'=, 'aesColor'=list( 462 | h4('Color Specification'), 463 | conditionalPanel('input.aesDiscrete==null || input.aesDiscrete=="discrete"', 464 | selectInput('discreteColorScaleType', 'Type of Scale', 465 | selected=aes[['scale']][['discreteColorScaleType']], 466 | choices=c('Default'='', 'Hue'='hue', 'Brewer'='brewer')), 467 | selectInput('colorBrewerPallete', 'Palette', 468 | selected=aes[['scale']][['colorBrewerPallete']], 469 | choices=BrewerPaletteChoices) 470 | ), 471 | conditionalPanel('input.aesDiscrete=="continuous"', 472 | checkboxInput('colorDiverging', 'Diverging Colors', value=aes[['scale']][['colorDiverging']]), 473 | fluidRow(column(4, 474 | colorInput('colorLow', 'Low', value=aes[['scale']][['colorLow']])), 475 | column(4, 476 | conditionalPanel('input.colorDiverging == true', 477 | colorInput('colorMid', 'Middle', value=aes[['scale']][['colorMid']]), 478 | numericInput('colorMidpoint', 'Scale Center', 479 | value=aes[['scale']][['colorMidpoint']]))), 480 | column(4, colorInput('colorHigh', 'High', value=aes[['scale']][['colorHigh']]), 481 | colorInput('colorNA_value', 'Missing Data', value=aes[['scale']][['colorNA_value']])) 482 | ) 483 | ) 484 | ) 485 | 486 | ), 487 | if(currentAes != 'aesX' && currentAes != 'aesY' && currentAes != 'aesGroup'){ 488 | list( 489 | radioButtons('legendType', 'Legend:', selected=aes[['scale']][['legendType']], 490 | choices=c('Default'='','Custom'='custom','Hide'='none'), inline=TRUE), 491 | conditionalPanel('input.legendType != "none"', 492 | textInput('legendTitle', 'Legend Title', value=aes[['scale']][['legendTitle']])), 493 | conditionalPanel('input.legendType == "custom"', 494 | fluidRow( 495 | column(6, 496 | selectInput('title_position', 'Title Position', selected=aes[['scale']][['legend']][['title_position']], 497 | choices=c('Default'='', 'Top'='top', 'Bottom'='bottom', 'Left'='left', 'Right'='right')), 498 | selectInput('direction', 'Layout Direction', selected=aes[['scale']][['legend']][['direction']], 499 | choices=c('Default'='', 'Horizontal'='horizontal', 'Vertical'='vertical')), 500 | checkboxInput('reverse', 'Reverse', value=empty2FALSE(aes[['scale']][['legend']][['reverse']])) 501 | ), 502 | column(6, 503 | selectInput('label_position', 'Label Position', selected=aes[['scale']][['legend']][['label_position']], 504 | choices=getLegendLabelPositionChoices(aes[['scale']][['legend']][['direction']])), 505 | conditionalPanel('input.direction=="horizontal"', 506 | numericInput('label_hjust', 'Label Horizontal Adjust', 507 | value=aes[['scale']][['legend']][['label_hjust']])), 508 | conditionalPanel('input.direction=="" || input.direction=="vertical"', 509 | numericInput('label_vjust', 'Label Vertical Adjust', 510 | value=aes[['scale']][['legend']][['label_vjust']])) 511 | ) 512 | ) 513 | ) 514 | ) 515 | } 516 | ) 517 | 518 | } else { 519 | switch(currentAes, 520 | 'aesLabel'=textInput('aesValue', '', value=aes[['aesValue']]), 521 | 'aesFontface'=selectInput('aesValue','',choices=FontFaceChoices, selected=aes[['aesValue']]), 522 | 'aesFamily'=selectInput('aesValue','',choices=FontFamilyChoices, selected=aes[['aesValue']]), 523 | 'aesColor'=, 'aesBorderColor'=colorInput('aesValue', '', value=aes[['aesValue']]), 524 | 'aesShape'=, 'aesLineType'=numericInput('aesValue', 'Value', value=aes[['aesValue']], step=1), 525 | numericInput('aesValue', 'Value', value=aes[['aesValue']], step=0.1) 526 | ) 527 | } 528 | }) 529 | } 530 | } 531 | } 532 | }) 533 | 534 | 535 | ## upsert basic aes properties 536 | lapply(list(list(inputId='aesValue', inputType=''), 537 | list(inputId='aesAggregate', inputType=''), 538 | list(inputId='aesAggFun', inputType='')), 539 | function(x){ 540 | assign(paste0('observer_', x$inputId, '_push'), 541 | observeEvent(input[[x$inputId]], { 542 | v <- input[[x$inputId]] 543 | currentSheet <- (projProperties[['activeSheet']]) 544 | if(!isEmpty(currentSheet)){ 545 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 546 | if(!isEmpty(currentLayer)){ 547 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 548 | if(!isEmpty(currentAes)){ 549 | if(are.vectors.different(v, 550 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][[x$inputId]])) 551 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][[x$inputId]] <<- v 552 | } 553 | } 554 | } 555 | }), 556 | sessionEnv) 557 | 558 | }) 559 | 560 | ## upsert aes scales 561 | lapply(list(list(inputId='legendType', inputType='', storage='scale'), 562 | list(inputId='legendTitle', inputType='text', storage='scale'), 563 | list(inputId='discreteColorScaleType', inputType='', storage='scale'), 564 | list(inputId='colorBrewerPallete', inputType='', storage='scale'), 565 | list(inputId='shapeSolid', inputType='', storage='scale'), 566 | list(inputId='sizeRange', inputType='', storage='scale'), 567 | list(inputId='colorDiverging', inputType='', storage='scale'), 568 | list(inputId='colorLow', inputType='', storage='scale'), 569 | list(inputId='colorMid', inputType='', storage='scale'), 570 | list(inputId='colorMidpoint', inputType='', storage='scale'), 571 | list(inputId='colorHigh', inputType='', storage='scale'), 572 | list(inputId='colorNA_value', inputType='', storage='scale'), 573 | list(inputId='title_position', inputType='', storage='legend'), 574 | list(inputId='direction', inputType='', storage='legend'), 575 | list(inputId='reverse', inputType='', storage='legend'), 576 | list(inputId='label_position', inputType='select', storage='legend'), 577 | list(inputId='label_hjust', inputType='', storage='legend'), 578 | list(inputId='label_vjust', inputType='', storage='legend') 579 | ), 580 | function(x){ 581 | push.label <- paste0('observer_', x$inputId, '_push') 582 | assign(push.label, 583 | observeEvent(input[[x$inputId]], label=push.label, { 584 | v <- input[[x$inputId]] 585 | currentSheet <- (projProperties[['activeSheet']]) 586 | if(!isEmpty(currentSheet)){ 587 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 588 | if(!isEmpty(currentLayer)){ 589 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 590 | if(!isEmpty(currentAes)){ 591 | if(is.null(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']])) 592 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']] <<- list() 593 | if(x$storage=='scale'){ 594 | if(are.vectors.different(v, 595 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 596 | 'aesList']][[currentAes]][['scale']][[x$inputId]])) 597 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 598 | 'aesList']][[currentAes]][['scale']][[x$inputId]] <<- v 599 | } else { # legend 600 | if(is.null(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 601 | 'aesList']][[currentAes]][['scale']][['legend']])) 602 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 603 | 'aesList']][[currentAes]][['scale']][['legend']] <<- list() 604 | if(are.vectors.different(v, 605 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 606 | 'aesList']][[currentAes]][['scale']][['legend']][[x$inputId]])) 607 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 608 | 'aesList']][[currentAes]][['scale']][['legend']][[x$inputId]] <<- v 609 | 610 | if(x$inputId=='direction'){ 611 | label.pos <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 612 | 'aesList']][[currentAes]][['scale']][['legend']][['label_position']] 613 | choices <- getLegendLabelPositionChoices(v) 614 | if(!isEmpty(label.pos) && !label.pos %in% choices){ 615 | label.pos <- choices[1] 616 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][[ 617 | 'aesList']][[currentAes]][['scale']][['legend']][['label_position']] <<- label.pos 618 | } 619 | updateSelectInput(session, 'label_position', selected=label.pos, choices=choices) 620 | } 621 | } 622 | 623 | 624 | } 625 | } 626 | } 627 | }), 628 | sessionEnv) 629 | 630 | if(isEmpty(x$inputType)) return() 631 | assign(paste0('observer_', x$inputId, '_pull'), 632 | observeEvent(updateInput[[x$inputId]], { 633 | currentSheet <- projProperties[['activeSheet']] 634 | s <- '' 635 | if(!isEmpty(currentSheet)){ 636 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 637 | if(!isEmpty(currentLayer)){ 638 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 639 | if(!isEmpty(currentAes)){ 640 | scales <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']] 641 | s <- if(x$storage=='scale') scales[[x$inputId]] else scales[['legend']][[x$inputId]] 642 | } 643 | } 644 | } 645 | 646 | updateInput(session, x$inputType, x$inputId, s) 647 | 648 | }), 649 | sessionEnv) 650 | }) 651 | 652 | ## set aes field 653 | observe({ 654 | v <- input$aesField 655 | if(!is.null(v)){ 656 | isolate({ 657 | currentSheet <- (projProperties[['activeSheet']]) 658 | if(!isEmpty(currentSheet)){ 659 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 660 | if(!isEmpty(currentLayer)){ 661 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 662 | if(!isEmpty(currentAes)){ 663 | if(are.vectors.different(v, sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesField']])){ 664 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesField']] <<- v 665 | 666 | ## set default field properties 667 | if(isEmpty(v) && currentLayer != 'Plot'){ 668 | v <- null2String(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][['Plot']][['aesList']][[currentAes]][['aesField']]) 669 | } 670 | is.measure <- v %in% sheetList[[currentSheet]][['measuresR']]() 671 | statType <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statType']] 672 | notAggregate <- are.vectors.different(statType, 'identity') && (currentAes=='aesX' || currentAes=='aesY') 673 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesIsFieldMeasure']] <<- 674 | is.measure ## just for capturing this information to customize choices for agg fun 675 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[ 676 | currentLayer]][['aesList']][[currentAes]][['aesAggregate']] <<- is.measure && (!notAggregate) 677 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesAggFun']] <<- if(is.measure) 'sum' else 'length' 678 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesDiscrete']] <<- !is.measure 679 | sapply(c('aesAggregate','aesAggFun','aesDiscrete'), triggerUpdateInput) 680 | 681 | ## set default xlab, ylab 682 | if(!isEmpty(v)){ 683 | fieldNames <- sheetList[[currentSheet]][['fieldNames']]() 684 | i.match <- match(v, fieldNames) 685 | if(!is.na(i.match)){ 686 | fieldName <- names(fieldNames)[i.match] 687 | switch(currentAes, 688 | 'aesX'={ 689 | sheetList[[currentSheet]][['dynamicProperties']][['plotXlab']] <<- fieldName 690 | triggerUpdateInput('plotXlab') 691 | }, 692 | 'aesY'={ 693 | sheetList[[currentSheet]][['dynamicProperties']][['plotYlab']] <<- fieldName 694 | triggerUpdateInput('plotYlab') 695 | }, 696 | { 697 | if(is.null(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']])) 698 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']] <<- list() 699 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['scale']][['legendTitle']] <<- fieldName 700 | triggerUpdateInput('legendTitle') 701 | } 702 | ) 703 | 704 | } 705 | } 706 | 707 | } 708 | } 709 | } 710 | } 711 | }) 712 | } 713 | 714 | }) 715 | 716 | 717 | output$canAesFieldBeContinuous <- reactive({ 718 | ans <- FALSE 719 | currentSheet <- (projProperties[['activeSheet']]) 720 | if(!isEmpty(currentSheet)){ 721 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 722 | if(!isEmpty(currentLayer)){ 723 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 724 | if(!isEmpty(currentAes)){ 725 | ans <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['canFieldBeContinuous']]() 726 | } 727 | } 728 | } 729 | ans 730 | }) 731 | outputOptions(output, "canAesFieldBeContinuous", suspendWhenHidden=FALSE) 732 | 733 | ## set aes aggregate 734 | observe({ 735 | updateInput[['aesAggregate']] 736 | isolate({ 737 | currentSheet <- (projProperties[['activeSheet']]) 738 | s <- FALSE 739 | if(!isEmpty(currentSheet)){ 740 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 741 | if(!isEmpty(currentLayer)){ 742 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 743 | if(!isEmpty(currentAes)){ 744 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesAggregate']]) 745 | 746 | } 747 | } 748 | } 749 | updateCheckboxInput(session, 'aesAggregate', value=s) 750 | }) 751 | 752 | }) 753 | 754 | 755 | ## set aes agg fun 756 | observe({ 757 | updateInput[['aesAggFun']] 758 | isolate({ 759 | currentSheet <- (projProperties[['activeSheet']]) 760 | s <- '' 761 | choices <- YFunChoices 762 | if(!isEmpty(currentSheet)){ 763 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 764 | if(!isEmpty(currentLayer)){ 765 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 766 | if(!isEmpty(currentAes)){ 767 | s <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesAggFun']] 768 | is.measure <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesIsFieldMeasure']] 769 | if(!is.null(is.measure) && !is.measure) choices <- AggFunChoicesDimension 770 | } 771 | } 772 | } 773 | 774 | if(!isEmpty(s) && !(s %in% choices)) choices[s]=s 775 | updateSelectizeInput(session, 'aesAggFun', choices=null2String(choices), selected=null2String(s)) 776 | }) 777 | }) 778 | 779 | ## set aes discrete 780 | observe({ 781 | v <- input$aesDiscrete 782 | if(!is.null(v)){ 783 | isolate({ 784 | currentSheet <- (projProperties[['activeSheet']]) 785 | if(!isEmpty(currentSheet)){ 786 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 787 | if(!isEmpty(currentLayer)){ 788 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 789 | if(!isEmpty(currentAes)){ 790 | isDiscrete <- (v=='discrete') 791 | if(currentAes %in% c('aesX', 'aesY')){ 792 | ## can't mix discrete with continuous scales on x or y, so need to keep all layers the same 793 | for(layer in names(sheetList[[currentSheet]][['dynamicProperties']][['layerList']])){ 794 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[layer]][['aesList']][[currentAes]][['aesDiscrete']] <<- isDiscrete 795 | } 796 | } else { 797 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesDiscrete']] <<- isDiscrete 798 | } 799 | } 800 | } 801 | } 802 | }) 803 | } 804 | 805 | }) 806 | observe({ 807 | updateInput[['aesDiscrete']] 808 | isolate({ 809 | currentSheet <- (projProperties[['activeSheet']]) 810 | s <- 'discrete' 811 | if(!isEmpty(currentSheet)){ 812 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 813 | if(!isEmpty(currentLayer)){ 814 | currentAes <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['activeAes']] 815 | if(!isEmpty(currentAes)){ 816 | d <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][[currentAes]][['aesDiscrete']]) 817 | if(!isEmpty(d) && !d){ 818 | s <- 'continuous' 819 | } 820 | 821 | } 822 | } 823 | } 824 | updateRadioButtons(session, 'aesDiscrete', selected=s) 825 | }) 826 | }) 827 | 828 | setStatType <- function(currentSheet, currentLayer, value){ 829 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statType']] <<- value 830 | if(!isEmpty(value) && value!='identity'){ 831 | ## no aggregation on x, y when stat is not identity 832 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][['aesX']][['aesAggregate']] <<- FALSE 833 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['aesList']][['aesY']][['aesAggregate']] <<- FALSE 834 | triggerUpdateInput('aesAggregate') 835 | } 836 | } 837 | 838 | ## set Mark Type / geom 839 | observe({ 840 | v <- input$markList 841 | isolate({ 842 | if(!isEmpty(v)){ 843 | currentSheet <- (projProperties[['activeSheet']]) 844 | if(!isEmpty(currentSheet)){ 845 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 846 | if(!isEmpty(currentLayer)){ 847 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['geom']] <<- v 848 | # set default stat type & position 849 | setStatType(currentSheet, currentLayer, switch(v, 'boxplot'='boxplot', 'density'='density', 'smooth'='smooth', 'identity')) 850 | triggerUpdateInput('layerStatType') 851 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionType']] <<- 852 | switch(v, 'bar'='dodge', 'identity') 853 | triggerUpdateInput('layerPositionType') 854 | } 855 | } 856 | } 857 | }) 858 | }) 859 | observe({ 860 | updateInput[['layerGeom']] 861 | currentSheet <- (projProperties[['activeSheet']]) 862 | s <- choices <- '' 863 | if(!isEmpty(currentSheet)){ 864 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 865 | if(!isEmpty(currentLayer)){ 866 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['geom']]) 867 | #choices <- (sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['geomChoices']]) 868 | } 869 | } 870 | updateSelectInput(session, 'markList', selected=null2String(s)) 871 | }) 872 | 873 | ## set Stat Type 874 | observe({ 875 | v <- input$statTypeList 876 | isolate({ 877 | if(!isEmpty(v)){ 878 | currentSheet <- (projProperties[['activeSheet']]) 879 | if(!isEmpty(currentSheet)){ 880 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 881 | if(!isEmpty(currentLayer)){ 882 | setStatType(currentSheet, currentLayer, v) 883 | } 884 | } 885 | } 886 | }) 887 | }) 888 | observe({ 889 | updateInput[['layerStatType']] 890 | currentSheet <- (projProperties[['activeSheet']]) 891 | s <- choices <- '' 892 | if(!isEmpty(currentSheet)){ 893 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 894 | if(!isEmpty(currentLayer)){ 895 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statType']]) 896 | choices <- (sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['statChoices']]) 897 | } 898 | } 899 | 900 | updateSelectInput(session, 'statTypeList', choices=null2String(choices), selected=null2String(s)) 901 | }) 902 | 903 | ## set y fun 904 | observe({ 905 | v <- input$yFunList 906 | isolate({ 907 | if(!isEmpty(v)){ 908 | currentSheet <- (projProperties[['activeSheet']]) 909 | if(!isEmpty(currentSheet)){ 910 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 911 | if(!isEmpty(currentLayer)){ 912 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['yFun']] <<- v 913 | } 914 | } 915 | } 916 | }) 917 | }) 918 | observe({ 919 | updateInput[['layerYFun']] 920 | currentSheet <- (projProperties[['activeSheet']]) 921 | s <- '' 922 | if(!isEmpty(currentSheet)){ 923 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 924 | if(!isEmpty(currentLayer)){ 925 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['yFun']]) 926 | } 927 | } 928 | choices <- YFunChoices 929 | if(!isEmpty(s) && !(s %in% choices)) choices[s]=s 930 | updateSelectizeInput(session, 'yFunList', choices=null2String(choices), selected=null2String(s)) 931 | }) 932 | 933 | 934 | 935 | ## set PositionType 936 | observe({ 937 | v <- input$layerPositionType 938 | isolate({ 939 | currentSheet <- (projProperties[['activeSheet']]) 940 | if(!isEmpty(currentSheet)){ 941 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 942 | if(!isEmpty(currentLayer)){ 943 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionType']] <<- v 944 | } 945 | } 946 | }) 947 | 948 | }) 949 | observe({ 950 | updateInput[['layerPositionType']] 951 | currentSheet <- (projProperties[['activeSheet']]) 952 | s <- '' 953 | if(!isEmpty(currentSheet)){ 954 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 955 | if(!isEmpty(currentLayer)){ 956 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionType']]) 957 | } 958 | } 959 | updateSelectizeInput(session, 'layerPositionType', selected=null2String(s)) 960 | }) 961 | 962 | ## set Position Height 963 | observe({ 964 | v <- empty2NULL(as.numeric(input$layerPositionHeight)) 965 | isolate({ 966 | currentSheet <- (projProperties[['activeSheet']]) 967 | if(!isEmpty(currentSheet)){ 968 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 969 | if(!isEmpty(currentLayer)){ 970 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionHeight']] <<- v 971 | } 972 | } 973 | }) 974 | 975 | }) 976 | observe({ 977 | updateInput[['layerPositionHeight']] 978 | currentSheet <- (projProperties[['activeSheet']]) 979 | s <- '' 980 | if(!isEmpty(currentSheet)){ 981 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 982 | if(!isEmpty(currentLayer)){ 983 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionHeight']]) 984 | } 985 | } 986 | updateTextInput(session, 'layerPositionHeight', value=null2String(s)) 987 | }) 988 | 989 | ## set Position Width 990 | observe({ 991 | v <- empty2NULL(as.numeric(input$layerPositionWidth)) 992 | isolate({ 993 | currentSheet <- (projProperties[['activeSheet']]) 994 | if(!isEmpty(currentSheet)){ 995 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 996 | if(!isEmpty(currentLayer)){ 997 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionWidth']] <<- v 998 | } 999 | } 1000 | }) 1001 | 1002 | }) 1003 | observe({ 1004 | updateInput[['layerPositionWidth']] 1005 | currentSheet <- (projProperties[['activeSheet']]) 1006 | s <- '' 1007 | if(!isEmpty(currentSheet)){ 1008 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 1009 | if(!isEmpty(currentLayer)){ 1010 | s <- isolate(sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]][['layerPositionWidth']]) 1011 | } 1012 | } 1013 | updateTextInput(session, 'layerPositionWidth', value=null2String(s)) 1014 | }) 1015 | 1016 | 1017 | 1018 | 1019 | tabS <- tabular( (Species + 1) ~ (n=1) + Format(digits=2)* 1020 | (Sepal.Length + Sepal.Width)*(mean + sd), data=iris ) 1021 | canLatexPNG <- tryCatch(length(make.png(tabS)), error=function(e) FALSE) 1022 | 1023 | 1024 | output$sheetOutput <- renderUI({ 1025 | currentSheet <- projProperties[['activeSheet']] 1026 | if(!isEmpty(currentSheet)){ 1027 | switch(null2String(sheetList[[currentSheet]][['dynamicProperties']][['outputType']]), 1028 | 'table'=if(canLatexPNG) imageOutput('sheetOutputTable') else { 1029 | tags$div( 1030 | HTML(paste(capture.output(Hmisc::html(sheetList[[currentSheet]][['tableR']]())), collapse=" ")) 1031 | ) 1032 | }, 1033 | plotOutput('ggplot')) 1034 | } 1035 | 1036 | }) 1037 | 1038 | 1039 | output$sheetOutputTable <- renderImage(if(canLatexPNG) { 1040 | currentSheet <- projProperties[['activeSheet']] 1041 | if(!isEmpty(currentSheet)){ 1042 | tab <- sheetList[[currentSheet]][['tableR']]() 1043 | 1044 | if(!is.null(tab)){ 1045 | #width <- session$clientData$output_test_width 1046 | #height <- session$clientData$output_test_height 1047 | 1048 | # For high-res displays, this will be greater than 1 1049 | pixelratio <- session$clientData$pixelratio 1050 | fileName <- make.png(tab, resolution=72*pixelratio) 1051 | pngFile <- readPNG(fileName) 1052 | 1053 | # Return a list containing the filename 1054 | list(src = normalizePath(fileName), 1055 | width = dim(pngFile)[2], 1056 | height = dim(pngFile)[1], 1057 | alt = "Output not available") 1058 | } 1059 | } 1060 | }, deleteFile = TRUE) 1061 | 1062 | # x <- tabular( (Species + 1) ~ (n=1) + Format(digits=3)* 1063 | # (Sepal.Length + Sepal.Width)*(mean + Justify(r)*sd), data=iris ) 1064 | # tags$div( 1065 | # HTML(paste(capture.output(Hmisc::html(x)), collapse=" ")) 1066 | # ) 1067 | 1068 | ## Reshaped output 1069 | output$reshapedDat <- renderTable({ 1070 | currentSheet <- projProperties[['activeSheet']] 1071 | if(!isEmpty(currentSheet)){sheetList[[currentSheet]][['dynamicProperties']][['outputTable']]} 1072 | }) 1073 | 1074 | output$ggplot <- renderPlot({ 1075 | if(input$autoRefresh=='refresh'){ 1076 | currentSheet <- projProperties[['activeSheet']] 1077 | if(!isEmpty(currentSheet)){ 1078 | sheetList[[currentSheet]][['plotR']]() 1079 | } 1080 | } else { 1081 | gg <- last_plot() 1082 | if(!is.null(gg)) gg <- gg + theme_grey() 1083 | gg 1084 | } 1085 | 1086 | }) 1087 | 1088 | 1089 | 1090 | ## add Layer 1091 | observe({ 1092 | v <- input$addLayer 1093 | isolate({ 1094 | if(v){ 1095 | currentSheet <- (projProperties[['activeSheet']]) 1096 | if(!isEmpty(currentSheet)){ 1097 | existingNames <- names(sheetList[[currentSheet]][['dynamicProperties']][['layerList']]) 1098 | layerName <- make.unique(c(existingNames, 'Overlay'), sep='_')[length(existingNames)+1] 1099 | 1100 | newLayer <- createNewLayer() 1101 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[layerName]] <<- newLayer 1102 | sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']] <<- layerName 1103 | 1104 | #copy from Plot layer 1105 | plotLayer <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][['Plot']] 1106 | names1 <- names(plotLayer) 1107 | for(n1 in names1){ 1108 | if(n1=='aesList'){ 1109 | names2 <- names(plotLayer[[n1]]) 1110 | for(n2 in names2){ 1111 | names3 <- names(plotLayer[[n1]][[n2]]) 1112 | for(n3 in names3){ 1113 | if(n3 != 'aesField' && typeof(plotLayer[[n1]][[n2]][[n3]]) != 'closure'){# 1114 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[layerName]][[n1]][[n2]][[n3]] <<- plotLayer[[n1]][[n2]][[n3]] 1115 | } 1116 | } 1117 | setAesReactives(currentSheet, layerName, n2) 1118 | } 1119 | } else { 1120 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[layerName]][[n1]] <<- plotLayer[[n1]] 1121 | } 1122 | } 1123 | 1124 | } 1125 | } 1126 | }) 1127 | }) 1128 | ## delete Layer 1129 | observe({ 1130 | v <- input$deleteLayer 1131 | isolate({ 1132 | if(v){ 1133 | currentSheet <- (projProperties[['activeSheet']]) 1134 | if(!isEmpty(currentSheet)){ 1135 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 1136 | if(!isEmpty(currentLayer) && currentLayer!='Plot'){ 1137 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]] <<- NULL 1138 | sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']] <<- 'Plot' 1139 | } 1140 | } 1141 | } 1142 | }) 1143 | }) 1144 | ## bring Layer to top 1145 | observe({ 1146 | v <- input$bringToTop 1147 | isolate({ 1148 | if(v){ 1149 | currentSheet <- (projProperties[['activeSheet']]) 1150 | if(!isEmpty(currentSheet)){ 1151 | currentLayer <- (sheetList[[currentSheet]][['dynamicProperties']][['activeLayer']]) 1152 | if(!isEmpty(currentLayer)){ 1153 | temp <- sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]] 1154 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]] <<- NULL 1155 | sheetList[[currentSheet]][['dynamicProperties']][['layerList']][[currentLayer]] <<- temp 1156 | } 1157 | } 1158 | } 1159 | }) 1160 | }) 1161 | 1162 | ## add sheet 1163 | observe({ 1164 | v <- input$addSheet 1165 | isolate({ 1166 | if(v){ 1167 | addSheet() 1168 | } 1169 | }) 1170 | }) 1171 | ## delete sheet 1172 | observe({ 1173 | v <- input$deleteSheet 1174 | isolate({ 1175 | if(v){ 1176 | currentSheet <- (projProperties[['activeSheet']]) 1177 | if(!isEmpty(currentSheet)){ 1178 | sheets <- names(sheetList) 1179 | i <- match(currentSheet, sheets) 1180 | sheetList[[currentSheet]] <<- NULL 1181 | projProperties[['activeSheet']] <<- ifelse(length(sheets)>i, sheets[i+1], 1182 | ifelse(i>1, sheets[i-1], '')) 1183 | } 1184 | } 1185 | }) 1186 | }) 1187 | 1188 | --------------------------------------------------------------------------------