R/model_shiny_templates.R

Defines functions model_path ga_model_shiny_load make_auth_dropdown shiny_ui make_model_template make_model_libraries make_date_range has_server_object ga_model_shiny_template_make template_type write_template_object create_app_from_template ga_model_shiny ga_model_shiny_template

Documented in ga_model_shiny ga_model_shiny_load ga_model_shiny_template

#' Get a Shiny template file
#' 
#' Gets a pre-created template from the googleAnalyticsR samples
#' 
#' @param name the template name
#' @param read_lines If TRUE will use `readLines()` to print out the template contents
#' 
#' @export
#' @family GA modelling functions
ga_model_shiny_template <- function(name = "list", read_lines = FALSE){
  
  if(name == "list"){
    return(list.files(system.file("models","shiny_templates", 
                                  package = "googleAnalyticsR"),
                      recursive = TRUE))
  }
  
  f <- system.file("models","shiny_templates",name, 
                   package = "googleAnalyticsR")
  if(!nzchar(f)){
    stop("Couldn't find template named ", name, call. = FALSE)
  }
  
  if(read_lines){
    return(readLines(f))
  }
  
  f
}


#' Create a Shiny app from a ga_model file
#' 
#' @param models The [ga_model] file location ("my_model.gamr") or a [ga_model] object - can pass in multiple as a list
#' @param template The template Shiny files for the Shiny app - passed to `shiny::runApp()`
#' @param header_boilerplate Whether to add header boilerplate to the template
#' @param auth_dropdown What type of account picker to include
#' @param web_json The client.id json file for Web
#' @param scopes The scope the API requests will be under
#' @param title The title of the Shiny app
#' @param local_folder If not empty, will not launch Shiny app but write code to the folder location you put here
#' @param deployed_url If deploying Shiny app to a server, put the URL of the deployed app here so the authentication will redirect to the correct place
#' @param date_range Most templates support a {{ date_range }} global input for the data import functions, set this to FALSE to remove it
#' @param ... Extra macro variables the template may support: a named list with the name being a template variable
#' 
#' @details 
#' 
#' As [ga_model] objects have standardised code, they can be used to build standard templated Shiny apps.  Templates are made using the [whisker.render][whisker::whisker.render] function
#' 
#' Some templates are included with the package, seen via `ga_model_shiny_template("list")`
#' 
#' Templates hold macro variables indicated via \code{ \{\{ macro_name \}\} } in the Shiny app template code. See `ga_model_shiny_template("basic_app", TRUE)` for an example showing a minimal viable app.  Templates can be files such as ui.R or app.R files; folders containing ui.R, app.R files; or ui.R with html files for advanced themes - see [Shiny HTML templates](https://shiny.rstudio.com/articles/templates.html). All additional files that may be in the folder are also copied over (such as global.R or www/ folders)
#' 
#' Templates contain code to allow multi-user login via Google OAuth2.
#' 
#' If your template is pointing at a file such as ui.R or app.R it will create an app.R Shiny object.  If your template is pointing at a directory it will check for the presence of ui.R within the folder.  In either case if the server.R is missing it will use the boilerplate version from `ga_model_shiny_template("boilerplate")`
#' 
#' By default the Shiny app is launched which in most cases will prompt authorisation for your Google Analytics.  You can instead write the app out using `local_folder` to a valid location for deployment later.
#' 
#' @section Template macro variables:
#' 
#' \itemize{
#'  \item{\code{\{\{\{ model_libraries \}\}\}}}{- Adds `library()` calls based on models$required_packages}
#'  \item{\code{\{\{\{ web_json \}\}\}}}{- Adds Google OAuth2 client for web applications}
#'  \item{\code{\{\{\{ scopes \}\}\}}}{- Adds Google OAuth2 scopes for the API calls}
#'  \item{\code{\{\{\{ deployed_url \}\}\}}}{- Adds `option(googleAuthR.redirect)` option for deployed Shiny apps}
#'  \item{\code{\{\{\{ model_load \}\}\}}}{- Adds [ga_model_load] calls loading all models in the list passed to this function's `models` argument.  It creates R objects called 'model1', 'model2' etc. in the Shiny app code}
#'  \item{\code{\{\{\{ model_list \}\}\}}}{- Adds a list of the model objects after model_load.  Useful for creating custom functions in themes that can loop over model objects}
#'  \item{\code{\{\{\{ shiny_title \}\}\}}}{- Adds the title to the Shiny app}
#'  \item{\code{\{\{\{ auth_ui \}\}\}}}{- Adds the correct dropdown Shiny module for picking a GA4 or Universal Analytics properties}
#'  \item{\code{\{\{\{ date_range \}\}\}}}{- Adds a `shiny::dateInput()` date selector with id "date_range" for use in model's data fetching functions}
#'  \item{\code{\{\{\{ model_ui \}\}\}}}{- Adds the models UI elements as configured in the [ga_model] object.  It uses the object loaded above via the model_load macro.  It looks like `model1$ui('model1')` in the code.}
#'  \item{\code{\{\{\{ auth_server \}\}\}}}{- Adds the authentication module's server side function}
#'  \item{\code{\{\{\{ auth_accounts \}\}\}}}{- Adds a call to [ga_account_list] for the appropriate GA account type (GA4 or Universal)}
#'  \item{\code{\{\{\{ model_server \}\}\}}}{- Adds the server side module for the models as configured in the [ga_model] configuration. It uses the object loaded above via the model_load macro.  It looks like `model1$server('model1')` in the code.}
#'  \item{\code{\{\{\{ model1 \}\}\}}}{- Alternative to `model_load`, this will load the model file location instead, which you can pass to `ga_model_load()`} in the template.  model1 is the first model passed, model2 the second, etc.
#'  \item{\code{\{\{\{ your_argument \}\}\}}}{- You can pass in your own custom variables to the template via the `...` argument of this function if they are named the same as the template macro variable}
#' }
#' 
#' 
#' @export
#' @importFrom assertthat is.readable is.writeable
#' @importFrom whisker whisker.render
#' 
#' @examples
#' 
#' # see Shiny templates included with the package
#' ga_model_shiny_template("list")
#' 
#' # see an example of an ui.R template with macros
#' ga_model_shiny_template("basic/ui.R", read_lines = TRUE)
#' 
#' # see an example of an app.R template with macros
#' ga_model_shiny_template("basic_app/app.R", read_lines = TRUE)
#' 
#' \dontrun{
#' 
#' # a universal analytics model using default template "basic"
#' ga_model_shiny(
#'   ga_model_example("decomp_ga.gamr"), 
#'   auth_dropdown = "universal")
#'
#' # a template from a directory holding an app.R file
#' ga_model_shiny(
#'   ga_model_example("decomp_ga.gamr"), 
#'   auth_dropdown = "universal",
#'   template = ga_model_shiny_template("basic_app"))
#'   
#'   
#' # a template from only an ui.R file that will import boilerplate server.R
#' ga_model_shiny(
#'   ga_model_example("decomp_ga.gamr"), 
#'   auth_dropdown = "universal",
#'   template = ga_model_shiny_template("basic/ui.R"))
#'
#' # a template from a custom html based theme
#' ga_model_shiny(
#'   ga_model_example("decomp_ga.gamr"), 
#'   auth_dropdown = "universal",
#'   template = ga_model_shiny_template("html_based"))
#' 
#' # a template using library(argonDash)
#' ga_model_shiny(
#'   ga_model_example("ga-effect.gamr"), 
#'   title = "Argon Demo",
#'   auth_dropdown = "universal",
#'   template = ga_model_shiny_template("argonDash") )
#' 
#' # multiple models
#' m3 <- ga_model_example("time-normalised.gamr")
#' m4 <- ga_model_example("ga-effect.gamr")
#' 
#' # launch in gentelella template
#' ga_model_shiny(list(m4, m3), auth_dropdown = "universal",
#'               template = ga_model_shiny_template("gentelella"))
#' 
#'      
#' # you can make custom ui embedded within the template file
#' # use \{\{\{ model_list \}\}\} to work with the models in the ui.R
#' 
#' # below adds custom macro 'theme' and a custom ui in box tabs
#' ga_model_shiny(list(m4, m3), auth_dropdown = "universal", 
#'                template = ga_model_shiny_template("shinythemes"), 
#'                theme = "yeti")
#'
#' # shinydashboard's custom ui functions put a model in each side tab      
#' ga_model_shiny(list(m4, m3), auth_dropdown = "universal", 
#'                template = ga_model_shiny_template("shinydashboard"), 
#'                skin = "green")
#'                
#' # send in lots of theme variables to bslib in shiny > 1.6.0
#' ga_model_shiny(list(m4, m3), auth_dropdown = "universal",
#'                template = ga_model_shiny_template("basic_bslib"), 
#'                bg = "white", fg = "red", primary = "grey")
#'  
#' # write out an app to a local folder
#' ga_model_shiny(list(m4, m3), auth_dropdown = "universal",
#'                template = ga_model_shiny_template("basic_bslib"), 
#'                bg = "white", fg = "red", primary = "grey",
#'                local_folder = "deploy_shiny")
#' }
#' 
#' 
#' 
#' @family GA modelling functions
ga_model_shiny <- function(
  models,
  template = ga_model_shiny_template("basic"),
  header_boilerplate = TRUE,
  title = "ga_model_shiny",
  auth_dropdown = c("ga4","universal","none"),
  web_json = Sys.getenv("GAR_CLIENT_WEB_JSON"),
  date_range = TRUE,
  scopes = "https://www.googleapis.com/auth/analytics.readonly",
  deployed_url = "",
  local_folder = "",
  ...){
  
  auth_dropdown <- match.arg(auth_dropdown)
  
  # make a deployment folder
  if(nzchar(local_folder)){
    
    if(!dir.exists(local_folder)){
      dir.create(local_folder)
      assert_that(is.writeable(local_folder))
    }
    
    # for apps we don't need to make an app folder
    if(grepl("^app", template_type(template))){
      # a useful Dockerfile
      file.copy(ga_model_shiny_template("boilerplate/Dockerfile_app"), 
                to = file.path(local_folder, "Dockerfile"),
                overwrite = TRUE)
      
    } else {
      # a useful Dockerfile
      file.copy(ga_model_shiny_template("boilerplate/Dockerfile_ui_server"), 
                to = file.path(local_folder, "Dockerfile"),
                overwrite = TRUE)
      
      # this is in the root, to aid deployment
      file.copy(ga_model_shiny_template("boilerplate/deploy.R"), 
                to = file.path(local_folder, "app.R"),
                overwrite = TRUE)
      # the rest of the app is copied to local_folder/app/
      local_folder <- file.path(local_folder, "app")
      dir.create(local_folder, showWarnings = FALSE)
    }
    # copy web_json file over
    file.copy(web_json, 
              to = file.path(local_folder, basename(web_json)),
              overwrite = TRUE)
    web_json <- basename(web_json)
    if(!nzchar(deployed_url)){
      myMessage("If deploying this app online remember to set the 'deployed_url' to the URL of the final Shiny app location and set the same URL in the GCP console web client settings", 
                level = 3)
    }
  }
  
  if(is.ga_model(models)){
    models <- list(models)
  }
  
  model_locations <- lapply(models, model_path, local_path = local_folder)
  # model1, model2, etc.
  names(model_locations) <- paste0("model", seq_along(models))
  
  assert_that(is.readable(template),
              nzchar(web_json),
              nzchar(scopes))
  
  model_template <- make_model_template(
    model_locations, 
    date_range = date_range)
  
  txt <- ga_model_shiny_template_make(
    template, 
    header_boilerplate = header_boilerplate)
  
  values <- c(list(...),
              make_date_range(date_range),
              make_auth_dropdown(auth_dropdown), 
              model_locations,
              model_template,
              make_model_libraries(models),
              web_json = web_json,
              scopes = scopes,
              deployed_url = deployed_url,
              shiny_title = title)
  
  myMessage("passed template values:\n", 
            paste(names(values),"=",values, collapse = "\n"),
            level = 2)
  
  render <- lapply(txt, whisker.render, data = values)

  if(nzchar(local_folder)){
    write_template_object(render, local_folder)
    # copy over any dependencies in template folder
    file.copy(list.files(template, full.names = TRUE), 
              local_folder, recursive = TRUE, overwrite = FALSE)   
    return(invisible(render))
  }
  
  tmp_dir <- tempdir()
  if(dir.exists(template)){
    # copy over any dependencies in template folder
    file.copy(list.files(template, full.names = TRUE), 
              tmp_dir, recursive = TRUE, overwrite = FALSE)    
  }

  write_template_object(render, tmp_dir)
  
  myMessage("Launching Shiny app from", tmp_dir, level = 3)
  
  shiny_obj <- create_app_from_template(render, tmp_dir)
  shiny::runApp(shiny_obj)
}

