本文介绍了R实时图表-Shiny的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我正在尝试制作一个交互式图表，在一个闪亮的应用程序上绘制金融股票数据.我的尝试是连续更新数据，从而更新图表.我使用一个称为Highcharter的软件包来管理此问题.下面显示了服务器部分的一部分代码(getDataIntraday()接收两个输入并返回更新的xts).
getID<-反应性({invalidateLater(60000)y<-getDataIntraDay(input $ text，input $ radio)回报(y)})output $ plot1<-renderHighchart({y<-getID()highchart()％>％hc_credits(enabled = TRUE，hc_exporting(enabled = TRUE)％&％;％hc_add_series_ohlc(y)％>％hc_add_theme(hc_theme_538(colors = c("red"，"blue"，"green")，图表=列表(backgroundColor ="white")))}) 这有效:每60秒图表和数据自动更新一次.问题如下:
-
当数据和图表更新时，不会保持用户确定的缩放比例.
-
图表需要太多时间才能更新自身，因为它是对所有结构进行计算，而不是仅添加最后一个蜡烛.
是否有一些方法(某些软件包)可以更新图表而无需再次计算整个函数?或者，至少，有一种方法可以修复图表中除蜡烛以外的所有元素?
解决方案
您可以尝试通过
I'm trying to make an interactive chart that plots financial stock data on a shiny app. My attempt is to update continuously the data, hence the chart. I managed this using a package called Highcharter. Below it's shown a part of code in the server part (getDataIntraday() receive two input and returns updated xts).
getID <- reactive({
invalidateLater(60000)
y <- getDataIntraDay(input$text, input$radio)
return(y)
})
output$plot1 <- renderHighchart({
y <- getID()
highchart() %>%
hc_credits(enabled = TRUE,
hc_exporting(enabled = TRUE)%>%
hc_add_series_ohlc(y) %>%
hc_add_theme(hc_theme_538(colors = c("red", "blue", "green"),
chart = list(backgroundColor = "white")))
})
This works: every 60 seconds the chart and the data are automatically updated. The problem are the following:
When the data and the chart is updated, the zoom settled by the user is not maintained.
The chart need too many seconds in order to update itself because it is computed all the structure, instead of only add the last candle.
Are there some ways (some package) that allows to update the chart without compute again the entire function? Or, at least, is there a way to fix all the elements in the chart except by the candles?
解决方案
You can try to refer to mine via DataCollection.
require('shiny')
require('shinyTime')
#'@ require('rdrop2')
require('magrittr')
require('plyr')
require('dplyr')
require('stringr')
require('data.table')
#'@ require('rvest')
require('quantmod')
require('TFX')
require('lubridate')
require('ggplot2')
require('DT')
#'@ drop_auth()
## email : [email protected]
## pass : trader888
#
# https://github.com/karthik/rdrop2
#
#'@ token <- drop_auth()
#'@ saveRDS(token, "droptoken.rds")
# Upload droptoken to your server
# ******** WARNING ********
# Losing this file will give anyone
# complete control of your Dropbox account
# You can then revoke the rdrop2 app from your
# dropbox account and start over.
# ******** WARNING ********
# read it back with readRDS
#'@ token <- readRDS("droptoken.rds")
# Then pass the token to each drop_ function
#'@ drop_acc(dtoken = token)
#'@ token <<- readRDS("droptoken.rds")
# Then pass the token to each drop_ function
#'@ drop_acc(dtoken = token)
# === Data =====================================================
Sys.setenv(TZ = 'Asia/Tokyo')
zones <- attr(as.POSIXlt(now('Asia/Tokyo')), 'tzone')
zone <- ifelse(zones[[1]] == '', paste(zones[-1], collapse = '/'), zones[[1]])
# === UI =====================================================
ui <- shinyUI(fluidPage(
titlePanel(
tags$a(href='https://github.com/scibrokes', target='_blank',
tags$img(height = '120px', alt='HFT', #align='right',
src='https://raw.githubusercontent.com/scibrokes/real-time-fxcm/master/www/HFT.jpg'))),
pageWithSidebar(
mainPanel(
tabsetPanel(
tabPanel('Data Price',
tabsetPanel(
tabPanel('Board',
h3('Real Time Board'),
p(strong(paste0('Current time (', zone, '):')),
textOutput('currentTime')),
br(),
p(strong('Latest FX Quotes:'),
tableOutput('fxdata'),
checkboxInput('pause', 'Pause updates', FALSE))),
tabPanel('Chart',
h3('Real Time Chart'),
p(strong(paste0('Current time (', zone, '):')),
textOutput('currentTime2')),
br(),
plotOutput("plotPrice")#,
#'@ tags$hr(),
#'@ plotOutput("plotAskPrice")
),
tabPanel('Data',
h3('Data Download'),
p(strong(paste0('Current time (', zone, '):')),
textOutput('currentTime3')),
p('The time zone of data in GMT, Current time (GMT) :',
textOutput('currentTime4')),
dataTableOutput('fxDataTable'),
p(strong('Refresh'), 'button will collect the latest dataset ',
'(time unit in seconds).'),
p('Please becareful, once you click on',
strong('Reset'), 'button, ',
'all data will be lost. Kindly download the dataset ',
'as csv format prior to reset it.'),
actionButton('refresh', 'Refresh', class = 'btn-primary'),
downloadButton('downloadData', 'Download'),
actionButton('reset', 'Reset', class = 'btn-danger')))),
tabPanel('Appendix',
tabsetPanel(
tabPanel('Reference',
h3('Speech'),
p('I try to refer to the idea from below reference to create this web ',
'application for data collection.'),
p(HTML("<a href='https://beta.rstudioconnect.com/content/3138/'>Q1App2</a>"),
'(', strong('Q1App2'), 'inside 2nd reference link at below',
strong('Reference'), 'tab) for algorithmic trading. Kindly browse over',
HTML("<a href='https://github.com/scibrokes/real-time-fxcm'>Real Time FXCM</a>"),
'for more information about high frequency algorithmic trading.'),
br(),
h3('Reference'),
p('01. ', HTML("<a href='https://github.com/cran/TFX'>TFX r package</a>")),
p('02. ', HTML("<a href='https://www.fxcmapps.com/apps/basic-historical-data-downloader/'>Basic Historical Data Downloader</a>")),
p('03. ', HTML("<a href='https://github.com/englianhu/binary.com-interview-question'>binary.com : Job Application - Quantitative Analyst</a>"))),
tabPanel('Author',
h3('Author'),
tags$iframe(src = 'https://beta.rstudioconnect.com/content/3091/ryo-eng.html',
height = 800, width = '100%', frameborder = 0)))))),
br(),
p('Powered by - Copyright® Intellectual Property Rights of ',
tags$a(href='http://www.scibrokes.com', target='_blank',
tags$img(height = '20px', alt='scibrokes', #align='right',
src='https://raw.githubusercontent.com/scibrokes/betting-strategy-and-model-validation/master/regressionApps/oda-army.jpg')),
HTML("<a href='http://www.scibrokes.com'>Scibrokes®</a>")))))
# === Server =====================================================
server <- shinyServer(function(input, output, session){
output$currentTime <- renderText({
# Forces invalidation in 1000 milliseconds
invalidateLater(1000, session)
as.character(now('Asia/Tokyo'))
})
output$currentTime2 <- renderText({
# Forces invalidation in 1000 milliseconds
invalidateLater(1000, session)
as.character(now('Asia/Tokyo'))
})
output$currentTime3 <- renderText({
# Forces invalidation in 1000 milliseconds
invalidateLater(1000, session)
as.character(now('Asia/Tokyo'))
})
output$currentTime4 <- renderText({
# Forces invalidation in 1000 milliseconds
invalidateLater(1000, session)
as.character(now('GMT'))
})
fetchData <- reactive({
if (!input$pause)
invalidateLater(750)
qtf <- QueryTrueFX()
qtf %<>% mutate(TimeStamp = as.character(TimeStamp))
names(qtf)[6] <- 'TimeStamp (GMT)'
return(qtf)
})
output$fxdata <- renderTable({
update_data()
fetchData()
}, digits = 5, row.names = FALSE)
# Function to get new observations
get_new_data <- function(){
readLines('http://webrates.truefx.com/rates/connect.html')
}
## ----------------- Start fxData ---------------------------
# Initialize fxData
fxData <<- get_new_data()
# Function to update fxData, latest data will be showing upside.
update_data <- function(){
fxData <<- rbind(fxData, get_new_data())# %>% unique
saveRDS(fxData, paste0(str_replace_all(now('GMT'), ':', 'T'), 'GMT.rds'))
}
output$plotPrice <- renderPlot({
invalidateLater(1000, session)
#update_data()
if(any(file.exists(paste0(dir(pattern = '.rds'))))) {
realPlot <<- llply(dir(pattern = '.rds'), readRDS)
realPlot <<- do.call(rbind, realPlot) %>% unique
realPlot <<- ldply(realPlot, ParseTrueFX) %>% unique %>%
filter(Symbol == 'USD/JPY')
}
if(nrow(realPlot) > 10) {
ggplot(tail(realPlot, 10), aes(TimeStamp)) +
geom_line(aes(y = Bid.Price, colour = 'Bid.Price')) +
geom_line(aes(y = Ask.Price, colour = 'Ask.Price')) +
ggtitle('Real Time USD/JPY')
} else {
ggplot(realPlot, aes(TimeStamp)) +
geom_line(aes(y = Bid.Price, colour = 'Bid.Price')) +
geom_line(aes(y = Ask.Price, colour = 'Ask.Price')) +
ggtitle('Real Time USD/JPY')
}
})
#'@ output$plotAskPrice <- renderPlot({
#'@ invalidateLater(1000, session)
#'@ update_data()
#'@
#'@ dt <- terms()
#'@ if(nrow(dt) > 40) {
#'@ ggplot(data = tail(dt, 40), aes(x = TimeStamp, y = Ask.Price,
#'@ group = Symbol, colour = Symbol)) +
#'@ geom_line() + geom_point( size = 4, shape = 21, fill = 'white') +
#'@ ggtitle('Real Time Graph 2 : Forex Ask Price')
#'@
#'@ } else {
#'@ ggplot(data = dt, aes(x = TimeStamp, y = Ask.Price,
#'@ group = Symbol, colour = Symbol)) +
#'@ geom_line() + geom_point( size = 4, shape = 21, fill = 'white') +
#'@ ggtitle('Real Time Graph 2 : Forex Ask Price')
#'@ }
#'@ })
## ------------------ End fxData ----------------------------
terms <- reactive({
input$refresh
if(any(file.exists(paste0(dir(pattern = '.rds'))))) {
realData <<- llply(dir(pattern = '.rds'), readRDS)
realData <<- do.call(rbind, realData) %>% unique
realData <<- ldply(realData, ParseTrueFX) %>% unique
}
})
# Downloadable csv
output$downloadData <- downloadHandler(
filename = function() {
paste('fxData.csv', sep = '')
},
content = function(file) {
fwrite(terms(), file, row.names = FALSE)
}
)
observe({
if(input$reset){
do.call(file.remove, list(dir(pattern = '.rds')))
rm(list = ls())
stopApp('Delete all downloaded dataset!')
}
})
output$fxDataTable <- renderDataTable({
terms() %>% datatable(
caption = "Table : Forex",
escape = FALSE, filter = "top", rownames = FALSE,
extensions = list("ColReorder" = NULL, "RowReorder" = NULL,
"Buttons" = NULL, "Responsive" = NULL),
options = list(dom = 'BRrltpi', scrollX = TRUE, #autoWidth = TRUE,
lengthMenu = list(c(10, 50, 100, -1), c('10', '50', '100', 'All')),
ColReorder = TRUE, rowReorder = TRUE,
buttons = list('copy', 'print',
list(extend = 'collection',
buttons = c('csv', 'excel', 'pdf'),
text = 'Download'), I('colvis'))))
})
## Set this to "force" instead of TRUE for testing locally (without Shiny Server)
## If session$allowReconnect(TRUE), stopApp() will auto reconnect and there will be endless
## reconnect and disconnect step only and not able to reset the app.
#'@ session$allowReconnect(TRUE)
llply(c('plotPrice', 'fxdata', 'fxDataTable'), function(x) {
outputOptions(output, x, suspendWhenHidden = FALSE)
})
})
shinyApp(ui, server)
Source : DataCollection
这篇关于R实时图表-Shiny的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！