inst/shiny_app/main.R

# Module UI function ------------------------------------------------------
mainUI <- function(id) {

  # Create a namespace function using the provided id ---------------------
  ns <- NS(id)

  fluidPage( # Top panel -----------------------------------------------------------
    div(
      id = "rcorners5",

      fluidRow(
        column(
          2,
          align = "left",
          img(
            src = "duck-hunter.gif",
            alt = "duck hunter",
            height = "100"
          )
        ),
        column(
          6,
          align = "center",
          h2("huntfishapp: Exploratory Data Analysis App for Hunting, Fishing, and Outdoor Recreation")
        ),
        column(
          4,
          align = "right",
          img(
            src = "fish_hunt_logo_no_text_crop.png",
            alt = "fish hunt logo",
            height = "100"
          )
        )
      )
    ),

    # Filter sidebar --------------------------------------------------
    sidebarLayout(
      sidebarPanel(
        bsplus::bs_modal(
          id = "modalFilters",
          title = "Filters Sidebar",
          body = includeHTML("descriptions/filters.html"),
          size = "medium"
        ),
        div(style = "display: inline; float: right;",
        bsplus::shiny_iconlink("info-circle", "fa-2x") %>%
          bsplus::bs_attach_modal(id_modal = "modalFilters")),
        h4(HTML("Item Attributes")),
        selectizeInput(
          ns("itemType"),
          label = "Item Type(s):",
          choices = itemType,
          selected = itemTypeDefault,
          multiple = TRUE,
          width = "100%"
        ),
        checkboxGroupInput(
          ns("itemResidency"),
          label = "Item Residency:",
          choices = c(
            "Resident Item" = "T",
            "Non-resident Item" = "F"
          ),
          selected = itemResidencyDefault
        ),
        selectizeInput(
          ns("duration"),
          label = "Item Duration(s):",
          choices = duration,
          selected = durationDefault,
          multiple = TRUE,
          width = "100%"
        ),
        hr(),
        h4(HTML("Customer Demographics")),
        sliderInput(
          ns("age"),
          label = "Age:",
          min = 0,
          max = 100,
          value = ageDefault,
          step = 1
        ),
        checkboxGroupInput(
          ns("gender"),
          label = "Gender:",
          choices = c("Female", "Male"),
          selected = genderDefault
        ),
        hr(),
        h4(HTML("Purchase Date")),
        sliderInput(
          ns("itemYear"),
          label = "Item Year:",
          min = itemYear[1],
          max = itemYear[2],
          value = itemYearDefault,
          step = 1,
          sep = ""
        ),
        hr(),
        h4(HTML("Customer Address")),
        checkboxGroupInput(
          ns("residency"),
          label = "Residency:",
          choices = c("Resident" = "T", "Non-resident" = "F"),
          selected = residencyDefault
        ),
        selectizeInput(
          ns("county"),
          label = "County of Residence:",
          choices = county,
          selected = countyResidencyDefault,
          multiple = T
        ),
        width = 2
      ),
      mainPanel(
        tags$div(class = "sticky_footer", 
                 tags$p("This software has been approved for release by the U.S. Geological Survey (USGS). Although the software has 
                                       been subjected to rigorous review, the USGS reserves the right to update the software as needed pursuant to
                                       further analysis and review. No warranty, expressed or implied, is made by the USGS or the U.S. Government as to
                                       the functionality of the software and related material nor shall the fact of release constitute any such warranty.
                                       Furthermore, the software is released on condition that neither the USGS nor the U.S. Government shall be held
                                       liable for any damages resulting from its authorized or unauthorized use."),
                 tags$a(align = "center", href="https://snr.unl.edu/aboutus/who/people/faculty-member.aspx?pid=1394", "Contact information for Chris Chizinski")
                 )
        ,

        # Filter description -------------------------------------------
        htmlOutput(ns("filterDesc")),

        # Hidden input active panel (used with shinytest) --------------
        if (isTRUE(getOption("shiny.testmode"))) {
          conditionalPanel(condition = "false",
                           selectInput(
                             ns("activePanelSelect"),
                             label = "Active Panel:",
                             choices = c(
                               "",
                               "revenue",
                               "customers",
                               "gender",
                               "age",
                               "map",
                               "recruitment",
                               "churn",
                               "upset",
                               "radialsets"
                             ),
                             selected = ""
                           ))
        },
        shinyBS::bsCollapse(
          id = ns("collapsePlotModules"),

          # Plot modules -----------------------------------------------
          shinyBS::bsCollapsePanel("Revenue",
            value = "revenue",
            revenueUI(ns("revenue"))
          ),
          shinyBS::bsCollapsePanel("Customers",
            value = "customers",
            customersUI(ns("customers"))
          ),
          shinyBS::bsCollapsePanel("Gender Ratio",
            value = "gender",
            genderUI(ns("gender"))
          ),
          shinyBS::bsCollapsePanel("Age Distribution",
            value = "age",
            ageUI(ns("age"))
          ),
          shinyBS::bsCollapsePanel("Map",
            value = "map",
            mapUI(ns("map"))
          ),
          shinyBS::bsCollapsePanel("Recruitment",
            value = "recruitment",
            recruitmentUI(ns("recruitment"))
          ),
          shinyBS::bsCollapsePanel("Churn",
            value = "churn",
            churnUI(ns("churn"))
          ),
          shinyBS::bsCollapsePanel("Item Combinations (UpSet plot)",
            value = "upset",
            upsetUI(ns("upset"))
          ),
          shinyBS::bsCollapsePanel("Item Combinations (Radial Sets plot)",
            value = "radialsets",
            radialsetsUI(ns("radialsets"))
          )
        ),
        width = 10
      )
    )
  )
}


# Module server function --------------------------------------------------
main <- function(input, output, session, sharedInputs) {

  # Define namespace ------------------------------------------------------
  ns <- session$ns

  # Define data filters ---------------------------------------------------
  dataFilters <- reactive({

    # Create list of filters (NULL values are dropped)
    activeFilters <- list()
    activeFilters$itemType <- input$itemType
    activeFilters$duration <- input$duration
    activeFilters$itemResidency <- input$itemResidency
    activeFilters$gender <- input$gender
    activeFilters$age <- if (all(input$age %in% c(0, 100))) {
      NULL
    } else {
      input$age
    }
    activeFilters$itemYear <- input$itemYear
    activeFilters$residency <- input$residency
    activeFilters$county <- input$county

    # Return data
    return(activeFilters)
  }) %>% debounce(2e3)


  # Create filter description ---------------------------------------------
  output$filterDesc <- renderText({

    # Filters must be available
    req(dataFilters())

    activeFilters <- dataFilters()

    # Replace T and F with descriptions
    if (!is.null(activeFilters[["itemResidency"]])) {
      activeFilters[["itemResidency"]] <-
        stringr::str_replace(activeFilters[["itemResidency"]], "T", "Resident Item")
      activeFilters[["itemResidency"]] <-
        stringr::str_replace(activeFilters[["itemResidency"]], "F", "Nonresident Item")
    }
    if (!is.null(activeFilters[["residency"]])) {
      activeFilters[["residency"]] <-
        stringr::str_replace(activeFilters[["residency"]], "T", "Resident")
      activeFilters[["residency"]] <-
        stringr::str_replace(activeFilters[["residency"]], "F", "Nonresident")
    }

    # Convert filter list to string
    desc <- paste(lapply(
      activeFilters,
      FUN = function(s)
        paste(s, collapse = ", ")
    ), collapse = " | ")

    paste('<p style="padding: 1em 0 1em 0;"><font color="black"><b>Active Filters:</b></font>', desc, "</p>")
  })

  # Active panel ----------------------------------------------------------
  activePanel <- reactive({
    input$collapsePlotModules
  })

  sharedInputs$activePanel <- activePanel

  # Update active panel (used with shinytest) -------------------------------
  observe({
    shinyBS::updateCollapse(session,
      "collapsePlotModules",
      open = input$activePanelSelect
    )
  })

  # Call shiny modules ----------------------------------------------------
  callModule(revenue, "revenue", dataFilters, sharedInputs)
  callModule(customers, "customers", dataFilters, sharedInputs)
  callModule(gender, "gender", dataFilters, sharedInputs)
  callModule(age, "age", dataFilters, sharedInputs)
  callModule(map, "map", dataFilters, sharedInputs)
  callModule(recruitment, "recruitment", dataFilters, sharedInputs)
  callModule(churn, "churn", dataFilters, sharedInputs)
  callModule(upset, "upset", dataFilters, sharedInputs)
  callModule(radialsets, "radialsets", dataFilters, sharedInputs)
  
  
}
chrischizinski/huntfishapp documentation built on Sept. 7, 2020, 12:14 p.m.