create_app_from_template <- function(output, location){
  if(!is.null(output$app) && nzchar(output$app)){
    myMessage("Detected Shiny app.R for location:", location, level = 3)
    app <- source(file.path(location, "app.R"), chdir = TRUE)
    return(app$value)
  }
  
  # a shiny app in location with ui.R and server.R
  ui     <- source(file.path(location, "ui.R"), chdir = TRUE)
  server <- source(file.path(location, "server.R"), chdir = TRUE)

  shiny::shinyApp(
    googleAuthR::gar_shiny_ui(ui$value, 
                              login_ui = googleAuthR::silent_auth), 
    server$value)
  
}

write_template_object <- function(output, destination_folder){
  if(!dir.exists(destination_folder)){
    dir.create(destination_folder)
  }

  if(!is.null(output$app) && nzchar(output$app)){
    loc <- file.path(destination_folder, "app.R")
    myMessage("Writing Shiny app.R to", loc, level = 2)
    writeLines(output$app, loc)
  }
  
  if(!is.null(output$ui) && nzchar(output$ui)){
    loc <- file.path(destination_folder, "ui.R")
    myMessage("Writing Shiny ui.R to", loc, level = 2)
    writeLines(output$ui, loc)
  }
  
  if(!is.null(output$server) && nzchar(output$server)){
    loc <- file.path(destination_folder, "server.R")
    myMessage("Writing Shiny server.R to", loc, level = 2)
    writeLines(output$server, loc)
  }
  
  invisible(NULL)
  
}

