Introduction to Shiny, Session 2

.title[
# Introduction to Shiny, Session 2
]
.subtitle[
## <html><br />
<br />
<hr color='#EB811B' size=1px width=796px><br />
</html><br />
Bioinformatics Resource Center - Rockefeller University
]
.author[
### <a href="http://rockefelleruniversity.github.io/RU_course_template/" class="uri">http://rockefelleruniversity.github.io/RU_course_template/</a>
]
.author[
### <a href="mailto:brc@rockefeller.edu" class="email">brc@rockefeller.edu</a>
]

---

##  Recap

- Session 1 - 
    + Shiny basics
    + app layouts 
    + app theming
    
  - **Session 2** -
    + Input types 
    + basic reactivity 
    + interactive plots 
    + downloading files from apps
    
  - Session 3 - 
    + uploading files and conditional UIs 
    + observers
    + publishing apps
    + basic debugging

---
class: inverse, center, middle

# Session 2 - Input types and reactivity

---

## Inputs

Inputs are UI elements that take some kind of information from the user that we can then use in the server function of the app.

In the server function, there will be an list called 'input' available that contains all of the inputs in the app.

Typically an input will have two required arguments:
  - inputId - this is a text string that will be linked to the 'input' list in the server function
    +  if `inputID = "user_info"`, then in the server there will be an element in the 'input' list called *input$user_info* that is available for reactive contexts. More on this later.
    + depending on the input type, the element put into the list will differ (string, number, date, a vector of these, etc)
    
  - label - the text that is displayed above the input element
    
    
---

## Inputs - text boxes

``` r
ui = page_fluid(
  
  textInput(inputId = "text_box", label = "Experiment name:"),
  textAreaInput(inputId = "big_text_box", "Describe your experiment:", rows = 3)
)
```

``` r
shinyApp(ui = ui, server = function(input, output){})
```

---

## Inputs - dropdowns

``` r
ui <- page_fluid(
  selectInput("dropdown", "Select a gene:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K")),
  
  selectInput("dropdown", "Select a gene from this really wide box!", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"),
              width = "100%"),
  
  selectInput("dropdown2", "Select more than one gene if you want:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"), 
              selected = c("PTEN", "HRAS"), multiple = T),
)
```

---

## Inputs - dropdowns

``` r
shinyApp(ui = ui, server = function(input, output){})
```

---

## Inputs - selection of choices

``` r
ui <- page_fluid(

"If you want the user to only select one option from a list, radioButtons work well",
  radioButtons("radio", "Select only one gene from the radio selections:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"), 
              selected = "HRAS"),
  
  "To allow the user to select multiple options, use checkboxGroupInput",
  checkboxGroupInput("checkbox_group", "Check one or more boxes next to a gene:", 
                     choices = c("TP53", "PTEN", "HRAS", "PI3K")),

"OR if you only want a binary yes/no, you can use checkboxInput",
  checkboxInput("checkbox", "Do you agree to the terms and conditions?"),
)
```

---

## Inputs - selection of choices

``` r
shinyApp(ui = ui, server = function(input, output){})
```

---

## Inputs - numeric

``` r
ui <- page_fluid(
  
  numericInput("numeric", "Number of samples", value = 1, min = 0, max = 100),
  
  sliderInput("num_slider", "Number of samples", value = 10, min = 0, max = 25),
  
  sliderInput("num_slider", "Range of sample numbers", value = c(10,20), min = 0, max = 25)
)
```

``` r
shinyApp(ui = ui, server = function(input, output){})
```

---

## Inputs - dates

``` r
ui <- page_fluid(
  dateInput("date", "Choose a date:"),
  
  dateRangeInput("date_range", "Choose a range of dates:")
)
```

``` r
shinyApp(ui = ui, server = function(input, output){})
```

---

## Inputs - action buttons

To have the user trigger downstream events by clicking a button, we can use an *actionButton*

``` r
ui <- page_fluid(
  actionButton("button", "Click me!"),
)
```

``` r
shinyApp(ui = ui, server = function(input, output){})
```
<img src="imgs/actionButton.png"height="100" width="250">

---

# Reactivity

---

## Reactive use of inputs

We have seen many types of inputs, but these would be pointless if we can't detect when they change or know what is selected.

Every input returns some kind of value, and changes in this value can be recorded by shiny. This introduces the concept of 'reactivity', the key element of shiny that makes apps useful and cool.

**We need to use reactive elements (eg an input value) in reactive contexts.** These reactive contexts are designed to listen for changes in the reactive dependencies in contains, and then communicate those changes to the UI.

So far the *render_* functions are the only reactive contexts we have learned about.

---

## Using reactivity

This is an example of simple reactivity, we change the gene, and the *gene_text* output detects this and displays the new gene name, which is the value of *input$gene*.

