inst/DSAIDE/app.R

In DSAIDE: Dynamical Systems Approach to Infectious Disease Epidemiology (Ecology/Evolution)

#The main use is as R package
#since it is a shiny app, it can also deployed to a shiny server
#The comments below explain how one can deploy to shinyappsio or a shiny server

#note that the UI loads the google analytics bit, which currently is for the UGA server.
#Shouldn't affect deployment as R package.
#Will not apply to loading to shinyappsio (would need to create a new google analytics property)

##############################################
#This is a bit of code and instructions for deployment of the package to a server
##############################################
#to deploy to shinyappsio, follow these steps:
#1. go into the folder where this file (app.R) resides
#2. install the package through CRAN or github if we want to use the github version
#3. #uncomment the library() command below
#4. with the above 'library' statement active, deploy with:
# run rsconnect::deployApp(account = 'epibiouga')
# as suitable, change the account to another one, e.g. handelgroup
# tokens need to be set up for the connection to work
# to set up an account, run setAccountInfo.
# Best way to do is to log into shinyappsio, go to
# 'tokens' and copy the command into the console
#5. comment out the library command again

##############################################
#to deploy to a self-hosted shiny server, steps are similar
#1. install package on server, either CRAN or Github version
#2. uncomment the library() command below
#3. save app.R, copy it and packagestyle.css to the server app folder
#4. comment out the library command again
#5. as needed, update DSAIDE on server by running: sudo su - -c "R -e \"devtools::install_github('ahgroup/DSAIDE')\""

#library('DSAIDE')

##############################################
#This is the Shiny App for the main menu of DSAIDE
##############################################


##############################################
#Set up some variables, define all as global (the <<- notation)
#name of R package
packagename <<- "DSAIDE"
#find path to apps
appdir <<- system.file("appinformation", package = packagename) #find path to apps
modeldir <<- system.file("mbmodels", package = packagename) #find path to apps
simdir <<- system.file("simulatorfunctions", package = packagename) #find path to apps
#load app table that has all the app information
at <<- read.table(file = paste0(appdir,"/apptable.tsv"), sep = '\t', header = TRUE)
appNames <<- at$appid
#path to simulator function zip file
allsimfctfile <<- paste0(system.file("simulatorfunctions", package = packagename),"/simulatorfunctions.zip")
currentdocfilename <<- NULL


##############################################
#define functions
##############################################

#simple function that creates app buttons for UI
#specify data frame containing app info and the id of the app
make_button <- function(at,appid)
{
  id = which(at$appid == appid)
  actionButton(at$appid[id], paste0(at$apptitle[id]), class="mainbutton")
}


