R - Shiny 上的实时图表
Posted
技术标签:
【中文标题】R - Shiny 上的实时图表【英文标题】：Real time chart on R - Shiny 【发布时间】：2017-03-18 09:21:24 【问题描述】：我正在尝试制作一个交互式图表，在闪亮的应用程序上绘制金融股票数据。我的尝试是不断更新数据，因此图表。我使用一个名为 Highcharter 的包来管理它。下面显示了服务器部分中的一部分代码（getDataIntraday() 接收两个输入并返回更新的 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")))
)
这很有效：图表和数据每 60 秒自动更新一次。问题如下：
数据和图表更新时，用户设置的缩放比例不保持。
图表需要太多秒才能更新自身，因为它是计算所有结构的，而不是只添加最后一根蜡烛。
是否有一些方法（某些包）可以在不重新计算整个函数的情况下更新图表？或者，至少，有没有办法修复图表中除蜡烛之外的所有元素？
【问题讨论】：
看看这个例子，可能会有所帮助github.com/thanhleviet/shiny-realtime-stock-chart/blob/master/… 谢谢，但是这个例子的工作方式与我上面展示的完全一样：每 60 秒它会再次计算整个图表。我正在寻找一种解决方案，在图表中仅添加最后一个柱（最后一根蜡烛或最后一个值），而所有其他元素始终保持不变。 我认为一个可行的方法是设置通常的图表，然后使用这个例子jsfiddle.net/gh/get/jquery/1.9.1/highslide-software/…。重要的部分是我从哪里获得新数据。一种方法是每秒通过闪亮更新输入或输出（一个 html 元素），然后放置一个onChange（javascript 世界）事件关联以检测更改，如果值更改，则将此值添加到系列中。也许不是最优雅的，但我认为这可以工作
我只是说你怎么能用 highcharter+shiny XD。但是我明白。如果我这周有时间，我将尝试实施一个示例：D。最后，作为推荐，尝试做和学习一些js，因为学习js总是一件好事;）
你可以在104.140.247.162:3838/shiny-real-time-chart看到一个非常基本的demo，有一个repo的链接，希望对你有帮助
【参考方案1】：
您可以尝试通过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 : scibrokes_demo@gmail.com
## 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)
来源：DataCollection
【讨论】：
以上是关于R - Shiny 上的实时图表的主要内容，如果未能解决你的问题，请参考以下文章
R Shiny - 使用 DateSlider 动态过滤 ggplot2 图表