Note that *input$gene* must be within a reactive context in the server, which in this case is the *renderText* function.

``` r
ui <- page_fluid(
  radioButtons("gene", "Select only one gene from the radio selections:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"), 
              selected = "HRAS"),
  
  textOutput("gene_text")
)

server = function(input, output){
   output$gene_text <- renderText({
     paste0("We will study ", input$gene)
   })
 }
```

---

## Using reactivity

``` r
shinyApp(ui = ui, server = server)
```

<img src="imgs/pi3k.png"height="200" width="250">
]

---

## Using reactivity

``` r
shinyApp(ui = ui, server = server)
```

<img src="imgs/pi3k.png"height="200" width="250">
]

Reactive Graph:

---

## Reactive contexts

To reiterate, a reactive value can only be used in certain contexts.  For example, we get an error if we just try and print *input$gene* without putting it inside a reactive handler, such as *renderText*.

We will learn more about other reactive contexts later on.

``` r
ui <- page_fluid(
  radioButtons("gene", "Select only one gene from the radio selections:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"), 
              selected = "HRAS"))

server = function(input, output){
    print(paste0("We will study ", input$gene))
 }
```

``` r
shinyApp(ui = ui, server = server)
```

---

## Reactivity

Here is a slightly more complicated reactive situation where we have more than one input being used by an output, including a calculation involving two separate inputs.

``` r
ui <- page_fluid(
  radioButtons("gene", "Select only one gene from the radio selections:", 
              choices = c("TP53", "PTEN", "HRAS", "PI3K"), 
              selected = "HRAS"),
  
  sliderInput("conditions", "Number of samples", value = 10, min = 0, max = 25),
  
  numericInput("replicates", "Number of replicates", value = 1, min = 0, max = 100),
  
  textOutput("study_summary")
)

server = function(input, output){
   output$study_summary <- renderText({
     paste0("We will study ", input$gene, " and there will be ", input$conditions*input$replicates, " total samples.")
   })
 }
```

---

## Reactivity

``` r
shinyApp(ui = ui, server = server)
```

<img src="imgs/app_gene2.png"height="400" width="400">
---

## Reactivity
 This sets up a reactive graph where we have one output, *output$study_summary*, that depends on three inputs, including a calculation that involves the two numeric inputs.

---

## Reactivity

While this code will work, it is not the most efficient way to write this app. Because *output$study_summary* depends directly on the sample calculation, it will re-run it any time that **any one of these inputs change**, even if it is not involved in that calculation, such as *input$gene*.

This is okay for this situation, but if a more intensive calculation was being done, this would slow the app considerably.

---

## Reactive expressions

We will introduce a new shiny function that helps to make reactivity much more efficient.

That would be the *reactive* function, which takes a chunk of R code that will contain other reactive values (eg inputs) and returns a value like a regular R function.

To use the result, use the name of the expression followed by parenthesis, e.g. total_samples() below. It will return the object made by the last line, or you can use the *return* function, just like any other function in R.

``` r
server = function(input, output){
  
  total_samples <- reactive({
*   input$conditions*input$replicates
  }) 
  
   output$study_summary <- renderText({
     paste0("We will study ", input$gene, " and there will be ", total_samples(), " total samples.")
   })
}
```

``` r
shinyApp(ui = ui, server = server)
```

---

## Reactive expressions

Looking at the reactive graph, *output$study_summary* calls *total_samples()*, which takes dependencies on the two numeric inputs to make this calculation.

---

## Reactive expressions

- It usually depends on one or more reactive inputs
  
  - The output of the function is **cached** and is available for use within the app.
  
  - If a dependency changes, the reactive is invalidated and **will only be computed the next time it is called**.
  
  - If the reactive is called in the app and the value of that reactive has not changed, this value is **retrieved without any further computation**. 
]

---

## Reactive expressions

*total_samples()* is only calculated if *input$conditions* or *input$replicates* has changed since the last time this text was rendered.

If the *input$gene* is changed, then the cached value of *total_samples()* is used and it does not need to be re-calculated.

---
## Lazy evaluation

A key aspect of reactivity in Shiny is that evaluation in a shiny app is generally 'lazy'.

This means that any code in the app is only evaluated when it is needed, typically when a dependency changes. This is different than a typical R script that runs from top to bottom.

---

## Lazy evaluation and output typos

Quick tip - the lazy evaluation of Shiny is great for making apps efficient, but can sometimes cause confusion with bugs.

In the following very simple app, it will run with no errors, but the table will never appear. This is because I misspelled 'all_data' to be 'al_data' in the server function.

Misspelled variables usually cause errors in R, but here because Shiny is never instructed to look for *output$al_data*, it doesn't know or care that is isn't spelled correctly. Typos in outputs are oftne a good place to start if an app isnt behaving as you want.

