How to keep shiny sever operating even though closed browser?

shiny

#1

I tried to write a web application DataCollection to stored real time forex data. However I noticed that the shiny app will not keep going on after close the browser (As I noted from Persistent R sessions in Shiny Server?)… Is there any solution or better way to made the web application keep going on even though closed browser?

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)
  session$allowReconnect(TRUE)
  llply(c('plotPrice', 'fxdata', 'fxDataTable'), function(x) {
    outputOptions(output, x, suspendWhenHidden = FALSE)
  })
})

shinyApp(ui, server)

#2

I know you have this functionality on Rstudio connect. You can change default parameter and keep one or more process running to never close your server part of your application even if no-one has it opened in a browser. For your interest.

Nothing to do with your question but out of curiosity what’s the use of #' @ in your code?
First time I saw that. :slight_smile:


#3

Is it set the minimum processes in Runtime to be 1? the default setting is 0. I always using default setting and doesn’t notice the setting for rstudioconnect…

I have just differentiate the coding comment as #' @ and elaborated comment as ## but no other meaning…


#4

Yes it is this parameter you can change for each application. Should work. We use that to have always a process running the app. It helps save loading time and prevent the shiny process to close.


Previous posts suddenly hidden
#5

Just tried my web application and noticed that I cannot set session$allowReconnect(TRUE). Otherwise it will be endless disconnect and reconnect once Reset button pressed (as we can see from below gif file). :sweat_smile:

## 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) 

ice_video_20171117-122451

Now I set tried to set my min processes to be 3 and max keep unchanged to be 3 as well and closed the browser… Will check the stored dataset few hours later.


I have some question about the Runtime setting here…

  1. May I how to count the number of r processes? What max and min processes shall I set for this app (as you can know the coding from the beginning of this thread)?

  2. Is that one output$test1 consider as one prossess? Or only using parallel set clusters will be count as more than one prosses? From my app showing 3 output variables which is llply(c('plotPrice', 'fxdata', 'fxDataTable'), function(x) { outputOptions(output, x, suspendWhenHidden = FALSE) }).

  3. How do min processes setting recognize which processes should be keep going on if I have multiple processes? What will be the impact to the web application upon adjusting of min and max of processes?

Below is the default setting of Runtime for shiny web application.

Runtime settings
Changes to runtime settings will be applied immediately to any running instances of this content. However, existing user connections (or processes with open connections) will not be disconnected; the settings will take effect opportunistically. Learn more about these settings in the RStudio Connect Admin Guide.
 Use server defaults
 Specify custom settings
Max processes
The most R processes that will ever be simultaneously running for this content, regardless of load.

3
Min processes
The minimum number of R processes that will be kept running for this content, regardless of load.

1
Max connections per process
The maximum number of client connections allowed to an individual R process. Incoming connections which will exceed this limit are routed to a new R process or rejected.

20
Load factor: 0.50
A value between 0 and 1 which determines how lazily additional R processes will be spawned to handle incoming load for this process. At the highest setting, Connect will only spawn additional R processes when existing processes are not allowed to accept an additional connection. At the lowest setting, Connect will create many new R processes as new users arrive to handle the load.

0
1

Reference


#6

I’ve just checked the dataset, runtime setting doesn’t helps… The duration of not open the browser does not stored the data as we know from below image. Any other method to made the R process keep going on (hidden operating) even though closed the browser?

I think the only solution is using cloud operating system to open the browser 24/7 to made the R processes will not be killed.


#7

I don’t think this is a good use case for Shiny - its more the viewing UI layer, and it seems you are asking it to do the realtime stream layer as well, feels like a square peg to a round hole.

I would approach it with a background script running somewhere else, that handles the stream of data to a file system somewhere, either locally to .rds files or I think better to a cloud database. Then the Shiny app would just query that database each time a user was viewing, which will have the latest data.

I have an example of that approach in this series of posts that use BigQuery as the database: Real-time forcasting with Shiny part 1 and part 2


#8

Thanks alot Marked for your shiny examples, I found some others useful functions and packages to improve the efficiency for real time data scrapping…

  1. readChar() faster than readLines().
    https://rpubs.com/englianhu/milestone-report

  2. fread() is even faster than sqldf() and ffdf()
    https://stackoverflow.com/questions/1727772/quickly-reading-very-large-tables-as-dataframes-in-r

  3. fst package even fastest…
    http://blog.revolutionanalytics.com/2017/02/fst-fast-serialization-of-r-data-frames.html

  4. bigrquery package need to test the read/write speed.
    https://github.com/r-dbi/bigrquery