Interactive web apps with Shiny
RaukR 2021 • Advanced R for Bioinformatics
Roy Francis
This is an introduction to shiny web applications with R. Please follow the exercise to familiarise yourself with the fundamentals. And then you can follow instructions to build one of the two complete apps. Code chunks starting with shinyApp() can be simply copy-pasted to the RStudio console and run. Generally, complete shiny code is saved as a text file, named for example, as app.R and then clicking Run app launches the app.
1 UI • Layout
This is an example to show the layout of widgets on a webpage using shiny functions. fluidPage() is used to define a responsive webpage. titlePanel() is used to define the top bar. sidebarLayout() is used to create a layout that includes a region on the left called side bar panel and a main panel on the right. The contents of these panels are further defined under sidebarPanel() and mainPanel().
In the main panel, the use of tab panels are demonstrated. The function tabsetPanel() is used to define a tab panel set and individual tabs are defined using tabPanel(). fluidRow() and column() are used to structure elements within each tab. The width of each column is specified. Total width of columns must add up to 12.
library(shiny)
ui <- fluidPage(
titlePanel("Title Panel"),
sidebarLayout(
sidebarPanel(
helpText("Sidebar Panel")
),
mainPanel(tabsetPanel(
tabPanel("tab1",
fluidRow(
column(6,helpText("Col1")),
column(6,
helpText("Col2"),
fluidRow(
column(4,style="background-color:#b0c6fb",
helpText("Col1")
),
column(4,style="background-color:#ffa153",
helpText("Col2")
),
column(4,style="background-color:#b1f6c6",
helpText("Col3")
)
)
)
)
),
tabPanel("tab2",
inputPanel(helpText("Input Panel"))
),
tabPanel("tab3",
wellPanel(helpText("Well Panel"))
)
)
)
)
)
server <- function(input,output){}
shinyApp(ui=ui,server=server)
2 UI • Widgets • Input
Input widgets are used to accept content interactively from the user. These widgets usually end in Input like selectInput(). Below are usage examples of several of shiny’s built-in widgets. Every widget has a variable name which is accessible through input$ in the server function. For example, the value of a variable named text-input would be accessed through input$text-input.
shinyApp(
ui=fluidPage(
fluidRow(
column(6,
fileInput("file-input","fileInput:"),
selectInput("select-input",label="selectInput",choices=c("A","B","C")),
numericInput("numeric-input",label="numericInput",value=5,min=1,max=10),
sliderInput("slider-input",label="sliderInput",value=5,min=1,max=10),
textInput("text-input",label="textInput"),
textAreaInput("text-area-input",label="textAreaInput"),
dateInput("date-input",label="dateInput"),
dateRangeInput("date-range-input",label="dateRangeInput"),
radioButtons("radio-button",label="radioButtons",choices=c("A","B","C"),inline=T),
checkboxInput("checkbox","checkboxInput",value=FALSE),
actionButton("action-button","Action"),
hr(),
submitButton()
)
)
),
server=function(input,output){},
options=list(height=900))
3 UI • Widgets • Outputs
Similar to input widgets, output widgets are used to display information to the user on the webpage. These widgets usually end in Output like textOutput(). Every widget has a variable name accessible under output$ to which content is written in the server function. Render functions are used to write content to output widgets. For example renderText() is used to write text data to textOutput() widget.
shinyApp(
ui=fluidPage(fluidRow(column(6,
textInput("text_input",label="textInput",value="<h3 style='color:red'>Red text</h3>"),
hr(),
htmlOutput("html_output"),
textOutput("text_output"),
verbatimTextOutput("verbatim_text_output"),
tableOutput("table_output"),
plotOutput("plot_output",width="300px",height="300px")
))),
server=function(input, output) {
output$html_output <- renderText({input$text_input})
output$text_output <- renderText({input$text_input})
output$verbatim_text_output <- renderText({input$text_input})
output$table_output <- renderTable({iris[1:3,1:3]})
output$plot_output <- renderPlot({
plot(iris[,1],iris[,2])
})
},
options=list(height=700))
In this example, we have a text input box which takes user text and outputs it in three different variations. The first output is html output htmlOutput(). Since the default text is html content, the output is red coloured text. A normal non-html text would just look like normal text. The second output is normal text output textOutput(). The third variation is verbatimTextOutput() which displays text in monospaced code style. This example further shows table output and plot output.
4 Dynamic UI
Sometimes we want to add, remove or change currently loaded UI widgets conditionally based on dynamic changes in code execution or user input. Conditional UI can be defined using conditionalPanel(), uiOutput()/renderUI(), insertUI() or removeUI. In this example, we will use uiOutput()/renderUI().
In the example below, the output plot is displayed only if the selected dataset is iris.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("mtcars","faithful","iris")),
tableOutput("table_output"),
uiOutput("ui")
),
server=function(input,output) {
getdata <- reactive({ get(input$data_input, 'package:datasets') })
output$ui <- renderUI({
if(input$data_input=="iris") plotOutput("plot_output",width="400px")
})
output$plot_output <- renderPlot({hist(getdata()[, 1])})
output$table_output <- renderTable({head(getdata())})
})
Here, conditional UI is used to selectively display an output widget (plot). Similarly, this idea can be used to selectively display any input or output widget.
5 Updating widgets
Widgets can be updated with new values dynamically. observe() and observeEvent() functions can monitor the values of interest and update relevant widgets.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",choices=c("mtcars","faithful","iris")),
selectInput("header_input",label="Select column name",choices=NULL),
plotOutput("plot_output",width="400px")
),
server=function(input,output,session) {
getdata <- reactive({ get(input$data_input, 'package:datasets') })
observe({
updateSelectInput(session,"header_input",label="Select column name",choices=colnames(getdata()))
})
output$plot_output <- renderPlot({
#shiny::req(input$header_input)
#validate(need(input$header_input %in% colnames(getdata()),message="Incorrect column name."))
hist(getdata()[, input$header_input],xlab=input$header_input,main=input$data_input)
})
},
options=list(height=600))
In this example, the user selects a dataset and a column from the selected dataset to be plotted as a histogram. The column name selection widget must automatically update it’s choices depending on the selected dataset. This achieved using observe() where the updateSelectInput() function updates the selection choices. Notice that a third option session is in use in the server function. ie; server=function(input,output,session). And session is also the first argument in updateSelectInput(). Session keeps track of values in the current session.
When changing the datasets, we can see that there is a short red error message. This is because, after we have selected a new dataset, the old column name from the previous dataset is searched for in the new dataset. This occurs for a short time and causes the error. This can be fixed using careful error handling. We will discuss this in another section.
6 Isolate
You might’ve noticed that shiny tends to update changes immediately as the input widgets change. This may not be desirable in all circumstances. For example, if the apps runs a heavy calculation, it is more efficient to grab all the changes and execute in one step rather than executing the heavy calculation after every input change. To illustrate this, we have an example below where we plot an image which has the title as input text. Try adding a long title to it.
shinyApp(
ui=fluidPage(
textInput("in_title",label="Title",value="Title"),
plotOutput("out_plot")),
server=function(input,output) {
output$out_plot <- renderPlot({
plot(iris[,1],iris[,2],main=input$in_title)
})
}
)
The plot changes as soon as the input text field is changed. And as we type in text, the image is continuously being redrawn. This can be computationally intensive depending on the situation. A better solution would be to write the text completely without any reactivity and when done, let the app know that you are ready to redraw.
We can add an action button such that the plot is changed only when the button is clicked.
shinyApp(
ui=fluidPage(
textInput("in_title",label="Title",value="Title"),
actionButton("btn_go","Go!"),
plotOutput("out_plot")),
server=function(input,output) {
output$out_plot <- renderPlot({
input$btn_go
plot(iris[,1],iris[,2],main=isolate(input$in_title))
})
}
)
Now, changes to any of the input fields do not initiate the plot function. The plot is redrawn only when the action button is clicked. When the action button is click, the current values in the input fields are collected and used in the plotting function.
7 Error validation
Shiny returns an error when a variable is NULL, NA or empty. This is similar to normal R operation. The errors show up as bright red text. By using careful error handling, we can print more informative and less distracting error messages. We also have the option of hiding error messages.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("","mtcars","faithful","iris")),
tableOutput("table_output")
),
server=function(input, output) {
getdata <- reactive({ get(input$data_input,'package:datasets') })
output$table_output <- renderTable({head(getdata())})
},
options=list(height="350px"))
In this example, we have a list of datasets to select which is then printed as a table. The first and default option is an empty string which cannot be printed as a table and therefore returns an error.
We can add an extra line to the above app so that the selected string is validated before running downstream commands in the getdata({}) reactive function. The function validate() is used to validate inputs. validate() can be used with need() function or a custom function.
Below we use the need() function to check the input. It checks if the input is NULL, NA or an empty string and returns a specified message if TRUE. try() is optional and is used to catch any other unexpected errors.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("","mtcars","faithful","iris")),
tableOutput("table_output")
),
server=function(input, output) {
getdata <- reactive({
validate(need(try(input$data_input),"Please select a data set"))
get(input$data_input,'package:datasets')
})
output$table_output <- renderTable({head(getdata())})
},
options=list(height="350px"))
Now we see an informative grey message (less scary) asking the user to select a dataset.
We can use a custom function instead of using need(). Below, we have created a function called valfun() that checks if the input is NULL, NA or an empty string. This is then used in validate().
valfn <- function(x) if(is.null(x) | is.na(x) | x=="") return("Input data is incorrect.")
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("","mtcars","faithful","iris")),
tableOutput("table_output")
),
server=function(input, output) {
getdata <- reactive({
validate(valfn(try(input$data_input)))
get(input$data_input,'package:datasets')
})
output$table_output <- renderTable({head(getdata())})
},
options=list(height="350px"))
The last option is to simple hide the error. This may be used in situations where there is no input needed from the user. We use req() to check if the input is valid, else stop execution there till the condition becomes true.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("","mtcars","faithful","iris")),
tableOutput("table_output")
),
server=function(input, output) {
getdata <- reactive({
shiny::req(try(input$data_input))
get(input$data_input,'package:datasets')
})
output$table_output <- renderTable({head(getdata())})
},
options=list(height="350px"))
As expected there is no error or any message at all. This is not always the best to use this option as we need the user to do something. An informative message may be better than nothing.
Finally, instead of printing messages about the error or hiding the error, we can try to resolve the errors from the previous section in a more robust manner. shiny::req(input$header_input) is added to ensure that a valid column name string is available before running any of the renderPlot() commands. Second, we add validate(need(input$header_input %in% colnames(getdata()),message="Incorrect column name.")) to ensure that the column name is actually a column in the currently selected dataset.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",choices=c("mtcars","faithful","iris")),
selectInput("header_input",label="Select column name",choices=NULL),
plotOutput("plot_output",width="400px")
),
server=function(input,output,session) {
getdata <- reactive({ get(input$data_input, 'package:datasets') })
observe({
updateSelectInput(session,"header_input",label="Select column name",choices=colnames(getdata()))
})
output$plot_output <- renderPlot({
shiny::req(input$header_input)
validate(need(input$header_input %in% colnames(getdata()),message="Incorrect column name."))
hist(getdata()[, input$header_input],xlab=input$header_input,main=input$data_input)
})
},
options=list(height=600))
Now, we do not see any error messages. Note that shiny apps on shinyapps.io do not display the complete regular R error message for security reasons. It returns a generic error message in the app. One needs to inspect the error logs to view the actual error message.
8 Download • Data
It is often desirable to let the user down data tables and plots as images. This is done using downloadHandler().
In the example below, we are downloading a table as a csv text file. We define a button that accepts the action input from the user. The downloadHandler() function has the file name argument, and the content argument where we specify the write.csv() command. Note that this example needs to be opened in a browser and may not in the RStudio preview. In the RStudio preview, click on Open in Browser.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("mtcars","faithful","iris")),
textOutput("text_output"),
downloadButton("button_download","Download")
),
server=function(input, output) {
getdata <- reactive({ get(input$data_input, 'package:datasets') })
output$text_output <- renderText(paste0("Selected dataset: ",input$data_input))
output$button_download <- downloadHandler(
filename = function() {
paste0(input$data_input,".csv")
},
content = function(file) {
write.csv(getdata(),file,row.names=FALSE,quote=F)
})
},
options=list(height="200px")
)
9 Download • Plot
In this next example, we are downloading a plot. In the content part of downloadHandler(), we specify commands to export a png image. Note that this example needs to be opened in a browser and may not in the RStudio preview. In the RStudio preview, click on Open in Browser.
shinyApp(
ui=fluidPage(
selectInput("data_input",label="Select data",
choices=c("mtcars","faithful","iris")),
textOutput("text_output"),
plotOutput("plot_output",height="300px",width="300px"),
downloadButton("button_download","Download")
),
server=function(input, output) {
getdata <- reactive({ get(input$data_input, 'package:datasets') })
output$text_output <- renderText(paste0("Selected dataset: ",input$data_input))
output$plot_output <- renderPlot({hist(getdata()[,1])})
output$button_download <- downloadHandler(
filename = function() {
paste0(input$data_input,".png")
},
content = function(file) {
png(file)
hist(getdata()[, 1])
dev.off()
})
},
options=list(height="500px")
)
10 Shiny in Rmarkdown
Shiny interactive widgets can be embedded into Rmarkdown documents. These documents need to be live and can handle interactivity. The important addition is the line runtime: shiny to the YAML matter. Here is an example:
---
runtime: shiny
output: html_document
---
```{r}
library(shiny)
```
This is a standard RMarkdown document. Here is some code:
```{r}
head(iris)
```
```{r}
plot(iris$Sepal.Length,iris$Petal.Width)
```
But, here is an interactive shiny widget.
```{r}
sliderInput("in_breaks",label="Breaks:",min=5,max=50,value=5,step=5)
```
```{r}
renderPlot({
hist(iris$Sepal.Length,breaks=input$in_breaks)
})
```This code can be copied to a new file in RStudio and saved as, for example, shiny.Rmd. Then click ‘Knit’. Alternatively, you can run rmarkdown::run("shiny.Rmd").
11 RNA-Seq power
Run power analysis for an RNA-Seq experiment.
Topics covered
- UI layout using pre-defined function (pageWithSidebar)
- Input and output widgets and reactivity
- Conditional widgets based on user input
- Validating inputs and custom error messages
- Custom theme
The following R packages are required for this app: c(shiny, shinythemes). In addition, install RNASeqPower from Bioconductor. BiocManager::install('RNASeqPower').
Below is a preview of the complete app.
11.1 RNASeqPower
The R package RNASeqPower helps users to perform a power analysis before running an RNA-Seq experiment. It helps you to estimate, for example, the number of samples required to detect a certain level of significance. The idea of this shiny app is to create a GUI for the RNASeqPower app.
So we first need to understand how RNASeqPower works. For a complete understanding, check out . For our purpose, we will take a brief look at how it works. We only need to use one function rnapower(). Check out ?RNASeqPower::rnapower.
So, let’s say we want to find out how many samples are required per group. We have some known input parameters. Let’s say the sequencing depth is 50 (depth=50), coefficient of variation is 0.6 (cv=0.6), effect size is 1.5 fold change (effect=1.5), significance cut-off is 0.05 (alpha=0.05) and lastly power of the test is 0.8 (power=0.8). The parameter we want to compute is the number of samples (n), therefore it is not specified.
library(RNASeqPower)
RNASeqPower::rnapower(depth=1000,cv=0.6,effect=2,alpha=0.05,power=0.8)## [1] 11.79489So, we see the number of samples required given these input conditions.
Similarly, we can estimate any of the other parameters (except depth). We can try another example we solve for power. What would the power be for a study with 12 per group, to detect a 2-fold change, given deep (50x) coverage?
rnapower(depth=50, n=12, cv=0.6, effect=2, alpha=.05)## [1] 0.7864965And the function has returned the power.
Now the idea is to create a web application take these input parameters from the user through input widgets.
11.2 Scaffolding
Let’s build the basic scaffolding for our app including the input widgets. Let’s assume we are estimating number of samples.
We use a sidebar layout. The input controls go on the sidebar panel and the output goes on the main panel. So we need 5 numeric inputs. We can set some default values as well as reasonable min and max values and steps to increase or decrease. The output will be verbatim text, so we use verbatimTextOutput() widget.
library(shiny)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1),
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
}
)
The app should visually look close to our final end result. Check that the widgets work.
The next step is to wire up the inputs to the rnapower() function and return the result to the output text field.
Try to see if you can get this to work.
library(shiny)
library(RNASeqPower)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1),
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$out_pa <- renderPrint({
rnapower(depth=input$in_pa_depth, cv=input$in_pa_cv,
effect=input$in_pa_effect, alpha=input$in_pa_alpha,
power=input$in_pa_power)
})
}
)
Verify that the inputs and outputs work. One can stop at this point if you only need to compute number of samples. But, we will continue to add more functionality.
11.3 Conditional UI
The function can estimate not only sample size, but cv, effect, alpha or power. We should let the user choose what they want to compute. So, we need a selection input widget to enable selection. And the input fields must change depending on the user’s selected choice. The rnapower() function must also use a different set of parameters depending on the selection choice. For conditional logic, you can chain if else statements or use switch().
Try to add a selection based conditional UI. ?selectInput(), ?uiOutput(), ?renderUI().
library(shiny)
library(RNASeqPower)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
selectInput("in_pa_est","Variable to estimate",choices=c("n","cv","effect","alpha","power"),selected=1,multiple=FALSE),
uiOutput("ui_pa")
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$ui_pa <- renderUI({
switch(input$in_pa_est,
"n"=div(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1)
),
"cv"=div(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_n","Sample size",value=12,min=3,max=1000,step=1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1)
),
"effect"=div(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_n","Sample size",value=12,min=3,max=1000,step=1),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1)
),
"alpha"=div(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_n","Sample size",value=12,min=3,max=1000,step=1),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_power","Power",value=0.8,min=0,max=1,step=0.1)
),
"power"=div(
numericInput("in_pa_depth","Sequencing depth",value=100,min=1,max=1000,step=5),
numericInput("in_pa_n","Sample size",value=12,min=3,max=1000,step=1),
numericInput("in_pa_cv","Coefficient of variation",value=0.4,min=0,max=1,step=0.1),
numericInput("in_pa_effect","Effect",value=2,min=0,max=10,step=0.1),
numericInput("in_pa_alpha","Alpha",value=0.05,min=0.01,max=0.1,step=0.01)
)
)
})
output$out_pa <- renderPrint({
switch(input$in_pa_est,
"n"=rnapower(depth=input$in_pa_depth, cv=input$in_pa_cv,
effect=input$in_pa_effect, alpha=input$in_pa_alpha,
power=input$in_pa_power),
"cv"=rnapower(depth=input$in_pa_depth, n=input$in_pa_n,
effect=input$in_pa_effect, alpha=input$in_pa_alpha,
power=input$in_pa_power),
"effect"=rnapower(depth=input$in_pa_depth, cv=input$in_pa_cv,
n=input$in_pa_n, alpha=input$in_pa_alpha,
power=input$in_pa_power),
"alpha"=rnapower(depth=input$in_pa_depth, cv=input$in_pa_cv,
effect=input$in_pa_effect, n=input$in_pa_n,
power=input$in_pa_power),
"power"=rnapower(depth=input$in_pa_depth, cv=input$in_pa_cv,
effect=input$in_pa_effect, alpha=input$in_pa_alpha,
n=input$in_pa_n),
)
})
}
)
Let’s summarise what we have done. In the ui part, instead of directly including the rnapower() input variable in the sidebarPanel(), we have added a selection input and a conditional UI output. The content inside the output UI depends on the selection made by the user.
selectInput("in_pa_est", "Variable to estimate", choices=c("n","cv","effect","alpha","power"), selected=1, multiple=FALSE),
uiOutput("ui_pa")Now to the server part where we make this all work. All conditional UI elements are inside renderUI({}) and we use a conditional logic inside it. And since we are returning multiple input widgets, they are all wrapped inside a div() container.
output$ui_pa <- renderUI({
switch(input$in_pa_est,
"n"=div(),
"cv"=div()
)
})In the renderPrint({}) function, we use a similar idea. rnapower() is calculated conditionally based on the user selection.
11.4 Multiple numeric input
Another feature of the rnapower() function that we have not discussed so far is that all the input arguments can take more than one number as input. Or in other words, instead of a single number, it can take a vector of number. For example;
RNASeqPower::rnapower(depth=c(50,100),cv=0.6,effect=1.5,alpha=0.05,power=0.8)## 50 100
## 36.28393 35.32909And it expands the results in various ways.
RNASeqPower::rnapower(depth=50,cv=0.6,effect=c(1.5,2,3),alpha=0.05,power=0.8)## 1.5 2 3
## 36.283928 12.415675 4.942337RNASeqPower::rnapower(depth=50,cv=c(0.4,0.6),effect=c(1.5,2,3),alpha=0.05,power=0.8)## 1.5 2 3
## 0.4 17.18712 5.881109 2.341107
## 0.6 36.28393 12.415675 4.942337The output expands in a bit unpredictable manner and this is the reason why our output widget type is set to verbatimTextOutput({}). Otherwise, we could have formatted it to perhaps, a neater table.
How do we incorporate this into our app interface? Ponder over this and try to come up with solutions.
One way to do it is to accept comma separated values from the user. And then parse that into a vector of numbers. For example;
x <- "2.5,6"
as.numeric(unlist(strsplit(gsub(" ","",x),",")))## [1] 2.5 6.0Blank space are removed, the string is split by comma into a list of strings, the list is converted to a vector and the strings are coerced to numbers.
Update the app such that all numeric inputs are replaced by text inputs and the server logic is able to parse the strings into numbers.
library(shiny)
library(RNASeqPower)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
selectInput("in_pa_est","Variable to estimate",choices=c("n","cv","effect","alpha","power"),selected=1,multiple=FALSE),
uiOutput("ui_pa")
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$ui_pa <- renderUI({
switch(input$in_pa_est,
"n"=div(
textInput("in_pa_depth","Sequencing depth",value=100),
textInput("in_pa_cv","Coefficient of variation",value=0.4),
textInput("in_pa_effect","Effect",value=2),
textInput("in_pa_alpha","Alpha",value=0.05),
textInput("in_pa_power","Power",value=0.8)
),
"cv"=div(
textInput("in_pa_depth","Sequencing depth",value=100),
textInput("in_pa_n","Sample size",value=12),
textInput("in_pa_effect","Effect",value=2),
textInput("in_pa_alpha","Alpha",value=0.05),
textInput("in_pa_power","Power",value=0.8)
),
"effect"=div(
textInput("in_pa_depth","Sequencing depth",value=100),
textInput("in_pa_n","Sample size",value=12),
textInput("in_pa_cv","Coefficient of variation",value=0.4),
textInput("in_pa_alpha","Alpha",value=0.05),
textInput("in_pa_power","Power",value=0.8)
),
"alpha"=div(
textInput("in_pa_depth","Sequencing depth",value=100),
textInput("in_pa_n","Sample size",value=12),
textInput("in_pa_cv","Coefficient of variation"),
textInput("in_pa_effect","Effect",value=2),
textInput("in_pa_power","Power",value=0.8)
),
"power"=div(
textInput("in_pa_depth","Sequencing depth",value=100),
textInput("in_pa_n","Sample size",value=12),
textInput("in_pa_cv","Coefficient of variation",value=0.4),
textInput("in_pa_effect","Effect",value=2),
textInput("in_pa_alpha","Alpha",value=0.05)
)
)
})
output$out_pa <- renderPrint({
switch(input$in_pa_est,
"n"={
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, power=power)
},
"cv"={
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
rnapower(depth=depth, n=n, effect=effect, alpha=alpha, power=power)
},
"effect"={
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
rnapower(depth=depth, cv=cv, n=n, alpha=alpha, power=power)
},
"alpha"={
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
rnapower(depth=depth, cv=cv, effect=effect, n=n, power=power)
},
"power"={
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, n=n)
},
)
})
}
)
To summarise our changes, in the ui part, all numericInput() has been changed to textInput() and in the process we lost the number specific input limits such as min, max, step size etc. In the server part, incoming strings are parsed and split into a vector of numbers, saved to a variable and passed to the rnapower() function. Ensure that the app works without errors and we can progress further.
11.5 Code cleaning
It is good practice to check whether the current code can be cleaned-up/polished or reduced. In this example, depth is always needed and could be moved out of the conditional block. Only one variable changes based on user input, but all 5 variables are repeated in each conditional block. There is room for improvement there.
Try to figure out how the code can be reorganised and simplified.
library(shiny)
library(RNASeqPower)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
selectInput("in_pa_est","Variable to estimate",choices=c("n","cv","effect","alpha","power"),selected=1,multiple=FALSE),
uiOutput("ui_pa")
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$ui_pa <- renderUI({
div(
textInput("in_pa_depth","Sequencing depth",value=4),
if(input$in_pa_est != "n") textInput("in_pa_n","Sample size",value=100),
if(input$in_pa_est != "cv") textInput("in_pa_cv","Coefficient of variation",value=0.4),
if(input$in_pa_est != "effect") textInput("in_pa_effect","Effect",value=2),
if(input$in_pa_est != "alpha") textInput("in_pa_alpha","Alpha",value=0.05),
if(input$in_pa_est != "power") textInput("in_pa_power","Power",value=0.8)
)
})
output$out_pa <- renderPrint({
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
if(input$in_pa_est != "n") n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
if(input$in_pa_est != "cv") cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
if(input$in_pa_est != "effect") effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
if(input$in_pa_est != "alpha") alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
if(input$in_pa_est != "power") power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
switch(input$in_pa_est,
"n"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, power=power),
"cv"=rnapower(depth=depth, n=n, effect=effect, alpha=alpha, power=power),
"effect"=rnapower(depth=depth, cv=cv, n=n, alpha=alpha, power=power),
"alpha"=rnapower(depth=depth, cv=cv, effect=effect, n=n, power=power),
"power"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, n=n)
)
})
}
)
UI and server blocks have been considerably reduced in length by removing redundant code.
11.6 Input validation
When we changed numeric inputs to character, we lost the input limits and numeric validation. Regardless of what input you enter, the app tries to proceed with the calculation.
Try entering some unreasonable inputs and see what happens. Try entering random strings, or huge integers for alpha etc.
We can bring back input validation manually using validate() functions. This can be used to check if the input conforms to some expected range of values and if not, return a message to the user.
Here are the limits we want to set:
depth: A numericn: A numericcv: A numericeffect: A numericalpha: A numeric between 0 and 1 excluding 0 and 1power: A numeric between 0 and 1 excluding 0 and 1
Try to figure out how to add input validation. ?shiny::validate().
library(shiny)
library(RNASeqPower)
# returns a message if condition is true
fn_validate <- function(input,message) if(input) print(message)
shinyApp(
ui=fluidPage(
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
selectInput("in_pa_est","Variable to estimate",choices=c("n","cv","effect","alpha","power"),selected=1,multiple=FALSE),
uiOutput("ui_pa")
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$ui_pa <- renderUI({
div(
textInput("in_pa_depth","Sequencing depth",value=100),
if(input$in_pa_est != "n") textInput("in_pa_n","Sample size",value=12),
if(input$in_pa_est != "cv") textInput("in_pa_cv","Coefficient of variation",value=0.4),
if(input$in_pa_est != "effect") textInput("in_pa_effect","Effect",value=2),
if(input$in_pa_est != "alpha") textInput("in_pa_alpha","Alpha",value=0.05),
if(input$in_pa_est != "power") textInput("in_pa_power","Power",value=0.8)
)
})
output$out_pa <- renderPrint({
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
validate(fn_validate(any(is.na(depth)),"Sequencing depth must be a numeric."))
if(input$in_pa_est != "n") {
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
validate(fn_validate(any(is.na(n)),"Sample size must be a numeric."))
}
if(input$in_pa_est != "cv") {
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
validate(fn_validate(any(is.na(cv)),"Coefficient of variation must be a numeric."))
}
if(input$in_pa_est != "effect") {
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
validate(fn_validate(any(is.na(effect)),"Effect must be a numeric."))
}
if(input$in_pa_est != "alpha") {
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
validate(fn_validate(any(is.na(alpha)),"Alpha must be a numeric."))
validate(fn_validate(any(alpha>=1|alpha<=0),"Alpha must be a numeric between 0 and 1."))
}
if(input$in_pa_est != "power") {
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
validate(fn_validate(any(is.na(power)),"Power must be a numeric."))
validate(fn_validate(any(power>=1|power<=0),"Power must be a numeric between 0 and 1."))
}
switch(input$in_pa_est,
"n"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, power=power),
"cv"=rnapower(depth=depth, n=n, effect=effect, alpha=alpha, power=power),
"effect"=rnapower(depth=depth, cv=cv, n=n, alpha=alpha, power=power),
"alpha"=rnapower(depth=depth, cv=cv, effect=effect, n=n, power=power),
"power"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, n=n)
)
})
}
)
We have added validate() to all incoming text to ensure that user input is within reasonable limits.
Test that the validation works by inputting unreasonable inputs such as alphabets, symbols etc into the input fields.
11.7 Theme
This part is purely cosmetic. We can add a custom theme from R package shinythemes to make our app stand out from the default. The theme is added as an argument to fluidPage() like so fluidPage(theme = shinytheme("spacelab")).
Try changing the theme and pick one that you like. Check out ?shinythemes. The themes can be visualised on Bootswatch.
library(shiny)
library(shinythemes)
library(RNASeqPower)
# returns a message if condition is true
fn_validate <- function(input,message) if(input) print(message)
shinyApp(
ui=fluidPage(
theme=shinytheme("spacelab"),
titlePanel("RNA-Seq | Power analysis"),
sidebarLayout(
sidebarPanel(
selectInput("in_pa_est","Variable to estimate",choices=c("n","cv","effect","alpha","power"),selected=1,multiple=FALSE),
uiOutput("ui_pa")
),
mainPanel(
verbatimTextOutput("out_pa")
)
)
),
server=function(input,output){
output$ui_pa <- renderUI({
div(
textInput("in_pa_depth","Sequencing depth",value=100),
if(input$in_pa_est != "n") textInput("in_pa_n","Sample size",value=12),
if(input$in_pa_est != "cv") textInput("in_pa_cv","Coefficient of variation",value=0.4),
if(input$in_pa_est != "effect") textInput("in_pa_effect","Effect",value=2),
if(input$in_pa_est != "alpha") textInput("in_pa_alpha","Alpha",value=0.05),
if(input$in_pa_est != "power") textInput("in_pa_power","Power",value=0.8)
)
})
output$out_pa <- renderPrint({
depth <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_depth),",")))
validate(fn_validate(any(is.na(depth)),"Sequencing depth must be a numeric."))
if(input$in_pa_est != "n") {
n <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_n),",")))
validate(fn_validate(any(is.na(n)),"Sample size must be a numeric."))
}
if(input$in_pa_est != "cv") {
cv <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_cv),",")))
validate(fn_validate(any(is.na(cv)),"Coefficient of variation must be a numeric."))
}
if(input$in_pa_est != "effect") {
effect <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_effect),",")))
validate(fn_validate(any(is.na(effect)),"Effect must be a numeric."))
}
if(input$in_pa_est != "alpha") {
alpha <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_alpha),",")))
validate(fn_validate(any(is.na(alpha)),"Alpha must be a numeric."))
validate(fn_validate(any(alpha>=1|alpha<=0),"Alpha must be a numeric between 0 and 1."))
}
if(input$in_pa_est != "power") {
power <- as.numeric(unlist(strsplit(gsub(" ","",input$in_pa_power),",")))
validate(fn_validate(any(is.na(power)),"Power must be a numeric."))
validate(fn_validate(any(power>=1|power<=0),"Power must be a numeric between 0 and 1."))
}
switch(input$in_pa_est,
"n"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, power=power),
"cv"=rnapower(depth=depth, n=n, effect=effect, alpha=alpha, power=power),
"effect"=rnapower(depth=depth, cv=cv, n=n, alpha=alpha, power=power),
"alpha"=rnapower(depth=depth, cv=cv, effect=effect, n=n, power=power),
"power"=rnapower(depth=depth, cv=cv, effect=effect, alpha=alpha, n=n)
)
})
}
)
This is the completed app.
11.8 Deployment
You do not necessarily need to do this section. This is just so you know.
The app is now ready to be deployed. If you have an account on shinyapps.io, you can quickly deploy this app to your account using the R package rsconnect.
library(rsconnect)
rsconnect::setAccountInfo(name="username", token="KJHF853HG6G59C2F4J7B6", secret="jhHD7%jdg)62F67G/")
deployApp(appName="my-awesome-app",appDir=".")The packages used are automatically detected and are installed on to the instance. If Bioconductor packages give an error during deployment, the repos need to be explicitly set on your system.
setRepositories(c(1,2),graphics=FALSE)This completes this app tutorial. Hope you have enjoyed this build and learned something interesting along the way. There are few more example apps below, but that is optional.
12 Calendar app
A shiny app to create a calendar planner plot.
Topics covered
- UI layout using pre-defined function (pageWithSidebar)
- Input and output widgets and reactivity
- Use of date-time
- Customised ggplot
- Download image files
- Update inputs using observe
- Validating inputs with custom error messages
The following R packages will be required for this app: ggplot2, shiny, colourpicker.
Below is a preview of the finished app.
The idea of this app is to create and display a calendar styled planner. Below is a preview of the expected output.
The image is a plot created in ggplot. X axis showing week numbers, y axis showing weekdays, facet titles showing months and dates are coloured by categories. We can split this into two parts. The first part is preparing the code for the core task at hand (ie; generating the plot) and the second part is creating a graphical user interface around it using shiny apps to enable the user to input values and adjust dates, categories, plot parameters etc.
12.1 Creating the plot
The first step is to figure out how to create this plot in ggplot. The data will be contained in a data.frame. The data.frame is created based on start and end dates.
start_date <- as.Date("2019-06-01")
end_date <- as.Date("2019-07-05")
dfr <- data.frame(date=seq(start_date,end_date,by=1))
head(dfr)## date
## 1 2019-06-01
## 2 2019-06-02
## 3 2019-06-03
## 4 2019-06-04
## 5 2019-06-05
## 6 2019-06-06We can add some code to get specific information from these dates such as the day, week, month and numeric date. Finally we
dfr$day <- factor(strftime(dfr$date,format="%a"),levels=rev(c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")))
dfr$week <- factor(strftime(dfr$date,format="%V"))
dfr$month <- strftime(dfr$date,format="%B")
dfr$month <- factor(dfr$month,levels=unique(dfr$month))
dfr$ddate <- factor(strftime(dfr$date,format="%d"))
head(dfr)## date day week month ddate
## 1 2019-06-01 Sat 22 June 01
## 2 2019-06-02 Sun 22 June 02
## 3 2019-06-03 Mon 23 June 03
## 4 2019-06-04 Tue 23 June 04
## 5 2019-06-05 Wed 23 June 05
## 6 2019-06-06 Thu 23 June 06Finally, we add a column called track which will hold the categorical information for colouring dates by activity.
dfr$track <- "Available"
dfr$track[dfr$day=="Sat"|dfr$day=="Sun"] <- "Weekend"
head(dfr)## date day week month ddate track
## 1 2019-06-01 Sat 22 June 01 Weekend
## 2 2019-06-02 Sun 22 June 02 Weekend
## 3 2019-06-03 Mon 23 June 03 Available
## 4 2019-06-04 Tue 23 June 04 Available
## 5 2019-06-05 Wed 23 June 05 Available
## 6 2019-06-06 Thu 23 June 06 AvailableThis is enough information to plot.
ggplot(dfr,aes(x=week,y=day))+
geom_tile(aes(fill=track))+
geom_text(aes(label=ddate))+
facet_grid(~month,scales="free",space="free")+
theme_bw()
We can add more activities to the track column. Or in other words, I refer to it as adding more tracks.
dfr$track[dfr$date>=as.Date("2019-06-10") & dfr$date<=as.Date("2019-06-20")] <- "RaukR"
dfr$track[dfr$date==as.Date("2019-06-21")] <- "Midsummer"
ggplot(dfr,aes(x=week,y=day))+
geom_tile(aes(fill=track))+
geom_text(aes(label=ddate))+
facet_grid(~month,scales="free",space="free")+
theme_bw()
Now, we can customise the plot as you prefer. I am modifying the axes labels, changing colours and removing most of the plot elements.
all_cols <- c("#bebada","#fb8072","#80b1d3","#fdb462")
ggplot(dfr,aes(x=week,y=day))+
geom_tile(aes(fill=track))+
geom_text(aes(label=ddate))+
scale_fill_manual(values=all_cols)+
facet_grid(~month,scales="free",space="free")+
labs(x="Week",y="")+
theme_bw(base_size=14)+
theme(legend.title=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank(),
axis.ticks=element_blank(),
axis.title=element_text(colour="grey30"),
strip.background=element_blank(),
legend.key.size=unit(0.3,"cm"),
legend.spacing.x=unit(0.2,"cm"))
Our plot is now ready and we have the code to create this plot. The next step is to build a shiny app around it.
12.2 Building the app
12.2.1 Layout
We need to first have a plan for the app page, which UI elements to include and how they will be laid out and structured. My plan is as shown in the preview image.
There is a horizontal top bar for the title and two columns below. The left column will contain the input widgets and control. The right column will contain the plot output. Since, this is a commonly used layout, it is available as a predefined function in shiny called pageWithSidebar(). It takes three arguments headerPanel, sidebarPanel and mainPanel which is self explanatory.
shinyApp(
ui=fluidPage(
pageWithSidebar(
headerPanel(),
sidebarPanel(),
mainPanel())
),
server=function(input,output){}
)12.2.2 UI
Then we fill in the panels with widgets and contents.
shinyApp(
ui=fluidPage(
pageWithSidebar(
headerPanel(title="Calendar Planner",windowTitle="Calendar Planner"),
sidebarPanel(
h3("Duration"),
fluidRow(
column(6,style=list("padding-right: 5px;"),
dateInput("in_duration_date_start","From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(6,style=list("padding-left: 5px;"),
dateInput("in_duration_date_end","To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
)
)
),
mainPanel())
),
server=function(input,output){}
)The app as it is now, when previewed, should look like below:
We have defined a part of the side bar panel with a title Duration. fluidRow() is an html tag used to create rows. Above, in the side bar panel, a row is defined and two columns are defined inside. Each column is filled with date input widgets for start and end dates. We use the columns here to place date input widgets side by side. To place widgets one below the other, the columns can simply be removed. The default value for the start date is set to current date and the end date is set to current date + 30 days.
Now we add more sections to the side bar panel, namely track input variables and plot settings variables. We also added custom colours. Custom colours can be selected using the input widget colourpicker::colourInput().
cols <- toupper(c(
"#bebada","#fb8072","#80b1d3","#fdb462","#b3de69","#fccde5","#FDBF6F","#A6CEE3",
"#56B4E9","#B2DF8A","#FB9A99","#CAB2D6","#A9C4E2","#79C360","#FDB762","#9471B4",
"#A4A4A4","#fbb4ae","#b3cde3","#ccebc5","#decbe4","#fed9a6","#ffffcc","#e5d8bd",
"#fddaec","#f2f2f2","#8dd3c7","#d9d9d9"))
shinyApp(
ui=fluidPage(
pageWithSidebar(
headerPanel(title="Calendar Planner",windowTitle="Calendar Planner"),
sidebarPanel(
h3("Duration"),
fluidRow(
column(6,style=list("padding-right: 5px;"),
dateInput("in_duration_date_start","From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(6,style=list("padding-left: 5px;"),
dateInput("in_duration_date_end","To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
)
),
h3("Tracks"),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_1",label="Name",value="Vacation",placeholder="Vacation")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_1",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_1",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_1",label="Colour",
palette="limited",allowedCols=cols,value=cols[1])
)
),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_2",label="Name",value="Offline",placeholder="Offline")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_2",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_2",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_2",label="Colour",
palette="limited",allowedCols=cols,value=cols[2])
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
colourpicker::colourInput("in_track_colour_available",label="Track colour (Available)",
palette="limited",allowedCols=cols,value=cols[length(cols)-1])
),
column(6,style=list("padding-left: 5px;"),
colourpicker::colourInput("in_track_colour_weekend",label="Track colour (Weekend)",
palette="limited",allowedCols=cols,value=cols[length(cols)])
)
),
tags$br(),
h3("Settings"),
selectInput("in_legend_position",label="Legend position",
choices=c("top","right","left","bottom"),selected="right",multiple=F),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_legend_justification",label="Legend justification",
choices=c("left","right"),selected="right",multiple=F)
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_legend_direction",label="Legend direction",
choices=c("vertical","horizontal"),selected="vertical",multiple=F)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_themefontsize",label="Theme font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_datefontsize",label="Date font size",value=2.5,step=0.1)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_monthfontsize",label="Month font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_legendfontsize",label="Legend font size",value=5,step=0.5)
)
)
),
mainPanel(
plotOutput("out_plot")
))
),
server=function(input,output){}
)
The track start and end dates are by default set to the same as that of duration start and end dates. We will adjust this later. Under the settings section, we have added a few useful plot variables to adjust sizes and spacing of plot elements. They are set to reasonable defaults. These variables will be passed on to the ggplot plotting function.
We can end with column with the download options. Input fields are height, width, resolution and file format. Last we add a button for download.
h3("Download"),
helpText("Width is automatically calculated based on the number of weeks. File type is only applicable to download and does not change preview."),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_height","Height (cm)",step=0.5,value=5.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_width","Width (cm)",step=0.5,value=NA)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_res","Res/DPI",choices=c("200","300","400","500"),selected="200")
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_format","File type",choices=c("png","tiff","jpeg","pdf"),selected="png",multiple=FALSE,selectize=TRUE)
)
),
downloadButton("btn_downloadplot","Download Plot"),
tags$hr(),
helpText("2019 | RaukR")In the main panel, we add the plot output function that will hold the output plot. We also add a slider for image preview scaling and the output image. The idea behind the preview scaling is to allow the user to increase or decrease the size of the plot in the browser without affecting the download size. The part of the UI code to add the preview slider is below:
mainPanel(
sliderInput("in_scale","Image preview scale",min=0.1,max=3,step=0.10,value=1),
helpText("Scale only controls preview here and does not affect download."),
tags$br(),
imageOutput("out_plot")
)This should now look like this.
## load colours
cols <- toupper(c(
"#bebada","#fb8072","#80b1d3","#fdb462","#b3de69","#fccde5","#FDBF6F","#A6CEE3",
"#56B4E9","#B2DF8A","#FB9A99","#CAB2D6","#A9C4E2","#79C360","#FDB762","#9471B4",
"#A4A4A4","#fbb4ae","#b3cde3","#ccebc5","#decbe4","#fed9a6","#ffffcc","#e5d8bd",
"#fddaec","#f2f2f2","#8dd3c7","#d9d9d9"))
shinyApp(
ui=fluidPage(
pageWithSidebar(
headerPanel(title="Calendar Planner",windowTitle="Calendar Planner"),
sidebarPanel(
h3("Duration"),
fluidRow(
column(6,style=list("padding-right: 5px;"),
dateInput("in_duration_date_start","From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(6,style=list("padding-left: 5px;"),
dateInput("in_duration_date_end","To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
)
),
h3("Tracks"),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_1",label="Name",value="Vacation",placeholder="Vacation")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_1",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_1",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_1",label="Colour",
palette="limited",allowedCols=cols,value=cols[1])
)
),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_2",label="Name",value="Offline",placeholder="Offline")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_2",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_2",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_2",label="Colour",
palette="limited",allowedCols=cols,value=cols[2])
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
colourpicker::colourInput("in_track_colour_available",label="Track colour (Available)",
palette="limited",allowedCols=cols,value=cols[length(cols)-1])
),
column(6,style=list("padding-left: 5px;"),
colourpicker::colourInput("in_track_colour_weekend",label="Track colour (Weekend)",
palette="limited",allowedCols=cols,value=cols[length(cols)])
)
),
tags$br(),
h3("Settings"),
selectInput("in_legend_position",label="Legend position",
choices=c("top","right","left","bottom"),selected="right",multiple=F),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_legend_justification",label="Legend justification",
choices=c("left","right"),selected="right",multiple=F)
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_legend_direction",label="Legend direction",
choices=c("vertical","horizontal"),selected="vertical",multiple=F)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_themefontsize",label="Theme font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_datefontsize",label="Date font size",value=2.5,step=0.1)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_monthfontsize",label="Month font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_legendfontsize",label="Legend font size",value=5,step=0.5)
)
),
tags$br(),
h3("Download"),
helpText("Width is automatically calculated based on the number of weeks. File type is only applicable to download and does not change preview."),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_height","Height (cm)",step=0.5,value=5.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_width","Width (cm)",step=0.5,value=NA)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_res","Res/DPI",choices=c("200","300","400","500"),selected="200")
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_format","File type",choices=c("png","tiff","jpeg","pdf"),selected="png",multiple=FALSE,selectize=TRUE)
)
),
downloadButton("btn_downloadplot","Download Plot"),
tags$hr(),
helpText("2019 | RaukR")
),
mainPanel(
sliderInput("in_scale","Image preview scale",min=0.1,max=3,step=0.10,value=1),
helpText("Scale only controls preview here and does not affect download."),
tags$br(),
imageOutput("out_plot")
)
)
),
server=function(input,output){}
)
12.2.3 Server
We can start adding content into the server function to actually enable functionality.
The server code can be organised into 5 blocks.
fn_plot(): Reactive function that generates ggplot object- out_plot: Plots the ggplot object
fn_downloadplotname(): Function to create download image namefn_downloadplot(): Function to create and download the image- btn_downloadplot: Download handler that runs fn_downloadplot on button trigger
- observe: Observer that updates input values
Here is a flow diagram of how these blocks work.
1 > [2]
v
3 > [4] < 5
{6}The core block 1 creates the preview plot in block 2. The download handler block 5 calls block 1 to generate the plot which is downloaded using block 4. Block 6 is standalone observer.
Reactive values used across multiple functions can be stored using reactiveValues(). These can be written to or accessed from within a reactive environment.
store <- reactiveValues(week=NULL)We have our core function fn_plot() (block 1). Inputs are validated and gathered from input widgets. We are using shiny::req() to silently check that necessary input variables are available before running through the function. We use validate() with need() to run some basic sanity checks namely that track names are not duplicated and to ensure that start-dates precede end-dates. Necessary date-time calculations are performed. The calendar plot is created and returned.
## RFN: fn_plot -----------------------------------------------------------
## core plotting function, returns a ggplot object
fn_plot <- reactive({
shiny::req(input$in_duration_date_start)
shiny::req(input$in_duration_date_end)
shiny::req(input$in_track_date_start_1)
shiny::req(input$in_track_date_end_1)
shiny::req(input$in_track_name_1)
shiny::req(input$in_track_colour_1)
shiny::req(input$in_track_date_start_2)
shiny::req(input$in_track_date_end_2)
shiny::req(input$in_track_name_2)
shiny::req(input$in_track_colour_2)
shiny::req(input$in_legend_position)
shiny::req(input$in_legend_justification)
shiny::req(input$in_legend_direction)
shiny::req(input$in_themefontsize)
shiny::req(input$in_datefontsize)
shiny::req(input$in_monthfontsize)
shiny::req(input$in_legendfontsize)
validate(need(input$in_track_name_1!=input$in_track_name_2,"Duplicate track names are not allowed."))
validate(need(as.Date(input$in_duration_date_start) < as.Date(input$in_duration_date_end),"End duration date must be later than start duration date."))
# prepare dates
dfr <- data.frame(date=seq(as.Date(input$in_duration_date_start),as.Date(input$in_duration_date_end),by=1))
dfr$day <- factor(strftime(dfr$date,format="%a"),levels=rev(c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")))
dfr$week <- factor(strftime(dfr$date,format="%V"))
dfr$month <- strftime(dfr$date,format="%B")
dfr$month <- factor(dfr$month,levels=unique(dfr$month))
dfr$ddate <- factor(strftime(dfr$date,format="%d"))
#add tracks
dfr$track <- "Available"
dfr$track[dfr$day=="Sat" | dfr$day=="Sun"] <- "Weekend"
temp_start_date_1 <- as.Date(input$in_track_date_start_1)
temp_end_date_1 <- as.Date(input$in_track_date_end_1)
temp_track_name_1 <- input$in_track_name_1
temp_track_col_1 <- input$in_track_colour_1
validate(need(temp_start_date_1 < temp_end_date_1,"End track duration date must be later than start track duration date."))
dfr$track[dfr$date>=temp_start_date_1 & dfr$date<=temp_end_date_1] <- temp_track_name_1
temp_start_date_2 <- as.Date(input$in_track_date_start_2)
temp_end_date_2 <- as.Date(input$in_track_date_end_2)
temp_track_name_2 <- input$in_track_name_2
temp_track_col_2 <- input$in_track_colour_2
validate(need(temp_start_date_2 < temp_end_date_2,"End track duration date must be later than start track duration date."))
dfr$track[dfr$date>=temp_start_date_2 & dfr$date<=temp_end_date_2] <- temp_track_name_2
# create order factor
fc <- vector(mode="character")
if("Available" %in% unique(dfr$track)) fc <- c(fc,"Available")
fc <- c(fc,temp_track_name_1,temp_track_name_2)
if("Weekend" %in% unique(dfr$track)) fc <- c(fc,"Weekend")
dfr$track <- factor(dfr$track,levels=fc)
# prepare colours
all_cols <- c(input$in_track_colour_available,temp_track_col_1,temp_track_col_2,input$in_track_colour_weekend)
# plot
p <- ggplot(dfr,aes(x=week,y=day))+
geom_tile(aes(fill=track))+
geom_text(aes(label=ddate),size=input$in_datefontsize)+
scale_fill_manual(values=all_cols)+
facet_grid(~month,scales="free",space="free")+
labs(x="Week",y="")+
theme_bw(base_size=input$in_themefontsize)+
theme(legend.title=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank(),
axis.ticks=element_blank(),
axis.title=element_text(colour="grey30"),
strip.background=element_blank(),
strip.text=element_text(size=input$in_monthfontsize),
legend.position=input$in_legend_position,
legend.justification=input$in_legend_justification,
legend.direction=input$in_legend_direction,
legend.text=element_text(size=input$in_legendfontsize),
legend.key.size=unit(0.3,"cm"),
legend.spacing.x=unit(0.2,"cm"))
# add number of weeks to reactive value
store$week <- length(levels(dfr$week))
return(p)
})Here is the block that generates the output image. Image dimensions and resolution is obtained from input widgets. Default width is computed based on number of weeks. This is why the number of weeks was stored as a reactive value. The plot is exported to the working directly and then displayed in the browser. The scale slider allows the plot preview to be scaled in the browser.
## OUT: out_plot ------------------------------------------------------------
## plots figure
output$out_plot <- renderImage({
shiny::req(fn_plot())
shiny::req(input$in_height)
shiny::req(input$in_res)
shiny::req(input$in_scale)
height <- as.numeric(input$in_height)
width <- as.numeric(input$in_width)
res <- as.numeric(input$in_res)
if(is.na(width)) {
width <- (store$week*1.2)
if(width < 4.5) width <- 4.5
}
p <- fn_plot()
ggsave("calendar_plot.png",p,height=height,width=width,units="cm",dpi=res)
return(list(src="calendar_plot.png",
contentType="image/png",
width=round(((width*res)/2.54)*input$in_scale,0),
height=round(((height*res)/2.54)*input$in_scale,0),
alt="calendar_plot"))
})The fn_downloadplotname() function simply generates the output filename depending on the filetype extension.
# FN: fn_downloadplotname ----------------------------------------------------
# creates filename for download plot
fn_downloadplotname <- function()
{
return(paste0("calendar_plot.",input$in_format))
}The fn_downloadplot() function uses fn_plot() to create the image and then export the image.
## FN: fn_downloadplot -------------------------------------------------
## function to download plot
fn_downloadplot <- function(){
shiny::req(fn_plot())
shiny::req(input$in_height)
shiny::req(input$in_res)
shiny::req(input$in_scale)
height <- as.numeric(input$in_height)
width <- as.numeric(input$in_width)
res <- as.numeric(input$in_res)
format <- input$in_format
if(is.na(width)) width <- (store$week*1)+1
p <- fn_plot()
if(format=="pdf" | format=="svg"){
ggsave(fn_downloadplotname(),p,height=height,width=width,units="cm",dpi=res)
#embed_fonts(fn_downloadplotname())
}else{
ggsave(fn_downloadplotname(),p,height=height,width=width,units="cm",dpi=res)
}
}The download handler then downloads the file.
## DHL: btn_downloadplot ----------------------------------------------------
## download handler for downloading plot
output$btn_downloadplot <- downloadHandler(
filename=fn_downloadplotname,
content=function(file) {
fn_downloadplot()
file.copy(fn_downloadplotname(),file,overwrite=T)
}
)Finally, we have the observer function. The observer continuously monitors change in input widgets of interest (here start and end duration) and updates other widget values.
## OBS: tracks dates ---------------------------------------------------------
observe({
shiny::req(input$in_duration_date_start)
shiny::req(input$in_duration_date_end)
validate(need(as.Date(input$in_duration_date_start) < as.Date(input$in_duration_date_end),"End duration date must be later than start duration date."))
# create date intervals
dseq <- seq(as.Date(input$in_duration_date_start),as.Date(input$in_duration_date_end),by=1)
r1 <- unique(as.character(cut(dseq,breaks=3)))
updateDateInput(session,"in_track_date_start_1",label="From",value=as.Date(r1[1],"%Y-%m-%d"))
updateDateInput(session,"in_track_date_end_1",label="To",value=as.Date(r1[1+1],"%Y-%m-%d")-1)
updateDateInput(session,"in_track_date_start_2",label="From",value=as.Date(r1[2],"%Y-%m-%d"))
updateDateInput(session,"in_track_date_end_2",label="To",value=as.Date(r1[2+1],"%Y-%m-%d")-1)
})The complete code for the app is as below.
## load libraries
library(ggplot2)
library(shiny)
library(colourpicker)
## load colours
cols <- toupper(c(
"#bebada","#fb8072","#80b1d3","#fdb462","#b3de69","#fccde5","#FDBF6F","#A6CEE3",
"#56B4E9","#B2DF8A","#FB9A99","#CAB2D6","#A9C4E2","#79C360","#FDB762","#9471B4",
"#A4A4A4","#fbb4ae","#b3cde3","#ccebc5","#decbe4","#fed9a6","#ffffcc","#e5d8bd",
"#fddaec","#f2f2f2","#8dd3c7","#d9d9d9"))
shinyApp(
# UI ---------------------------------------------------------------------------
ui=fluidPage(
pageWithSidebar(
headerPanel(title="Calendar Planner",windowTitle="Calendar Planner"),
sidebarPanel(
h3("Duration"),
fluidRow(
column(6,style=list("padding-right: 5px;"),
dateInput("in_duration_date_start","From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(6,style=list("padding-left: 5px;"),
dateInput("in_duration_date_end","To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
)
),
h3("Tracks"),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_1",label="Name",value="Vacation",placeholder="Vacation")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_1",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_1",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_1",label="Colour",
palette="limited",allowedCols=cols,value=cols[1])
)
),
fluidRow(
column(3,style=list("padding-right: 3px;"),
textInput("in_track_name_2",label="Name",value="Offline",placeholder="Offline")
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_start_2",label="From",value=format(Sys.time(),"%Y-%m-%d"))
),
column(3,style=list("padding-right: 3px; padding-left: 3px;"),
dateInput("in_track_date_end_2",label="To",value=format(as.Date(Sys.time())+30,"%Y-%m-%d"))
),
column(3,style=list("padding-left: 3px;"),
colourpicker::colourInput("in_track_colour_2",label="Colour",
palette="limited",allowedCols=cols,value=cols[2])
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
colourpicker::colourInput("in_track_colour_available",label="Track colour (Available)",
palette="limited",allowedCols=cols,value=cols[length(cols)-1])
),
column(6,style=list("padding-left: 5px;"),
colourpicker::colourInput("in_track_colour_weekend",label="Track colour (Weekend)",
palette="limited",allowedCols=cols,value=cols[length(cols)])
)
),
tags$br(),
h3("Settings"),
selectInput("in_legend_position",label="Legend position",
choices=c("top","right","left","bottom"),selected="right",multiple=F),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_legend_justification",label="Legend justification",
choices=c("left","right"),selected="right",multiple=F)
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_legend_direction",label="Legend direction",
choices=c("vertical","horizontal"),selected="vertical",multiple=F)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_themefontsize",label="Theme font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_datefontsize",label="Date font size",value=2.5,step=0.1)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_monthfontsize",label="Month font size",value=8,step=0.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_legendfontsize",label="Legend font size",value=5,step=0.5)
)
),
tags$br(),
h3("Download"),
helpText("Width is automatically calculated based on the number of weeks. File type is only applicable to download and does not change preview."),
fluidRow(
column(6,style=list("padding-right: 5px;"),
numericInput("in_height","Height (cm)",step=0.5,value=5.5)
),
column(6,style=list("padding-left: 5px;"),
numericInput("in_width","Width (cm)",step=0.5,value=NA)
)
),
fluidRow(
column(6,style=list("padding-right: 5px;"),
selectInput("in_res","Res/DPI",choices=c("200","300","400","500"),selected="200")
),
column(6,style=list("padding-left: 5px;"),
selectInput("in_format","File type",choices=c("png","tiff","jpeg","pdf"),selected="png",multiple=FALSE,selectize=TRUE)
)
),
downloadButton("btn_downloadplot","Download Plot"),
tags$hr(),
helpText("2019 | RaukR")
),
mainPanel(
sliderInput("in_scale","Image preview scale",min=0.1,max=3,step=0.10,value=1),
helpText("Scale only controls preview here and does not affect download."),
tags$br(),
imageOutput("out_plot")
)
)
),
# SERVER -----------------------------------------------------------------------
server=function(input, output, session) {
store <- reactiveValues(week=NULL)
## RFN: fn_plot -----------------------------------------------------------
## core plotting function, returns a ggplot object
fn_plot <- reactive({
shiny::req(input$in_duration_date_start)
shiny::req(input$in_duration_date_end)
shiny::req(input$in_track_date_start_1)
shiny::req(input$in_track_date_end_1)
shiny::req(input$in_track_name_1)
shiny::req(input$in_track_colour_1)
shiny::req(input$in_track_date_start_2)
shiny::req(input$in_track_date_end_2)
shiny::req(input$in_track_name_2)
shiny::req(input$in_track_colour_2)
shiny::req(input$in_legend_position)
shiny::req(input$in_legend_justification)
shiny::req(input$in_legend_direction)
shiny::req(input$in_themefontsize)
shiny::req(input$in_datefontsize)
shiny::req(input$in_monthfontsize)
shiny::req(input$in_legendfontsize)
validate(need(input$in_track_name_1!=input$in_track_name_2,"Duplicate track names are not allowed."))
validate(need(as.Date(input$in_duration_date_start) < as.Date(input$in_duration_date_end),"End duration date must be later than start duration date."))
# prepare dates
dfr <- data.frame(date=seq(as.Date(input$in_duration_date_start),as.Date(input$in_duration_date_end),by=1))
dfr$day <- factor(strftime(dfr$date,format="%a"),levels=rev(c("Mon","Tue","Wed","Thu","Fri","Sat","Sun")))
dfr$week <- factor(strftime(dfr$date,format="%V"))
dfr$month <- strftime(dfr$date,format="%B")
dfr$month <- factor(dfr$month,levels=unique(dfr$month))
dfr$ddate <- factor(strftime(dfr$date,format="%d"))
#add tracks
dfr$track <- "Available"
dfr$track[dfr$day=="Sat" | dfr$day=="Sun"] <- "Weekend"
temp_start_date_1 <- as.Date(input$in_track_date_start_1)
temp_end_date_1 <- as.Date(input$in_track_date_end_1)
temp_track_name_1 <- input$in_track_name_1
temp_track_col_1 <- input$in_track_colour_1
validate(need(temp_start_date_1 < temp_end_date_1,"End track duration date must be later than start track duration date."))
dfr$track[dfr$date>=temp_start_date_1 & dfr$date<=temp_end_date_1] <- temp_track_name_1
temp_start_date_2 <- as.Date(input$in_track_date_start_2)
temp_end_date_2 <- as.Date(input$in_track_date_end_2)
temp_track_name_2 <- input$in_track_name_2
temp_track_col_2 <- input$in_track_colour_2
validate(need(temp_start_date_2 < temp_end_date_2,"End track duration date must be later than start track duration date."))
dfr$track[dfr$date>=temp_start_date_2 & dfr$date<=temp_end_date_2] <- temp_track_name_2
# create order factor
fc <- vector(mode="character")
if("Available" %in% unique(dfr$track)) fc <- c(fc,"Available")
fc <- c(fc,temp_track_name_1,temp_track_name_2)
if("Weekend" %in% unique(dfr$track)) fc <- c(fc,"Weekend")
dfr$track <- factor(dfr$track,levels=fc)
# prepare colours
all_cols <- c(input$in_track_colour_available,temp_track_col_1,temp_track_col_2,input$in_track_colour_weekend)
# plot
p <- ggplot(dfr,aes(x=week,y=day))+
geom_tile(aes(fill=track))+
geom_text(aes(label=ddate),size=input$in_datefontsize)+
scale_fill_manual(values=all_cols)+
facet_grid(~month,scales="free",space="free")+
labs(x="Week",y="")+
theme_bw(base_size=input$in_themefontsize)+
theme(legend.title=element_blank(),
panel.grid=element_blank(),
panel.border=element_blank(),
axis.ticks=element_blank(),
axis.title=element_text(colour="grey30"),
strip.background=element_blank(),
strip.text=element_text(size=input$in_monthfontsize),
legend.position=input$in_legend_position,
legend.justification=input$in_legend_justification,
legend.direction=input$in_legend_direction,
legend.text=element_text(size=input$in_legendfontsize),
legend.key.size=unit(0.3,"cm"),
legend.spacing.x=unit(0.2,"cm"))
# add number of weeks to reactive value
store$week <- length(levels(dfr$week))
return(p)
})
## OUT: out_plot ------------------------------------------------------------
## plots figure
output$out_plot <- renderImage({
shiny::req(fn_plot())
shiny::req(input$in_height)
shiny::req(input$in_res)
shiny::req(input$in_scale)
height <- as.numeric(input$in_height)
width <- as.numeric(input$in_width)
res <- as.numeric(input$in_res)
if(is.na(width)) {
width <- (store$week*1.2)
if(width < 4.5) width <- 4.5
}
p <- fn_plot()
ggsave("calendar_plot.png",p,height=height,width=width,units="cm",dpi=res)
return(list(src="calendar_plot.png",
contentType="image/png",
width=round(((width*res)/2.54)*input$in_scale,0),
height=round(((height*res)/2.54)*input$in_scale,0),
alt="calendar_plot"))
})
# FN: fn_downloadplotname ----------------------------------------------------
# creates filename for download plot
fn_downloadplotname <- function()
{
return(paste0("calendar_plot.",input$in_format))
}
## FN: fn_downloadplot -------------------------------------------------
## function to download plot
fn_downloadplot <- function(){
shiny::req(fn_plot())
shiny::req(input$in_height)
shiny::req(input$in_res)
shiny::req(input$in_scale)
height <- as.numeric(input$in_height)
width <- as.numeric(input$in_width)
res <- as.numeric(input$in_res)
format <- input$in_format
if(is.na(width)) width <- (store$week*1)+1
p <- fn_plot()
if(format=="pdf" | format=="svg"){
ggsave(fn_downloadplotname(),p,height=height,width=width,units="cm",dpi=res)
#embed_fonts(fn_downloadplotname())
}else{
ggsave(fn_downloadplotname(),p,height=height,width=width,units="cm",dpi=res)
}
}
## DHL: btn_downloadplot ----------------------------------------------------
## download handler for downloading plot
output$btn_downloadplot <- downloadHandler(
filename=fn_downloadplotname,
content=function(file) {
fn_downloadplot()
file.copy(fn_downloadplotname(),file,overwrite=T)
}
)
## OBS: tracks dates ---------------------------------------------------------
observe({
shiny::req(input$in_duration_date_start)
shiny::req(input$in_duration_date_end)
validate(need(as.Date(input$in_duration_date_start) < as.Date(input$in_duration_date_end),"End duration date must be later than start duration date."))
# create date intervals
dseq <- seq(as.Date(input$in_duration_date_start),as.Date(input$in_duration_date_end),by=1)
r1 <- unique(as.character(cut(dseq,breaks=3)))
updateDateInput(session,"in_track_date_start_1",label="From",value=as.Date(r1[1],"%Y-%m-%d"))
updateDateInput(session,"in_track_date_end_1",label="To",value=as.Date(r1[1+1],"%Y-%m-%d")-1)
updateDateInput(session,"in_track_date_start_2",label="From",value=as.Date(r1[2],"%Y-%m-%d"))
updateDateInput(session,"in_track_date_end_2",label="To",value=as.Date(r1[2+1],"%Y-%m-%d")-1)
})
})
For a variation of this app where number of tracks are user-defined, click here.
13 Nametagger app
Generate labels for clip-on nametags.
Topics covered
- UI layout using rows and columns
- Input and output widgets and reactivity
- Uploading and using the contents of a tabular text file
- Reading in tabular text using text field (shinyAce)
- Conditional settings panel
- Read in and plot a raster image (logo)
- Generate multiple output files
- Download zipped output files
- Validating inputs with custom error messages
The following R packages will be required for this app:
install.packages(c(ggplot2, shiny, shinythemes, shinyAce, showtext, curl))The final app will look something like below.
The idea is to create the labels suitable for A4 paper size and generate as many pages as needed. We wish to include one, two or three lines of text on each label. Also, we may choose to include a logo. We need input for label information, option to select logo, a preview plot and finally an option to download the images.
13.1 Creating the figure
We need to first write the code needed to take some input labels and generate a figure.
We have measured the labels to be 9cm x 5.5cm which means that 8 of them will fit on an A4 paper suitable for print. We have the function for generating the plot below.
# nametag_plot_page ------------------------------------------------------------
#' @title nametag_plot_page
#' @description Creates a page with 1-8 nametags.
#' @param dfr A data.frame. See details.
#' @param logo_right A raster logo to be placed on the right.
#' @param logo_right_scale A scale value. Typically 0.1-0.4.
#' @param logo_right_offset Logo offset from the edge. Around 0.01-0.1.
#' @param height Height of nametag in cm. Defaults to 5.5.
#' @param width Width of nametag in cm. Defaults to 9.
#' @details Argument 'dfr' is a data.frame that must have columns
#' label1, label1_x, label1_y, page, row and col.
#'
nametag_plot_page <- function(dfr,logo_right=NULL,logo_right_scale,logo_right_offset,height=5.5,width=9)
{
if(missing(dfr)) stop("Input argument 'dfr' missing.")
# check columns
req_cols <- c("label1","label1_sz","label1_x","label1_y","page","row","col")
chk_cols <- req_cols %in% colnames(dfr)
if(any(!chk_cols)) stop(paste0("Input data is missing columns: ",paste0(req_cols[!chk_cols],collapse=","),"."))
# add labels if any has length >0
p <- ggplot(dfr)
if(any(nchar(dfr$label1)!=0)) p <- p + geom_text(aes(x=label1_x,y=label1_y,label=label1),size=dfr$label1_sz[1],fontface="bold")
if("label2" %in% colnames(dfr)) {
req_cols <- c("label2_sz","label2_x","label2_y")
chk_cols <- req_cols %in% colnames(dfr)
if(any(!chk_cols)) stop(paste0("Input data contains column 'label2' but missing columns: ",paste0(req_cols[!chk_cols],collapse=","),"."))
if(any(nchar(dfr$label2)!=0)) p <- p + geom_text(aes(x=label2_x,y=label2_y,label=label2),size=dfr$label2_sz[1])
}
if("label3" %in% colnames(dfr)) {
req_cols <- c("label3_sz","label3_x","label3_y")
chk_cols <- req_cols %in% colnames(dfr)
if(any(!chk_cols)) stop(paste0("Input data contains column 'label2' but missing columns: ",paste0(req_cols[!chk_cols],collapse=","),"."))
if(any(nchar(dfr$label3)!=0)) p <- p + geom_text(aes(x=label3_x,y=label3_y,label=label3),size=dfr$label3_sz[1])
}
p <- p + scale_x_continuous(limits=c(0,1),expand=c(0,0))+
scale_y_continuous(limits=c(0,1),expand=c(0,0))+
labs(x=NULL,y=NULL)
w_scaler <- width/height
# check and add right logo
if(!is.null(logo_right)) {
# height scaling multiplier 1.6
logo_right_height <- ((logo_right_scale*nrow(logo_right))/ncol(logo_right))*w_scaler
# create logo positions
logo_right_x2 <- 1-logo_right_offset
logo_right_x1 <- logo_right_x2-logo_right_scale
logo_right_y2 <- 1-(logo_right_offset+(logo_right_offset*w_scaler))
logo_right_y1 <- round(logo_right_y2-logo_right_height,3)
# add right logo to plot
p <- p + annotation_raster(logo_right,xmin=logo_right_x1,xmax=logo_right_x2,ymin=logo_right_y1,ymax=logo_right_y2)
}
p <- p+
facet_grid(row~col)+
theme(axis.text=element_blank(),
axis.title=element_blank(),
panel.grid=element_blank(),
panel.spacing=unit(0,"lines"),
strip.background=element_blank(),
strip.text=element_blank(),
axis.ticks=element_blank(),
panel.background=element_rect(colour="grey75",fill="white",size=0.4,linetype="25"),
plot.background=element_blank(),
plot.margin=margin(0.1,0.1,0.1,0.1),
axis.ticks.length=unit(0,"pt"))
return(p)
}
# nametag ----------------------------------------------------------------------
#' @title nametag
#' @description Creates an A4 paper with 1-8 name tags.
#' @param dfr A data.frame with column 'label1'. Optionally 'label2' and 'label3'.
#' @param label1_sz Size of label on line 1.
#' @param label1_x X-axis coordinate for the label on line 1.
#' @param label1_y Y-axis coordinate for the label on line 1.
#' @param label2_sz Size of label on line 2.
#' @param label2_x X-axis coordinate for the label on line 2.
#' @param label2_y Y-axis coordinate for the label on line 2.
#' @param label3_sz Size of label on line 3.
#' @param label3_x X-axis coordinate for the label on line 3.
#' @param label3_y Y-axis coordinate for the label on line 3.
#' @param logo_right A raster logo for the right side.
#' @param logo_right_offset Logo offset from the edge. Around 0.01-0.1.
#' @param logo_right_scale A scale value. Typically 0.1-0.4.
#' @param filename A character denoting filename (prefix) of exported files.Defaults to 'nametag_' followed by page number and '.png'.
#' @param path A character path to the directory where file(s) are to be exported. Do not add / at the end of the path.
#' @param ftype Export file type. 'png' or 'pdf'. Defaults to 'png'.
#' @param height Height of nametag in cm. Defaults to 5.5.
#' @param width Width of nametag in cm. Defaults to 9.
#' @details A data.frame with one column 'label1' is the only mandatory input for this function.
#'
nametag <- function(dfr,label1_sz=8,label1_x=0.5,label1_y=0.54,
label2_sz=6.5,label2_x=0.5,label2_y=0.37,
label3_sz=6,label3_x=0.5,label3_y=0.22,
logo_right=NULL,logo_right_offset=0.04,logo_right_scale=0.2,
filename="nametag_",path=".",ftype="png",height=5.5,width=9)
{
if(missing(dfr)) stop("Input argument 'dfr' is missing.")
if(!is.data.frame(dfr)) stop("Input argument 'dfr' must be a data.frame.")
if(nrow(dfr)<1) stop("Input data must have at least 1 row.")
if(!("label1" %in% colnames(dfr))) stop("Input data must contain a column named 'label1'.")
if("label3" %in% colnames(dfr)) {if(!("label2" %in% colnames(dfr))) stop("Column 'label3' is present, but 'label2' is missing. If 'label3' is used, 'label2' must be present." )}
if(is.null(filename)) filename <- "nametag_"
# compute tags and pages
n <- nrow(dfr)
npages <- ceiling(n/8)
ntags <- npages*8
filler <- ntags-n
l1 <- c(dfr$label1,rep("",filler))
if("label2" %in% colnames(dfr)) l2 <- c(dfr$label2,rep("",filler))
if("label3" %in% colnames(dfr)) l3 <- c(dfr$label3,rep("",filler))
nn <- length(l1)
# create working df
dfw <- data.frame(label1=l1,label1_sz=label1_sz,
label1_x=rep(label1_x,nn),label1_y=rep(label1_y,nn),
stringsAsFactors=F)
if("label2" %in% colnames(dfr)) {
dfw$label2 <- l2
dfw$label2_sz <- label2_sz
dfw$label2_x <- rep(label2_x,nn)
dfw$label2_y <- rep(label2_y,nn)
}
if("label3" %in% colnames(dfr)) {
dfw$label3 <- l3
dfw$label3_sz <- label3_sz
dfw$label3_x <- rep(label3_x,nn)
dfw$label3_y <- rep(label3_y,nn)
}
dfw$page <- rep(1:npages,each=8)
dfw$row <- rep(rep(1:4,each=2),npages)
dfw$col <- rep(rep(c(1,2),4),npages)
dflist <- split(dfw,dfw$page)
ids <- names(dflist)
# creates plots and saves ggplot objects to a list
plist <- lapply(dflist,nametag_plot_page,logo_right,logo_right_scale,logo_right_offset,height=height,width=width)
# function to export images
efun <- function(p,id,height,width,filename,ftype) {
if(ftype=="png") {
fname <- paste0(path,"/",filename,id,".png")
ggsave(filename=fname,plot=p,height=height*4,width=width*2,units="cm",dpi=300,device="png")
}
if(ftype=="pdf") {
fname <- paste0(path,"/",filename,id,".pdf")
ggsave(filename=fname,plot=p,height=height*4*0.3937,width=width*2*0.3937,device="pdf")
}
}
# exports images
mapply(function(p,id,height,width,filename,ftype) efun(p,id,height,width,filename,ftype),plist,ids,height,width,filename,ftype)
}We will skip the details of the function as it is not exactly shiny related. There is a function called nametag() which generates the figures given appropriate input. It needs an input data.frame with at least one column named label1. We can test this out.
dfr <- data.frame(label1=c("Person A","Person B"),label2=c("Institution X","Institution Y"),stringsAsFactors = F)
nametag(dfr)This should have exported a png image to the working directory. nametag() also has an argument called logo_right to pass in a raster image which will be plotted as a logo on the top right side. nametag() also has numerous other arguments to adjust label positions, logo position, size justification etc. But, these arguments have reasonable defaults.
13.2 Building the app
Now that we have the function, we are ready to build the GUI around it. Let’s remind ourselves of the app layout.
13.2.1 UI
We want a three-column layout with a title panel on the top. The input widgets go on the left and the preview figure in the middle and the optional settings on the right. We can start by building up the structure using row and column functions.
shinyApp(
ui=fluidPage(
fixedRow(
column(12,
h1("Nametagger"),
fixedRow(
column(3
),
column(6
),
uiOutput("ui_settings")
)
)
)
),
server=function(input,output) {}
)
This code displays a blank page with the title. But, there is quite a bit going on here. We started with a responsive fluidPage container. We added a row and a column to hold everything. This column has the full width of 12. We added the h1 heading. Then we added a new row which contains 3 columns of widths 3,6 and 3 adding up to 12. The first column will hold the standard input widgets, second column will contain the preview plot and the last column is a hidden conditional UI which will hold the optional settings. Conditional UI defined using uiOutput() is hidden by default and is displayed only if a condition is true.
Next, we will populate the columns with widgets.
shinyApp(
ui=fluidPage(
fixedRow(
column(12,style="margin:15px;",
h1("Nametagger"),
fixedRow(
column(3,
fluidRow(
column(6,
selectInput("in_input","Input method",choices=c("Upload file","Paste text"),
selected="Paste text",multiple=FALSE)),
column(6,
selectInput("in_data_format","File format",choices=c("tsv","csv","csv2"),selected="csv",multiple=FALSE))
),
uiOutput("ui_input"),
helpText("Input must contain column names. 'label1' is a mandatory column. Optional columns are 'label2' and 'label3'.",style="display:inline;"),
selectInput("in_logo_right",label="Logo",c("None","NBIS Green","NBIS Blue","NBIS Orange","SciLifeLab Green","SciLifeLab Blue","SciLifeLab Orange","Elixir"),selected="None",multiple=FALSE),
downloadButton("btn_download","Download"),
checkboxInput("in_settings","Settings",value=FALSE),
tags$hr(),
helpText("2019 | NBIS")
),
column(6,
textOutput("out_pagecount"),
tags$br(),
imageOutput("out_plot")
),
uiOutput("ui_settings")
)
)
)),
server=function(input,output) {}
)
We have added input for file upload and paste text so that users can input labels either way. The tabular column delimiter can be user-defined. The actual input widget is hidden since it’s a conditional UI. This works only when further code is defined under server. A help text is added to explain the input format to the user. A download button to download the images. A settings checkbox to optionally display the advanced settings panel. The main column has text showing number of files generated and the preview plot.
Finally, we will add some custom styling to the columns. For example style="max-width:300px;border-radius:4px;background:#ebedef;" was added to the left input column to colour the background grey, rounded corners and limit responsive width to 300px.
shinyApp(
ui=fluidPage(
fixedRow(
column(12,style="margin:15px;",
h1("Nametagger"),
fixedRow(
column(3,style="max-width:300px;background:#ebedef;padding-top:15px;padding-bottom:15px;border-radius:4px;",
fluidRow(
column(6,style=list("padding-right:5px;"),
selectInput("in_input","Input method",choices=c("Upload file","Paste text"),
selected="Paste text",multiple=FALSE)),
column(6,style=list("padding-left: 5px;"),
selectInput("in_data_format","File format",choices=c("tsv","csv","csv2"),selected="csv",multiple=FALSE))
),
uiOutput("ui_input"),
helpText("Input must contain column names. 'label1' is a mandatory column. Optional columns are 'label2' and 'label3'.",style="display:inline;"),
selectInput("in_logo_right",label="Logo",c("None","NBIS Green","NBIS Blue","NBIS Orange","SciLifeLab Green","SciLifeLab Blue","SciLifeLab Orange","Elixir"),selected="None",multiple=FALSE),
downloadButton("btn_download","Download"),
checkboxInput("in_settings","Settings",value=FALSE),
tags$hr(),
helpText("2019 | NBIS")
),
column(6,style="max-width:450px;min-width:400px;padding-top:15px;padding-bottom:15px;border-radius:4px;",
textOutput("out_pagecount"),
tags$br(),
imageOutput("out_plot")
),
uiOutput("ui_settings")
)
)
)
),
server=function(input,output) {}
)
13.2.2 Server
Now let’s plan a bit on how to organise the server code. We can break it up into 8 blocks.
- Conditional UI for input
- Conditional UI for settings
- Reactive function for reading and processing input
- Reactive function for computing plotting parameters
- Plot output for plotting preview
- Text output for displaying number of files generated
- Function for downloading files
- A download handler for the download button
Here is a flow diagram roughly showing the sequence of steps. < > v denotes direction, () denotes optional input and [] denotes endpoint outputs.
1
v
[6] < 3 < (2)
v
4 > [7] < 8
v
[5]The plot preview block (5) and download block (7) depends on common reactive functions 3 and 4.
Let’s look at block 1. This is a conditional UI which is active only if the Input method (input$in_input) is not NULL. If input method is Upload file, then the UI for file upload is displayed, otherwise the input method is paste text (aceEditor).
## UI: ui_input --------------------------------------------------------------
## ui to select input type: upload or paste
output$ui_input <- renderUI({
validate(fn_validate(input$in_input))
if(input$in_input=="Upload file") {
fileInput("in_data","Upload a text file.",multiple=FALSE)
}else{
shinyAce::aceEditor("in_data","label1,label2\nJohn Doe,Uppsala University\nMary Jane,Stockholm University",mode="text",theme="textmate",readOnly=FALSE,height="150px",fontSize=12)
}
})The settings panel is displayed only if the Settings checkbox is displayed. This panel contains input widgets for adjusting the position and alignment of text and logo.
Let’s look at block 3 to process input data. It depends on input method and input data format. Depending on the input method (file upload/paste text), different processing steps are carried out eventually resulting in identical output data.frame structure. Upload file is read in using defined separator. For paste-text field, the input is split by separator and organised into a data.frame.
## FN: fn_input --------------------------------------------------------
## function to get input data
fn_input <- reactive({
validate(fn_validate(input$in_input))
validate(fn_validate(try(input$in_data),message1="Upload a file or paste text."))
validate(fn_validate(input$in_data_format))
fr <- ifelse(input$in_data_format=="tsv","\t",ifelse(input$in_data_format=="csv",",",";"))
if(input$in_input=="Upload file") {
dfr <- read.delim(input$in_data$datapath,header=TRUE,sep=fr,stringsAsFactors=F)
}
if(input$in_input=="Paste text") {
df1 <- as.data.frame(strsplit(as.character(unlist(strsplit(input$in_data,"\n"))),fr))
cnames <- as.character(df1[,1])
df1[,1] <- NULL
dfr <- as.data.frame(t(df1),stringsAsFactors=F)
colnames(dfr) <- cnames
rownames(dfr) <- 1:nrow(dfr)
}
colnames(dfr) <- tolower(colnames(dfr))
return(dfr)
})Let’s explore the block 4 that generates the plotting parameters. It depends on block 3 (fn_input()), settings checkbox (input$in_settings) and logo dropdown (input$in_logo_right).
It checks if columns label1,label2 and label3 are present in the input data.frame. Label size, x-position, y-position, logo scale and logo offset and set from input widgets or defaults are set. Depending on selected logo, the path is set and logo is read in. All these parameters are returned as a list.
The logos are placed under a directory labelled www in the app root.
## FN: fn_params ------------------------------------------------------------
## function to get plot params
fn_params <- reactive({
validate(fn_validate(fn_input()))
validate(fn_validate(input$in_settings))
validate(fn_validate(input$in_logo_right))
if("label1" %in% colnames(fn_input())) {l1 <- TRUE}else{l1 <- FALSE}
if("label2" %in% colnames(fn_input())) {l2 <- TRUE}else{l2 <- FALSE}
if("label3" %in% colnames(fn_input())) {l3 <- TRUE}else{l3 <- FALSE}
# if values are available, use them, else use defaults
if(is.null(input$in_label1_size)){l1s <- 8}else{l1s <- input$in_label1_size}
if(is.null(input$in_label1_x)){l1x <- 0.5}else{l1x <- input$in_label1_x}
if(is.null(input$in_label1_y)){l1y <- 0.54}else{l1y <- input$in_label1_y}
if(is.null(input$in_label2_size)){l2s <- 6.5}else{l2s <- input$in_label2_size}
if(is.null(input$in_label2_x)){l2x <- 0.5}else{l2x <- input$in_label2_x}
if(is.null(input$in_label2_y)){l2y <- 0.37}else{l2y <- input$in_label2_y}
if(is.null(input$in_label3_size)){l3s <- 6}else{l3s <- input$in_label3_size}
if(is.null(input$in_label3_x)){l3x <- 0.5}else{l3x <- input$in_label3_x}
if(is.null(input$in_label3_y)){l3y <- 0.22}else{l3y <- input$in_label3_y}
if(is.null(input$in_logo_right_offset)){lro <- 0.04}else{lro <- input$in_logo_right_offset}
if(is.null(input$in_logo_right_scale)){lrs <- 0.2}else{lrs <- input$in_logo_right_scale}
# logos
lr = switch(
input$in_logo_right,
"None"=NULL,
"NBIS Green"="./www/nbis_200_green.png",
"NBIS Blue"="./www/nbis_200_blue.png",
"NBIS Orange"="./www/nbis_200_orange.png",
"SciLifeLab Green"="./www/scilifelab_200_green.png",
"SciLifeLab Blue"="./www/scilifelab_200_blue.png",
"SciLifeLab Orange"="./www/scilifelab_200_orange.png",
"Elixir"="./www/elixir_200.png"
)
if(!is.null(lr)) {lri <- readPNG(lr)}else{lri <- NULL}
return(list(l1s=l1s,l1x=l1x,l1y=l1y,l2s=l2s,l2x=l2x,l2y=l2y,l3s=l3s,l3x=l3x,l3y=l3y,
lro=lro,lrs=lrs,lri=lri))
})Now, we have block 5 which creates the preview plot. It takes input from block 3 (fn_input()) and parameters from block 4 (fn_params()) which are passed to our nametag() function. Lastly, a list is returned with image path and render dimensions.
## OUT: out_plot ------------------------------------------------------------
## plots figure
output$out_plot <- renderImage({
validate(fn_validate(fn_input()))
validate(fn_validate(fn_params()))
p <- fn_params()
nametag(dfr=fn_input(),label1_sz=p$l1s,label1_x=p$l1x,label1_y=p$l1y,
label2_sz=p$l2s,label2_x=p$l2x,label2_y=p$l2y,
label3_sz=p$l3s,label3_x=p$l3x,label3_y=p$l3y,
logo_right=p$lri,logo_right_offset=p$lro,logo_right_scale=p$lrs)
return(list(src="nametag_1.png",contentType="image/png",
width=round(9*2*37.7*0.6,0),
height=round(5.5*4*37.7*0.6,0),
alt="nametagger_image"))
})Block 6 simply prints out the number of pages of images.
## OUT: out_pagecount -------------------------------------------------------
## prints general variables for debugging
output$out_pagecount <- renderText({
req(fn_input())
npages <- ceiling(nrow(fn_input())/8)
paste0("Showing 1 of ",npages," pages.")
})Here is block 7 and 8. Block 7 is the download function. This is very similar to the plotting block. The only real addition here is creation of the zip file collating all output PNGs. Individual images are then deleted. Block 8 below when triggered using the download button calls the fn_download() function.
## FN: fn_download -----------------------------------------------------------
## function to download a zipped file with images
fn_download <- function(){
validate(fn_validate(fn_input()))
validate(fn_validate(fn_params()))
p <- fn_params()
nametag(dfr=fn_input(),label1_sz=p$l1s,label1_x=p$l1x,label1_y=p$l1y,
label2_sz=p$l2s,label2_x=p$l2x,label2_y=p$l2y,
label3_sz=p$l3s,label3_x=p$l3x,label3_y=p$l3y,
logo_right=p$lri,logo_right_offset=p$lro,logo_right_scale=p$lrs,
path=".")
unlink("nametagger.zip")
zip("nametagger.zip",files=list.files()[grep("nametag_[0-9]+[.png$|.pdf$]",list.files())])
unlink(list.files()[grep("nametag_[0-9]+[.png$|.pdf$]",list.files())])
}
## DHL: btn_download ---------------------------------------------------------
## download handler for downloading zipped file
output$btn_download <- downloadHandler(
filename="nametagger.zip",
content=function(file) {
fn_download()
file.copy("nametagger.zip",file,overwrite=T)
}
)Now, we can add all of this to the server section. The final code looks like below.
library(ggplot2)
library(shinyAce)
shinyApp(
# UI -------------------------------------------------------------------------
ui=fluidPage(
fixedRow(
column(12,style="margin:15px;",
h1("Nametagger"),
fixedRow(
column(3,style="max-width:300px;background:#ebedef;padding-top:15px;padding-bottom:15px;border-radius:4px;",
fluidRow(
column(6,style=list("padding-right:5px;"),
selectInput("in_input","Input method",choices=c("Upload file","Paste text"),
selected="Paste text",multiple=FALSE)),
column(6,style=list("padding-left: 5px;"),
selectInput("in_data_format","File format",choices=c("tsv","csv","csv2"),selected="csv",multiple=FALSE))
),
uiOutput("ui_input"),
helpText("Input must contain column names. 'label1' is a mandatory column. Optional columns are 'label2' and 'label3'.",style="display:inline;"),
selectInput("in_logo_right",label="Logo",c("None","NBIS Green","NBIS Blue","NBIS Orange","SciLifeLab Green","SciLifeLab Blue","SciLifeLab Orange","Elixir"),selected="None",multiple=FALSE),
downloadButton("btn_download","Download"),
checkboxInput("in_settings","Settings",value=FALSE),
tags$hr(),
helpText("2019 | NBIS")
),
column(6,style="max-width:450px;min-width:400px;padding-top:15px;padding-bottom:15px;border-radius:4px;",
textOutput("out_pagecount"),
tags$br(),
imageOutput("out_plot")
),
uiOutput("ui_settings")
)
)
)
),
# SERVER -----------------------------------------------------------------------
server=function(input, output, session) {
## UI: ui_input --------------------------------------------------------------
## ui to select input type: upload or paste
output$ui_input <- renderUI({
validate(fn_validate(input$in_input))
if(input$in_input=="Upload file") {
fileInput("in_data","Upload a text file.",multiple=FALSE)
}else{
shinyAce::aceEditor("in_data","label1,label2\nJohn Doe,Uppsala University\nMary Jane,Stockholm University",mode="text",theme="textmate",readOnly=FALSE,height="150px",fontSize=12)
}
})
## UI: ui_settings -----------------------------------------------------------
## ui to display settings
output$ui_settings <- renderUI({
validate(fn_validate(input$in_settings))
if(input$in_settings) {
column(3,style="max-width:300px;border-radius:4px;background:#ebedef;",
h4("Settings"),
div(
tags$b("Label 1"),
fluidRow(
column(4,style=list("padding-right: 3px;"),
numericInput("in_label1_size",label="Size",value=8,min=4,max=12,step=0.5)
),
column(4,style=list("padding-right: 3px; padding-left: 3px;"),
numericInput("in_label1_x",label="X pos",value=0.5,min=0,max=1,step=0.02)
),
column(4,style=list("padding-left: 3px;"),
numericInput("in_label1_y",label="Y pos",value=0.54,min=0,max=1,step=0.02)
)
),
tags$b("Label 2"),
fluidRow(
column(4,style=list("padding-right: 3px;"),
numericInput("in_label2_size",label="Size",value=6.5,min=4,max=12,step=0.5)
),
column(4,style=list("padding-right: 3px; padding-left: 3px;"),
numericInput("in_label2_x",label="X pos",value=0.5,min=0,max=1,step=0.02)
),
column(4,style=list("padding-left: 3px;"),
numericInput("in_label2_y",label="Y pos",value=0.37,min=0,max=1,step=0.02)
)
),
tags$b("Label 3"),
fluidRow(
column(4,style=list("padding-right: 3px;"),
numericInput("in_label3_size",label="Size",value=6,min=4,max=12,step=0.5)
),
column(4,style=list("padding-right: 3px; padding-left: 3px;"),
numericInput("in_label3_x",label="X pos",value=0.5,min=0,max=1,step=0.02)
),
column(4,style=list("padding-left: 3px;"),
numericInput("in_label3_y",label="Y pos",value=0.22,min=0,max=1,step=0.02)
)
),
tags$b("Logo"),
fluidRow(
column(6,style=list("padding-right: 3px;"),
numericInput("in_logo_right_offset",label="Offset",value=0.02,min=0,max=0.2,step=0.01)
),
column(6,style=list("padding-left: 3px;"),
numericInput("in_logo_right_scale",label="Width",value=0.2,min=0.1,max=0.6,step=0.01)
)
)
)
)
}
})
## FN: fn_input --------------------------------------------------------
## function to get input data
fn_input <- reactive({
validate(fn_validate(input$in_input))
validate(fn_validate(try(input$in_data),message1="Upload a file or paste text."))
validate(fn_validate(input$in_data_format))
fr <- ifelse(input$in_data_format=="tsv","\t",ifelse(input$in_data_format=="csv",",",";"))
if(input$in_input=="Upload file") {
dfr <- read.delim(input$in_data$datapath,header=TRUE,sep=fr,stringsAsFactors=F)
}
if(input$in_input=="Paste text") {
df1 <- as.data.frame(strsplit(as.character(unlist(strsplit(input$in_data,"\n"))),fr))
cnames <- as.character(df1[,1])
df1[,1] <- NULL
dfr <- as.data.frame(t(df1),stringsAsFactors=F)
colnames(dfr) <- cnames
rownames(dfr) <- 1:nrow(dfr)
}
colnames(dfr) <- tolower(colnames(dfr))
return(dfr)
})
## FN: fn_params ------------------------------------------------------------
## function to get plot params
fn_params <- reactive({
validate(fn_validate(fn_input()))
validate(fn_validate(input$in_settings))
validate(fn_validate(input$in_logo_right))
if("label1" %in% colnames(fn_input())) {l1 <- TRUE}else{l1 <- FALSE}
if("label2" %in% colnames(fn_input())) {l2 <- TRUE}else{l2 <- FALSE}
if("label3" %in% colnames(fn_input())) {l3 <- TRUE}else{l3 <- FALSE}
# if values are available, use them, else use defaults
if(is.null(input$in_label1_size)){l1s <- 8}else{l1s <- input$in_label1_size}
if(is.null(input$in_label1_x)){l1x <- 0.5}else{l1x <- input$in_label1_x}
if(is.null(input$in_label1_y)){l1y <- 0.54}else{l1y <- input$in_label1_y}
if(is.null(input$in_label2_size)){l2s <- 6.5}else{l2s <- input$in_label2_size}
if(is.null(input$in_label2_x)){l2x <- 0.5}else{l2x <- input$in_label2_x}
if(is.null(input$in_label2_y)){l2y <- 0.37}else{l2y <- input$in_label2_y}
if(is.null(input$in_label3_size)){l3s <- 6}else{l3s <- input$in_label3_size}
if(is.null(input$in_label3_x)){l3x <- 0.5}else{l3x <- input$in_label3_x}
if(is.null(input$in_label3_y)){l3y <- 0.22}else{l3y <- input$in_label3_y}
if(is.null(input$in_logo_right_offset)){lro <- 0.04}else{lro <- input$in_logo_right_offset}
if(is.null(input$in_logo_right_scale)){lrs <- 0.2}else{lrs <- input$in_logo_right_scale}
# logos
lr = switch(
input$in_logo_right,
"None"=NULL,
"NBIS Green"="./www/nbis_200_green.png",
"NBIS Blue"="./www/nbis_200_blue.png",
"NBIS Orange"="./www/nbis_200_orange.png",
"SciLifeLab Green"="./www/scilifelab_200_green.png",
"SciLifeLab Blue"="./www/scilifelab_200_blue.png",
"SciLifeLab Orange"="./www/scilifelab_200_orange.png",
"Elixir"="./www/elixir_200.png"
)
if(!is.null(lr)) {lri <- readPNG(lr)}else{lri <- NULL}
return(list(l1s=l1s,l1x=l1x,l1y=l1y,l2s=l2s,l2x=l2x,l2y=l2y,l3s=l3s,l3x=l3x,l3y=l3y,
lro=lro,lrs=lrs,lri=lri))
})
## OUT: out_plot ------------------------------------------------------------
## plots figure
output$out_plot <- renderImage({
validate(fn_validate(fn_input()))
validate(fn_validate(fn_params()))
p <- fn_params()
nametag(dfr=fn_input(),label1_sz=p$l1s,label1_x=p$l1x,label1_y=p$l1y,
label2_sz=p$l2s,label2_x=p$l2x,label2_y=p$l2y,
label3_sz=p$l3s,label3_x=p$l3x,label3_y=p$l3y,
logo_right=p$lri,logo_right_offset=p$lro,logo_right_scale=p$lrs)
return(list(src="nametag_1.png",contentType="image/png",
width=round(9*2*37.7*0.6,0),
height=round(5.5*4*37.7*0.6,0),
alt="nametagger_image"))
})
## OUT: out_pagecount -------------------------------------------------------
## prints general variables for debugging
output$out_pagecount <- renderText({
req(fn_input())
npages <- ceiling(nrow(fn_input())/8)
paste0("Showing 1 of ",npages," pages.")
})
## FN: fn_download -----------------------------------------------------------
## function to download a zipped file with images
fn_download <- function(){
validate(fn_validate(fn_input()))
validate(fn_validate(fn_params()))
p <- fn_params()
nametag(dfr=fn_input(),label1_sz=p$l1s,label1_x=p$l1x,label1_y=p$l1y,
label2_sz=p$l2s,label2_x=p$l2x,label2_y=p$l2y,
label3_sz=p$l3s,label3_x=p$l3x,label3_y=p$l3y,
logo_right=p$lri,logo_right_offset=p$lro,logo_right_scale=p$lrs,
path=".")
unlink("nametagger.zip")
zip("nametagger.zip",files=list.files()[grep("nametag_[0-9]+[.png$|.pdf$]",list.files())])
unlink(list.files()[grep("nametag_[0-9]+[.png$|.pdf$]",list.files())])
}
## DHL: btn_download ---------------------------------------------------------
## download handler for downloading zipped file
output$btn_download <- downloadHandler(
filename="nametagger.zip",
content=function(file) {
fn_download()
file.copy("nametagger.zip",file,overwrite=T)
}
)
}
)
For a variation of this app with left and right logos and custom fonts, click here.
Hopefully, this has not been too overwhelming. Shiny app code may look like a jungle on the first look, but it is easier to understand what is happening by breaking it apart into smaller chunks and creating a flow diagram of how functions are connected. It is crucial to plan out the structure of your app well in advanced as it is easy to get lost and confused. Remember to name functions and variables sensibly. Use text output widgets and/or print statements in the code to keep track of internal variable values during run-time. Go forth and build awesome apps!
14 Session info
## R version 4.0.2 (2020-06-22)
## Platform: x86_64-conda_cos6-linux-gnu (64-bit)
## Running under: Ubuntu 20.04.2 LTS
##
## Matrix products: default
## BLAS/LAPACK: /home/roy/miniconda3/envs/r-4.0/lib/libopenblasp-r0.3.10.so
##
## locale:
## [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C LC_TIME=en_GB.UTF-8
## [4] LC_COLLATE=en_GB.UTF-8 LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8
## [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C LC_ADDRESS=C
## [10] LC_TELEPHONE=C LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] shinythemes_1.2.0 RNASeqPower_1.30.0 ggplot2_3.3.3 shiny_1.6.0
## [5] fontawesome_0.2.1 captioner_2.2.3 bookdown_0.22 knitr_1.33
##
## loaded via a namespace (and not attached):
## [1] tidyselect_1.1.1 xfun_0.23 bslib_0.2.5.1 purrr_0.3.4
## [5] colorspace_2.0-1 vctrs_0.3.8 generics_0.1.0 htmltools_0.5.1.1
## [9] yaml_2.2.1 utf8_1.2.1 rlang_0.4.11 jquerylib_0.1.4
## [13] later_1.2.0 pillar_1.6.1 glue_1.4.2 withr_2.4.2
## [17] DBI_1.1.1 lifecycle_1.0.0 stringr_1.4.0 munsell_0.5.0
## [21] gtable_0.3.0 evaluate_0.14 callr_3.7.0 fastmap_1.1.0
## [25] httpuv_1.6.1 ps_1.6.0 fansi_0.5.0 highr_0.9
## [29] Rcpp_1.0.6 xtable_1.8-4 promises_1.2.0.1 scales_1.1.1
## [33] cachem_1.0.5 webshot_0.5.2 jsonlite_1.7.2 farver_2.1.0
## [37] mime_0.10 digest_0.6.27 stringi_1.6.2 processx_3.5.2
## [41] dplyr_1.0.6 grid_4.0.2 tools_4.0.2 magrittr_2.0.1
## [45] sass_0.4.0 tibble_3.1.2 crayon_1.4.1 pkgconfig_2.0.3
## [49] ellipsis_0.3.2 assertthat_0.2.1 rmarkdown_2.8 R6_2.5.0
## [53] compiler_4.0.2Built on: 08-Jun-2021 at 15:27:04.
2021 • SciLifeLab • NBIS • RaukR
