runstan.R

# runstan.R
session_dir =  commandArgs(TRUE)[1]
chains  =  commandArgs(TRUE)[2]
# For debug
if (is.na(session_dir)) session_dir = tempdir()
if (is.na(chains)) chains = 2

log_file = file.path(session_dir, "stan.log")
dummy = suppressWarnings(unlink(log_file))
out_file =  paste0(session_dir, "stan.rda")
dummy = suppressWarnings(unlink(out_file))
iter = 50000


# If rstan package is installed, use it
if (require(rstan)) {
  rstan_options(auto_write = TRUE)
  sink(log_file)
  schools_data = list(
    J = 8,
    y = c(28, 8, -3, 7, -1, 1, 18, 12),
    sigma = c(15, 10, 16, 11, 9, 11, 10, 18))

  # Only works for cores = 1
  fit = stan(file = "schools.stan", data = schools_data,
            iter = iter, chains = chains, cores = 1)
  sink()
  save(fit, file = out_file)
} else {

# Emulation whan rstan is not installed
#  Chain 1, Iteration:     1 / 50000 [  0%]  (Warmup)
  sink(log_file)
  for (ch in 1:chains) {
    for (progress in seq(0,100, by = 10)){
      cat(sprintf("Chain %d, EmulIteration:     %d / %d [  %d%%]  (DemoSample)",
              as.integer(ch), progress*iter/100, iter, progress),"\n")
      Sys.sleep(0.25)
    }
  }
  sink()
}

schools.stan

data {
  int<lower=0> J; // number of schools
  real y[J]; // estimated treatment effects
  real<lower=0> sigma[J]; // s.e. of effect estimates
}
parameters {
  real mu;
  real<lower=0> tau;
  vector[J] eta;
}
transformed parameters {
  vector[J] theta;
  theta <- mu + tau * eta;
}
model {
  eta ~ normal(0, 1);
  y ~ normal(theta, sigma);
}

server.R

# Monitoring progress of a process running in a separate thread
library(shiny)
library(stringr)
chains = 2

shinyServer(function(input, output, session) {

  session_dir = file.path(tempdir(), str_sub(session$token, 1,8))
  dir.create(session_dir, showWarnings = FALSE)
  progress = NULL

  session$onSessionEnded(function() {
    unlink(session_dir, TRUE)
    #progress$close() # raises error
  })

  observeEvent(input$start, {
    progress <<- shiny::Progress$new(session, min = 0, max = 100)
    progress$set(message = 'Stan calculation in progress',
                 detail = 'This may take a while...')
    progress$set(value = 0)
    system(paste("rscript runstan.R", session_dir, chains), wait = FALSE)
  })

  do_progress = function(file) {
    print(file)
    if (!file.exists(file)) return(NULL)
    r = readLines(file, warn = FALSE)
    if (length(r) == 0) return(NULL)
    r = unlist(str_extract_all(r, "Chain \\d+.*"))
    r = r[length(r)]
    frac_s = str_match(r, "(\\d+)%")
    if (nrow(frac_s) == 0) return(NULL)
    frac = as.numeric(frac_s[1,2])
    chain = as.integer(str_match(r, "Chain (\\d+)")[1,2])
    complete = floor(((chain - 1)*100 + frac)/chains)
    emul = c("rstan", "emulation")[str_detect(r, "Emul")+1]
    if (complete == 100) {
      suppressWarnings(progress$close())
#      unlink(file.path(session_dir, "stan.log"))
      return("")
    }
    else {
      progress$set(value = complete)
      return(paste0(complete, paste("% completed", emul)))
    }
  }

  file_info = reactiveFileReader(1000, session,
                    file.path(session_dir, "stan.log"),  do_progress)

  output$textout = renderText({
    file_info()
  })
})

ui.R

library(shiny)

# Define UI for application that draws a histogram
shinyUI(fluidPage(

  # Application title
  titlePanel("Shiny and Stan with progress indicator."),
  helpText("Uses emulation when rstan is not installed"),

  # Sidebar with a slider input for number of bins
  sidebarLayout(
    sidebarPanel(
      actionButton("start", "start"),
      textOutput("textout"),
      tags$style(type = "text/css", ".shiny-progress .progress { height: 15px; }")
    ),

    # Show a plot of the generated distribution
    mainPanel(
       plotOutput("distPlot")
    )
  )
))