inst/app/server.R

In cypressf/EPPADashboard: An Interactive Dashboard for Exploring GCAM Scenario Data

library(shiny)
library(rgcam)
library(magrittr)
library(readxl)
library(dplyr)
library(readr)
library(purrr)
library(fs)
library(GCAMdashboard)
library(tibble)
library(stringr)
library(randomcoloR)

options(shiny.maxRequestSize=512*1024^2) # 512 MB max file upload size.

# Define server logic required to draw a histogram
shinyServer(function(input, output, session) {

    ## Set up some UI state
    scenarios <- ""
    queries <- ""

    # Initialize reactive values to hold the data frame being displayed in both
    # the time plot view and the map plot view. These data frames are used for
    # getting hover values and for viewing the raw table data.
    timePlot.df <- reactiveVal()
    timePlot.plot_type <- reactiveVal()

    ## Get the new data file on upload
    rFileinfo <- reactive({
        fileinfo <- input$projectFile
        project.settings <- loadDefaultProjectSettings()
        project.regionSettings <- loadDefaultRegionSettings()
        project.sectorColors <- loadDefaultSectorColors()
        project.data <- loadDefault(project.regionSettings)


        if(!is.null(fileinfo)) {
            extraData <- loadProject2(fileinfo$datapath, project.regionSettings)
            extraScenario <- attr(extraData, "scenario_name")
            project.data[[extraScenario]] <- extraData
        }

        updateSelectInput(session, 'scenarioInput', choices=rev(listScenarios(project.data)))
        list(project.data=project.data,
             project.settings=project.settings,
             project.regionSettings=project.regionSettings,
             project.sectorColors=project.sectorColors)
    })

    ## Update controls on sidebar in response to user selections
    observe({
        if(is.null(rFileinfo()$project.data)) {
            new.scenarios <- list()
        }
        else {
            new.scenarios <- getProjectScenarios(rFileinfo)
        }

        if(!all(scenarios == new.scenarios)) {
            scenarios <<- new.scenarios # Update UI state
            updateSelectInput(session, 'plotScenario', choices=scenarios)
            updateSelectInput(session, 'diffScenario', choices=scenarios)
        }

        if(!is.null(rFileinfo()$project.data)) {
            if(input$plotScenario == "") {
                # When first loading a dataset, no scenario is selected
                qscenarios <- scenarios
            }
            else if(input$diffCheck) {
                qscenarios <- c(input$plotScenario, input$diffScenario)
            }
            else {
                qscenarios <- input$plotScenario
            }
            new.queries <- getScenarioQueries(rFileinfo, qscenarios)

            if(!identical(queries,new.queries)) {
                ## capture new query list
                queries <<- new.queries
                ## preserve selected value if possible
                sel <- input$plotQuery
                if(!(sel %in% queries))
                    sel <- NULL          # allow update to reset selection
                updateSelectInput(session, 'plotQuery', choices=queries,
                                  selected=sel)
            }
        }

    })

    observe({
        ## update the subcategory selector on the time value plot.
        ## Only do this when the selected plot query changes.
        scen <- isolate(input$plotScenario)
        prj <- isolate(rFileinfo()$project.data)
        query <- input$plotQuery
        if(uiStateValid(prj, scen, query)) {
            ## Assumes that a particular query has the same columns in all scenarios
            subcategories <- getSubcategories()
            prevSubcat <- if(input$subcategorySelect %in% subcategories) input$subcategorySelect else 'none'
            updateSelectInput(session, 'subcategorySelect', choices=c('none', subcategories),
                              selected=prevSubcat)
        }
    })

    getSubcategories <- reactive({
        scen <- isolate(input$plotScenario)
        prj <- isolate(rFileinfo()$project.data)
        query <- input$plotQuery
        data <- getQuery(prj, query, scen)
        possible_subcategories <- data %>% names
        subcategories <- list()

        i <- 1
        for (subcategory in possible_subcategories) {
            if (!all(is.na(data[subcategory]))) {
                subcategories[[i]] <- subcategory
                i <- i + 1
            }
        }

        subcategories[!subcategories %in% c('scenario', 'order', 'Units', 'year', 'value')]
    })

    output$scenarios <- renderText({
        getProjectScenarios(rFileinfo, concat='\n')
    })

    output$queries <- renderText({
        getScenarioQueries(rFileinfo, input$scenarioInput, concat='\n')
    })

    getTimePlot <- function()
    {
        prj <- rFileinfo()$project.data
        settings <- rFileinfo()$project.settings
        regionSettings <- rFileinfo()$project.regionSettings
        sectorColors <- rFileinfo()$project.sectorColors
        scen <- input$plotScenario
        query <- input$plotQuery
        plot_type <- filter(settings, query == !!query)$type

        if(!uiStateValid(prj, scen, query)) return(default.plot())

        diffscen <- if(input$diffCheck) input$diffScenario else NULL
        if (!is.null(diffscen) && diffscen == scen) {
            return(default.plot("Scenarios are the same"))
        }

        subcategorySelect <- input$subcategorySelect

        region.filter <- input$tvRgns
        last.region.filter <<- region.filter

        # If the query has changed, the value of the subcategory selector
        # may not be valid anymore. Change it to none.
        if(!subcategorySelect %in% names(getQuery(prj, query, scen))) {
            subcategorySelect <- 'none'
        }

        plt <- plotTime(prj, plot_type, query, scen, diffscen, subcategorySelect,
                        input$tvFilterCheck, region.filter, regionSettings, sectorColors)
        timePlot.df(plt$plotdata)
        timePlot.plot_type(plot_type)
        plt$plot
    }

    output$timePlot <- renderPlot({
        getTimePlot()
    })

    output$region_controls <- renderUI({
        prj <- rFileinfo()$project.data
        regionSettings <- rFileinfo()$project.regionSettings %>%
            select(region, group)
        scen <- input$plotScenario
        query <- input$plotQuery
        if(uiStateValid(prj, scen, query)) {
            tbl <- getQuery(prj,query,scen)
            regions <- unique(tbl$region) %>% sort
            # Tibble with two columns: (group, region)
            # group is name of group
            # region is list of regions
            regions_by_group <- tibble(region = regions) %>%
                left_join(regionSettings) %>%
                group_by(group) %>%
                summarize(region = list(region)) %>%
                mutate(group = as.character(group))
            checkboxMultiGroupInput("tvRgns", choicesByLabel = regions_by_group, selected = last.region.filter)
        } else {
            checkboxGroupInput("tvRgns", "Regions")
        }
    })

    output$show_breakdown_input <- reactive({
        settings <- rFileinfo()$project.settings
        query <- input$plotQuery
        plot_type <- filter(settings, query == !!query)$type
        plot_type != "line"
    })

    output$download_plot <- downloadHandler(
        filename = function() {
            "plot.png"
        },
        content = function(file) {
            plotPNG(function(){print(getTimePlot())}, filename = file, res = 150, width = 1500, height = 1200)
        }
    )

    # Debugging
    observe({
        print('****************Change of Input****************')
        cat('plotScenario: ', input$plotScenario, '\n')
        cat('diffScenario: ', input$diffScenario, '\n')
        cat('plotQuery: ', input$plotQuery, '\n')
    })

    outputOptions(output, "show_breakdown_input", suspendWhenHidden = FALSE)

    # Add a hover over the time plot bar chart
    callModule(
        barChartHover,
        "timePlot",
        reactive(input$exploreHover),
        reactive(timePlot.df()),
        reactive(timePlot.plot_type()),
        reactive(input$subcategorySelect)
    )
})