# returns app or ui_server or ui suffix _folder/_file
template_type <- function(template){
  
  the_type <- NULL
  
  if(!dir.exists(template) && !file.exists(template)){
    stop("Couldn't detect if template was a file or directory: ", template, 
         call. = FALSE)
  }
  
  if(dir.exists(template)){
    # its a directory holding at least ui.R or app.R
    dir_files <- list.files(template, recursive = TRUE)
    
    if(!"ui.R" %in% dir_files && !"app.R" %in% dir_files){
      stop("Template folder must include ui.R or app.R file", call. = FALSE)
    }
    
    if("app.R" %in% dir_files){
      the_type <- "app_folder"
    } else {
      
      # it has its own server.R so overwrite default
      if("server.R" %in% dir_files){
        the_type <- "ui_server_folder"
      }
      
      the_type <- "ui_folder"
    }
    myMessage("Template type:", the_type, level = 2)
    return(the_type)
    
  }
  # its a file
    
  # we assume all ui.R files do not include server objects
  if(basename(template) == "ui.R"){
    the_type <- "ui_file"
  } else {
    the_type <- "app_file"
  }
  
  myMessage("Template type:", the_type, level = 2)
  the_type
  
}

# turn templates files into txt for server.R and ui.R for launching
ga_model_shiny_template_make <- function(template, header_boilerplate = TRUE){
  
  the_type <- template_type(template)
  
  # as an example
  output <- list(
    app = NULL,
    ui = NULL,
    server = NULL
  )
  
  hdr_txt <- ""
  if(header_boilerplate){
    myMessage(
      "Adding ga_model_shiny_template('header_boilerplate.R') to Shiny code",
      level = 2)
    # add the header boiler plate
    hdr_txt <- ga_model_shiny_template("boilerplate/header_boilerplate.R", 
                                       read_lines = TRUE)
  }
  
  # default
  server_txt <- ga_model_shiny_template("boilerplate/server_boilerplate.R",
                                        read_lines = TRUE)
  
  if(the_type == "app_folder"){
    # does it have a server object? write it out as app.R
    app_txt <- readLines(file.path(template, "app.R"))
    output$app <- has_server_object(
      app_txt, 
      ga_model_shiny_template("boilerplate/server_app_boilerplate.R", 
                              read_lines = TRUE))
  } else if(the_type == "ui_folder"){
    ui_txt <- readLines(file.path(template, "ui.R"))
    
    output$server <- server_txt
    output$ui <- c(hdr_txt, ui_txt)
  } else if(the_type == "ui_server_folder"){
    ui_txt <- readLines(file.path(template, "ui.R"))
    server_txt <- readLines(file.path(template, "server.R"))
    
    output$ui <- c(hdr_txt, ui_txt)    
    output$server <- server_txt
  } else if(the_type == "ui_file"){
    ui_txt <- readLines(template)
    
    output$ui <- c(hdr_txt, ui_txt)
    output$server <- server_txt
  } else if(the_type == "app_file"){
    ui_txt <- readLines(template)
    
    output$app <- has_server_object(
      ui_txt, 
      ga_model_shiny_template("boilerplate/server_app_boilerplate.R", 
                              read_lines = TRUE))
  } else {
    stop("Unrecognised type of template file.", call. = FALSE)
  }
  
  output

}

