With R Shiny how can I select interactively and dynamically a column in a data frame based on a name returned by a reactive statement?

I assign a name to a Reactive Value via a Radio Button. I then try to select in the data frame the column with that name. But my code does not work. Perhaps I need an "observe()" statement, which I am not familiar with

library(shiny)
library(plotly)
library(purrr)

z_curves_expos_delta <-
data.frame(
Tenor = c("SPOT", "BALM", "PRPT", "1_YR"),
Month = c(0, 0.5, 1, 12),
NG_NYMEX = c(10000, 5000, 1000, 3000),
LG_JKM = c(1000, 7000, 1000, 4000),
CR_WTI = c(8000, 4000, 2500, 1000),
PR_JET = c(6000, 3000, 4500, 2000),
PW_PJM = c(9000, 7000, 4500, 2000)
)

z_curve <- "NG_NYMEX"
z_exposD <- z_curves_expos_delta %>% select(z_curve)
plot(z_exposD)

ui <- fluidPage(sidebarLayout(sidebarPanel(

radioButtons(
"curve",
"Curve name:",
c(
"NG_NYMEX" = "NG_NYMEX",
"LG_JKM" = "LG_JKM",
"CR_WTI" = "CR_WTI",
"PR_JET" = "PR_JET",
"PW_PJM" = "PW_PJM"
),
selected = "NG_NYMEX"
),

),
mainPanel(tabsetPanel(type = "tabs",

                  tabPanel("CHARTS")))))

server <- function(input, output, session) {

z_curve <- reactive({
input$curve
})

z_exposD <-
reactive({
tmp <- z_curves_expos_delta %>% select(input$curve)
return(tmp)
})

#observe()

#plot(z_exposD)
plot_ly() %>%
add_markers(
x = z_exposD,
y = z_exposD,
color = I("green"),
name = "Title"
)
}

shinyApp(ui, server)

Hi,

Thanks for the reprex, it's so much easier to debug if you can start from a 'working' example.

Here is a way to make an interactive plotly object:

library(shiny)
library(plotly)
library(purrr)

#DATA
z_curves_expos_delta <-
  data.frame(
    Tenor = c("SPOT", "BALM", "PRPT", "1_YR"),
    Month = c(0, 0.5, 1, 12),
    NG_NYMEX = c(10000, 5000, 1000, 3000),
    LG_JKM = c(1000, 7000, 1000, 4000),
    CR_WTI = c(8000, 4000, 2500, 1000),
    PR_JET = c(6000, 3000, 4500, 2000),
    PW_PJM = c(9000, 7000, 4500, 2000)
  )

#UI
ui <- fluidPage(sidebarLayout(sidebarPanel(
  
  radioButtons(
    "curve",
    "Curve name:",
    c(
      "NG_NYMEX" = "NG_NYMEX",
      "LG_JKM" = "LG_JKM",
      "CR_WTI" = "CR_WTI",
      "PR_JET" = "PR_JET",
      "PW_PJM" = "PW_PJM"
    ),
    selected = "NG_NYMEX"
  ),
  
),
mainPanel(
  tabsetPanel(
    type = "tabs",
    tabPanel("CHARTS",
             #Plotly Output object
             plotlyOutput("myPlot")
                               )))))
#SERVER
server <- function(input, output, session) {
  
  #Reactive dataframe based off input selection
  z_exposD <-
    reactive({
      tmp <- z_curves_expos_delta %>% select(Month, y = input$curve)
      return(tmp)
    })
  
  #Plotly Plot
  output$myPlot = renderPlotly({
    plot_ly(data = z_exposD(), x = ~Month, y = ~y, 
            type = "scatter", mode = "lines")
  })
  
}

shinyApp(ui, server)
#> 
#> Listening on http://127.0.0.1:3785

Created on 2021-05-03 by the reprex package (v2.0.0)