``` r
# read in table
de_table <- read.csv("data/shP53_vs_control_DEG.csv")
de_table$negLog10_pval <- -log10(de_table$pvalue)

ui <- page_fluid(
*  dataTableOutput(outputId = "all_data")
)

server <- function(input, output){
* output$al_data = renderDataTable(datatable(de_table_in()))
}

shinyApp(ui = ui, server = server)
```

---
## Add reactivity to RNAseq app

We will eventually add reactivity to our RNAseq analysis app, which currently displays some nice information, but does not respond to the user in any way (current app is below).

We will go through some useful modifications with small example apps before adding them to the app we built in Session 1. The previous app state is saved as a Rscript in the 'data' folder called 'app_endSess1.R'.

---
## Add the filter to the DE table - UI

We can add numeric inputs for the user to add cutoff values for adjusted pvalue and log2 fold change.

Here we use those input values from the user and filter the table:

``` r
# read in table
de_table <- read.csv("data/shP53_vs_control_DEG.csv")
de_table$negLog10_pval <- -log10(de_table$pvalue)

ui <- page_fluid(
* numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005),
* numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1),
  
  dataTableOutput(outputId = "de_data")
)

server = function(input, output){ 
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))

output$de_data = renderDataTable(datatable(filtered_de()))
}
```

---
## Add the filter to the DE table - server

In the server function we will add a reactive expression that will take these values and make a filtered version of the differential expression table.

We then use this table in the *renderDataTable* function where we render the table.

``` r
# read in table
de_table <- read.csv("data/shP53_vs_control_DEG.csv")
de_table$negLog10_pval <- -log10(de_table$pvalue)

ui <- page_fluid(
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
  
  dataTableOutput(outputId = "de_data")
)

server = function(input, output){ 
* filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))

* output$de_data = renderDataTable(datatable(filtered_de()))
}
```

---
## Add a filter to the DE table - launch

``` r
shinyApp(ui = ui, server = server)
```

---
## Value boxes + filter - UI

Value boxes can be a nice way to let the user know of important numbers that are changing. Here we add *textOutput* function calls to the 'value' argument to dynamically sense when the user changes the pdj or log2FC inputs.

This will be paired with a *renderText* function in the server to use the inputs.

``` r
ui <- page_fluid(
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
  
  layout_columns(
*     value_box(title = "Number of genes that go up:", value = textOutput("num_up"), showcase = icon("arrow-up"), theme = value_box_theme(bg = "#22b430")),
*     value_box(title = "Number of genes that go down:", value = textOutput("num_down"), showcase = icon("arrow-down"), theme = value_box_theme(bg ="#c34020" )),
      col_widths = c(2,2)))

server = function(input, output){ 
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))
  
  num_up_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange > 0 & padj < 0.05) %>% nrow) 
  num_down_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange < 0 & padj < 0.05) %>% nrow) 
  output$num_up <- renderText(num_up_genes())
  output$num_down <- renderText(num_down_genes()) 
}
```

---
## Value boxes + filter - UI

In the server we make reactives that return the number of genes that go up or down, and these reactives are used by *renderText*, which is paired with the *textOutput* in the UI.

These reactives contain both the padj and log2 fold change inputs, so whenever these inputs are modified, the reactive and the value displayed in the value box will change.

``` r
ui <- page_fluid(
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
  
  layout_columns(
      value_box(title = "Number of genes that go up:", value = textOutput("num_up"), showcase = icon("arrow-up"), theme = value_box_theme(bg = "#22b430")), 
      value_box(title = "Number of genes that go down:", value = textOutput("num_down"), showcase = icon("arrow-down"), theme = value_box_theme(bg ="#c34020" )), 
      col_widths = c(2,2)))

server = function(input, output){ 
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))
  
* num_up_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange > 0 & padj < 0.05) %>% nrow)
* num_down_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange < 0 & padj < 0.05) %>% nrow)
* output$num_up <- renderText(num_up_genes())
* output$num_down <- renderText(num_down_genes())
}
```

---
## Value boxes + filter - UI - launch

In the app, we see that the numbers in the box react when we change the log2FC input.

``` r
shinyApp(ui = ui, server = server)
```

---
## Control filtering with a button

You'll notice the table is reacting in real time as we change the values. Reactive contexts like *reactive* or *render_* functions invalidate whenever any reactive element it contains is changed. This might be what you want, but a cleaner solution could be to wait to apply the filter until the user explicitly wants to.

We can to this by pairing an *actionButton* with a new function, *bindEvent*. This modifies the reactive expression and instead of updating when any reactive value it depends on changes, it will only update based on a specific event (e.g. when a button is pressed)

.pull-right[
Note: there is another function called *eventReactive* that was used in older versions of shiny, so you might see this in forums and tutorials. It still works, and is essentially the same as reactive + bindEvent with different implementation.
]
---
## Add button to app UI