has_server_object <- function(txt, default){
  
  # does it have a server object? 
  if(any(grepl("^server", txt))){
    return(txt)
  }
  
  default
}

make_date_range <- function(date_range){
  if(!date_range) return("br()")
  
  list(date_range = 
         'dateRangeInput("date_range", "Date Range", 
          start = Sys.Date() - 400, end = Sys.Date() - 1)')
}

make_model_libraries <- function(models){
  the_libs <- unique(unlist(lapply(models, function(x) x$required_packages)))
  list(
    model_libraries = paste(sprintf("library(%s)", the_libs), collapse = "\n")
  )
}

make_model_template <- function(model_locations, date_range){
  
  # add dependency on global input$date_range?
  if(!date_range){
    model_server <- paste(
      sprintf("%s$server('%s', view_id = view_id)", 
              names(model_locations), names(model_locations)), 
      collapse = "\n")
  } else {
    model_server <- paste(
      sprintf("%s$server('%s', view_id = view_id, 
                         date_range = reactive(input$date_range))", 
              names(model_locations), names(model_locations)), 
      collapse = "\n")
  }
  
  # models in a list that can be used in theme templates
  model_list <- paste("list(", 
                      paste(names(model_locations), 
                            collapse = ",", sep = ","),
                      ")")
  
  list(
    model_load = paste(
      sprintf("%s <- ga_model_shiny_load('%s')", 
              names(model_locations), model_locations), 
      collapse = "\n"),
    model_ui = shiny_ui(names(model_locations)),
    model_server = model_server,
    model_list = model_list
  )
  
}

