Code to find functions called within other functions

[RobertASmith]

# start fresh
rm(list = ls())

# [description] parse out a function's body into a character
#               vector separating the individual symbols
.parse_function <- function (x) {
  # If expression x is not an atomic value or symbol (i.e., name of object) or
  # an environment pointer then we can break x up into list of components
  listable <- (!is.atomic(x) && !is.symbol(x) && !is.environment(x))
  if (!is.list(x) && listable) {
    x <- as.list(x)

    # Check for expression of the form foo$bar
    # We still want to split it up because foo might be a function
    # but we want to get rid of bar, because it's a symbol in foo's namespace
    # and not a symbol that could be reliably matched to the package namespace
    if (identical(x[[1]], quote(`$`))) {
      x <- x[1:2]
    }
  }

  if (listable){
    # Filter out atomic values because we don't care about them
    x <- Filter(f = Negate(is.atomic), x = x)

    # Parse each listed expression recursively until
    # they can't be listed anymore
    out <- unlist(lapply(x, .parse_function), use.names = FALSE)
  } else {

    # If not listable, deparse into a character string
    out <- paste(deparse(x), collapse = "\n")
  }
  return(out)
}

.called_by <- function(fname, all_functions, pkg_env){

  assertthat::assert_that(
    is.environment(pkg_env)
    , is.character(all_functions)
    , assertthat::is.string(fname)
  )

  # Get only the body of the function
  # We will potentially miss calls if they are in attributes of the closure,
  # e.g., the way the decorators package implements decorators
  f <- body(get(fname, envir = pkg_env))

  # get the literal code of the function
  f_vec <- .parse_function(f)

  # Figure out which ones mix
  matches <- match(
    x = f_vec
    , table = all_functions
    , nomatch = 0
  )
  matches <- matches[matches > 0]

  if (length(matches) == 0){
    return(invisible(NULL))
  }

  # Convention: If A depends on B, then A is the SOURCE
  # and B is the TARGET so that it looks like A -> B
  # This is consistent with the UML dependency convention
  # fname calls <matches>. So fname depends on <matches>.
  # So fname is SOURCE and <matches> are TARGETs
  edgeDT <- data.table::data.table(
    SOURCE = fname
    , TARGET = unique(all_functions[matches])
  )

  return(edgeDT)
}

# function to find the other functions called in the body of a specific function
# in this case 'check_trans_prob_array'.
.called_by(fname = "check_trans_prob_array", 
           all_functions = assertHE::get_active_functions("assertHE"),
           pkg_env = environment())

# or directly
rm(list = ls())

# the scripts must be loaded in the namespace...
# so we have to source them all before we can run the code.
# ideally we would not need to do this, although its hardly the end of the world
miceadds::source.all("R")

#===========================#
# EXAMPLE WITH A SINGLE FUNCTION

# function to find the other functions called in the body of a specific function
# in this case 'check_trans_prob_array'.
.called_by(fname = "check_trans_prob_array", 
           all_functions = assertHE::get_active_functions("assertHE"),
           pkg_env = environment())
#===========================#

# get all the active functions.
funs <- assertHE::get_active_functions("assertHE")

# loop through each function, identify which function it is called by in the list
# of functions and then combine this information in a table.
example_table <- data.table::rbindlist(
  lapply(
    X = funs
    , FUN = .called_by
    , all_functions = funs
    , pkg_env = environment()
  )
  , fill = TRUE
)

example_table

[RobertASmith]

Then loop through functions:

nodes <- data.table::data.table(
                node = funs
                , type = "function"
            )

funs <- # insert list of functions here... 
pkg_env <- environment()

edgeDT <- data.table::rbindlist(
                lapply(
                    X = funs
                    , FUN = .called_by
                    , all_functions = funs
                    , pkg_env = pkg_env
                )
                , fill = TRUE
            )