R - Shiny 上的实时图表

Question

我正在尝试制作一个交互式图表，在一个闪亮的应用程序上绘制金融股票数据。我的尝试是不断更新数据，从而更新图表。我使用一个名为 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 秒自动更新一次。问题如下：

1. 当数据和图表更新时，不保持用户设定的缩放比例。

2. 图表需要太多秒才能更新自身，因为它计算了所有结构，而不是仅添加最后一个蜡烛。

是否有一些方法（某些包）允许更新图表而无需再次计算整个函数？或者，至少有没有办法修复图表中除蜡烛之外的所有元素？

Answer 1

您可以尝试通过DataCollection参考我的。

\n\n

\n\n

require(\'shiny\')\nrequire(\'shinyTime\')\n#\'@ require(\'rdrop2\')\nrequire(\'magrittr\')\nrequire(\'plyr\')\nrequire(\'dplyr\')\nrequire(\'stringr\')\nrequire(\'data.table\')\n#\'@ require(\'rvest\')\nrequire(\'quantmod\')\nrequire(\'TFX\')\nrequire(\'lubridate\')\nrequire(\'ggplot2\')\nrequire(\'DT\')\n\n#\'@ drop_auth()\n## email : scibrokes_demo@gmail.com\n## pass : trader888\n#\n# https://github.com/karthik/rdrop2\n#\n#\'@ token <- drop_auth()\n#\'@ saveRDS(token, "droptoken.rds")\n# Upload droptoken to your server\n# ******** WARNING ********\n# Losing this file will give anyone \n# complete control of your Dropbox account\n# You can then revoke the rdrop2 app from your\n# dropbox account and start over.\n# ******** WARNING ********\n# read it back with readRDS\n#\'@ token <- readRDS("droptoken.rds")\n# Then pass the token to each drop_ function\n#\'@ drop_acc(dtoken = token)\n#\'@ token <<- readRDS("droptoken.rds")\n# Then pass the token to each drop_ function\n#\'@ drop_acc(dtoken = token)\n\n# === Data =====================================================\nSys.setenv(TZ = \'Asia/Tokyo\')\nzones <- attr(as.POSIXlt(now(\'Asia/Tokyo\')), \'tzone\')\nzone <- ifelse(zones[[1]] == \'\', paste(zones[-1], collapse = \'/\'), zones[[1]])\n\n# === UI =====================================================\nui <- shinyUI(fluidPage(\n\n  titlePanel(\n    tags$a(href=\'https://github.com/scibrokes\', target=\'_blank\', \n           tags$img(height = \'120px\', alt=\'HFT\', #align=\'right\', \n                    src=\'https://raw.githubusercontent.com/scibrokes/real-time-fxcm/master/www/HFT.jpg\'))), \n  pageWithSidebar(\n    mainPanel(\n      tabsetPanel(\n        tabPanel(\'Data Price\', \n                 tabsetPanel(\n                   tabPanel(\'Board\', \n                            h3(\'Real Time Board\'), \n                            p(strong(paste0(\'Current time (\', zone, \'):\')),\n                              textOutput(\'currentTime\')),\n                            br(), \n                            p(strong(\'Latest FX Quotes:\'),\n                              tableOutput(\'fxdata\'), \n                              checkboxInput(\'pause\', \'Pause updates\', FALSE))), \n                   tabPanel(\'Chart\', \n                            h3(\'Real Time Chart\'), \n                            p(strong(paste0(\'Current time (\', zone, \'):\')),\n                              textOutput(\'currentTime2\')),\n                            br(), \n                            plotOutput("plotPrice")#, \n                            #\'@ tags$hr(),\n                            #\'@ plotOutput("plotAskPrice")\n                            ), \n                   tabPanel(\'Data\', \n                            h3(\'Data Download\'), \n                            p(strong(paste0(\'Current time (\', zone, \'):\')),\n                              textOutput(\'currentTime3\')), \n                            p(\'The time zone of data in GMT, Current time (GMT) :\', \n                              textOutput(\'currentTime4\')), \n                            dataTableOutput(\'fxDataTable\'), \n                            p(strong(\'Refresh\'), \'button will collect the latest dataset \', \n                              \'(time unit in seconds).\'), \n                            p(\'Please becareful, once you click on\', \n                              strong(\'Reset\'), \'button, \', \n                              \'all data will be lost. Kindly download the dataset \', \n                              \'as csv format prior to reset it.\'), \n                            actionButton(\'refresh\', \'Refresh\', class = \'btn-primary\'), \n                            downloadButton(\'downloadData\', \'Download\'), \n                            actionButton(\'reset\', \'Reset\', class = \'btn-danger\')))), \n\n        tabPanel(\'Appendix\', \n                 tabsetPanel(\n                   tabPanel(\'Reference\', \n                            h3(\'Speech\'), \n                            p(\'I try to refer to the idea from below reference to create this web \', \n                              \'application for data collection.\'), \n                            p(HTML("<a href=\'https://beta.rstudioconnect.com/content/3138/\'>Q1App2</a>"), \n                              \'(\', strong(\'Q1App2\'), \'inside 2nd reference link at below\', \n                              strong(\'Reference\'), \'tab) for algorithmic trading. Kindly browse over\', \n                              HTML("<a href=\'https://github.com/scibrokes/real-time-fxcm\'>Real Time FXCM</a>"), \n                              \'for more information about high frequency algorithmic trading.\'), \n                            br(), \n                            h3(\'Reference\'), \n                            p(\'01. \', HTML("<a href=\'https://github.com/cran/TFX\'>TFX r package</a>")), \n                            p(\'02. \', HTML("<a href=\'https://www.fxcmapps.com/apps/basic-historical-data-downloader/\'>Basic Historical Data Downloader</a>")), \n                            p(\'03. \', HTML("<a href=\'https://github.com/englianhu/binary.com-interview-question\'>binary.com : Job Application - Quantitative Analyst</a>"))), \n\n                   tabPanel(\'Author\', \n                            h3(\'Author\'), \n                            tags$iframe(src = \'https://beta.rstudioconnect.com/content/3091/ryo-eng.html\', \n                                        height = 800, width = \'100%\', frameborder = 0)))))), \n    br(), \n    p(\'Powered by - Copyright\xc2\xae Intellectual Property Rights of \', \n      tags$a(href=\'http://www.scibrokes.com\', target=\'_blank\', \n             tags$img(height = \'20px\', alt=\'scibrokes\', #align=\'right\', \n                      src=\'https://raw.githubusercontent.com/scibrokes/betting-strategy-and-model-validation/master/regressionApps/oda-army.jpg\')), \n      HTML("<a href=\'http://www.scibrokes.com\'>Scibrokes\xc2\xae</a>")))))\n\n# === Server =====================================================\nserver <- shinyServer(function(input, output, session){\n\n  output$currentTime <- renderText({\n    # Forces invalidation in 1000 milliseconds\n    invalidateLater(1000, session)\n    as.character(now(\'Asia/Tokyo\'))\n  })\n\n  output$currentTime2 <- renderText({\n    # Forces invalidation in 1000 milliseconds\n    invalidateLater(1000, session)\n    as.character(now(\'Asia/Tokyo\'))\n  })\n\n  output$currentTime3 <- renderText({\n    # Forces invalidation in 1000 milliseconds\n    invalidateLater(1000, session)\n    as.character(now(\'Asia/Tokyo\'))\n  })\n\n  output$currentTime4 <- renderText({\n    # Forces invalidation in 1000 milliseconds\n    invalidateLater(1000, session)\n    as.character(now(\'GMT\'))\n  })\n\n  fetchData <- reactive({\n    if (!input$pause)\n      invalidateLater(750)\n    qtf <- QueryTrueFX()\n    qtf %<>% mutate(TimeStamp = as.character(TimeStamp))\n    names(qtf)[6] <- \'TimeStamp (GMT)\'\n    return(qtf)\n  })\n\n  output$fxdata <- renderTable({\n    update_data()\n\n    fetchData()\n  }, digits = 5, row.names = FALSE)\n\n  # Function to get new observations\n  get_new_data <- function(){\n    readLines(\'http://webrates.truefx.com/rates/connect.html\')\n    }\n\n  ## ----------------- Start fxData ---------------------------\n  # Initialize fxData\n  fxData <<- get_new_data()\n\n  # Function to update fxData, latest data will be showing upside.\n  update_data <- function(){\n    fxData <<- rbind(fxData, get_new_data())#  %>% unique\n    saveRDS(fxData, paste0(str_replace_all(now(\'GMT\'), \':\', \'T\'), \'GMT.rds\'))\n    }\n\n  output$plotPrice <- renderPlot({\n    invalidateLater(1000, session)\n    #update_data()\n\n    if(any(file.exists(paste0(dir(pattern = \'.rds\'))))) {\n      realPlot <<- llply(dir(pattern = \'.rds\'), readRDS)\n      realPlot <<- do.call(rbind, realPlot) %>% unique\n      realPlot <<- ldply(realPlot, ParseTrueFX) %>% unique %>% \n        filter(Symbol == \'USD/JPY\')\n    }\n\n    if(nrow(realPlot) > 10) {\n\n      ggplot(tail(realPlot, 10), aes(TimeStamp)) + \n        geom_line(aes(y = Bid.Price, colour = \'Bid.Price\')) + \n        geom_line(aes(y = Ask.Price, colour = \'Ask.Price\')) + \n        ggtitle(\'Real Time USD/JPY\')\n\n    } else {\n\n      ggplot(realPlot, aes(TimeStamp)) + \n        geom_line(aes(y = Bid.Price, colour = \'Bid.Price\')) + \n        geom_line(aes(y = Ask.Price, colour = \'Ask.Price\')) + \n        ggtitle(\'Real Time USD/JPY\')\n    }\n    })\n\n  #\'@ output$plotAskPrice <- renderPlot({\n  #\'@   invalidateLater(1000, session)\n    #\'@ update_data()\n  #\'@   \n  #\'@   dt <- terms()\n  #\'@   if(nrow(dt) > 40) {\n  #\'@     ggplot(data = tail(dt, 40), aes(x = TimeStamp, y = Ask.Price, \n  #\'@                           group = Symbol, colour = Symbol)) +\n  #\'@       geom_line() + geom_point( size = 4, shape = 21, fill = \'white\') + \n  #\'@       ggtitle(\'Real Time Graph 2 : Forex Ask Price\')\n  #\'@     \n  #\'@   } else {\n  #\'@     ggplot(data = dt, aes(x = TimeStamp, y = Ask.Price, \n  #\'@                           group = Symbol, colour = Symbol)) +\n  #\'@       geom_line() + geom_point( size = 4, shape = 21, fill = \'white\') + \n  #\'@       ggtitle(\'Real Time Graph 2 : Forex Ask Price\')\n  #\'@   }\n  #\'@ })\n  ## ------------------ End fxData ----------------------------\n\n  terms <- reactive({\n    input$refresh\n\n    if(any(file.exists(paste0(dir(pattern = \'.rds\'))))) {\n      realData <<- llply(dir(pattern = \'.rds\'), readRDS)\n      realData <<- do.call(rbind, realData) %>% unique\n      realData <<- ldply(realData, ParseTrueFX) %>% unique\n    }\n  })\n\n  # Downloadable csv\n  output$downloadData <- downloadHandler(\n    filename = function() {\n      paste(\'fxData.csv\', sep = \'\')\n    },\n    content = function(file) {\n      fwrite(terms(), file, row.names = FALSE)\n    }\n  )\n\n  observe({\n    if(input$reset){\n      do.call(file.remove, list(dir(pattern = \'.rds\')))\n      rm(list = ls())\n      stopApp(\'Delete all downloaded dataset!\')\n    }\n  })\n\n  output$fxDataTable <- renderDataTable({\n\n    terms() %>% datatable(\n      caption = "Table : Forex", \n      escape = FALSE, filter = "top", rownames = FALSE, \n      extensions = list("ColReorder" = NULL, "RowReorder" = NULL, \n                        "Buttons" = NULL, "Responsive" = NULL), \n      options = list(dom = \'BRrltpi\', scrollX = TRUE, #autoWidth = TRUE, \n                     lengthMenu = list(c(10, 50, 100, -1), c(\'10\', \'50\', \'100\', \'All\')), \n                     ColReorder = TRUE, rowReorder = TRUE, \n                     buttons = list(\'copy\', \'print\', \n                                    list(extend = \'collection\', \n                                         buttons = c(\'csv\', \'excel\', \'pdf\'), \n                                         text = \'Download\'), I(\'colvis\'))))\n  })\n\n  ## Set this to "force" instead of TRUE for testing locally (without Shiny Server)\n  ## If session$allowReconnect(TRUE), stopApp() will auto reconnect and  there will be endless \n  ##   reconnect and disconnect step only and not able to reset the app.\n  #\'@ session$allowReconnect(TRUE) \n\n  llply(c(\'plotPrice\', \'fxdata\', \'fxDataTable\'), function(x) {\n    outputOptions(output, x, suspendWhenHidden = FALSE)\n  })\n})\n\nshinyApp(ui, server)\n

\n\n

资料来源：数据收集

\n