I simplified it just to show what you needed to change

  • You did not put a plotly object in the UI (i.e. plotlyOutput)
  • You did not create a reactive plotly output environment in the server (i.e. renderPlotly)
  • When calling a reactive object (in your case z_exposD), you need to add () to it to call it in the reactive environment.

You should now have all elements to build the plot you want

Hope this helps,
PJ

Hello PJ,

Thank you for this. It helped me advance. I fear I did not provide enough of my code to allow you to offer the complete solution to my problem, apologies. So I still get an error message when the routine tries to plot: ".y must be a vector, not a reactiveExpr/reactive/function object". Here is the full code.

#
# v 1.0 mb 042921
# VaR_Scenario_Analysis_R_Code.R
#
# R Code to illustrate Interface for VaR Scenario Analysis Tool
#



library(shiny)
library(plotly)
library(purrr)


#z_curve <- "NG_NYMEX"

z_curves_expos_delta <-
  data.frame(
    Tenor = c("SPOT", "BALM", "PRPT", "1_YR"),
    Month = c(0, 0.5, 1, 12),
    NG_NYMEX = c(10000, 5000, 1000, 3000),
    LG_JKM = c(1000, 7000, 1000, 4000),
    CR_WTI = c(8000, 4000, 2500, 1000),
    PR_JET = c(6000, 3000, 4500, 2000),
    PW_PJM = c(9000, 7000, 4500, 2000)
  )


ui <- fluidPage(
  titlePanel("POC for Interface - QP VaR Scenario Analysis - CRMS in Shell T&S"),
  
  textOutput("a_curve"),
  textOutput("selected_var"),
  
  sidebarLayout(
    sidebarPanel(
      # Input: Select the random distribution type ----
      radioButtons(
        "curve",
        "Curve name:",
        c(
          "NG_NYMEX" = "NG_NYMEX",
          "LG_JKM" = "LG_JKM",
          "CR_WTI" = "CR_WTI",
          "PR_JET" = "PR_JET",
          "PW_PJM" = "PW_PJM"
        ),
        selected = "NG_NYMEX"
      ),
      
      radioButtons(
        "ad-hoc_scenario",
        "Ad-Hoc Scenario:",
        c(
          "Target levels specified by drawing in chart" = "chart",
          "Target levels specified by typing in table" = "table"
        )
      ),
      
      radioButtons(
        "date-range_scenario",
        "Date Range Scenario:",
        c("Target levels based on changes between 2 past dates" = "past_dates")
      ),
      
      dateRangeInput("daterange1", "Date range:",
                     start = "2001-01-01",
                     end   = "2021-04-28"),
      
      radioButtons(
        "preset_scenario",
        "Preset Scenario:",
        c(
          "Polar Vortex 2021" = "preset_Vortex-2021",
          "Hurricane Harvey" = "preset_Harvey",
          "Gulf War" = "preset_Gulf"
        )
      ),
    ),
    mainPanel(tabsetPanel(
      type = "tabs",
      
      tabPanel(
        "CHARTS",
        fluidRow(
          column(4, plotlyOutput("p_expoD"))
        )
      ),
      
      tabPanel(
        "TABLES",
        fluidRow(
          column(4, tableOutput("table_expoD"))
        )
      ),
      tabPanel("CORRELATIONS")
      
    ))
  )
  ,
  tags$head(tags$style(
    HTML('* {font-family: "Arial"; font-size: 12px;};')
  ))
)


