I need to add a textbox and button for each of the iteration. User will enter the value in the textbox and button will write the value in textbpx to a file along with other information. This other informatin can be taken from current graph item . This needs to be done in for each iteration similar to the graphs as shown for each symbol as below
library('quantmod')
getSymbols("AAPL", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("MSFT", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("FB", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("ORCL", 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_FB <- as.data.frame(FB)
df_FB$DATE <- index(FB)
rownames(df_FB) <- NULL
names(df_FB) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_FB$SYMBOL <- 'FB'
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_all <- rbind(df_AAPL, df_MSFT,df_FB,df_ORCL)
df_all[, c('SYMBOL','DATE','OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED')]
library(shiny)
#unique(df_all$DATE)
df_rep_date <- data.frame('RunDate'= character(),'ListStocks' = character(), stringsAsFactors=FALSE)
df_rep_date[1,] <- c("2020-01-06", 'AAPL,MSFT')
df_rep_date[2,] <- c("2021-01-04",'ORCL,AAPL')
df_rep_date[3,] <- c("2022-01-04", 'FB,ORCL')
df_rep_date$RunDate <- as.Date(df_rep_date$RunDate)
v_lst_sel_dates <-c(df_rep_date$RunDate)
func_1symb_plot <- function(p_symb){
#p_symb = 'AAPL'
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)}
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, '_plot')]] <- renderPlot(func_1symb_plot(v_symb))
})
})
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')
id2 <- paste0(v_symb, '_plot')
textOutput(ns(id1))
plotOutput(ns(id2))
# add the textbox and the button.
# this will be for each of the element in the loop
})
)
})
})
}
ui <- fluidPage(fluidRow(simpUI("par1")))
server <- function(input, output, session) {
simpServer("par1")
}
shinyApp(ui = ui, server = server)
Related
I would like to color only the cell that contains the highest value in the first row of my table (kableExtra).
For example, if the highest value is 98.32 the background color should be red.
My data:
library(shiny)
library(shinydashboard)
library(tidyverse)
header <- dashboardHeader(title = "kable")
sidebar <- dashboardSidebar()
body <- dashboardBody(htmlOutput(outputId = "simul"))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$simul <- renderText({
df_1 <- data.frame(x = replicate(n = 5, expr = runif(n = 10, min = 20, max = 100)))
df_1 %>%
kableExtra::kable(x = .,row.names = F, format = "html",
col.names = lapply(X = 1:length(.), FUN = function(x) {
names <- paste("Var", x, sep = " ")
})) %>%
kableExtra::kable_styling(font_size = 16, bootstrap_options = "striped") %>%
kableExtra::kable_styling() %>%
kableExtra::row_spec(kable_input = ., row = 0, background = "#008cba", color = "#f2f2f2") %>%
kableExtra::row_spec(kable_input = ., row = 1,
background = ifelse(test = (max(as.numeric(.)) == which.max(as.numeric(.))),
yes = "red", no = "white"),
color = "#020202")
})
}
shinyApp(ui, server)
The problem is in this part of the code.
kableExtra::row_spec(kable_input = ., row = 1,
background = ifelse(test = (max(as.numeric(.)) == which.max(as.numeric(.))),
yes = "red", no = "white"),
color = "#020202")
So again, if the highest value is 98.32 in line 1 the background color should be red (and just this cell).
You could use cell_spec.
escape parameter from kable must be set to FALSE in order to interpret correctly the associated html:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(kableExtra)
set.seed(123)
header <- dashboardHeader(title = "kable")
sidebar <- dashboardSidebar()
body <- dashboardBody(htmlOutput(outputId = "simul"))
ui <- dashboardPage(header, sidebar, body)
server <- function(input, output, session) {
output$simul <- renderText({
df_1 <- data.frame(x = replicate(n = 5, expr = runif(n = 10, min = 20, max = 100)))
cmax <- which.max(df_1[1,])
df_1[1, cmax] <- kableExtra::cell_spec(df_1[1, cmax],format = "html", background = "red",color = "#020202")
# Needed : escape = FALSE
df_1 %>% kable( row.names = F,format = "html", escape = FALSE,
col.names = lapply(X = 1:length(.), FUN = function(x) {
names <- paste("Var", x, sep = " ")})) %>%
kableExtra::kable_styling(font_size = 16, bootstrap_options = "striped") %>%
kableExtra::row_spec(kable_input = ., row = 0, background = "#008cba", color = "#f2f2f2")
})
}
shinyApp(ui, server)
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)
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)
There is one dashboard where need to put the analysis for each of the element selected list.
I have created a setup as below fot testing
Need to generate the graphs for the date for the individual symbols as shown below.
The date is selected from the drop down. The list of symbols is provided by df_rep_date for this date.
This list is iterated and the graph is genereated for the symbols in the list as shown below.
install.packages('quantmod')
library('quantmod')
getSymbols("AAPL", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("MSFT", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("FB", from = "2020/01/01",to = Sys.Date(), periodicity = "daily")
getSymbols("ORCL", 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_FB <- as.data.frame(FB)
df_FB$DATE <- index(FB)
rownames(df_FB) <- NULL
names(df_FB) <- c('OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED','DATE')
df_FB$SYMBOL <- 'FB'
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_all <- rbind(df_AAPL, df_MSFT,df_FB,df_ORCL)
df_all[, c('SYMBOL','DATE','OPEN','HIGH','LOW','CLOSE','VOLUME','ADJUSTED')]
library(shiny)
#unique(df_all$DATE)
df_rep_date <- data.frame('RunDate'= character(),'ListStocks' = character(), stringsAsFactors=FALSE)
df_rep_date[1,] <- c("2020-01-06", 'AAPL,MSFT')
df_rep_date[2,] <- c("2021-01-04",'ORCL,AAPL')
df_rep_date[3,] <- c("2022-01-04", 'FB,ORCL')
df_rep_date$RunDate <- as.Date(df_rep_date$RunDate)
v_lst_sel_dates <-c(df_rep_date$RunDate)
func_1symb_plot <- function(p_symb){
p_symb = 'AAPL'
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 = v_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)}
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')),
textOutput(NS(id,'test_text'))),
fluidPage( for (v_symb in lst_symb_output){
renderTex('v_symb_name')
plotOutput(v_symb)
})
simpServer <- function(id) {
moduleServer(id, function(input, output, session) {
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())
for (v_symb in v_lst_symbol()){
v_symb_name = paste0(v_symb, '_name')
output$v_symb_name = v_symb
output$v_symb <- renderPlot(func_1symb_plot(v_symb))
}
})
}
ui <- fluidPage(fluidRow(simpUI("par1")))
server <- function(input, output, session) {
simpServer("par1")
}
shinyApp(ui = ui, server = server)
Try this
df_rep_date <- data.frame('RunDate'= character(),'ListStocks' = character(), stringsAsFactors=FALSE)
df_rep_date[1,] <- c("2020-01-06", 'AAPL')
df_rep_date[2,] <- c("2021-01-04", 'ORCL')
df_rep_date[3,] <- c("2022-01-04", 'FB,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_1symb_plot <- function(p_symb){
#p_symb = 'AAPL'
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)}
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, '_plot')]] <- renderPlot(func_1symb_plot(v_symb))
})
})
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')
id2 <- paste0(v_symb, '_plot')
textOutput(ns(id1))
plotOutput(ns(id2))
})
)
})
})
}
ui <- fluidPage(fluidRow(simpUI("par1")))
server <- function(input, output, session) {
simpServer("par1")
}
shinyApp(ui = ui, server = server)
I use a function with a text loading bar (get_reddit()) in a Shiny app and I would like to display the progression not in the R console but in the app. Does anyone know how I could do that?
For now I have an empty progress bar in the app (not surprising since I don't have any incProgress() to go with the withProgress()) and an active text bar in my RStudio console.
library(shiny)
library(RedditExtractoR)
ui <- fluidPage(actionButton("go", "GO !"),
tableOutput("reddit"))
server <- function(input, output) {
get_data <- eventReactive(input$go, {
withProgress(message = 'Work in progress', value = 0, {
df <-
get_reddit(
search_terms = "Lyon",
regex_filter = "",
subreddit = "france",
cn_threshold = 1,
page_threshold = 1,
sort_by = "comments",
wait_time = 2
)
df
})
})
output$reddit <- renderTable({
df <- get_data()
df[1:5, 1:5]
})
}
shinyApp(ui = ui, server = server)
Thank you for your help!
A simple solution is to edit the function in the RedditExtractoR package responsible for the progress bar, which is reddit_content. This function is called from within the get_reddit function, so this function has to be updated too.
library(shiny)
library(RedditExtractoR)
source("get_reddit2.R") # source the new get_reddit2 function (see below)
source("reddit_content2.R") # source the new reddit_content2 function (see below)
ui <- fluidPage(actionButton("go", "GO !"),
tableOutput("reddit"))
server <- function(input, output) {
get_data <- eventReactive(input$go, {
df <- get_reddit2(
search_terms = "science",
subreddit = "science")
})
output$reddit <- renderTable({
df <- get_data()
df[1:5, 1:5]
})
}
shinyApp(ui = ui, server = server)
Put the following function in a separate file called get_reddit2.R which you source from the app (see above):
get_reddit2 <- function (
search_terms = NA,
regex_filter = "",
subreddit = NA,
cn_threshold = 1,
page_threshold = 1,
sort_by = "comments",
wait_time = 2)
{
URL = unique(as.character(
reddit_urls(
search_terms,
regex_filter,
subreddit,
cn_threshold,
page_threshold,
sort_by,
wait_time
)$URL
))
retrieved_data = reddit_content2(URL, wait_time)
return(retrieved_data)
}
Put also the following function in a separate file called reddit_content2.R (see above):
reddit_content2 <- function (URL, wait_time = 2)
{
if (is.null(URL) | length(URL) == 0 | !is.character(URL)) {
stop("invalid URL parameter")
}
GetAttribute = function(node, feature) {
Attribute = node$data[[feature]]
replies = node$data$replies
reply.nodes = if (is.list(replies))
replies$data$children
else
NULL
return(list(Attribute, lapply(reply.nodes, function(x) {
GetAttribute(x, feature)
})))
}
get.structure = function(node, depth = 0) {
if (is.null(node)) {
return(list())
}
filter = is.null(node$data$author)
replies = node$data$replies
reply.nodes = if (is.list(replies))
replies$data$children
else
NULL
return(list(
paste0(filter, " ", depth),
lapply(1:length(reply.nodes),
function(x)
get.structure(reply.nodes[[x]], paste0(depth,
"_", x)))
))
}
data_extract = data.frame(
id = numeric(),
structure = character(),
post_date = as.Date(character()),
comm_date = as.Date(character()),
num_comments = numeric(),
subreddit = character(),
upvote_prop = numeric(),
post_score = numeric(),
author = character(),
user = character(),
comment_score = numeric(),
controversiality = numeric(),
comment = character(),
title = character(),
post_text = character(),
link = character(),
domain = character(),
URL = character()
)
# pb = utils::txtProgressBar(min = 0,
# max = length(URL),
# style = 3)
withProgress(message = 'Work in progress', value = 0, {
for (i in seq(URL)) {
if (!grepl("^https?://(.*)", URL[i]))
URL[i] = paste0("https://www.", gsub("^.*(reddit\\..*$)",
"\\1", URL[i]))
if (!grepl("\\?ref=search_posts$", URL[i]))
URL[i] = paste0(gsub("/$", "", URL[i]), "/?ref=search_posts")
X = paste0(gsub("\\?ref=search_posts$", "", URL[i]),
".json?limit=500")
raw_data = tryCatch(
RJSONIO::fromJSON(readLines(X, warn = FALSE)),
error = function(e)
NULL
)
if (is.null(raw_data)) {
Sys.sleep(min(1, wait_time))
raw_data = tryCatch(
RJSONIO::fromJSON(readLines(X,
warn = FALSE)),
error = function(e)
NULL
)
}
if (is.null(raw_data) == FALSE) {
meta.node = raw_data[[1]]$data$children[[1]]$data
main.node = raw_data[[2]]$data$children
if (min(length(meta.node), length(main.node)) > 0) {
structure = unlist(lapply(1:length(main.node),
function(x)
get.structure(main.node[[x]], x)))
TEMP = data.frame(
id = NA,
structure = gsub("FALSE ",
"", structure[!grepl("TRUE", structure)]),
post_date = format(as.Date(
as.POSIXct(meta.node$created_utc,
origin = "1970-01-01")
), "%d-%m-%y"),
comm_date = format(as.Date(
as.POSIXct(unlist(lapply(main.node,
function(x) {
GetAttribute(x, "created_utc")
})), origin = "1970-01-01")
), "%d-%m-%y"),
num_comments = meta.node$num_comments,
subreddit = ifelse(
is.null(meta.node$subreddit),
"UNKNOWN",
meta.node$subreddit
),
upvote_prop = meta.node$upvote_ratio,
post_score = meta.node$score,
author = meta.node$author,
user = unlist(lapply(main.node, function(x) {
GetAttribute(x, "author")
})),
comment_score = unlist(lapply(main.node,
function(x) {
GetAttribute(x, "score")
})),
controversiality = unlist(lapply(main.node,
function(x) {
GetAttribute(x, "controversiality")
})),
comment = unlist(lapply(main.node, function(x) {
GetAttribute(x, "body")
})),
title = meta.node$title,
post_text = meta.node$selftext,
link = meta.node$url,
domain = meta.node$domain,
URL = URL[i],
stringsAsFactors = FALSE
)
TEMP$id = 1:nrow(TEMP)
if (dim(TEMP)[1] > 0 & dim(TEMP)[2] > 0)
data_extract = rbind(TEMP, data_extract)
else
print(paste("missed", i, ":", URL[i]))
}
}
# utils::setTxtProgressBar(pb, i)
incProgress()
Sys.sleep(min(2, wait_time))
}
# close(pb)
})
return(data_extract)
}
Now the loading bar is shown in Shiny instead of the console.
I have been strugling for hours to find out what's worng with my shiny app. The server and ui are below, as well as the function that makes the prediction for the server.
As I write in the text box the reactiveness does work, but the same error appears. I am not an expert in Shiny. This is my second app.
When I run it I get below app (image):
Please help.
Function:
library(tidyr)
library(dplyr)
library(quanteda)
library(stringr)
## Read-in frequencies
df1 <- readRDS("./App/nextword/g1.rds")
df2 <- readRDS("./App/nextword/g2.rds")
df3 <- readRDS("./App/nextword/g3.rds")
df4 <- readRDS("./App/nextword/g4.rds")
texti <- "i, Don't think"
texti <- corpus(texti)
texti <- corpus(tolower(texti))
## Clean input
texti <- tokenize(texti,
remove_numbers = TRUE,
remove_punct = TRUE,
remove_symbols = TRUE,
remove_separators = TRUE,
remove_twitter = TRUE,
remove_hyphens = TRUE,
remove_url = TRUE,
concatenator = " ",
verbose = FALSE)
texti <- dfm(texti)
texti <- data.frame(word = featnames(texti), row.names = NULL, stringsAsFactors = FALSE)
p <- function(texti) {
if(texti[1, ] == "" & texti[2, ] == "" & texti[3, ] == "") {
prediction = df1 %>%
select(word, Frequency)
} else if(texti[1, ] %in% df4$w1 & texti[2, ] %in% df4$w2 & texti[3, ] %in% df4$w2) {
prediction = df4 %>%
filter(w1 %in% texti[1, ] & w2 %in% texti[2, ] & w3 %in% texti[3, ]) %>%
select(w4, Frequency)
} else if(texti[1, ] %in% df3$w1 & texti[2, ] %in% df3$w2) {
prediction = df3 %>%
filter(w1 %in% texti[1, ] & w2 %in% texti[2, ]) %>%
select(w3, Frequency)
} else if(texti[1, ] %in% df2$w1) {
prediction = df2 %>%
filter(w1 %in% texti[1, ]) %>%
select(w2, Frequency)
} else{
prediction = df1 %>%
select(word, Frequency)
}
return(prediction)
}
server:
library(shiny)
library(shinythemes)
library(markdown)
shinyServer(function(input, output, session) {
pt1 <- reactive(p(input$texti)[1])
output$texti1 <- pt1
observeEvent(input$b1, {
updateTextInput(session, "texti",
value = paste(input$texti, pt1()))
})
pt2 <- reactive(p(input$texti)[2])
output$texti2 <- pt2
observeEvent(input$b2, {
updateTextInput(session, "texti",
value = paste(input$texti, pt2()))
})
pt3 <- reactive(p(input$texti)[3])
output$texti3 <- pt3
observeEvent(input$b3, {
updateTextInput(session, "texti",
value = paste(input$texti, pt3()))
})
})
ui:
library(shinythemes)
shinyUI(fluidPage(
theme = shinytheme("darkly"),
tags$hr(),
titlePanel("Next Word Prediction Application"),
tags$hr(),
mainPanel(tabsetPanel(
tabPanel("Prediction",
sidebarLayout(
sidebarPanel(
width = 3,
tags$p(""),
tags$h5("Predicted next word:"),
flowLayout(
actionButton("b1", label = textOutput("texti1")),
actionButton("b2", label = textOutput("texti2")),
actionButton("b3", label = textOutput("texti3"))
)
),
mainPanel(
tags$p(""),
tags$h5("Please, enter your text:"),
h4(tags$textarea(id = "texti", rows = 1, cols = 30, "")))
)),
tabPanel("About", includeMarkdown("README.md"))
))
))