The *actionButton* function is added to the UI object.

In the server function, we modify the reactive expression to be dependent on this button. We wrap the reactive (or add using a pipe) in the *bindEvent* function and include the dependency *input$de_filter* as the first argument.

``` r
ui <- page_fluid(theme = custom_theme,
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
* actionButton("de_filter", "Apply filter"),
  card(card_header("Filtered data"), dataTableOutput(outputId = "de_data"), min_height = "750px")
)

server = function(input, output){ 
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))  %>%
*   bindEvent(input$de_filter)

output$de_data = renderDataTable(datatable(filtered_de())) 
}
```

---
## Launch app with button

You'll notice that the table doesn't appear initially, and only appears once we click the button. By default, *bindEvent* does not run when a button still has a value of 0 (meaning it hasn't been clicked).

``` r
shinyApp(ui = ui, server = server)
```

---
## Initialize table before first button click

The *bindEvent* function has an argument 'ignoreNULL' that tells it whether to not update the reactive expression when the value is NULL, or 0 for an actionButton. We can turn this setting off and the reactive will update when the button initializes and has a value of 0.

``` r
ui <- page_fluid(theme = custom_theme,
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
  actionButton("de_filter", "Apply filter"), 
  card(card_header("Filtered data"), dataTableOutput(outputId = "de_data"), min_height = "750px")
)

server = function(input, output){ 
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))  %>%
*   bindEvent(input$de_filter, ignoreNULL = FALSE)

output$de_data = renderDataTable(datatable(filtered_de())) 
}
```

---
## Initialize table before first button click

``` r
shinyApp(ui = ui, server = server)
```
<img src="imgs/button_ignoreNULL_resolved.png"height="450" width="550">

---
## Add tabs to a card

Now we have two tables, filtered and unfiltered. Which do we show to the user? both? Both might be overwhelming, but the user might want access the whole dataset after filtering. Oftentimes having multiple tabs within a card can be a nice clean way to do this.

To do this, we change the card that we want to contain tabs to use the function *navset_card_tab*. This works just like the *page_navbar* function, where multiple *nav_panel* function calls within *navset_card_tab* results in individual tabs.

There are a few other options for how the tabs will look, outlined [here.](https://rstudio.github.io/bslib/reference/navset.html)

---

## Add tabs to a card

In the UI, the *navset_card_tab* function is added with two *nav_panel* objects, one for the full data set and one for the fitlered data. We then need to add a corresponding render function for the second tab containing the full table.

``` r
ui <- page_fluid(theme = custom_theme,
  numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005), 
  numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 0, min = 0, step = 0.1), 
  actionButton("de_filter", "Apply filter"), 
* navset_card_tab(title = "DE result tables", height = "750px",
*                 nav_panel(card_header("DEGs"), dataTableOutput(outputId = "de_data")),
*                 nav_panel(card_header("All genes"), dataTableOutput(outputId = "all_data"))),
)

server = function(input, output){ 
* output$all_data = renderDataTable(datatable(de_table))
  
  filtered_de <- reactive(de_table %>% dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter))  %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE)

output$de_data = renderDataTable(datatable(filtered_de())) 
}
```

---
## Launch app with tabs

``` r
shinyApp(ui = ui, server = server)
```

---
## Color the DE genes in plots - UI

We can also make the plots responsive to the cutoffs by coloring the points that exceed the thresholds.

Most of the work here will be done with server logic, but in the simple app below we include the filters, a button, and MA plot to the UI object.

---
## Color the DE genes in plots - server

``` r
server = function(input, output){ 
* ma_plot_reac <- reactive({
*   de_table %>%
*     dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>%
*     ggplot(aes(x = baseMean, y = log2FoldChange, color = sig)) + geom_point() + scale_x_log10() +
*       scale_color_manual(name = "DE status", values = c("red", "grey")) +
*       xlab("baseMean (log scale)") + theme_bw()
  })  %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE) 
  
    output$ma_plot = renderPlot(ma_plot_reac())
}
```

---
## Color the DE genes in plots - server

- Since the plots will now be dependent on the filtering inputs, it's good practice to make the ggplot objects reactive expressions
- Add the inputs to the newly created *reactive* function that creates the ggplot object
- **Wrap with or add a pipe to a *bindEvent* function so that the *reactive* function with the plot takes a dependency on the button**

``` r
server = function(input, output){ 
  ma_plot_reac <- reactive({ 
    de_table %>% 
      dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>% 
      ggplot(aes(x = baseMean, y = log2FoldChange, color = sig)) + geom_point() + scale_x_log10() +
        scale_color_manual(name = "DE status", values = c("red", "grey")) + #
        xlab("baseMean (log scale)") + theme_bw() 
  })  %>%
*   bindEvent(input$de_filter, ignoreNULL = FALSE)
  
    output$ma_plot = renderPlot(ma_plot_reac()) 
}
```

---
## Color the DE genes in plots - server

- Since the plots will now be dependent on the filtering inputs, it's good practice to make the ggplot objects reactive expressions
- Filter the table using the inputs in the newly created *reactive* function before making the plot 
- Wrap with or add a pipe to a *bindEvent* function so that the *reactive* function with the plot takes a dependency on the button
- **Use the reactive expression in the render function**

``` r
server = function(input, output){ 
  ma_plot_reac <- reactive({ 
    de_table %>% 
      dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>% 
      ggplot(aes(x = baseMean, y = log2FoldChange, color = sig)) + geom_point() + scale_x_log10() +
        scale_color_manual(name = "DE status", values = c("red", "grey")) + 
        xlab("baseMean (log scale)") + theme_bw() 
  })  %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE) 
  
*   output$ma_plot = renderPlot(ma_plot_reac())
}
```

---
## Launch app with reactive plots

``` r
shinyApp(ui = ui, server = server)
```

<img src="imgs/color_filter_small.png"height="400" width="900">
 
---

## Add reactivity to RNAseq app

Now we can use some of these inputs and reactivity to improve our RNAseq analysis app. As a reminder, below is the UI of the app we left off with.

In the app we built in Session 1, we have a blank sidebar and this would be a good place to add the pvalue and log2FC filters that the tables and plots will depend on.

---
## Add filters and tabs to main app UI

Recap of changes to UI:

- In the sidebar, add inputs for padj and log2FC filter values and the button to control when those changes happen
  - Make a *navset_card_tab* that will have two tabs, one for the filtered data based on the user inputs and another showing the entire data set.

---
## Add filters and tabs to main app server

Recap of changes to server:

- Add a reactive expression that returns the filtered table and then use that table as an output in the *renderDataTable* function.
  - Add an output and *renderDataTable* function for the whole data set.
  - Convert the ggplot objects into reactive expressions and add a column to the data indicating whether a gene should be colored as passing filters from user. These reactives are used in the *renderPlot* functions.
  - Add *bindEvent* function calls to the filtered table and ggplot reative expressions so they will update when the user changes the filters.

``` r
server = function(input, output) {
  output$all_data = renderDataTable({ # >>>>>>>>>>>>>>>
    datatable(de_table,
              selection = "none",
              filter = 'top') %>%
      formatRound(columns = c("baseMean", "log2FoldChange", "lfcSE", "stat"), digits = 3) %>%
      formatSignif(columns = c("pvalue", "padj"), digits = 3)
  })
  
  filtered_de <- reactive({
    de_table %>%
      dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter) # >>>>>>>>>>>>>>>
  }) %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE) # >>>>>>>>>>>>>>>

output$de_data = renderDataTable({
    datatable(filtered_de(), # >>>>>>>>>>>>>>>
              selection = "none",
              filter = 'top') %>%
      formatRound(columns = c("baseMean", "log2FoldChange", "lfcSE", "stat"), digits = 3) %>%
      formatSignif(columns = c("pvalue", "padj"), digits = 3)
  })
  
  
  ma_plot_reac <- reactive({
    de_table %>%
      dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>%  # >>>>>>>>>>>>>>>
      ggplot(aes(x = baseMean, y = log2FoldChange, color = sig)) + geom_point() + scale_x_log10() +
      scale_color_manual(name = "DE status", values = c("red", "grey")) +
      xlab("baseMean (log scale)") + theme_bw() 
  })  %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE) # >>>>>>>>>>>>>>>
  
    output$ma_plot = renderPlot({
      ma_plot_reac() 
    }) 
  
    volcano_plot_reac <- reactive({
      de_table %>%
        dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>% # >>>>>>>>>>>>>>>
        ggplot(aes(x = log2FoldChange, y = negLog10_pval, color = sig)) + geom_point() +
        scale_color_manual(name = "DE status", values = c("red", "grey")) + theme_bw()
    }) %>%
      bindEvent(input$de_filter, ignoreNULL = FALSE) # >>>>>>>>>>>>>>>
    
    
  output$volcano_plot = renderPlot({
    volcano_plot_reac() # >>>>>>>>>>>>>>>
  }) 
  
}
```

---
## Launch app with reactive plots

``` r
shinyApp(ui = ui, server = server)
```

---

# Downloading files

---

## Downloading plots - UI

Shiny makes it easy to download components of the app in the same way you would save any R object. To do this we use a special kind of button, called a *downloadButton*.

``` r
library(plotly)
ui <- page_fluid(
  plotlyOutput("volcano_plotly"),
  
* downloadButton("download_volcano_plot", "Download volcano plot", style = "width:40%;")
)
```

---
## In line CSS to style button

NOTE: the download button does not have a 'width' argument like the action button, so we set this by giving inline CSS commands to the 'style' argument. We won't get into CSS much in this course, but it can be a powerful way to highly customize any UI components in your Shiny app if you know how to use it. You will also likely often see people using it on message boards.

``` r
library(plotly)
ui <- page_fluid(
  plotlyOutput("volcano_plotly"),
  
* downloadButton("download_volcano_plot", "Download volcano plot", style = "width:40%;")
)
```

---
## Downloading plots - server

In the server the output objects are paired with a *downloadHandler* function. This is a special kind of server function that will take two arguments that are both functions.

- The 'filename' argument takes  no arguments and returns a string that will be the filename
  - The 'content' argument is a function that takes one argument named *file* that will be a temporary file path to write the file to, and the function contains code to generate and save the file.
  - Reactive values can be used inside of the 'content' function.

``` r
server <- function(input, output){
  volcano_plot_reac <- reactive(ggplot(de_table, aes(x = log2FoldChange, y = negLog10_pval, text = Symbol)) + geom_point() + theme_bw())
  
  output$volcano_plotly = renderPlotly(ggplotly(volcano_plot_reac(), source = "volcano_plot")) 
  
* output$download_volcano_plot <- downloadHandler(
*   filename = function() {
*     "volcanoplot.pdf"
*   }, content = function(file) {
*     ggsave(filename = file, plot = volcano_plot_reac(), width = 7, height = 7)
*   }
* )
}
```

---
## Downloading plots - Launch app

``` r
shinyApp(ui, server)
```

---
class: inverse, center, middle

# Advanced interactivity with tables and plots

---

## Selecting rows in a DT datatable

The datatable we are using from the DT package has a very useful functionality to enhance app interactivity. Rows can be selected and this informaiton is caputured in the app.

If we change the 'selection' argument to 'single' in the *datatable* function, then the user can click rows. Every time a row is clicked, shiny tracks this with a special input object. This object will always be the name of the table input with '_rows_selected' pasted onto the end.

---
## Selecting rows in a DT datatable

In this simple app we print *input$all_data_rows_selected* and the gene in the selected row

``` r
ui <- page_fluid(
  dataTableOutput(outputId = "all_data"),
  
  textOutput("selected_row_info")
)

server <- function(input, output){
  output$all_data = renderDataTable({
    datatable(de_table,
*             selection = "single",
              filter = 'top')
  })
  
  selected_row <- reactive({
*   row_index <- input$all_data_rows_selected
    de_table[row_index, ]
  })
  
  output$selected_row_info <- renderText({
    print(paste0("The selected gene is ", selected_row()$Symbol, " and the index of the selected row is ", input$all_data_rows_selected))
  })
}
```

---
## Selecting rows in a DT datatable

``` r
shinyApp(ui, server)
```

<img src="imgs/select_row2.png"height="350" width="500">
]

---
## Pointer clicks on plots

Shiny also makes it easy to interact with plots. This cool feature can really enhance the user's ability to get information quickly from a simple looking app.

The *plotOutput* function has a 'click' argument, and the string used (e.g. 'plot_click') becomes the name of an element in the input object that can be accessed in the server function. For example, *plotOutput("plot", click = "plot_click")* will result in 'input$plot_click' being available in server.

In this case, 'input$plot_click' would be a list that contains the coordinates of the click. These coordinates can then be used in another Shiny function, *nearPoints*, which takes the clikc input object and the dataframe used for the plot, and returns the rows from the closest point (or points).

---
## Pointer clicks on plots

Here we show a table with the row of the clicked point in the server using the *nearPoints* function. The 'threshold' argument sets the distance (in y value space) from the point that is detected, and we also only return the closest point by setting 'maxpoints' to be one.

``` r
ui <- page_fluid(
* plotOutput("volcano_plot", click = "volcano_click"),
  
  tableOutput("selected_point_table"),
)

server <- function(input, output){
  volcano_plot_reac <- reactive({
        ggplot(de_table, aes(x = log2FoldChange, y = negLog10_pval)) +
          geom_point() +
          theme_bw() 
    })
    
  output$volcano_plot = renderPlot(volcano_plot_reac()) 
  
  output$selected_point_table <- renderTable({
*   nearPoints(de_table, input$volcano_click, threshold = 20, maxpoints = 1)
  })
}
```

---
## Pointer clicks on plots

``` r
shinyApp(ui, server)
```

---
## Pointer brush on plots

A brush can be used in a similar way as the click. The 'brush' argument is set in *plotOutput* in the UI and we can then track the points that are in the selected area by rendering a table with the dataframe output from the *brushedPoints* function.

``` r
ui <- page_fluid(
* plotOutput("volcano_plot", brush = "volcano_brush"),
  
  tableOutput("selected_brush_table")
)

server <- function(input, output){
  
  volcano_plot_reac <- reactive({
        ggplot(de_table, aes(x = log2FoldChange, y = negLog10_pval)) +
          geom_point() +
          theme_bw() 
    })
    
  output$volcano_plot = renderPlot(volcano_plot_reac()) 
  
  output$selected_brush_table <- renderTable({
*   brushedPoints(de_table, input$volcano_brush)
  })
}
```

---
## Pointer brush on plots

``` r
shinyApp(ui, server)
```

---
## Interactive plots with Plotly

``` r
library(plotly)
ui <- page_fluid(
* plotlyOutput("volcano_plotly"),
)

}
```

---
## Interactive plots with Plotly

``` r
shinyApp(ui, server)
```

---
## Get click info with Plotly

We can also pull out the row associated with the point that is clicked on when using plotly. Plotly has a function called *event_data* that returns a dataframe with the x and y values of the point that is highlighted when a cursor click occurs.

The plot and click event can be linked with the 'source' argument given to both the *ggplotly* and *event_data* functions. We can use the x and y values returned by *event_data* to get the row of our table that represented the point that was clicked on.

---
## Get click info with Plotly

``` r
library(plotly)
ui <- page_fluid(
  plotlyOutput("volcano_plotly"),
  
  tableOutput("plotly_click_row")
)

server <- function(input, output){
  volcano_plot_reac <- reactive({
    ggplot(de_table, aes(x = log2FoldChange, y = negLog10_pval, text = Symbol)) + geom_point() + theme_bw() 
  })
  
* output$volcano_plotly = renderPlotly(ggplotly(volcano_plot_reac(), source = "volcano_plot"))
  
  clicked_row <- reactive({
*   event <- event_data(event = "plotly_click", source = "volcano_plot")
    if(!is.null(event) > 0){
      de_table %>% filter(log2FoldChange == event$x & negLog10_pval == event$y)
    }
  })
  
  output$plotly_click_row <- renderTable({
    clicked_row()
  })
}
```

---
## Interactive plots with Plotly

``` r
shinyApp(ui, server)
```
<img src="imgs/plotly_clicked_point.png"height="400" width="500">

---
## Other packages for interactivity

- [Highcharter](https://jkunst.com/highcharter/) similar use case as plotly for general purpose plotting with a slightly different feel and some additional functionality. 
   + highcharter plots oftern look a bit better with smoother animations, but plotly integrates well with ggplot2 and usually allows for more customizations
  - [Leaflet package](https://rstudio.github.io/leaflet/articles/shiny.html) for interactive maps
  - [Dygraph pacakge](https://rstudio.github.io/dygraphs/shiny.html) for time series plots

---

## Add interactivity to main app - UI

Recap of changes to UI:

- Add value boxes to the sidebar (note the use of br(), which creates a new line to add space between inputs)
  - Make scatter plots interactive outputs by using *plotlyOutput*
  - Add download button for each plot

``` r
ui <- page_navbar(
  title = "RNAseq tools",
  theme = custom_theme,
  nav_panel(
    title = "DE Analysis",
    layout_sidebar(
      sidebar = sidebar(
        width = 300,
        numericInput("padj_filter", label = "Cutoff for padj:", value = 0.05, min = 0, max = 1, step = 0.005),
        
        numericInput("lfc_filter", label = "Cutoff for log2 FC:", value = 1, min = 0, step = 0.1),
        
        actionButton("de_filter", "Apply filter"),
        # >>>>>>>>>>>>>>>>>>>>>>>>
        # add value boxes (and new line spaces with br()) to the sidebar
        br(),
        br(),
        value_box(title = "Number of genes that go up:", value = textOutput("num_up"), 
                  showcase = icon("arrow-up"), 
                  theme = value_box_theme(bg = "#22b430")), 
        value_box(title = "Number of genes that go down:", value = textOutput("num_down"), 
                  showcase = icon("arrow-down"), 
                  theme = value_box_theme(bg ="#c34020" ))
        # >>>>>>>>>>>>>>>>>>>>>>>>
      ),
      layout_columns(
          navset_card_tab(
            title = "DE result tables",
            nav_panel(card_header("DEGs"), dataTableOutput(outputId = "de_data")),
            nav_panel(card_header("All genes"), dataTableOutput(outputId = "all_data"))
          ),
        # >>>>>>>>>>>>>>>>>>>>>>>>
        # change to plotly and add download buttons to each card
        card(card_header("MA plot"),
             plotlyOutput("ma_plot"), 
             downloadButton("download_ma_plot", "Download MA plot", style = "width:40%;")), 
        card(card_header("Volcano plot"),
             plotlyOutput("volcano_plot"),
             downloadButton("download_volcano_plot", "Download volcano plot", style = "width:40%;")), 
        # >>>>>>>>>>>>>>>>>>>>>>>>
        col_widths = c(12,6,6), row_heights = c("750px", "500px")
      )
    )
  ),
  nav_panel(title = "Next steps","The next step in our analysis will be..."),
  nav_spacer(),
  nav_menu(title = "Links",
           align = "right",
           nav_item(tags$a(shiny::icon("chart-simple"), "RU BRC - Learn more!", href = "https://rockefelleruniversity.github.io/",target = "_blank"))
  )
)
```

---
## Add interactivity to main app - server

Recap of changes to server:

- Add reactive expressions that return the number of genes passing user provided thresholds
  - outputs that render the number of genes as text in the value boxes
  - use *renderPlotly* and wrap ggplot objects in *ggplotly* to make plots interactive.
  - Add download handlers for each download button

``` r
server = function(input, output) {
 
  output$all_data = renderDataTable({
    datatable(de_table,
              filter = 'top') %>%
      formatRound(columns = c("baseMean", "log2FoldChange", "lfcSE", "stat"), digits = 3) %>%
      formatSignif(columns = c("pvalue", "padj"), digits = 3)
  })
  
  filtered_de <- reactive({
    de_table %>%
      dplyr::filter(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter)
  }) %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE)
  
  # >>>>>>>>>>>>>>>>>>>>>>>>
  # make reactives that return number of genes that go up or down based on user provided inputs
  num_up_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange > 0 & padj < 0.05) %>% nrow) 
  num_down_genes <- reactive(filtered_de() %>% dplyr::filter(log2FoldChange < 0 & padj < 0.05) %>% nrow) 
  # >>>>>>>>>>>>>>>>>>>>>>>>
  # make outputs that display the above reactives in the valueboxes
  output$num_up <- renderText(num_up_genes())
  output$num_down <- renderText(num_down_genes()) 
  
  output$de_data = renderDataTable({
    datatable(filtered_de(),
              selection = "single",
              filter = 'top') %>%
      formatRound(columns = c("baseMean", "log2FoldChange", "lfcSE", "stat"), digits = 3) %>%
      formatSignif(columns = c("pvalue", "padj"), digits = 3)
  })
  
  ma_plot_reac <- reactive({
    de_table %>%
      dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>%  
      ggplot(aes(x = baseMean, y = log2FoldChange, color = sig, text = Symbol)) + geom_point() + scale_x_log10() +
      scale_color_manual(name = "DE status", values = c("red", "grey")) +
      xlab("baseMean (log scale)") + theme_bw() 
  })  %>%
    bindEvent(input$de_filter, ignoreNULL = FALSE)
  
  # >>>>>>>>>>>>>>>>>>>>>>>>
  # use 'renderPlotly' and wrap plot in 'ggplotly' to make ma plot interactive
  output$ma_plot = renderPlotly({
    ggplotly(ma_plot_reac())
  }) 
  # >>>>>>>>>>>>>>>>>>>>>>>>
  
  volcano_plot_reac <- reactive({
    de_table %>%
      dplyr::mutate(sig = ifelse(padj < input$padj_filter & abs(log2FoldChange) > input$lfc_filter, "DE", "Not_DE")) %>% 
      ggplot(aes(x = log2FoldChange, y = negLog10_pval, color = sig, text = Symbol)) + geom_point() +
      scale_color_manual(name = "DE status", values = c("red", "grey")) + theme_bw()
  })
  
  # >>>>>>>>>>>>>>>>>>>>>>>>
  # use 'renderPlotly' and wrap plot in 'ggplotly' to make volcano plot interactive
  output$volcano_plot = renderPlotly({
    ggplotly(volcano_plot_reac())
  }) 
  # >>>>>>>>>>>>>>>>>>>>>>>>
  
   # >>>>>>>>>>>>>>>>>>>>>>>>
  # download hanlders for each download button below each plot
  output$download_ma_plot <- downloadHandler(
    filename = function() {
      "maplot.pdf"
    },
    content = function(file) {
      ggsave(filename = file, plot = ma_plot_reac())
    }
  )
  
  output$download_volcano_plot <- downloadHandler(
    filename = function() {
      "volcanoplot.pdf"
    },
    content = function(file) {
      ggsave(filename = file, plot = volcano_plot_reac())
    }
  )
  # >>>>>>>>>>>>>>>>>>>>>>>>
  
}
```

---
## Launch app

``` r
shinyApp(ui = ui, server = server)
```
<img src="imgs/add_interactivity.png"height="500" width="550">

---

## Time for an exercise!

Exercises for Session 2 are [here](../..//exercises/exercises/shiny_exercise2_exercise.html)

---
## Answers to exercise.

Answers can be found here  [here](../..//exercises/answers/shiny_exercise2_answers.html)

Rcode for answers can be found here  [here](../..//exercises/answers//answers/shiny_exercise2_Answers.R)