server <- function(input, output, session) {
  ####################### CURVE NAME SELECTION - START #######################
  #
  # Code works if I set "z_curve" specifically like in line below but not if set via Radio Button as Reactive Value
  # z_curve <- "NG_NYMEX"
  
  zz_curve <- reactive({
    input$curve
  })
  output$a_curve <- renderText({
    paste("You chose", zz_curve())
  })
  
  
  #Reactive dataframe based off input selection
  z_exposD <-
    reactive({  
      tmp <- z_curves_expos_delta %>% select(input$curve)
      return(tmp)
    })
  
  
  ####################### CURVE NAME SELECTION - END #######################
  
  
  ####################### CURVE DATA SELECTION - START #######################
  
  # Code works if I set "z_exposD" specifically like in line below but not if set it via Radio Button as Reactive Value
  #z_exposD <- z_curves_expos_delta[, z_curve]
  
  z_tenors <- z_curves_expos_delta$Tenor
  z_months <- z_curves_expos_delta$Month
  ####################### CURVE DATA SELECTION - END #######################
  
  
  ####################### EXPOSURES DELTA - START #######################
  rv_expoD <- reactiveValues(x = z_months,
                             y = z_exposD)
  grid_expoD <- reactive({
    data.frame(x = seq(min(rv_expoD$x), max(rv_expoD$x), length = 10))
    
  })
  
  #  model_expoD <- reactive({
  #    d <- data.frame(x = rv_expoD$x, y = rv_expoD$y)
  #    loess(y ~ x, d)
  #  })
  
  
  output$p_expoD <- renderPlotly({
    # creates a list of circle shapes from x/y data
    circles <- map2(
      rv_expoD$x,
      rv_expoD$y,
      ~ list(
        type = "circle",
        # anchor circles at (mpg, wt)
        xanchor = .x,
        yanchor = .y,
        # give each circle a 2 pixel diameter
        x0 = -4,
        x1 = 4,
        y0 = -4,
        y1 = 4,
        xsizemode = "pixel",
        ysizemode = "pixel",
        # other visual properties
        fillcolor = "blue",
        line = list(color = "transparent")
      )
    )
    
    
    fig <- plot_ly(source = "fig_expoD") %>%
      add_markers(
        x = z_months,
        y = z_exposD,
        color = I("green"),
        name = "exposures Delta"
      )
    
    #    fig <- fig %>%  add_lines(x = grid()$x, y = predict(loess(y ~ x, data.frame(x = z_months, y = z_exposD) ), grid()), color = I("green"), name = "original")
    #    fig <- fig %>% add_trace(x = grid()$x, y = predict(model(), grid()), color = I("red"), mode = "markers+lines", name = "scenario")
    
    fig <-
      fig %>% add_bars(
        x = rv_expoD$x,
        y = rv_expoD$y,
        color = I("red"),
        mode = "markers+bars",
        name = "scenario"
      )
    
    fig <-
      fig %>% add_bars(
        x = z_months,
        y = z_exposD,
        color = I("green"),
        name = "originals"
      )
    
    
    fig <-
      fig %>% layout(shapes = circles) %>% config(edits = list(shapePosition = TRUE))
    
    fig
    
    
  })
  
  data_expoD <- reactive({
    d <-
      data.frame(Deltas = rv_expoD$x,
                 Original = z_exposD,
                 Scenario = rv_expoD$y)
    d
  })
  
  output$table_expoD <- renderTable({
    data_expoD()
  })
  
  
  # update x/y reactive values in response to changes in shape anchors
  observe({
    ed <- event_data("plotly_relayout", source = "fig_expoD")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2)
      return()
    row_index <-
      unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv_expoD$x[row_index] <- pts[1]
    rv_expoD$y[row_index] <- pts[2]
    
  })
  
  ####################### EXPOSURES DELTA - END #######################
  
  
  
  
}

shinyApp(ui, server)

Hi there,

Your code is very complex. but I don't blame you as building a Shiny app for the first few times gets you so confused with all the reactive stuff :slight_smile:

I managed to clean up your code Shiny-wise, meaning that you won't have any errors regarding the incorrect reactive environment, but I'm at loss what you are trying to do with the plotly. A graph is plotted, but it generates a lot of warnings and it looks weird (the table seems to be working).

I think you should be able to fix the charts yourself, as this was not the issue you're having. Remember you can set debug points in Shiny code and when you run it, you can walk through your code and check the values of variables.

