6

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:

  1. When the data and the chart is updated, the zoom settled by the user is not maintained.

  2. 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?

Fabrizio Lasaponara
  • 61
  • 1
  • 2
  • 1
    Have a look at this example, might be helpful https://github.com/thanhleviet/shiny-realtime-stock-chart/blob/master/server.R – Pork Chop Nov 04 '16 at 13:59
  • Thank you, but this example works exactly like the one I showed above: every 60 seconds it computes again the entire chart. I'm looking for a solutions where in the chart is added only the last bar ( last candle or last value ) and all the other elements remains always the same. – Fabrizio Lasaponara Nov 04 '16 at 16:40
  • 1
    I think a viable approach is set the usual chart and then use this example http://jsfiddle.net/gh/get/jquery/1.9.1/highslide-software/highcharts.com/tree/master/samples/stock/demo/dynamic-update/. The important part will be where do I get the new data. 1 approach to do this is update a input or output (an html element) via shiny every second and then put a `onChange` (javascript world) event associate to detect the change, if the value change you add this value to the series. Maybe not the most elegant but I think that can work – jbkunst Nov 05 '16 at 01:37
  • Thank you, I really appreciate your idea but how could I implement this example in R with your package? Sorry but I lack of experience in javascript.. – Fabrizio Lasaponara Nov 05 '16 at 17:02
  • 1
    I just said how could you do with highcharter+shiny XD. But I understand. I will try to implement a example if I have time this week :D. Finally, as recommendation, try to do and learn some js, beacuse learn js is always a good thing ;) – jbkunst Nov 07 '16 at 03:02
  • You're vere kind. I hope you can help me with an example.. – Fabrizio Lasaponara Nov 07 '16 at 18:57
  • 1
    You can see a very basic demo at http://104.140.247.162:3838/shiny-real-time-chart/, there is a link to the repo, hope it helps – jbkunst Jan 08 '17 at 01:39
  • https://github.com/jbkunst/shiny-apps-highcharter/tree/master/real-time-chart – Pork Chop Oct 11 '18 at 07:32

1 Answers1

-4

You can try to refer to mine via DataCollection.

enter image description here

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)

Source : DataCollection

Rγσ ξηg Lιαη Ημ 雷欧
  • 486
  • 2
  • 9
  • 22