R shiny making my inputs reactive to parameters in a function

Question

I am trying to play around with R Shiny and learn a bit more. I have developed a reactive user interface but I am a little stuck on how to implement the users selections.

I want the user to click the "Add Textbox" button, select a variable/function from a drop down menu and apply the inputs to that function. For simplicity I use the SMA and WMA in the TTR package and quantmod for collecting data.

The SMA only takes one input n whereas the WMA can take 2 inputs n and weights. I managed to make the Shiny app reactive depending on the selection the user chooses but I now want to apply these user choices to the data. That is, I want to be able to add new columns to the table depending on the users function selection and inputs.

Expected output would be able to get a table with additional columns

MSFT.Open   MSFT.High   MSFT.Low    MSFT.Close  MSFT.Volume MSFT.Adjusted  SMA.2, SMA.10, WMA.10
46.66   47.42   46.54   46.76   27913900.00 41.75                           NA      NA      NA
46.37   46.73   46.25   46.33   39673900.00 41.36                           NA      NA      NA                       
46.38   46.75   45.54   45.65   36447900.00 40.76                           999     NA      NA
45.98   46.46   45.49   46.23   29114100.00 41.28                           999     NA      NA
46.75   47.75   46.72   47.59   29645200.00 42.49                           999     NA      NA

(Here the head of the data will contain NAs apart from the SMA.2 column). I think the user inferface is fine (correct me if I am wrong) and I just now need to insert and apply to the server function.

I would like it that the user can add as many SMA and WMA functions (and columns) as the user wants.

R code:

downloadFinancialData <- function(symbol, start, end){
  data <- getSymbols(Symbols = symbol, src = "yahoo", index.class = "POSIXct", from = start, to = end, auto.assign = FALSE)
  # we can compute the returns and some other things inside this function so we can later plot for the user.
}


symbol = "MSFT"
start = "2018-01-01"
end =  "2019-01-01"
data = downloadFinancialData(symbol = symbol, start = start, end = end)

n = 10
SMA(Cl(data), n = n)
WMA(Cl(data), n = n, wts = 1:n)
WMA(Cl(data), n = n, wts = rep(weights, times = nrow(data)))

Shiny code:

library(shiny)
library(quantmod)

dist <- c("SMA", "WMA")
add_box <- function(id){
    ns <- NS(id)
    tags$div(id = paste0("indicatorChoiceBox", id),
             selectInput(inputId = ns("indicatorChoiceSelection"),
                         label = paste0("Variable ", id),
                         choices = dist),

             conditionalPanel(
                 condition = "input.indicatorChoiceSelection=='SMA'",
                 ns = ns,
                 column(width = 3, numericInput(ns('nSMAPeriodSelection'), 'Number of Periods', value = '0'))
             ),
             conditionalPanel(
                 condition =  "input.indicatorChoiceSelection=='WMA'",
                 ns = ns,
                 column(width = 3, numericInput(ns('nWMAPeriodSelection'), 'Number of Periods', value = '0')),
                 column(width = 3, numericInput(ns('weightsWMAPeriodSelection'), 'Weights', value = '0'))
             )
    )
}


downloadFinancialData <- function(symbol, start, end){
    data <- getSymbols(Symbols = symbol, src = "yahoo", index.class = "POSIXct", from = start, to = end, auto.assign = FALSE)
    # we can compute the returns and some other things inside this function so we can later plot for the user.
}

#####################################################################################
ui <- shinyUI(fluidPage(

    sidebarPanel(
        # 1.a) Collect financial data:
        wellPanel(
            textInput(inputId = "symbolInput", label = "Symbol", value = "MSFT"),
            dateRangeInput(inputId = "stockDateRange", label = "Dates", start = "2015-01-01", end = "2018-01-01")
        ),

        actionButton("addIndicator", "Add Textbox"),
        actionButton("rmIndicator", "Remove Textbox"),
        textOutput("counter")

    ),

    mainPanel(
        tableOutput("stockData"),
        column(width = 12, id = "column")
        )

))

server <- shinyServer(function(input, output, session) {
    
    ###########################################
    # 1.a) Process financial data:
    stockData <- reactive({
        symbol = input$symbolInput
        start = input$stockDateRange[1]
        end = input$stockDateRange[2]
        
        data = downloadFinancialData(symbol = symbol, start = start, end = end)
        
        # Modify data here depending on the users function selection and value input

    })
    
    output$stockData <- renderTable({
        hd <- head(stockData())
        tl <- tail(stockData())
        
        out <- rbind(hd, tl)
        
    })
    ###########################################
    
    ###########################################
    # Track the number of input boxes to render
    counter <- reactiveValues(n = 0)

    # Track all user inputs
    AllInputs <- reactive({
        x <- reactiveValuesToList(input)
    })

    observeEvent(input$addIndicator, {
        counter$n <- counter$n + 1
        insertUI(selector = "#column",
                 where = "beforeEnd",
                 ui = add_box(counter$n)
        )
    })

    observeEvent(input$rmIndicator, {
        if (counter$n > 0) {
            removeUI(selector = paste0("#indicatorChoiceBox", counter$n))
            counter$n <- counter$n - 1
        }
    })

    output$counter <- renderPrint(print(counter$n))
    ###########################################

})