Good luck

library(shiny)
library(plotly)
library(purrr)

z_curves_expos_delta <-
  data.frame(
    Tenor = c("SPOT", "BALM", "PRPT", "1_YR"),
    Month = c(0, 0.5, 1, 12),
    NG_NYMEX = c(10000, 5000, 1000, 3000),
    LG_JKM = c(1000, 7000, 1000, 4000),
    CR_WTI = c(8000, 4000, 2500, 1000),
    PR_JET = c(6000, 3000, 4500, 2000),
    PW_PJM = c(9000, 7000, 4500, 2000)
  )


ui <- fluidPage(
  titlePanel("POC for Interface - QP VaR Scenario Analysis - CRMS in Shell T&S"),
  
  textOutput("a_curve"),
  textOutput("selected_var"),
  
  sidebarLayout(
    sidebarPanel(
      # Input: Select the random distribution type ----
      radioButtons(
        "curve",
        "Curve name:",
        c(
          "NG_NYMEX" = "NG_NYMEX",
          "LG_JKM" = "LG_JKM",
          "CR_WTI" = "CR_WTI",
          "PR_JET" = "PR_JET",
          "PW_PJM" = "PW_PJM"
        ),
        selected = "NG_NYMEX"
      ),
      
      radioButtons(
        "ad-hoc_scenario",
        "Ad-Hoc Scenario:",
        c(
          "Target levels specified by drawing in chart" = "chart",
          "Target levels specified by typing in table" = "table"
        )
      ),
      
      radioButtons(
        "date-range_scenario",
        "Date Range Scenario:",
        c("Target levels based on changes between 2 past dates" = "past_dates")
      ),
      
      dateRangeInput("daterange1", "Date range:",
                     start = "2001-01-01",
                     end   = "2021-04-28"),
      
      radioButtons(
        "preset_scenario",
        "Preset Scenario:",
        c(
          "Polar Vortex 2021" = "preset_Vortex-2021",
          "Hurricane Harvey" = "preset_Harvey",
          "Gulf War" = "preset_Gulf"
        )
      ),
    ),
    mainPanel(tabsetPanel(
      type = "tabs",
      
      tabPanel(
        "CHARTS",
        fluidRow(
          column(4, plotlyOutput("p_expoD"))
        )
      ),
      
      tabPanel(
        "TABLES",
        fluidRow(
          column(4, tableOutput("table_expoD"))
        )
      ),
      tabPanel("CORRELATIONS")
      
    ))
  )
  ,
  tags$head(tags$style(
    HTML('* {font-family: "Arial"; font-size: 12px;};')
  ))
)