#' How to generate the model objects HTML
#' 
#' This is the default way to create model UIs generated from the model name e.g. 'model1', 'model2' etc.
#' 
#' @param model_n The id of the model within Shiny.  This is usually `'modelN'` when N is the index of the model in the list
#' 
#' @details 
#' 
#' `ga_model_shiny_ui()` generates the UI for loading the model.  At minimum it needs to load `model1$ui('model1')` which is the default.  You may want to add some logic to make menu items for some templates, which this function helps facilitate.
#' 
#' @examples 
#' 
#' ga_model_shiny_ui("model1")
#' @keywords internal
#' @noRd
shiny_ui <- function(model_n){
  paste(
    sprintf("%s$ui('%s')", model_n, model_n), 
    collapse = ",\n")
}

make_auth_dropdown <- function(type){
  switch(type,
         none = NULL,
         universal = list(
           auth_ui = "authDropdownUI('auth_menu', inColumns = TRUE)",
           auth_server = "callModule(authDropdown, 'auth_menu', ga.table = al)",
           auth_accounts = "al <- reactive({req(token);ga_account_list()})"),
         ga4 = list(
           auth_ui = "accountPickerUI('auth_menu', inColumns = TRUE)",
           auth_server = "accountPicker('auth_menu', ga_table = al, id_only = TRUE)",
           auth_accounts = "al <- reactive({req(token);ga_account_list('ga4')})"
         ))
}

#' Load one model into a Shiny template
#' 
#' @param model_n The templated name of a model e.g. 'model1'
#' @param ... Other arguments passed from shiny server
#' @export
#' @family GA modelling functions
ga_model_shiny_load <- function(model_n, ...){
  model <- tryCatch(
    ga_model_load(model_n),
    error = function(err){
      myMessage("Error loading model from ", normalizePath(model_n), level = 3)
      NULL
    })
  if(is.null(model)){
    modelUi <- function(...) NULL
    modelServer <- function(...) NULL
  } else {
    modelUi <- model$shiny_module$ui
    modelServer <- model$shiny_module$server
  }
  
  list(
    ui = modelUi,
    server = modelServer,
    model = model
  )
}

model_path <- function(m, local_path){
  
  tmpdir <- tempdir()
  if(nzchar(local_path)){
    tmpdir <- local_path
  }
  
  if(is.ga_model(m)){
    tmp_model <- tempfile(fileext = ".gamr", tmpdir = tmpdir)
    ga_model_save(m, filename = tmp_model)
    model_location <- tmp_model
  } else {
    model_location <- m
  }
  
  assert_that(is.readable(model_location))
  
  if(nzchar(local_path)){
    # relative file path so its all self-contained in folder
    return(basename(model_location))
  }
  # absolute path for local use
  normalizePath(model_location)
}

Try the googleAnalyticsR package in your browser

Any scripts or data that you put into this service are public.

googleAnalyticsR documentation built on Oct. 7, 2021, 9:06 a.m.