hbcd-tlfb: HBCD TLFB shiny app

#   ____________________________________________________________________________
#   startup                                                                 ####

# If local_development, show "Browser button" and set URL parameters
local_development <- (Sys.getenv("R_CONFIG_ACTIVE") != "shinyapps")

source("www/R/startup_global.R", local = TRUE)

# Version number should match in DESCRIPTION
version <- "v0.2.2-alpha"

#   ____________________________________________________________________________
#   ui                                                                      ####

ui <- page(
  includeCSS("www/styles.css"),
  shinyjs::useShinyjs(),
  div(
    id = "show_all_substances",
    prettySwitch(
      "all_substances",
      "Show all substances",
      status = "primary",
      slim = TRUE
    )
  ),
  div(
    id = "inputs_calendar",
    conditionalPanel(
      "input.main_tabs == 'tab_entry'", 
      conditionalPanel(
        "input.nature != 'Routine'", 
        fluidRow(
          column(6,
                 virtualSelectInput(
                   "nb_weeks_display",
                   NULL,
                   choices = choices_weeks_display,
                   selected = 3,
                   inline = TRUE,
                   width = "200px")
                 
          ),
          column(6,
                 prettySwitch(
                   "display_holidays", 
                   "Display Holidays", 
                   status = "primary", 
                   value = TRUE, 
                   slim = TRUE)
          )
        )
      )
    )
  ),
  div(
    id = "calendar_renderRange_replacement",
    conditionalPanel(
      "input.main_tabs == 'tab_entry'", 
      conditionalPanel(
        "input.nature != 'Routine'",
        htmlOutput("text_calendar_range")
      )
    )
  ),
  page_navbar(
    window_title = "HBCD Timeline Followback",
    title = a(img(src = "logo-solo_HBCD_final.png", 
                  style = "height: 45px; position: relative;")),
    id = "main_tabs",
    position = "static-top",
    lang = "en",
    collapsible = TRUE,
    inverse = TRUE,
    footer = if(local_development) actionBttn("start_browser", "Browser"),
    nav(
      "Timeline Followback", 
      value = "tab_entry",
      div(
        id = "data_entry",
        fluidRow(
          column(
            9,
            conditionalPanel(
              "input.nature != 'Routine'", 
              calendarOutput("calendar")
            ),
            conditionalPanel(
              "input.nature == 'Routine'", 
              conditionalPanel(
                "output.tlfb_v1",
                htmltools::includeMarkdown("www/instructions_v1.md")
              ),
              conditionalPanel(
                "! output.tlfb_v1",
                htmltools::includeMarkdown("www/instructions_v2.md")
              )
            )
          ),
          column(
            3,
            uiOutput("radio_buttons_period"),
            conditionalPanel(
              "input.nature == 'Routine'",
              uiOutput("substance_add_routine")),
            conditionalPanel(
              "input.nature == 'Pre-LMP'",
              uiOutput("substance_add_P1")),
            conditionalPanel(
              "input.nature == 'Post-LMP'",
              uiOutput("substance_add_P2")),
            conditionalPanel(
              "input.nature == 'Last Week'",
              uiOutput("substance_add_P3")),
            conditionalPanel(
              "input.nature == 'Last Two Weeks Before Delivery'",
              uiOutput("substance_add_P4"))
          )
        )
      )
    ),
    nav(
      "Submission", 
      value = "tab_submit",
      fluidRow(
        column(
          7, 
          h5("Review:"),
          div(
            class = "review_block",
            h6("Routine:"),
            actionButton("edit_routine", "Edit"),
            span("or"),
            actionButton("delete_routine", "Delete"),
            span("selected record from the table below."),
            br(), br(),
            DTOutput("table_substance_routine")
          ),
          div(
            class = "review_block",
            h6("Periods of Interest:"),
            actionButton("edit_table", "Edit"),
            span("or"),
            actionButton("delete_table", "Delete"),
            span("selected record from the table below."),
            br(), br(),
            DTOutput("table_substance_period")
          )
        ),
        column(
          4,
          offset = 1,
          h5("Submit:"),
          textAreaInput(
            "submit_comments", 
            "(Optional) Send comment on this session:",
            width = "100%"
          ),
          virtualSelectInput(
            "submit_rating",
            "(Optional) Rate the data entry process:", 
            choices = c("No response", "Very Poor", "Poor", "Average", 
                        "Good", "Excellent")
          ),
          actionBttn(
            "submit",
            span(icon("check"), "Submit"),
            style = "material-flat",
            color = "primary")
        )
      )
    )
  )
)


#   ____________________________________________________________________________
#   server                                                                  ####