##############################################
#main server function of the app
##############################################
server <- function(input, output, session)
{
  #to get plot engine to be an object that is always be processed
  output$plotengine <- renderText('ggplot')
  outputOptions(output, "plotengine", suspendWhenHidden = FALSE)


  ###############
  #Code to reset the model settings for a given app
  ###############
  observeEvent(input$reset, {
    output$modelinputs <- NULL
    modelinputs <- generate_shinyinput(use_mbmodel = appsettings$use_mbmodel, mbmodel = appsettings$mbmodel,
                                       use_doc = appsettings$use_doc, model_file = appsettings$filepath,
                                       model_function = appsettings$simfunction[1],
                                       otherinputs = appsettings$otherinputs, packagename = packagename)
    output$modelinputs <- renderUI({modelinputs})
    output$plotly <- NULL
    output$ggplot <- NULL
    output$text <- NULL
  })


  #######################################################
  #start code that listens to the "download code" button
  #not currently implemented/activated
  #######################################################
  output$download_code <- downloadHandler(
    filename = function() {
      "output.R"
    },
    content = function(file) {
      #extract current model settings from UI input elements
      x1=reactiveValuesToList(input, all.names=TRUE) #get all shiny inputs
      #x1=as.list( c(g = 1, U = 100)) #get all shiny inputs
      x2 = x1[! (names(x1) %in% appNames)] #remove inputs that are action buttons for apps
      x3 = (x2[! (names(x2) %in% c('submitBtn','Exit') ) ]) #remove further inputs
      modelsettings <- x3[!grepl("*selectized$", names(x3))] #remove any input with selectized
      modelsettings <- c(modelsettings, appsettings)
      modelfunction = modelsettings$simfunction
      if (is.null(modelsettings$nreps)) {modelsettings$nreps <- 1} #if there is no UI input for replicates, assume reps is 1
      #if no random seed is set in UI, set it to 123.
      if (is.null(modelsettings$rngseed)) {modelsettings$rngseed <- 123}

      # output <- paste(modelsettings, modelfunction)
      # writeLines(output, file)

      output <- download_code(modelsettings, modelfunction)

      writeLines(output, file)
    }
    ,
    contentType= "application/zip"
  )
  #######################################################
  #end code that listens to the "download code" button
  #######################################################

  #######################################################
  #code that allows download of all files
  output$modeldownload <- downloadHandler(
    filename <- function() {
      "simulatorfunctions.zip"
    },
    content <- function(file) {
      file.copy(allsimfctfile, file)
    },
    contentType = "application/zip"
  )

  #######################################################
  #Button to create floating task list
  observeEvent(input$detachtasks, {
    x = withMathJax(generate_documentation(currentdocfilename))
    x1 = x[[2]][[3]] #task tab
    x2 = x1[[3]]
    x3 = x2[[1]][[3]] #pull out task list without buttons
    output$floattask <- renderUI({
      withMathJax(absolutePanel(x3, id = "taskfloat", class = "panel panel-default", fixed = TRUE,
                    draggable = TRUE, top = 100, left = "auto", right = 20, bottom = "auto",
                    width = "30%", height = "auto"))
    })
  })

  #######################################################
  #Button to remove floating task list
  observeEvent(input$destroytasks, {
    output$floattask <- NULL
  })


  #######################################################
  #start code that listens to model selection buttons and creates UI for a chosen model
  #placing it here in hopes it can fix some weird error message on some systems about appName not found
  #not sure if that works might have to do with order in which app is built
  #######################################################
  lapply(appNames, function(appName)
  {
    observeEvent(input[[appName]],
                 {
                   #clear out anything that might be left over from previous app
                   output$ggplot <- NULL
                   output$plotly <- NULL
                   output$text <- NULL
                   output$floattask <- NULL
                   output$analyzemodel <- NULL
                   output$modelinputs <- NULL
                   appsettings <<- NULL
                   modelsettings <<- NULL

                   #each app has settings stored in apptable
                   #read and assign to list called 'appsettings'
                   #store in global variable
                   appsettings <<- as.list(at[which(at$appid == appName),])

                   #a few apps have 2 simulator functions, combine here into vector
                   if (nchar(appsettings$simfunction2) > 1)
                   {
                     appsettings$simfunction <<- c(appsettings$simfunction,appsettings$simfunction2)
                   }

                   #all columns are read in as characters, convert some
                   appsettings$use_mbmodel = as.logical(appsettings$use_mbmodel)
                   appsettings$use_doc = as.logical(appsettings$use_doc)
                   appsettings$nplots = as.numeric(appsettings$nplots)

                   #if an mbmodel should be used, check that it exists and load
                   appsettings$mbmodel <- NULL
                   if (appsettings$use_mbmodel)
                   {
                     appsettings$mbmodel = readRDS(paste0(modeldir,"/",appsettings$mbmodelname) )
                     if (! is.list(appsettings$mbmodel))  {return("mbmodel could not be loaded in app.R")}
                   }

                   #if the doc of a file should be parsed for UI generation, get it here
                   appsettings$filepath <- NULL
                   if (appsettings$use_doc)
                   {
                     filepath = paste0(simdir,'/',appsettings$simfunction[1],'.R')
                     if (! file.exists(filepath))  {return("file for function can't be found")}
                     appsettings$filepath = filepath
                   }

                   #file name for documentation
                   currentdocfilename <<- paste0(appdir,"/",appsettings$docname)

                   #make globally available
                   appsettings <<- appsettings

                   #the information is stored in a list called 'appsettings'
                   #different models can have different variables
                   #all models need the following:
                   #variable appid - ID (short name) of the app
                   #variable apptitle - the name of the app. Used to display.
                   #variable docname - name of documentation file for app
                   #variable modelfigname - name of figure file for app
                   #variable simfunction - the name of the simulation function(s)
                   #variable mbmodelname - if there is an mbmodel available, list its name
                   #variable modeltype - the type of the model to be run. if multiple, i.e. containing "_and_" it is set by UI.

                   #additional elements that can be provided:
                   #variable otherinputs - contains additional shiny UI elements that are not generated automatically by functions above
                   #for instance all non-numeric inputs need to be provided separately.
                   #this is provided as text
                   #If not needed, it is empty ""

                   #extract function and other inputs and turn them into a taglist
                   #this uses the 1st function provided by the settings file
                   #indexing sim function in case there are multiple

                   modelinputs <- generate_shinyinput(use_mbmodel = appsettings$use_mbmodel, mbmodel = appsettings$mbmodel,
                                                      use_doc = appsettings$use_doc, model_file = appsettings$filepath,
                                                      model_function = appsettings$simfunction[1],
                                                      otherinputs = appsettings$otherinputs, packagename = packagename)
                   output$modelinputs <- renderUI({modelinputs})


                   #display all inputs and outputs on the analyze tab
                   output$analyzemodel <- renderUI({
                     tagList(
                       tags$div(id = "shinyapptitle", appsettings$apptitle),
                       tags$hr(),
                       #Split screen with input on left, output on right
                       fluidRow(
                         column(6,
                                h2('Simulation Settings'),
                                wellPanel(uiOutput("modelinputs"))
                         ), #end sidebar column for inputs
                         column(6,
                                h2('Simulation Results'),
                                conditionalPanel("output.plotengine == 'ggplot'", shiny::plotOutput(outputId = "ggplot") ),
                                conditionalPanel("output.plotengine == 'plotly'", plotly::plotlyOutput(outputId = "plotly") ),
                                htmlOutput(outputId = "text")
                         ) #end column with outcomes
                       ), #end fluidrow containing input and output
                       #Instructions section at bottom as tabs
                       h2('Instructions'),
                       #use external function to generate all tabs with instruction content
                       withMathJax(do.call(tabsetPanel, generate_documentation(currentdocfilename)))
                     ) #end tag list
                   }) # End renderUI for analyze tab

                   #once UI for the model in the analyze tab is created, switch to that tab
                   updateNavbarPage(session, packagename, selected = "Analyze")
                 },
                 priority = -100
    ) #end observeEvent for the analyze tab

  }) #end lapply function surrounding observeEvent to build app

  #######################################################
  #end code that listens to model selection buttons and creates UI for a chosen model
  #######################################################


    #######################################################
    #start code that listens to the 'run simulation' button and runs a model for the specified settings
    #######################################################
    observeEvent(input$submitBtn, {


      #run model with specified settings
      #run simulation, show a 'running simulation' message
      withProgress(message = 'Running Simulation',
                   detail = "This may take a while", value = 0,
                   {
                     #remove previous plots and text
                     output$ggplot <- NULL
                     output$plotly <- NULL
                     output$text <- NULL
                     #extract current model settings from UI input elements
                     x1=isolate(reactiveValuesToList(input)) #get all shiny inputs
                     x2 = x1[! (names(x1) %in% appNames)] #remove inputs that are action buttons for apps
                     x3 = (x2[! (names(x2) %in% c('submitBtn','Exit') ) ]) #remove further inputs
                     #modelsettings = x3[!grepl("*selectized$", names(x3))] #remove any input with selectized
                     modelsettings = x3
                     #remove nested list of shiny input tags
                     appsettings$otherinputs <- NULL
                     #add settings information from appsettings list
                     modelsettings = c(appsettings, modelsettings)
                     if (is.null(modelsettings$nreps)) {modelsettings$nreps <- 1} #if there is no UI input for replicates, assume reps is 1
                     #if no random seed is set in UI, set it to 123.
                     if (is.null(modelsettings$rngseed)) {modelsettings$rngseed <- 123}
                     #run model, process inside run_model function based on settings
                     result <- run_model(modelsettings)
                     #if things worked, result contains a list structure for processing with the plot and text functions
                     #if things failed, result contains a string with an error message
                     if (is.character(result))
                     {
                       output$ggplot <- NULL
                       output$plotly <- NULL
                       output$text <- renderText({ paste("<font color=\"#FF0000\"><b>", result, "</b></font>") })
                     }
                     else #create plots and text, for plots, do either ggplot or plotly
                     {
                       if (modelsettings$plotengine == 'ggplot')
                       {
                         output$plotengine <- renderText('ggplot')
                         output$ggplot  <- shiny::renderPlot({ generate_ggplot(result) })
                       }
                       if (modelsettings$plotengine == 'plotly')
                       {
                         output$plotengine <- renderText('plotly')
                         output$plotly  <- plotly::renderPlotly({ generate_plotly(result) })
                       }
                       #create text from results
                       output$text <- renderText({ generate_text(result) })
                     }
                   }) #end with-progress wrapper
    } #end the expression being evaluated by observeevent
    ) #end observe-event for analyze model submit button

    #######################################################
    #end code that listens to the 'run simulation' button and runs a model for the specified settings
    #######################################################


  #######################################################
  #Exit main menu
  observeEvent(input$Exit, {
    stopApp('Exit')
  })

} #ends the server function for the app