shinyApp(ui, server)

user_12647315 · Answer

Here is a solution that works (except the actual table output). I opted for the following strategy: not only use the modules to add/remove UI, but also add/remove server logic. Every module that gets added has its own logic to apply the chosen function to the data and returns the result. Therefore, I modified your module code as following:

add_box_UI <- function(id){
  ns <- NS(id)
  tags$div(id = paste0("indicatorChoiceBox", id),
           selectInput(inputId = ns("indicatorChoiceSelection"),
                       label = paste0("Variable ", id),
                       choices = dist),
           actionButton(inputId = ns("calculate_results"),
                        label = "Calculate results"),
           
           conditionalPanel(
             condition = "input.indicatorChoiceSelection=='SMA'",
             ns = ns,
             column(width = 3, numericInput(ns('nSMAPeriodSelection'), 'Number of Periods', value = '0'))
           ),
           conditionalPanel(
             condition =  "input.indicatorChoiceSelection=='WMA'",
             ns = ns,
             column(width = 3, numericInput(ns('nWMAPeriodSelection'), 'Number of Periods', value = '0')),
             column(width = 3, numericInput(ns('weightsWMAPeriodSelection'), 'Weights', value = '0'))
           )
  )
}

add_box <- function(id, data) {
  moduleServer(
    id,
    function(input, output, session) {
      results <- reactiveVal(NULL)
      observeEvent(input$calculate_results, {
        if (input$indicatorChoiceSelection == "SMA") {
          results(SMA(Cl(data), n = input$nSMAPeriodSelection))
        }
        
        if (input$indicatorChoiceSelection == "WMA") {
          results(WMA(Cl(data), n = n = input$nSMAPeriodSelection,
                      wts = rep(input$weightsWMAPeriodSelection,
                                times = nrow(data))))
        }
      })
      
      return(results)
    }
  )
}

I added an actionButton to calculate the results
in the server side of the module, an observeEvent listens for this button and executes the chosen function
the result is returned as a reactiveValue. Please note that I return results and not results(). By using results, the value is still recognised as a reactive Value from the calling environment

Now, when you add an UI element, you also have to add the server logic of the module. For this, you can just use the name of the module, add_box. Please note that you need Shiny 1.5.0 for this. I store all outputs of the called modules in a reactiveVal with list called module_results. When more modules are called or removed, you can just add/remove the entries from the list. I used a reactiveVal and not reactiveValues, because the latter is not reactive by itself, so stockData wouldn't be triggered when the output of one of the modules changes, only when a module is added/removed. Now you can use module_results to add the results to your original data.frame. As I'm not familiar with your data structure, I left this empty:

server <- shinyServer(function(input, output, session) {
  
  ###########################################
  # 1.a) Process financial data:
  stockData <- reactive({
    symbol = input$symbolInput
    start = input$stockDateRange[1]
    end = input$stockDateRange[2]
    
    data = downloadFinancialData(symbol = symbol, start = start, end = end)
    
    # Modify data here depending on the users function selection and value input
    
    
    # execute the reactiveValues to a normal value
    add_data <- lapply(module_results(), function(x) x())
    # check which data is not NULL
    index_data <- unlist(lapply(add_data, function(x) !is.null(x)))
    if (sum(index_data) > 0) {
      # do something with the data here
    }
    
    data
    
  })
  
  data_basis <- reactive({
    symbol = input$symbolInput
    start = input$stockDateRange[1]
    end = input$stockDateRange[2]
    
    data = downloadFinancialData(symbol = symbol, start = start, end = end)
    data
    
  })
  
  output$stockData <- renderTable({
    hd <- head(stockData())
    tl <- tail(stockData())
    
    out <- rbind(hd, tl)
    
  })
  ###########################################
  
  ###########################################
  # Track the number of input boxes to render
  counter <- reactiveValues(n = 0)
  
  # store the results of the called modules
  module_results <- reactiveVal(list())
  
  # Track all user inputs
  AllInputs <- reactive({
    x <- reactiveValuesToList(input)
  })
  
  observeEvent(input$addIndicator, {
    counter$n <- counter$n + 1
    insertUI(selector = "#column",
             where = "beforeEnd",
             ui = add_box_UI(counter$n)
    )
    
    # add the server logic
    temp <- module_results()
    temp[[as.character(counter$n)]] <-
      add_box(as.character(counter$n), data_basis())
    module_results(temp)
  })
  
  observeEvent(input$rmIndicator, {
    if (counter$n > 0) {
      removeUI(selector = paste0("#indicatorChoiceBox", counter$n))
      temp <- module_results()
      temp[[counter$n]] <- NULL
      module_results(temp)
      counter$n <- counter$n - 1
    }
  })
  
  output$counter <- renderPrint(print(counter$n))
  ###########################################
  
})

Apparently, adding all the observers can lead to problems ultimately, so you could think about removing them afterwards. I haven't tested it by myself yet.

Edit

I changed from reactiveValues to reactiveVal as the storage variable type.

R shiny making my inputs reactive to parameters in a function

1 Answers