R/access_trace.R

In inlabru: Bayesian Latent Gaussian Modelling using INLA and Extensions

access_trace <- function(name, package = NULL) {
  method <- fmesher::fm_caller_name(-1)
  access_method_ <- list(
    "^\\$<-" = "$<-",
    "^\\$" = "$",
    "^\\[\\[<-" = "[[<-",
    "^\\[\\[" = "[[",
    "^\\[<-" = "[<-",
    "^\\[" = "["
  )
  access_method <- NA_character_
  for (pattern in names(access_method_)) {
    if (grepl(pattern, method)) {
      access_method <- access_method_[[pattern]]
      break
    }
  }
  method_text_ <-
    list(
      "$<-" = "\\$<-",
      "$" = "\\$",
      "[[<-" = "\\[\\[<-",
      "[[" = "\\[\\[",
      "[<-" = "\\[<-",
      "[" = "\\["
    )
  method_text <- if (access_method %in% names(method_text_)) {
    method_text_[[access_method]]
  } else {
    ""
  }
  open_text_ <- list(
    "$<-" = "$",
    "$" = "$",
    "[[<-" = "[['",
    "[[" = "[['",
    "[<-" = "['",
    "[" = "['"
  )
  open_text <- if (access_method %in% names(open_text_)) {
    open_text_[[access_method]]
  } else {
    ""
  }
  close_text_ <- list(
    "$<-" = " <-",
    "$" = "",
    "[[<-" = "']] <-",
    "[[" = "']]",
    "[<-" = "'] <-",
    "[" = "']"
  )
  close_text <- if (access_method %in% names(close_text_)) {
    close_text_[[access_method]]
  } else {
    ""
  }

  fun_package <- function(fun_name) {
    fun <- tryCatch(
      get(fun_name, mode = "function", inherits = TRUE),
      error = function(e) NULL
    )
    if (is.null(fun)) {
      return("")
    }
    env <- environment(fun)
    pkg <- ""
    while (!is.null(env)) {
      if (identical(env, .GlobalEnv)) {
        pkg <- "global"
        break
      }
      env_name <- environmentName(env)
      if (!is.null(env_name) && !identical(env_name, "")) {
        pkg <- env_name
        break
      }
      env <- parent.env(env)
    }
    pkg
  }

  class_name <- sub(paste0("^", method_text, "\\."), "", method)
  idx <- -3
  caller <- fmesher::fm_caller_name(idx)
  if (caller %in% c("", "FUN")) {
    idx <- idx - 1L
    cal <- fmesher::fm_caller_name(idx)
    caller <- c(caller, cal)
  }
  for (i in seq_len(1)) {
    idx <- idx - 1L
    cal <- fmesher::fm_caller_name(idx)
    caller <- c(caller, cal)
  }
  caller_packages <- vapply(caller, fun_package, character(1))
  if (any(caller_packages %in% package)) {
    return(invisible())
  }
  caller <- paste0(caller, collapse = ":")

  if (!is.character(name)) {
    if (is.integer(name)) {
      name <- "<integer>"
    } else if (is.numeric(name)) {
      name <- "<numeric>"
    } else if (is.logical(name)) {
      name <- "<logical>"
    } else {
      name <- "<unknown>"
    }
  }

  print(glue::glue("{caller}: {class_name}{open_text}{name}{close_text}"))
}


access_trace_reset <- function(file = "R/access_trace_methods.R") {
  write(
    c(
      "# This file is auto-generated by access_trace_reset/add() calls.",
      "# Do not edit!"
    ),
    file = file,
    append = FALSE,
    sep = ""
  )
  invisible()
}


# @param class_name
# @param method_names
# @param file
# @param package character vector; If non-NULL, only trace access outside of
# this package or packages
access_trace_add <- function(
  class_name,
  method_names = c("$", "[[", "[", "$<-", "[[<-", "[<-"),
  file = "R/access_trace_methods.R",
  package = NULL
) {
  package <- union(package, c("base", "utils"))

  write(
    c("", glue::glue("# Class {class_name} ####"), ""),
    file = file,
    append = TRUE,
    sep = ""
  )
  arguments_ <-
    list(
      "$" = "name",
      "[[" = "i",
      "[" = "i",
      "$<-" = "name, value",
      "[[<-" = "i, value",
      "[<-" = "i, value"
    )
  trace_name_ <-
    list(
      "$" = "name",
      "[[" = "i",
      "[" = "i",
      "$<-" = "name",
      "[[<-" = "i",
      "[<-" = "i"
    )
  package_text <-
    if (is.null(package)) {
      "NULL"
    } else {
      paste0("c(", paste0('\"', package, '\"', collapse = ", "), ")")
    }
  for (method_name in method_names) {
    full_name <- paste0(method_name, ".", class_name)
    if (exists(full_name, mode = "function")) {
      warning("Method ", full_name, " already exists; skipping generation.")
      next
    }
    arguments <- arguments_[[method_name]]
    trace_name <- trace_name_[[method_name]]
    code <- c(
      glue::glue(
        "#' @export
       #'
       `{full_name}` <- function(x, {arguments}) {{
         access_trace({trace_name}, package = {package_text})
         NextMethod()
       }}"
      ),
      ""
    )
    write(
      code,
      file = file,
      append = TRUE,
      sep = ""
    )
  }
  invisible()
}