#######################################################
#This is the UI for the Main Menu of DSAIDE
#######################################################

ui <- fluidPage(
  tags$head(includeHTML(("google-analytics.html"))), #this is only needed for Google analytics when deployed as app to the UGA server. Should not affect R package use.
  tags$head(tags$script('window.onbeforeunload = function() { return "Please use the button on the webpage"; };')), #warning message if user hits browser back button
  includeCSS("packagestyle.css"), #use custom styling
  tags$style(HTML("
        input[type=number] {
              -moz-appearance:textfield;
        }
        input[type=number]::{
              -moz-appearance:textfield;
        }
        input[type=number]::-webkit-outer-spin-button,
        input[type=number]::-webkit-inner-spin-button {
              -webkit-appearance: none;
              margin: 0;
        }
    ")), #meant to remove the selector arrows on numeric input boxes: https://community.rstudio.com/t/how-to-remove-numeric-inputs-spin-button-in-r-shiny/13769/3
  tags$div(id = "shinyheadertitle", "DSAIDE - Dynamical Systems Approach to Infectious Disease Epidemiology"),
  tags$div(id = "shinyheadertext", "A collection of Shiny/R Apps to explore and simulate infectious disease models."),
    br(),
  tags$div(id = "infotext", paste0('This is ', packagename,  ' version ',utils::packageVersion(packagename),' last updated ', utils::packageDescription(packagename)$Date,'.')),
  tags$div(id = "infotext", "Written and maintained by", a("Andreas Handel", href="http://handelgroup.uga.edu", target="_blank"), "with contributions from", a("others.",  href="https://github.com/ahgroup/DSAIDE#contributors", target="_blank")),
  tags$div(id = "infotext", "More information can be found", a("on the package website.",  href="https://ahgroup.github.io/DSAIDE/", target="_blank")),
  navbarPage(title = packagename, id = packagename, selected = 'Menu',
             tabPanel(title = "Menu",
                      tags$div(class='mainsectionheader', 'The Basics'),
                      fluidRow(
                               make_button(at,"basicsir"),
                               make_button(at,"idcharacteristics"),
                               make_button(at,"idpatterns"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input

                      tags$div(class='mainsectionheader', 'The Reproductive Number'),
                      fluidRow(
                        make_button(at,"reproductivenumber1"),
                        make_button(at,"reproductivenumber2"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input

                      tags$div(class='mainsectionheader', 'Controlling Infectious Diseases'),
                      fluidRow(
                        make_button(at,"idcontrolvaccine"),
                        make_button(at,"idcontrolmultioutbreak"),
                        make_button(at,"idcontrolmultigroup"),
                        make_button(at,"idcontrolcomplex"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input

                      tags$div(class='mainsectionheader', 'Types of Transmission'),
                      fluidRow(
                        make_button(at,"directtransmission"),
                        make_button(at,"environmentaltransmission"),
                        make_button(at,"vectortransmission"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input

                      tags$div(class='mainsectionheader', 'Stochastic Models'),
                      fluidRow(
                        make_button(at,"stochasticsir"),
                        make_button(at,"stochasticseir"),
                        make_button(at,"evolution"),
                        class = "mainmenurow"
                      ),
                      tags$div(class='mainsectionheader', 'Fitting Models to Data'),
                      fluidRow(
                        make_button(at,"fitflu"),
                        make_button(at,"fitnoro"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input
                      tags$div(class='mainsectionheader', 'Model Exploration'),
                      fluidRow(
                        make_button(at,"modelexploration"),
                        make_button(at,"usanalysis"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input
                      tags$div(class='mainsectionheader', 'Further Topics'),
                      fluidRow(
                        make_button(at,"hostheterogeneity"),
                        make_button(at,"multipathogen"),
                        #make_button(at,"parasitemodel"),
                        make_button(at,"idsurveillance"),
                        #make_button(at,"maternalimmunity"),
                        class = "mainmenurow"
                      ), #close fluidRow structure for input
                      withTags({
                        div(style = "text-align:left", class="bottomtext",
                            tags$div(id = "bottomtext", 'This collection of model simulations/apps provides covers various aspects of infectious disease epidemiology from a dynamical systems model perspective. The software is meant to provide you with a "learning by doing" approach. You will likely learn best and fastest by using this software as part of a course on the topic, taught by an instructor who can provide any needed background information and help if you get stuck. Alternatively, you should be able to self-learn and obtain the needed background information by going through the materials listed in the "Further Information" section of the apps.'),
                            tags$div(id = "bottomtext", 'The main way of using the simulations is through this graphical interface. You can also access the simulations directly. This requires a bit of R coding but gives you many more options of things you can try. See the package vignette or the "Further Information" section of the apps for more on that.'),
                            tags$div(id = "bottomtext", 'You should start with the apps in the "The Basics" section and read all its instruction tabs since they contain information relevant for all apps. Most apps are arranged in a way that the best approach is to go through each section, and within a section from left to right. Some apps are out of order. If an app builds specifically on earlier ones, it is usually stated in the "Overview" section.')
                        )
                      }), #close withTags function
                      p('Have fun exploring the models!', class='maintext'),
                      fluidRow(
                        downloadButton("modeldownload", "Download R code for all simulations", class="mainbutton"),
                        actionButton("Exit", "Exit", class="exitbutton"),
                        class = "mainmenurow"
                      ) #close fluidRow structure for input

             ), #close "Menu" tabPanel tab

             tabPanel("Analyze",
                      fluidRow(
                        column(12,
                               uiOutput('analyzemodel'),
                               uiOutput('floattask')
                        )
                        #class = "mainmenurow"
                      ) #close fluidRow structure for input
             ) #close "Analyze" tab
  ), #close navbarPage

  tagList( hr(),
           p('All text and figures are licensed under a ',
           a("Creative Commons Attribution-NonCommercial-ShareAlike 4.0 International License.", href="http://creativecommons.org/licenses/by-nc-sa/4.0/", target="_blank"),
           'Software/Code is licensed under ',
           a("GPL-3.", href="https://www.gnu.org/licenses/gpl-3.0.en.html" , target="_blank")
           ,
           br(),
           "This project was/is partially supported by NIH grants U19AI117891, U01AI150747, R25AI147391 and R25GM089694.",
           align = "center", style="font-size:small") #end paragraph
  )
) #end fluidpage

shinyApp(ui = ui, server = server)