In PRL-PRG/instrumentr: Instrumentation Framework for R

knitr::opts_chunk$set(
  collapse = TRUE,
  comment = ">"
)

library(instrumentr)

functions <- get_package_function_names("dplyr", public = TRUE, private = FALSE)

application_load_callback <- function(context, application) {
    set_data(context, new.env(parent=emptyenv()))
}

application_unload_callback <- function(context, application) {
    data <- get_data(context)

    for(name in ls(data)) {
        cat(name, ":: ")

        type_sig <- get(name, envir=data)
        l <- length(type_sig)

        index <- 1

        cat("<")
        while(index < l) {
            if(index != 1) {
                cat(", ")
            }
            arg_type <- type_sig[[index]]
            cat(paste(arg_type, collapse = "|"))
            index <- index + 1
        }
        cat("> => ")

        cat(paste(type_sig[[index]], collapse = "|"))

        cat("\n")
    }
}

create_type_sig <- function(n) {
    type_sig <- list()
    index <- 1
    while(index <= n) {
        type_sig[[index]] <- character(0)
        index <- index + 1
    }
    type_sig
}

infer_type <- function(val) {
    typeof(val)
}

merge_type <- function(type_sig, index, type) {
    types <- type_sig[[index]]
    type_sig[[index]] <- unique(c(types, type))
    type_sig
}

call_exit_callback <- function(context, application, package, func, call) {
    fun_name <- get_name(func)

    parameters <- get_parameters(call)

    data <- get_data(context)

    if (exists(fun_name, envir=data)) {
        type_sig <- get(fun_name, envir=data)
    }
    else {
        type_sig <- create_type_sig(length(parameters) + 1)
    }

    index <- 1

    for (parameter in parameters) {

        arguments <- get_arguments(parameter)

        if(is_vararg(parameter)) {
            type_sig <- merge_type(type_sig, index, "...")
        }
        else if (length(arguments) == 0) {
            type_sig <- merge_type(type_sig, index, "any")
        }
        else if(!is_evaluated(arguments[[1]])) {
            type_sig <- merge_type(type_sig, index, "any")
        }
        else {
            argument_value <- get_result(arguments[[1]])
            type_sig <- merge_type(type_sig, index, infer_type(argument_value))
        }

        index <- index + 1
    }

    result_type <- "any"

    if(is_successful(call)) {
        result <- get_result(call)
        result_type <- infer_type(result)
    }

    type_sig <- merge_type(type_sig, index, result_type)

    assign(fun_name, type_sig, envir=data)
}

context <- create_context(application_load_callback = application_load_callback,
                          application_unload_callback = application_unload_callback,
                          call_exit_callback = call_exit_callback,
                          functions = functions)

trace_code(context, {
    suppressPackageStartupMessages(library(dplyr))

    starwars %>%
      filter(species == "Droid")

    starwars %>%
      select(name, ends_with("color"))

    starwars %>%
      mutate(name, bmi = mass / ((height / 100)  ^ 2)) %>%
      select(name:mass, bmi)

    starwars %>%
      arrange(desc(mass))

    starwars %>%
      group_by(species) %>%
      summarise(
          n = n(),
          mass = mean(mass, na.rm = TRUE)
      ) %>%
      filter(n > 1)
})

PRL-PRG/instrumentr documentation built on Feb. 26, 2021, 5:12 p.m.