Nothing
#' Use a model
#'
#' Use a model created by [ga_model_make]
#'
#' @param viewId The GA viewId to operate on
#' @param model A file location of a model object or a model object
#' created by [ga_model_make]
#' @param load_libs Whether to load the library requirements into your namespace
#' @param ... Other arguments to pass into the model as needed
#'
#' @export
#' @family GA modelling functions
#' @examples
#'
#' # models that come with the package
#' ga_model_example()
#' \dontrun{
#'
#' # your own Google Analytics viewID
#' my_viewid <- 81416156
#'
#' # load the model (equivalent to ga_model_load())
#' decomp_ga <- ga_model_example("decomp_ga.gamr")
#'
#' # apply model to your data
#' d1 <- ga_model(my_viewid, model = decomp_ga)
#'
#' # change default date range to 20 days ago to yesterday
#' d2 <- ga_model(my_viewid, model = decomp_ga,
#' date_range = c("20daysAgo","yesterday"))
#'
#'
#' }
ga_model <- function(viewId, model, load_libs = TRUE, ...){
# a filepath
if(is.character(model)){
model <- ga_model_load(model)
}
assert_that(is.ga_model(model))
check_packages_installed(model$required_packages, load_them = load_libs)
gadata <- model$data_f(viewId, ...)
myMessage("Downloaded data: Rows:",
nrow(gadata), " Columns:",
paste(names(gadata), collapse = " "), level = 3)
if(length(intersect(names(gadata), model$required_columns)) == 0){
stop("All required columns were not found in returned data.
Got: ", paste(names(gadata), collapse=" "),
" Needed: ", paste(model$required_columns, collapse = " "),
call. = FALSE)
}
o <- model$model_f(gadata, ...)
myMessage("Applied model to data", level = 3)
if(!is.null(model$output_f)){
myMessage("Creating plot", level = 3)
p <- model$output_f(o, ...)
} else {
p <- NULL
}
structure(
list(input = gadata,
output = o,
plot = p,
model = model,
viewId = viewId,
args = list(...)),
class = c("ga_model_result","list")
)
}
is.ga_model_result <- function(x){
inherits(x, "ga_model_result")
}
#' Save a created model
#'
#' @param model model to save
#' @param filename name to save model under
#'
#' @export
#' @family GA modelling functions
#' @examples
#'
#' \dontrun{
#' # load the model (equivalent to ga_model_load())
#' decomp_ga <- ga_model_example("decomp_ga.gamr")
#'
#' # save it somewhere else
#' ga_model_save(decomp_ga, "somewhereelse.gamr")
#'
#' }
ga_model_save <- function(model, filename = "my-model.gamr"){
assert_that(
is.ga_model(model)
)
saveRDS(model, filename)
}
#' Load a created model
#'
#' @param filename name to load model from
#'
#' @export
#' @import assertthat
#' @family GA modelling functions
#' @examples
#'
#' # models used in ga_model_example() are here:
#' location <- system.file("models","examples","decomp_ga.gamr",
#' package = "googleAnalyticsR")
#'
#' ga_model_load(location)
ga_model_load <- function(filename = "my-model.gamr"){
assert_that(is.readable(filename))
model <- readRDS(filename)
assert_that(is.ga_model(model))
myMessage("Loaded model from ", filename, level = 2)
model
}
#' Load an example model
#'
#' @param name name of the model - set to "list" to show available files
#' @export
#' @import assertthat
#' @family GA modelling functions
#' @examples
#'
#' # example .gamr files included with the package
#' ga_model_example()
#'
#' # load one example
#' ga_model_example("ga4-trend.gamr")
ga_model_example <- function(name = "list"){
if(name == "list"){
return(list.files(system.file("models","examples", package = "googleAnalyticsR"),
include.dirs = FALSE))
}
# this will fetch from more places such as other packages and GCS eventually
filename <- system.file("models","examples", name, package = "googleAnalyticsR")
ga_model_load(filename)
}
#' Modelling function factory for Google Analytics data
#'
#' Create ga_model objects for easy application of models to data
#'
#' @param data_f A function that gets the data
#' @param required_columns What dimensions and metrics are required
#' @param model_f A function that inputs data, and outputs a list of assets -
#' must take data from result of `data_f` in first argument
#' @param output_f A function that inputs the output from `model_f`, outputs a visualisation
#' @param required_packages The packages needed for `data_f` and `model_f` to work
#' @param description An optional description of what the model does
#' @param renderShiny A shiny render function that will create the output for `outputShiny` from `output_f`
#' @param outputShiny A shiny UI output function that will display the results `renderShiny`
#' @param inputShiny Optional input shiny functions (like `dateInput()`) that will be used within the model's Shiny module. The id should be exactly the same as one of the variables in the model functions.
#'
#' @details
#'
#' The passed functions should all have `...` to make them flexible
#' in what arguments can be added. Do not have the same argument names in both functions.
#' The `data_f` function result will feed to `model_f`
#'
#' @export
#' @import assertthat
#' @family GA modelling functions
#'
#' @return A `ga_model` object to pass to [ga_model]
#'
#' @examples
#'
#' \dontrun{
#'
#' get_model_data <- function(viewId,
#' date_range = c(Sys.Date()- 300, Sys.Date()),
#' ...){
#' google_analytics(viewId,
#' date_range = date_range,
#' metrics = "sessions",
#' dimensions = "date",
#' max = -1)
#' }
#'
#' decompose_sessions <- function(df, ...){
#' decompose(ts(df$sessions, frequency = 7))
#' }
#'
#' decomp_ga <- ga_model_make(get_model_data,
#' required_columns = c("date", "sessions"),
#' model_f = decompose_sessions,
#' description = "Performs decomposition and creates plot")
#'
#' # fetches data and outputs decomposition
#' ga_model(81416156, decomp_ga)
#'
#' # save the model for later
#' model_location <- "decomp_ga.gamr"
#' ga_model_save(decomp_ga, filename = model_location)
#'
#' # can load model from file
#' ga_model(81416156, model_location)
#'
#' # or load model to an object and use
#' model2 <- ga_model_load(model_location)
#'
#' ga_model(81416156, model2)
#'
#' # for shiny include functions for the UI and server rendering
#' decomp_ga <- ga_model_make(get_model_data,
#' required_columns = c("date", "sessions"),
#' model_f = decompose_sessions,
#' output_f = function(df, ...){graphics::plot(df)},
#' description = "Performs decomposition and creates a plot",
#' outputShiny = shiny::plotOutput,
#' renderShiny = shiny::renderPlot)
#'
#' }
ga_model_make <- function(
data_f,
required_columns,
model_f,
output_f = function(df, ...){plot(df)},
required_packages = NULL,
description = NULL,
outputShiny = shiny::plotOutput,
renderShiny = shiny::renderPlot,
inputShiny = shiny::tagList()){
if(is.null(inputShiny)) inputShiny <- shiny::tagList()
Model(
data_f = data_f,
required_columns = required_columns,
model_f = model_f,
output_f = output_f,
required_packages = required_packages,
description = description,
shiny_module = create_shiny_module_funcs(
data_f = data_f,
model_f = model_f,
output_f = output_f,
outputShiny = outputShiny,
renderShiny = renderShiny,
inputShiny = inputShiny)
)
}
#' Edit a created ga_model
#'
#' Change features of a model by changing the functions within it.
#'
#' @param model The model to edit - if a filepath will load model and
#' save back edited model to the same file
#' @inheritParams ga_model_make
#'
#'
#' @export
#' @family GA modelling functions
#' @examples
#'
#' \dontrun{
#'
#' decomp_ga <- ga_model_example("decomp_ga.gamr")
#' decomp_ga
#'
#' # edit its description
#' ga_model_edit(decomp_ga, description = "Changed")
#'
#' }
ga_model_edit <- function(
model,
data_f = NULL,
required_columns = NULL,
model_f = NULL,
required_packages = NULL,
description = NULL,
outputShiny = shiny::plotOutput,
renderShiny = shiny::renderPlot,
inputShiny = NULL,
output_f = NULL){
save_me <- ""
if(is.character(model)){
save_me <- model
model <- ga_model_load(model)
}
assert_that(is.ga_model(model))
myMessage("Editing model: ", model$description, level = 3)
data_f2 <- model$data_f
required_columns2 <- model$required_columns
model_f2 <- model$model_f
output_f2 <- model$output_f
required_packages2 <- model$required_packages
description2 <- model$description
shiny_module_ui2 <- model$shiny_module$ui
shiny_module_server2 <- model$shiny_module$server
shiny_module_uiInput2 <- model$shiny_module$uiInput
data_f2 <- assign_new(data_f, data_f2, is.function)
required_columns2 <- assign_new(required_columns, required_columns2, is.character)
model_f2 <- assign_new(model_f, model_f2, is.function)
output_f2 <- assign_new(output_f, output_f2, is.function)
required_packages2 <- assign_new(required_packages, required_packages2, is.character)
description2 <- assign_new(description, description2, assertthat::is.string)
# only do this bit if a shiny module is present
if(any(!is.null(outputShiny), !is.null(renderShiny), !is.null(inputShiny))){
shiny_module_ui2 <- assign_new(outputShiny, shiny_module_ui2)
shiny_module_server2 <- assign_new(renderShiny, shiny_module_server2)
shiny_module_uiInput2 <- assign_new(inputShiny, shiny_module_uiInput2, is.inputShiny)
}
shiny_module <- create_shiny_module_funcs(
data_f = data_f2,
model_f = model_f2,
output_f = output_f2,
outputShiny = shiny_module_ui2,
renderShiny = shiny_module_server2,
inputShiny = shiny_module_uiInput2)
model <- Model(
data_f = data_f2,
required_columns = required_columns2,
model_f = model_f2,
required_packages = required_packages2,
description = description2,
output_f = output_f2,
shiny_module = shiny_module
)
if(nzchar(save_me)) ga_model_save(model, filename = save_me)
model
}
is.inputShiny <- function(x){
inherits(x, "shiny.tag") || inherits(x, "shiny.tag.list")
}
#' @noRd
Model <- function(
data_f,
required_columns = NULL,
model_f = NULL,
required_packages = NULL,
description = NULL,
output_f = NULL,
shiny_module = NULL){
assert_that(
is.function(data_f),
is.character(required_columns),
is.function(model_f)
)
if(!any(function_args(data_f, TRUE) == "...")){
stop("data_f() arguments need to include ...", call.=FALSE)
}
if(!any(function_args(model_f, TRUE) == "...")){
stop("model_f() arguments need to include ...", call.=FALSE)
}
if(!is.null(output_f) && !any(function_args(output_f, TRUE) == "...")){
stop("output_f() arguments need to include ...", call.=FALSE)
}
# using id breaks shiny modules
if("id" %in% c(function_args(data_f), function_args(model_f), function_args(output_f))){
stop("Don't use 'id' in function arguments - it clashes with Shiny module's arg: id", call.=FALSE)
}
# data_f must include view_id as first argument
if(function_args(data_f)[[1]] != "view_id"){
stop("Must have 'view_id' as first argument of data_f", call.=FALSE)
}
structure(
list(
data_f = data_f,
required_columns = required_columns,
model_f = model_f,
required_packages = required_packages,
description = description,
output_f = output_f,
shiny_module = shiny_module
),
class = "ga_model"
)
}
is.ga_model <- function(x){
inherits(x, "ga_model")
}
is.ga_model_list <- function(x){
all(lapply(x, is.ga_model))
}
is.shinyTagList <- function(x){
inherits(x, "shiny.tag.list")
}
extract_ids <- function(inputShiny){
if(is.shinyTagList(inputShiny)){
input_ids <- lapply(inputShiny, extract_from_list, id_regex="id$")
if(any(lapply(input_ids, length) > 1)){
stop("inputShiny must be only one level deep of nesting e.g. tagList(xxxInput(), yyyInput()), not tagList(tagList(xxxInput(), yyyInput()), zzzInput())", call. = FALSE)
}
} else {
input_ids <- list(extract_from_list(inputShiny, id_regex = "id$"))
}
input_ids
}
replace_ids <- function(inputShiny, ids, ns){
f <- function(x, ids, ns){
replace_in_list(x, ids, ns(ids))
}
if(is.shinyTagList(inputShiny)){
inputs <- mapply(f, inputShiny, ids,
MoreArgs = list(ns = ns),
SIMPLIFY = FALSE, USE.NAMES = FALSE)
} else {
inputs <- f(inputShiny, ids[[1]], ns)
}
inputs
}
create_shiny_module_ui <- function(outputShiny,inputShiny, input_ids){
assert_that_ifnn(inputShiny, is.inputShiny)
assert_that(is.function(outputShiny))
function(id, ...){
ns <- shiny::NS(id)
if(!is.null(input_ids)){
inputShiny <- replace_ids(inputShiny, input_ids, ns)
}
shiny::tagList(
inputShiny,
outputShiny(outputId = ns("ui_out"), ...)
)
}
}
#' @noRd
#' @import assertthat
#' @importFrom utils modifyList
create_shiny_module_funcs <- function(data_f,
model_f,
output_f,
outputShiny,
renderShiny,
inputShiny = NULL
){
myMessage("Creating Shiny modules", level = 2)
if(any(is.null(output_f), is.null(outputShiny), is.null(renderShiny))){
myMessage("Can't create Shiny module as necessary functions are NULL",
level = 3)
return(NULL)
}
assert_that(
is.function(data_f),
is.function(model_f),
is.function(outputShiny),
is.function(renderShiny),
is.function(output_f)
)
input_ids <- extract_ids(inputShiny)
ui <- create_shiny_module_ui(outputShiny, inputShiny, input_ids)
server <- function(id, view_id, ...){
shiny::moduleServer(
id,
function(input, output, session){
dots <- list(...)
myMessage("shiny args passed: ",
paste(names(dots),"=", dots, collapse = ","),
level = 2)
copy_input_ids <- function(input_ids, input, dots){
new <- lapply(input_ids, function(x){
if(is.null(x)) return(NULL)
dots[[x]] <- input[[x]]
})
modifyList(dots, setNames(new, input_ids))
}
inputs_in_f_args <- function(f, dots){
intersect(function_args(f), names(dots))
}
cache_my_inputs <- function(f, dots){
dots <- copy_input_ids(input_ids, input, dots)
cache_these <- inputs_in_f_args(f, dots)
myMessage(
as.character(substitute(f)),
"cache_these:", paste(cache_these, collapse = ", "),
level = 3)
eval_input_list(dots[cache_these])
}
gadata <- shiny::reactive({
shiny::req(view_id())
dots <- copy_input_ids(input_ids, input, dots)
myMessage("Fetching data for view_id:",view_id(), level = 3)
execute_model_function(data_f,
dependency = list(view_id = view_id()),
dots = dots)
}) %>% shiny::bindCache(cache_my_inputs(data_f, dots), view_id())
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
dots <- copy_input_ids(input_ids, input, dots)
myMessage("Modelling data", level = 3)
execute_model_function(model_f,
dependency = list(gadata()),
dots = dots)
}) %>% shiny::bindCache(cache_my_inputs(model_f, dots), gadata())
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
dots <- copy_input_ids(input_ids, input, dots)
myMessage("Rendering model output", level = 3)
execute_model_function(output_f,
dependency = list(model_output()),
dots = dots)
}) %>% shiny::bindCache(cache_my_inputs(output_f, dots), model_output())
return(model_output)
})
}
list(
ui = ui,
server = server,
uiInput = inputShiny
)
}
execute_model_function <- function(f, dependency, dots){
assert_that(is.function(f), is.list(dependency))
myMessage("function_vars: ", paste(function_args(f), collapse = ", "))
tryCatch(do.call(f, args = c(dependency, eval_input_list(dots))),
error = function(err){
stop("Problem executing model function - ", err$message,
call. = FALSE)
})
}
# force evaluation to reactive inputs update
eval_input_list <- function(dots){
lapply(dots, function(x){
if(inherits(x, "reactive")){
do.call(x, args = list())
} else {
x
}
})
}
#' Write the ga_model functions to a file
#'
#' @param model The `ga_model` object to extract functions from to write, or a filepath to a model
#' @param filepath The filepath to write the functions to
#'
#' @export
#' @family GA modelling functions
#' @import assertthat
#'
#' @examples
#'
#' \dontrun{
#'
#' decomp_ga <- ga_model_example("decomp_ga.gamr")
#' ga_model_write(decomp_ga, "a_file.R")
#' }
ga_model_write <- function(model, filepath = "ga_model.R"){
if(is.character(model)){
model <- ga_model_load(model)
}
assert_that(is.ga_model(model))
if(!is.null(model$required_packages)){
libs <- paste0("library(",model$required_packages,")")
} else {
libs <- "# no libraries needed"
}
the_text <-
c(sprintf("# ga_model: %s\n", model$description),
libs,
write_f("\n# fetch data\ndata_f <-", model$data_f),
write_f("\n# model data\nmodel_f <-", model$model_f),
write_f("\n# output data\noutput_f <-", model$output_f),
write_f("\n# shiny input function\nuiInput <-", model$shiny_module$uiInput),
"\n# use via ga_model_make()")
writeLines(the_text, con = filepath)
suppressMessages(formatR::tidy_file(filepath, width.cutoff = 80))
myMessage("Written model to ", filepath, level = 3)
model
}
write_f <- function(name, f){
if(is.null(f)) return("function(){NULL}")
c(name, deparse(f))
}
#' Refresh a model
#'
#' Sometimes necessary if functions were created under differing package versions
#'
#' @param model Model or file location of model .gamr file
#'
#' @export
#' @examples
#'
#' \dontrun{
#'
#' decomp_ga <- ga_model_example("decomp_ga.gamr")
#' decomp_ga <- ga_model_refresh(decomp_ga)
#'
#' }
ga_model_refresh <- function(model){
save_me <- ""
if(is.character(model)){
save_me <- model
model <- ga_model_load(model)
}
new_model <- ga_model_edit(model,
data_f = model$data_f,
required_columns = model$required_columns,
model_f = model$model_f,
required_packages = model$required_packages,
description = model$description,
outputShiny = model$outputShiny,
renderShiny = model$renderShiny,
inputShiny = model$inputShiny,
output_f = model$output_f
)
if(nzchar(save_me)){
ga_model_save(new_model, filename = save_me)
}
new_model
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.