server <- function(input, output, session) {
  ####################### CURVE NAME SELECTION - START #######################

  output$a_curve <- renderText({
    paste("You chose", input$curve)
  })
  
  #Reactive dataframe based off input selection
  z_exposD <-
    reactive({  
      z_curves_expos_delta %>% select(input$curve)
    })
  
  ####################### CURVE NAME SELECTION - END #######################
  
  
  ####################### CURVE DATA SELECTION - START #######################
  
  z_months <- z_curves_expos_delta$Month
  
  ####################### CURVE DATA SELECTION - END #######################
  
  
  ####################### EXPOSURES DELTA - START #######################

  grid_expoD <- reactive({
    data.frame(x = seq(min(z_months), max(z_exposD()$x), length = 10))
    
  })
  
  output$p_expoD <- renderPlotly({

    # creates a list of circle shapes from x/y data
    circles <- map2(
      z_months,
      z_exposD(),
      ~ list(
        type = "circle",
        # anchor circles at (mpg, wt)
        xanchor = .x,
        yanchor = .y,
        # give each circle a 2 pixel diameter
        x0 = -4,
        x1 = 4,
        y0 = -4,
        y1 = 4,
        xsizemode = "pixel",
        ysizemode = "pixel",
        # other visual properties
        fillcolor = "blue",
        line = list(color = "transparent")
      )
    )
    
    
    fig <- plot_ly(source = "fig_expoD") %>%
      add_markers(
        x = z_months,
        y = z_exposD(),
        color = I("green"),
        name = "exposures Delta"
      )

    fig <-
      fig %>% add_bars(
        x = z_months,
        y = z_exposD(),
        color = I("red"),
        mode = "markers+bars",
        name = "scenario"
      )
    
    fig <-
      fig %>% add_bars(
        x = z_months,
        y = z_exposD(),
        color = I("green"),
        name = "originals"
      )
    
    
    fig <-
      fig %>% layout(shapes = circles) %>% config(edits = list(shapePosition = TRUE))
    
    fig
    
    
  })
  
  data_expoD <- reactive({
      data.frame(Deltas = z_months,
                 Original = z_exposD(),
                 Scenario = z_exposD())
  })
  
  output$table_expoD <- renderTable({
    data_expoD()
  })
  
  
  # update x/y reactive values in response to changes in shape anchors
  observe({
    ed <- event_data("plotly_relayout", source = "fig_expoD")
    shape_anchors <- ed[grepl("^shapes.*anchor$", names(ed))]
    if (length(shape_anchors) != 2)
      return()
    row_index <-
      unique(readr::parse_number(names(shape_anchors)) + 1)
    pts <- as.numeric(shape_anchors)
    rv_expoD()$x[row_index] <- pts[1]
    rv_expoD()$y[row_index] <- pts[2]
    
  })
  
  ####################### EXPOSURES DELTA - END #######################
  
}

shinyApp(ui, server)

Hello Pieter,

Thank you very much for your response. Your code runs great but does not achieve the functionality I am looking for. I see I failed (again, apologies...) to give enough information to allow experts to help me.

The purpose of the code is to allow the user to define an array with new values through graphical changes which affect the original array.
If you place your cursor on the blue points in the chart and "move" the points a new chart (the "scenario curve" in red) will be drawn through the new points (the "original curve" will still be visible in green). The changes will be reflected in the table (the "original" and "scenario" columns initially have the same values and the "scenario" column takes on new values after the chart is changed (eventually I also want to be able to change the numbers in the table and have it reflect automatically in the chart).

This is why I have to (I think?) define the reactive value
rv_expoD <- reactiveValues(x = z_months, y = z_exposD)
rather than just use z_expoD in my code, so the values in the chart can be "moved".

If I run your code I no longer have that functionality.

My problem is I would like to change the original data underlying the chart from one set to another, e.g. use in the data frame the column LG_JKM rather than NG_NYMEX, by selecting the corresponding "curve" through the Radio Buttons.

Do I make any sense? Many thanks for your help, Andre

HI,

I don't really understand what you mean by "moving" the points. Do you want the user to be able to click the plot and add points to it? It's just that it's all a bit confusing. Maybe you can explain the purpose of the graph a bit more regardless of the interactivity.

PJ

Hello Pieter,

Thank you for your message. Apologies for the confusion I am causing.

The "reactive" chart functionality allows to drag points on a chart in order to assign new values to the underlying variables. An illustration is provided at (please see middle & bottom of post):

The "reactive" functionality works well in my code and does not need to be edited.

You can check by adding, in the version of code I posted last, in the block "CURVE NAME SELECTION - ...", after the statement:
z_exposD <- reactive({ ... })
the following statements (which will "over-ride the previous statement):
z_curve <- "NG_NYMEX"
z_exposD <- z_curves_expos_delta[, z_curve]

I would like z_curve to act as a variable determined by the radio Button "curve" so I can plot on demand any one of the 4 curves that are available in my input data frame.

My current code generates an error message when the routine tries to plot: " .y must be a vector, not a reactiveExpr/reactive/function object".

Best regards, Andre