Unable to generate the candle charts on dialog box in R shiny - r

Question

I have a R shiny dashboard for stocks analysis. This dashboard has the date at top as driving criteria. The symbols are selected based on that.
The detailed information of these stocks are shown further one by one.
For demo purpose the data is displayed in the attached code.
One button is also added to the dashboard for each of the symbol.
On clicking the button the candle stick graph of that symbol is expected.
In present code when the button is clicked the graph is shown in the Plots pane of the RStudio and not in the graph..but error message subscript out of bounds is shown.
This is shown in the image .
Kindly suggest the changes to display the graph in the popup window.
Image in Plot Pange
library(quantmod)
library(shiny)
getSymbols("AAPL", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("MSFT", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("META", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("ORCL", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("TSLA", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("GOOG", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
df_AAPL <- as.data.frame(AAPL)
df_AAPL$DATE <- index(AAPL)
rownames(df_AAPL) <- NULL
names(df_AAPL) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_AAPL$SYMBOL <- 'AAPL'
df_MSFT <- as.data.frame(MSFT)
df_MSFT$DATE <- index(MSFT)
rownames(df_MSFT) <- NULL
names(df_MSFT) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_MSFT$SYMBOL <- 'MSFT'
df_META <- as.data.frame(META)
df_META$DATE <- index(META)
rownames(df_META) <- NULL
names(df_META) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_META$SYMBOL <- 'META'
df_ORCL <- as.data.frame(ORCL)
df_ORCL$DATE <- index(ORCL)
rownames(df_ORCL) <- NULL
names(df_ORCL) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_ORCL$SYMBOL <- 'ORCL'
df_TSLA <- as.data.frame(TSLA )
df_TSLA$DATE <- index(TSLA)
rownames(df_TSLA) <- NULL
names(df_TSLA) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_TSLA$SYMBOL <- 'TSLA'
df_GOOG <- as.data.frame(GOOG)
df_GOOG$DATE <- index(GOOG)
rownames(df_GOOG) <- NULL
names(df_GOOG) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_GOOG$SYMBOL <- 'GOOG'
df_all <- rbind(df_AAPL, df_MSFT,df_META,df_ORCL,df_TSLA,df_GOOG)
df_all[, c('SYMBOL','DATE','OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED')]
df_rep_date <- data.frame('RunDate'= character(),'ListStocks' = character(), stringsAsFactors=FALSE)
df_rep_date[1,] <- c("2020-01-06", 'AAPL,GOOG,TSLA')
df_rep_date[2,] <- c("2021-01-04", 'ORCL')
df_rep_date[3,] <- c("2022-01-04", 'META,MSFT')
#df_rep_date[4,] <- c("2022-01-07", 'MSFT')
df_rep_date$RunDate <- as.Date(df_rep_date$RunDate)
v_lst_sel_dates <-c(df_rep_date$RunDate)
func_common_crt_lst <- function(...){ x <- list(...); return(x)}
func_1symb_plot <- function(p_symb){
df_tmp_hist_dat = df_all[df_all$SYMBOL == p_symb,c("DATE" ,"OPEN","HIGH","LOW" ,"CLOSE","VOLUME" )]
v_df_dly_dat_6mnth_xts <- xts(df_tmp_hist_dat[, -1], order.by = df_tmp_hist_dat[, 1])
v_grph_op <- candleChart( v_df_dly_dat_6mnth_xts,name = p_symb, type = "auto", up.col = "green", dn.col = "red",
theme = "white",plot = TRUE,TA = "addVo();addSMA(n = 1, on = 1, overlay = TRUE, col ='black');
addSMA(n = 7, on = 1, overlay = TRUE, col ='gold'); addSMA(n = 14, on = 1, overlay = TRUE, col ='brown');addMACD(); addBBands();addRSI();addOBV();")
return(v_grph_op)}
func_1symb_tab <- function(p_symb){
df_tmp_hist_dat = df_all[df_all$SYMBOL == p_symb,c("DATE" ,"OPEN","HIGH","LOW" ,"CLOSE","VOLUME" )]
df_tmp_hist_dat <- df_tmp_hist_dat[1:5,]
df_tmp_hist_dat$DATE <- as.Date(df_tmp_hist_dat$DATE)
v_tab_op <- df_tmp_hist_dat
}
simpUI <- function(id) {
tagList(selectInput(NS(id, 'RunDate'), "Run Date", v_lst_sel_dates),
textOutput(NS(id,'date_output')),
textOutput(NS(id,'lst_symb_output')),
uiOutput(NS(id,"myplot"))
)
}
simpServer <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
string <- reactive(input$RunDate)
output$date_output <- renderText(string())
v_lst_symbol <- reactive(df_rep_date[df_rep_date$RunDate == input$RunDate,]$ListStocks)
output$lst_symb_output <- renderText(v_lst_symbol())
observeEvent(input$RunDate, {
print(v_lst_symbol())
symbs <- read.table(text = v_lst_symbol(), sep = ",", colClasses = "character")
print(symbs)
lapply(symbs[1,], function(v_symb){
v_symb_name = paste0(v_symb, '_name')
output[[paste0(v_symb, '_name')]] = renderText(v_symb_name)
output[[paste0(v_symb, '_table')]] <- renderTable(func_1symb_tab(v_symb))
observeEvent({input[[paste0(v_symb, '_cndl_chart')]]},{
plt_cndl <- func_1symb_plot(v_symb)
print(' before showModal')
showModal(modalDialog(title = v_symb, size = "l",renderPlot(plt_cndl)))
print("after showmodel ")
})
})
})
output$myplot <- renderUI({
symbs <- read.table(text = v_lst_symbol(), sep = ",", colClasses = "character")
tagList(
lapply(symbs[1,], function(v_symb){
id1 <- paste0(v_symb, '_name')
id3 <- paste0(v_symb, '_table')
id4 <- paste0(v_symb, '_cndl_chart')
fluidRow(
func_common_crt_lst(htmlOutput(ns(id1)),
tableOutput(ns(id3)),
actionButton(ns(id4), ns(id4))))
})
)
})
})
}
ui <- fluidPage(fluidRow(simpUI("par1")))
server <- function(input, output, session) {
simpServer("par1")
}
shinyApp(ui = ui, server = server)

Answer 1

Your code is by far not minimal and it needed quite some amount of time to strip all the unnecessary parts away to find out what you are trying. For future reference you may get more help if you minimize your code.
Your code has several issues:
You cannot use renderPlot without a corresponding plotOutput. That is the main issue why your plot does not show up. Hence, you need to place a plotOutput in your modal and add an additional renderPlot to fill it.
Your module is somewhat useless and you shoudl rather create a module around the elements symbol name, table and modal action button.
Using some loops helps tremendously to avoid this massive code duplictation.
Having said that, here's a working example which refactored your code quite extensively and made use of the tidyverse to simplify some of the data operations you are doing.
library(quantmod)
library(shiny)
library(dplyr)
library(purrr)
library(stringr)
get_data <- function(symbols = c("AAPL", "MSFT", "META", "ORCL",
"TSLA", "GOOG")) {
syms <- getSymbols(symbols, from = "2020/01/01",
to = Sys.Date(), periodicity = "daily")
map_dfr(syms, function(sym) {
raw_data <- get(sym)
raw_data %>%
as_tibble() %>%
set_names(c("OPEN", "HIGH", "LOW", "CLOSE", "VOLUME", "ADJUSTED")) %>%
mutate(SYMBOL = sym,
DATE = index(raw_data)) %>%
select(SYMBOL, DATE, OPEN, HIGH, LOW, CLOSE, VOLUME, ADJUSTED)
})
}
if (!exists("df_all")) {
df_all <- get_data()
}
df_rep_data <- tribble(~ RunDate, ~ ListStocks,
"2020-01-06", "AAPL, GOOG, TSLA",
"2021-01-04", "ORCL",
"2022-01-04", "META, MSFT") %>%
mutate(RunDate = as.Date(RunDate))
make_candle_chart <- function(symbol, dat = df_all) {
vals <- dat %>%
filter(SYMBOL == symbol)
ts <- xts(vals %>%
select(OPEN, HIGH, LOW, CLOSE, VOLUME),
order.by = vals %>% pull(DATE))
candleChart(ts, name = symbol, type = "auto",
up.col = "green", dn.col = "red", theme = "white", plot = TRUE,
TA = c(addVo(),
addSMA(n = 1, on = 1, overlay = TRUE, col = "black"),
addSMA(n = 7, on = 1, overlay = TRUE, col = "gold"),
addSMA(n = 14, on = 1, overlay = TRUE, col = "brown"),
addMACD(),
addBBands(),
addRSI(),
addOBV()))
}
make_table <- function(symbol, dat = df_all) {
dat %>%
filter(SYMBOL == symbol) %>%
select(DATE, OPEN, HIGH, LOW, CLOSE, VOLUME) %>%
slice(1:5)
}
symb_ui <- function(id) {
ns <- NS(id)
tagList(
tags$h4(textOutput(ns("symbol"))),
tableOutput(ns("table")),
actionButton(ns("show_modal"), "Show Candle Chart")
)
}
symb_server <- function(id, get_symbol_name) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$symbol <- renderText(get_symbol_name())
output$table <- renderTable(make_table(get_symbol_name()))
output$cndl_chart <- renderPlot(make_candle_chart(get_symbol_name()))
observeEvent(input$show_modal, {
mdl <- modalDialog(title = get_symbol_name(),
size = "l",
plotOutput(ns("cndl_chart")))
showModal(mdl)
})
})
}
ui <- fluidPage(
selectInput("run_date", "Run Date", df_rep_data %>% pull(RunDate)),
tags$h2(textOutput("date_output")),
tags$h3(textOutput("lst_symb_output")),
uiOutput("symbols_output")
)
server <- function(input, output, session) {
handler <- list()
get_syms <- list()
output$date_output <- renderText(req(input$run_date))
output$lst_symb_output <- renderText({
df_rep_data %>%
filter(RunDate == req(input$run_date)) %>%
pull(ListStocks)
})
output$symbols_output <- renderUI({
symbols <- df_rep_data %>%
filter(RunDate == req(input$run_date)) %>%
pull(ListStocks) %>%
str_split(fixed(", ")) %>%
unlist()
syms <- vector("list", length(symbols)) %>%
set_names(symbols)
for (sym in symbols) {
## this local construct is needed for scoping cf.
## https://gist.github.com/bborgesr/e1ce7305f914f9ca762c69509dda632e
local({
my_sym <- sym
syms[[my_sym]] <<- symb_ui(my_sym)
get_syms[[my_sym]] <<- reactive(my_sym)
handler[[my_sym]] <<- symb_server(my_sym, get_syms[[my_sym]])
})
}
tagList(syms)
})
}
shinyApp(ui = ui, server = server)