R/shiny-modules.R

In GeeHLee/GoogleR: Google Analytics API into R

#' authDropdown UI [Shiny Module]
#' 
#' @description Makes a dropdown row for use for authentication.
#' 
#' @param id Shiny id.
#' @param width The width of the input
#' @param inColumns whether to wrap selectInputs in width=4 columns.
#'   
#'   Shiny Module for use with \link{authDropdown}.
#'   
#'   
#' @import shiny
#' @return Shiny UI
#' @family Shiny modules
#' @export
#' 
authDropdownUI <- function(id, 
                           width = NULL,
                           inColumns = FALSE){
  
  ns <- shiny::NS(id)
  
  if(inColumns){
    out <- tagList(
      column(width = 4,
             selectInput(ns("accounts"),
                         label="Accounts",
                         choices = NULL,
                         width = width)    
             ),
      column(width = 4,
             selectInput(ns("web.prop"),
                         label="WebProperty",
                         choices = NULL,
                         width = width) 
             ),
      column(width = 4,
             selectInput(ns("view"),
                         label="Select View",
                         choices = NULL,
                         width = width)    
             )
    )
  } else {
    out <- tagList(
      selectInput(ns("accounts"),
                  label="Accounts",
                  choices = NULL,
                  width = width),
      selectInput(ns("web.prop"),
                  label="WebProperty",
                  choices = NULL,
                  width = width),
      selectInput(ns("view"),
                  label="Select View",
                  choices = NULL,
                  width = width)
    )
  }

  out
  
}

#' authDropdown [Shiny Module]
#'
#' Shiny Module for use with \link{authDropdownUI}
#'
#' Call via \code{shiny::callModule(authDropdown, "your_id")}
#'
#' @param input shiny input
#' @param output shiny output
#' @param session shiny session
#' @param ga.table A table of GA tables
#'
#' @return GA View Id selected
#' 
#' @import shiny
#' @family Shiny modules
#' @export
authDropdown <- function(input, output, session, ga.table){
  
  pList <- reactive({
    ga.table <- ga.table()
    
    ga.table[,c('accountName','webPropertyId','websiteUrl','viewName', 'viewId')]
    
  })
  
  observe({
    validate(
      need(pList(), "Need profiles")
    )
    pList  <- pList()
    
    choice <- unique(pList$accountName)
    
    updateSelectInput(session, 
                      "accounts",
                      label="Accounts",
                      choices = choice)
  })
  
  observe({
    validate(
      need(input$accounts, "Need accounts")
    )
    pList  <- pList()
    
    pList <- pList[input$accounts == pList$accountName,]
    
    choice <- pList$websiteUrl
    
    updateSelectInput(session, 
                      "web.prop", label="WebProperty",
                      choices = choice)
  })
  
  observe({
    validate(
      need(input$web.prop, "Need web")
    )
    pList <- pList()
    
    pList <- pList[input$web.prop == pList$websiteUrl,]
    
    choice <- pList$viewId 
    
    names(choice) <- paste(pList$viewName, pList$viewId)
    
    updateSelectInput(session, "view",
                      label="Views",
                      choices = choice)
  })
  
  chosen_view <- reactive({
    validate(
      need(input$view, "Please login")
    )
    pList <- pList()
    
    out <- pList[input$view == pList$viewId,]

    out$viewId
  })
  
  return(chosen_view)
  
}

#' multi_select UI [Shiny Module]
#'
#' Shiny Module for use with \link{multi_select}
#' 
#' Create a Google Analytics variable selector
#' 
#' @param id Shiny id
#' @param label label
#' @param multiple multiple select
#' @param width width of select
#'
#' @return Shiny UI
#' @family Shiny modules
#' @export
multi_selectUI <- function(id, 
                           label = "Metric",
                           multiple = TRUE,
                           width = NULL){
  
  ns <- shiny::NS(id)
  
  selectInput(ns("multi_select"),
              label=label,
              choices = NULL,
              multiple = multiple,
              width = width)
  
}

#' multi_select [Shiny Module]
#'
#' Shiny Module for use with \link{multi_selectUI}
#'
#' Call via \code{shiny::callModule(multi_select, "your_id")}
#'
#' @param input shiny input
#' @param output shiny output
#' @param session shiny session
#' @param type metric or dimension
#' @param subType Limit selections to those relevant
#' @param default The default selected choice. First element if NULL
#'
#' @return the selected variable
#' @family Shiny modules
#' @export
multi_select <- function(input, output, session, 
                         type = c("METRIC","DIMENSION"),
                         subType = c("none","segment","cohort"),
                         default = NULL){
  
  type <- match.arg(type)
  
  ## update select from meta
  observe({
    
    choice <- allowed_metric_dim(type = type, subType = subType)

    s <- choice[1]
    
    if(!is.null(default)){
      
      default <- checkPrefix(default)
      
      if(all(default %in% choice)){
        s <- default
      } else {
        warning("default '", default, "' not in choice")
      }
    }
    
    updateSelectInput(session,
                      "multi_select",
                      choices = choice,
                      selected = s)
  })
  
  return(shiny::reactive(input$multi_select))
  
}