server <- function(input, output, session) {
  observe({
    if(local_development) browser()
  }) |> bindEvent(input$start_browser)
  
  # Define reactive elements ----
  redcap_dta <- reactiveVal()
  
  existing_record <- reactiveVal()
  
  tlfb_id <- reactiveVal()
  
  tlfb_v <- reactiveVal()
  
  # Used to display the right instructions markdown file:
  output$tlfb_v1 <- reactive(tlfb_v() == 1)
  outputOptions(output, "tlfb_v1", suspendWhenHidden = FALSE)
  
  date_lmp <- reactiveVal(as.Date("1900-01-01", tz = "US/Pacific"))
  date_delivery <- reactiveVal(as.Date("1900-01-01", tz = "US/Pacific"))
  
  dates_study <- reactive(
    list(
      P1 = c((date_lmp() - lubridate::weeks(4)), (date_lmp() - lubridate::weeks(2) - 1)),
      P2 = c((date_lmp() + lubridate::weeks(2)), (date_lmp() + lubridate::weeks(6) - 1)),
      P3 = c((date_today_california - lubridate::weeks(1)), date_today_california - 1),
      P4 = c((date_delivery() - lubridate::weeks(2)), date_delivery() - 1)
    )
  )
  
  timevis_data_cal <- reactiveVal()
  
  substances_names_grouped <- reactiveVal()
  
  # (Optional TODO): change the logic to get rid of this table solely use for
  # ediding/deleting records?
  table_substance_routine_data <- reactiveVal(
    tibble(
      Id = character(0),
      Days = character(0),
      Substance = character(0),
      Frequency = character(0))
  )
  
  # Trigger change in the background color of periods of interest
  change_color_bg <- reactiveTimer(800)
  
  # Source files to generate outputs ----
  files <- list.files(path = "www/R/outputs", pattern = "*.R", recursive = TRUE)
  for (file in files) source(glue("www/R/outputs/{file}"), local = TRUE)$value
  
  # Get REDCap data / Test connection to AWS ----
  observe(
    isolate(
      source("www/R/startup_redcap_aws.R", local = TRUE)
    )
  )
  
  # Update data on "Start Session" ----
  observe(
    source("www/R/observe/update_data_start_session.R", local = TRUE)
  ) |> bindEvent(input$start_session)
  
  # Update data on record addition ----
  observe(
    source("www/R/observe/add_substance_routine.R", local = TRUE)
  ) |> bindEvent(input$add_routine)
  
  observe(
    source("www/R/observe/add_substance_P1.R", local = TRUE)
  ) |> bindEvent(input$add_substance_P1)
  
  observe(
    source("www/R/observe/add_event_P1.R", local = TRUE)
  ) |> bindEvent(input$add_event_P1)
  
  observe(
    source("www/R/observe/add_substance_P2.R", local = TRUE)
  ) |> bindEvent(input$add_substance_P2)
  
  observe(
    source("www/R/observe/add_event_P2.R", local = TRUE)
  ) |> bindEvent(input$add_event_P2)
  
  observe(
    source("www/R/observe/add_substance_P3.R", local = TRUE)
  ) |> bindEvent(input$add_substance_P3)
  
  observe(
    source("www/R/observe/add_event_P3.R", local = TRUE)
  ) |> bindEvent(input$add_event_P3)
  
  observe(
    source("www/R/observe/add_substance_P4.R", local = TRUE)
  ) |> bindEvent(input$add_substance_P4)
  
  observe(
    source("www/R/observe/add_event_P4.R", local = TRUE)
  ) |> bindEvent(input$add_event_P4)
  
  # Show all substances in dropdowns ----
  observe(
    source("www/R/observe/show_all_substances.R", local = TRUE)
  ) |> bindEvent(input$all_substances)
  
  # Update number of weeks displayed ----
  observe(
    source("www/R/observe/update_nb_weeks_display.R", local = TRUE)
  ) |> bindEvent(input$nature)
  
  # Edit/Delete record in table ----
  ## Routine ----
  observe(
    source("www/R/observe/edit_routine_modal.R", local = TRUE)
  ) |> bindEvent(input$edit_routine)
  
  observe(
    source("www/R/observe/edit_routine_confirmed.R", local = TRUE)
  ) |> bindEvent(input$edit_routine_confirmed)
  
  observe(
    source("www/R/observe/delete_routine_modal.R", local = TRUE)
  ) |> bindEvent(input$delete_routine)
  
  observe(
    source("www/R/observe/delete_routine_confirmed.R", local = TRUE)
  ) |> bindEvent(input$delete_routine_confirmed)
  
  
  ## Four periods ----
  observe(
    source("www/R/observe/edit_table_modal.R", local = TRUE)
  ) |> bindEvent(input$edit_table)
  
  observe(
    source("www/R/observe/edit_table_confirmed.R", local = TRUE)
  ) |> bindEvent(input$edit_table_confirmed)
  
  observe(
    source("www/R/observe/delete_table_modal.R", local = TRUE)
  ) |> bindEvent(input$delete_table)
  
  observe(
    source("www/R/observe/delete_table_confirmed.R", local = TRUE)
  ) |> bindEvent(input$delete_table_confirmed)
  
  
  # Change background colors of periods of interest in calendar
  observe(
    source("www/R/observe/change_bg_period.R", local = TRUE)
  ) |> bindEvent(change_color_bg())
  
  
  # Submission ----
  observe(
    source("www/R/observe/submit.R", local = TRUE)
  ) |> bindEvent(input$submit)
}

#   ____________________________________________________________________________
#   Run the application                                                     ####

shinyApp(ui = ui, server = server)