R/utils.R

In jdeboer/ganalytics: Interact with 'Google Analytics'

#' @importFrom lubridate ymd
#' @importFrom stringr regex str_replace str_detect
#' @importFrom plyr llply
#' @importFrom methods slot .valueClassTest
NULL

#' IsVarMatch.
#'
#' The following method is a temporary workaround to support XX placeholders in dimension and metric
#' names, such as with custom dimensions, metrics and various goal related variables.
#'
#' @param thisVar var to compare against inVars.
#' @param inVars vector of vars to check var against.
#'
#' @keywords internal
IsVarMatch <- function(thisVar, inVars) {
  inVars <- str_replace(inVars, "XX", replacement = "[0-9]+")
  inVars <- regex(paste0("^", inVars, "$"), ignore_case = TRUE)
  any(str_detect(as.character(thisVar), inVars))
}

#' ValidGaOperand.
#'
#' Checks whether an operand value is valid for a selected dimension.
#'
#' @param var selected dimension to check operand against
#' @param operand the operand value to check
#'
ValidGaOperand <- function(var, operand) {
  test <- switch(
    as.character(var),
    "ga:date" = grepl(pattern = "^[0-9]{8}$", x = operand) &&
      (as.Date(x = operand, format = kGaDateOutFormat) >= kGaDateOrigin),
    "ga:year" = grepl(pattern = "^[0-9]{4}$", x = operand) &&
      (as.Date(x = operand, format = "%Y") >= kGaDateOrigin),
    "ga:month" = grepl(pattern = "^(0[1-9]|1[0-2])$", x = operand),
    "ga:week" = grepl(pattern = "^([0-4][1-9]|5[0-3])$", x = operand),
    "ga:day" = grepl(pattern = "^([0-2][0-9][1-9]|3[0-5][0-9]|36[0-6])$", x = operand),
    "ga:hour" = grepl(pattern = "^([01][0-9]|2[0-3])$", x = operand),
    "ga:dayOfWeek" = grepl(pattern = "^[0-6]$", x = operand),
    "ga:visitorType" = operand %in% c("New Visitor", "Returning Visitor"),
    TRUE
  )
  if (var %in% c("ga:nthMonth", "ga:nthWeek", "ga:nthDay", "ga:pageDepth", "ga:visitLength", "ga:visitCount", "ga:daysSinceLastVisit")) {
    test <- as.numeric(operand) > 0
  } else if (var %in% c("ga:searchUsed", "ga:javaEnabled", "ga:isMobile", "ga:isTablet", "ga:hasSocialSourceReferral")) {
    test <- operand %in% c("Yes", "No")
  }
  if (test) {
    return(TRUE)
  } else {
    return(paste("Invalid", var, "operand:", operand))
  }
}

#' ArgList.
#'
#' If the only argument passed was already a list, then extract that list.
#'
#' @param ... arguments or list of arguments
#'
#' @keywords internal
ArgList <- function(...) {
  as.list(
    unlist(x = list(...), recursive = FALSE)
  )
}

#' unnest_objects.
#'
#' Concatenate objects of class \code{class} with lists of objects into a flattened list.
#'
#' @param ... objects to be concatenated, including lists of objects.
#' @param class the class of the objects considered as nested.
#'
#' @keywords internal
unnest_objects <- function(..., class) {
  exprList <- list(...)
  nested <- sapply(exprList, is, class)
  exprList <- c(exprList[!nested], unlist(exprList[nested], recursive = FALSE))
  exprList
}

#' flatten.
#'
#' Flatten a nested list while preserving the class of each element
#' Convert a list type object into a non-nested list, preserving
#' the original object classes.
#'
#' @param x a list type object to flatten.
#'
#' @return a list
#'
#' @references \url{https://stackoverflow.com/a/8139959/1007029}
#'
#' @keywords internal
flatten <- function(x) {
  len <- sum(rapply(x, function(x) 1L))
  y <- vector('list', len)
  i <- 0L
  rapply(x, function(x) { i <<- i + 1L; y[[i]] <<- x })
  y
}

