R/PERUapp.R

In Nicolabo/PERUapp:

#' hist Application for PERU team
#'
#'
#'
#'
#'

PERUapp <- function() {

      objects <- ls(pos = 1)

      #check if any dataset was loaded if not, give a message.
      condition <- sapply(objects, function(x) is.data.frame(get(x)))
      if (!any(condition)) {
            stop("You have to load at least one dataset in RStudio",
                 call. = FALSE)
      }

      # determine which are data frames
      dataChoices <- objects[condition]

      resourcePath <- system.file("gadgets", "histwww", package = "PERUapp")
      shiny::addResourcePath("histwww", resourcePath)

      # define the UI for the gadget
      ui <- miniPage(

            tags$head(includeCSS(file.path(resourcePath, "app.css"))),

            gadgetTitleBar(
                  span(strong("PERU application by Nicolabo"))
            ),

            plotOutput("plot", width = "70%", height = "80%"),

            miniTabstripPanel(
                  miniTabPanel(
                        "Main options",
                        icon = icon("cog"),
                        miniContentPanel(
                              padding = 0,
                              fillRow(
                                    # flex = c(2, 3),
                                    flex = c(3, 7),
                                    fillCol(
                                          class = "left-panel-area",
                                          div(
                                                class = 'left-wellpanel-area',
                                                selectInput("data", "1. Choose data:", choices = c('', dataChoices)),
                                                uiOutput('server_cols'),
                                                uiOutput('server_slider'),
                                                uiOutput('server_bins')
                                          )
                                    ),
                                    fillCol(
                                          class = "plot-area",
                                          div()
                                    )
                              )
                        )
                  )
                  ,
                  miniTabPanel(
                        "Advanced options",
                        icon = icon("sliders"),
                        miniContentPanel(
                              padding = 0,
                              fillRow(
                                    # flex = c(2, 3),
                                    flex = c(3, 7),
                                    fillCol(
                                          class = "left-panel-area",
                                          div(
                                                class = 'left-wellpanel-area',
                                                h5('Diversify the variable you choose in Main Options tab:'),
                                                checkboxInput("diversify", 'Diversify', FALSE),
                                                conditionalPanel(
                                                      condition = "input.diversify != false",
                                                      checkboxInput("density", 'Show density line', FALSE),
                                                      uiOutput("server_cols_fact"),
                                                      uiOutput("server_params")
                                                )
                                          )
                                    ),
                                    fillCol(
                                          class = "plot-area",
                                          div()
                                    )
                              )
                        )
                  )
            )
      )

      server <- function(input, output, session) {

            observeEvent(input$cancel, {
                  stopApp(stop("User canceled", call. = FALSE))
            })

            mainPanelData <- reactive({
                  get(input$data)
            })

            output$server_cols <- renderUI({
                  validate(need(input$data != "", "Firstly select a dataset."))
                  data <- mainPanelData()
                  nam <- colnames(data)
                  selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
            })

            output$server_bins <- renderUI({

                  req(input$cols)

                  df <- isolate(mainPanelData()); x <- eval(input$cols)
                  max_value <- abs(round(max(df[,x], na.rm = T)/10,2))

                  numericInput('bins','Choose width of bins:', value = max_value/2)
            })

            output$server_slider <- renderUI({

                  req(input$cols)

                  df <- isolate(mainPanelData()); col_name <- eval(input$cols)
                  minV <- min(df[,col_name], na.rm = T); maxV <- max(df[,col_name], na.rm = T)

                  min_value <- plyr::round_any(minV, accuracy = 10, f = floor)
                  max_value <- plyr::round_any(maxV, accuracy = 10, f = ceiling)

                  sliderInput('slider','Choose a X-axis range:', min = min_value,
                              max = max_value, value = c(min_value, max_value))
            })

            output$server_cols_fact <- renderUI({

                  req(input$data)

                  data <- mainPanelData(); nam <- colnames(data)
                  selectizeInput('cols_fact', "Choose a fill columns:",
                                 choices = nam[sapply(data, function(x) length(unique(x)) < 20)])
            })

            output$server_params <- renderUI({

                  req(input$cols_fact)

                  data <- isolate(mainPanelData()); col_nam <- input$cols_fact
                  params_vec <- unique(as.character(data[[col_nam]]))
                  selectizeInput('params', "Choose arguments of fill columns:", choices = params_vec,
                                 selected = params_vec, multiple = TRUE,
                                 options = list(placeholder = 'Click to select at least one factor'))

            })

            getDataParams <- eventReactive({
                  if(is.null(input$params) || !(input$cols_fact %in% colnames(mainPanelData()))){
                        NULL
                  }
                  else {
                        if(all(input$params %in% mainPanelData()[[input$cols_fact]])){
                              1
                        }
                        else {
                              NULL
                        }
                  }}, {
                        df <- isolate(mainPanelData())
                        factor_col <- input$cols_fact
                        col_diverse <- eval(factor_col)

                        criteria <- interp(~col_diverse %in% input$params, col_diverse = as.name(col_diverse))
                        df <- df %>%
                              filter_(criteria) %>%
                              mutate_each_(funs(factor), factor_col)
                  }, ignoreNULL = TRUE
            )

            output$plot <- renderPlot({
                  if (!is.null(isolate(input$cols)) & !is.null(input$bins) & !is.null(input$slider)) {

                        basicData <- isolate(mainPanelData())
                        var <- eval(isolate(input$cols))

                        validate(need(input$bins > 0, 'Number of bins has to be a positive value.'))

                        if (input$diversify == F) {
                              plot <- ggplot(basicData, aes_string(var)) +
                                    geom_histogram(color = 'white', fill = categorical_colors[1], binwidth = input$bins) +
                                    theme_peru()
                        }
                        else {
                              diversifyData <- getDataParams()
                              factor_col <- input$cols_fact

                              if (input$density == F) {
                                    plot <- ggplot(diversifyData, aes_string(var, fill = diversifyData[[factor_col]])) +
                                          geom_histogram(binwidth = input$bins, color = 'white') +
                                          theme_peru('fill')
                              }
                              else {
                                    plot <- ggplot(diversifyData, aes_string(var, fill = diversifyData[[factor_col]])) +
                                          geom_density(color = 'white', alpha = 0.5) +
                                          theme_peru('fill')
                              }
                        }
                        plot <- plot +
                              geom_hline(yintercept = 0, color = 'gray88') +
                              coord_cartesian(xlim = c(input$slider[1], input$slider[2])) +
                              scale_y_continuous(labels = comma) +
                              scale_x_continuous(labels = comma)
                  }
                  plot

            })

            observeEvent(input$done, {
                  stopApp(stop("", call. = FALSE))
            })

            observeEvent(input$data, { updateCheckboxInput(session, input = 'diversify', label = "Diversify", value = FALSE)
            })

      }
      runGadget(ui, server, viewer = dialogViewer("PERU App", width = 1200, height = 630))
}