#' CheckVectorBounds
#'
#' Check that the length of each named slot within \code{object} is within the
#' specified lower and upper bounds.
#'
#' @param object an object with slots that match the names of
#'   slot_vector_bound_list
#' @param slot_vector_bound_list a named list of length 2 vectors specifying the
#'   upper and lower bounds for the length of each slot of object.
#'
#' @keywords internal
CheckVectorBounds <- function(object, slot_vector_bound_list) {
  slot_vector_bounds <- data.frame(
    slot_vector_bound_list,
    row.names = c('lower', 'upper')
  )
  ret <- lapply(names(slot_vector_bounds), function(slot_name) {
    slot_length <- length(slot(object, slot_name))
    slot_bounds <- slot_vector_bounds[[slot_name]]
    names(slot_bounds) <- row.names(slot_vector_bounds)
    if (slot_length < slot_bounds['lower'] | slot_length > slot_bounds['upper']) {
      if (as.numeric(slot_bounds['lower'][1L]) == as.numeric(slot_bounds['upper'][1L])) {
        slot_bounds <- slot_bounds['lower']
        paste0("Slot '", slot_name, "' must be of length ", slot_bounds)
      } else {
        paste0("Slot '", slot_name, "' length must be from ",
               slot_bounds['lower'], " to ",
               slot_bounds['uppper'], "."
        )
      }
    } else {
      TRUE
    }
  })
  ret <- unlist(ret[sapply(ret, is.character)])
  if (length(ret) == 0L) {
    ret <- TRUE
  }
  return(ret)
}

#' checkDataFrameClasses
#'
#' Test whether the classes of each column in a data.frame match the supplied
#' list of expected class names.
#'
#' @keywords internal
checkDataFrameClasses <- function(object, matchClasses) {
  objectClasses <- lapply(object, class)
  ret <- lapply(names(matchClasses), function(className) {
    if (!(matchClasses[className] %in% objectClasses[[className]])) {
      return(paste0("<", className, "> must be of class '", matchClasses[className], "'."))
    } else {
      TRUE
    }
  })
  invalidClasses <- sapply(ret, function(x){!identical(x, TRUE)})
  if (any(invalidClasses)) {
    return(unlist(ret[invalidClasses]))
  } else {
    TRUE
  }
}

#' split_permissions
#'
#' Take a list of character vectors describing the permissions for each user and
#' transform into a nested list of users and their list of permissions.
#'
#' @keywords internal
split_permissions <- function(permissions) {
  permission_levels <- user_permission_levels
  names(permission_levels) <- permission_levels
  llply(permissions, function(permission_set) {
    y <- llply(permission_levels, function(level) {
      level %in% permission_set
    })
  })
}

#' unsplit_permissions
#'
#' Take a list of Google Analytics user permissions for a list of one or more users and
#' transform the into a list of character vector.
#'
#' @keywords internal
unsplit_permissions <- function(permissions) {
  llply(permissions, function(permission_set) {
    names(permission_set)[unlist(permission_set)]
  })
}

#' all_inherit
#'
#' Test whether all objects within a list all inherit from the same given class.
#'
#' @keywords internal
all_inherit <- function(list_object, class_names) {
  all(sapply(list_object, is, class_names))
}

#' parse_date
#'
#' Coerce a date into a character string formatted to either the
#' input or output format of the Google Analytics reporting API.
#'
#' @keywords internal
parse_date <- function(date, output_format = kGaDateInFormat) {
  format(ymd(date), format = output_format)
}

get_metadata_path <- function() {
  system.file("extdata", "metadata.RDA", package = "ganalytics")
}

# Helper functions for coercion between classes
# ---------------------------------------------

simpleCoerce <- function(from, to) {new(to, from)}
simpleCoerceData <- function(from, to) {new(to, from@.Data)}
simpleCoerceToNumeric <- function(from, to) {new(to, as.numeric(from))}
simpleCoerceToList <- function(from, to) {new(to, list(from))}
coerceViaList <- function(from, to) {as(as.list(from), to)}
coerceViaChar <- function(from, to){as(as(from, "character"), to)}
coerceViaAnd <- function(from, to) {as(as(from, "andExpr"), to)}
simpleReplace <- function(from, value) {initialize(from, value)}
coerceLogicalOperand <- function(from, to){
  operand <- ifelse(from, yes = "Yes", no = "No")
  if (is.na(operand)) operand <- from
  new(to, operand)
}

# Sourced from: https://stackoverflow.com/a/14838753/1007029
quotemeta <- function(string) {
  str_replace_all(string, "(\\W)", "\\\\\\1")
}