Nothing
# Copyright (C) President and Fellows of Harvard College and
# Trustees of Mount Holyoke College, 2014, 2015, 2016, 2017, 2018,
# 2019, 2020, 2021, 2022.
# This program is free software: you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program. If not, see
# <http://www.gnu.org/licenses/>.
############################ IOTrace.R #############################
# This file contains the functions needed to trace input and output
# operations, including the reading and writing of files, opening and
# closing of connections, and the creation of plots.
#
# In each case, there are a number of standard functions defined:
# 1. Make a data frame containing the names of functions to trace, and the
# names of the parameters identifying the function/connection
# 2. Define the function that trace calls. This will filter out
# some cases where we don't want to create nodes. Then, it will
# identify the file/connection being manipulated and add them to
# a list.
# 3. Define a function that goes through the list and creates the
# file nodes and edges.
#
# Note that we don't want to combine functions 2 & 3 above because function
# 2 must be called while inside the read/write/close/graphics function. Function
# 3 cannot be called until the R statement containing the call completes
# so that the procedure node exists to connect the file node to.
#
# WARNING: The tracing code filters out calls where specific ddg functions
# are on the call stack. If the names of those functions are changed, the
# code here will need to change as well.
#' .ddg.init.iotrace initialize the data needed to trace I/O functions
#' @return nothing
#' @noRd
.ddg.init.iotrace <- function () {
#print ("Initializing io tracing")
# Store the starting graphics device.
.ddg.set("ddg.open.devices", vector())
# Record the information about the input and output functions
.ddg.set ("ddg.file.write.functions.df", .ddg.create.file.write.functions.df ())
.ddg.set ("ddg.file.read.functions.df", .ddg.create.file.read.functions.df ())
.ddg.set ("ddg.file.close.functions.df", .ddg.create.file.close.functions.df ())
.ddg.set ("ddg.graphics.functions.df", .ddg.create.graphics.functions.df ())
.ddg.set ("ddg.graphics.update.functions.df", ls(which(search()=="package:graphics")))
.ddg.set ("ddg.add.device.output", FALSE)
.ddg.set ("ddg.add.device.io", FALSE)
.ddg.set ("ddg.add.device.close", FALSE)
.ddg.set ("ddg.no.graphics.file", TRUE)
# When true, it means that ggsave was called without
# a plot parameter.
.ddg.set ("ddg.implicit.plot", FALSE)
# When true, it means that ggplot was called to start
# a new plot.
.ddg.set ("ddg.ggplot.created", FALSE)
# On Travis, calling ggsave creates Rplots.pdf, while it does not
# on the Mac. Maybe it is because Travis runs headless??? In
# any case, if ggsave creates it, we will delete it so it
# does not show up in the ddg, causing regression tests to fail.
.ddg.set ("ddg.remove.Rplots", FALSE)
# If Rplots.pdf is created by ggsave and we are unable to delete it,
# this flag will prevent an Rplots.pdf node from being added to the
# end of the DDG.
.ddg.set("ddg.ignore.rplots", FALSE)
# Create an empty list for the input, output, and files
.ddg.clear.input.file()
.ddg.clear.output.file()
.ddg.clear.device.nodes ()
.ddg.create.device.table ()
# Start tracing of input and output functions
# capture.output is called twice to capture the output that is going to
# standard output and to standard error. These are messages that say
# "Tracing..." and list each function being traced.
#print ("Tracing write functions")
write.functions.df <- .ddg.get("ddg.file.write.functions.df")
tryCatch (
mapply(trace.oneOutput, write.functions.df$function.names, write.functions.df$package.names),
error = function (e) print (e)
)
#print ("Tracing read functions")
read.functions.df <- .ddg.get("ddg.file.read.functions.df")
mapply(trace.oneInput, read.functions.df$function.names, read.functions.df$package.names)
trace.oneClose <-
function (f) {
utils::capture.output(
utils::capture.output(trace (as.name(f),
function () .ddg.trace.close (),
print=FALSE),
type="message"))
}
lapply(.ddg.get("ddg.file.close.functions.df")$function.names, trace.oneClose)
#print ("Tracing graphics open")
trace.oneGraphicsOpen <-
function (f) {
utils::capture.output(
utils::capture.output(trace (as.name(f),
function () .ddg.trace.graphics.open (),
print=FALSE),
type="message"))
}
lapply(.ddg.get("ddg.graphics.functions.df")$function.names, trace.oneGraphicsOpen)
#print ("Tracing graphics update")
trace.oneGraphicsUpdate <-
function (f) {
utils::capture.output(
utils::capture.output(trace (as.name(f),
function () .ddg.trace.graphics.update (),
print=FALSE),
type="message"))
}
lapply(.ddg.get("ddg.graphics.update.functions.df"), trace.oneGraphicsUpdate)
#print ("Tracing dev.off")
utils::capture.output(
utils::capture.output(trace (grDevices::dev.off,
function () .ddg.trace.graphics.close (),
print=FALSE),
type="message"))
if (isNamespaceLoaded("vroom")) {
.ddg.trace.vroom.functions()
}
else {
# Loading happens when vroom::vroom_write is called if the
# vroom library has not been previously loaded, or
# when the library is attached with library(vroom)
#print ("Setting onLoad hook for vroom")
setHook(packageEvent("vroom", "onLoad"),
function (...) {
#print ("onLoad hook called for vroom")
.ddg.trace.vroom.functions()
},
"replace"
)
}
if (isNamespaceLoaded("ggplot2")) {
.ddg.trace.ggplot2.functions()
}
else {
setHook(packageEvent("ggplot2", "onLoad"),
function (...) {
#print ("onLoad hook called for ggplot2")
.ddg.trace.ggplot2.functions()
},
"replace"
)
}
#print ("Done initializing IO tracing")
}
trace.oneOutput <- function (f, pkg) {
#print (paste ("Adding tracing for ", f))
tryCatch (
if (pkg == "") {
# If vroom is loaded, and "" is passed in for the package,
# this gives: <simpleError in getFunction(what, where = whereF): no function 'vroom_write' found>
utils::capture.output(
utils::capture.output(trace (as.expression(f),
function () .ddg.trace.output(),
print=FALSE),
type="message"))
}
else {
# If vroom is loaded, and "vroom" is passed in for the package, this gives:
# <simpleError in as.environment(where): no item called "vroom" on the search list>
# It needs to be attached to be on the search list. But if it is already loaded,
# the load hook won't get called. And if it is called as vroom::vroom_write,
# it will never get attached. Is there a different parameter to pass to where?
utils::capture.output(
utils::capture.output(trace (as.expression(f),
function () .ddg.trace.output(),
where = pkg,
print=FALSE),
type="message"))
},
error = function (e) {warning ("I/O function ", f, " might not get traced.", call. = FALSE) }
)
}
untrace.oneFunction <- function (f, pkg) {
#cat ("Untracing", f, "in package", pkg)
tryCatch (
if (pkg == "") {
utils::capture.output(
utils::capture.output(
untrace (as.expression(f)) ,
type="message"))
}
else {
utils::capture.output(
utils::capture.output(
untrace (as.expression(f), where = asNamespace(pkg)),
type="message"))
},
error = function (e) {})
}
trace.oneInput <- function (f, pkg) {
tryCatch (
if (pkg == "") {
utils::capture.output(
utils::capture.output(trace (as.expression(f),
function () .ddg.trace.input(),
print=FALSE),
type="message"))
}
else {
utils::capture.output(
utils::capture.output(trace (as.expression(f),
function () .ddg.trace.input(),
where = pkg,
print=FALSE),
type="message"))
},
error = function (e) {warning ("I/O function ", f, " might not get traced.", call. = FALSE) }
)
}
#' .ddg.stop.iotracing stops tracing I/O calls. This should be called when RDT finishes.
#' @return nothing
#' @noRd
.ddg.stop.iotracing <- function () {
# Stop tracing output functions.
# utils::capture.output is used to prevent "Untracing" messages from appearing
# in the output
#print ("Untracing file write functions")
file.write.functions.df <- .ddg.get("ddg.file.write.functions.df")
mapply(untrace.oneFunction, file.write.functions.df$function.names, file.write.functions.df$package.names)
#print ("Removing vroom and ggplot2 hooks")
setHook (packageEvent("vroom", "onLoad"), NULL, "replace")
setHook (packageEvent("vroom", "attach"), NULL, "replace")
setHook (packageEvent("ggplot2", "onLoad"), NULL, "replace")
setHook (packageEvent("ggplot2", "attach"), NULL, "replace")
#print ("Untracing file read functions")
file.read.functions.df <- .ddg.get("ddg.file.read.functions.df")
mapply(untrace.oneFunction, file.read.functions.df$function.names, file.read.functions.df$package.names)
utils::capture.output (
untrace(.ddg.get("ddg.file.close.functions.df")$function.names),
type="message")
utils::capture.output (untrace(.ddg.get("ddg.graphics.functions.df")$function.names),
type="message")
utils::capture.output (untrace(.ddg.get("ddg.graphics.update.functions.df")),
type="message")
utils::capture.output (untrace(grDevices::dev.off), type="message")
#print ("Untracing vroom functions")
.ddg.untrace.vroom.functions()
#print ("Untracing ggplot2 functions")
.ddg.untrace.ggplot2.functions()
#print ("Done untracing")
}
################### Helper functions ######################3
#' .ddg.get.traced.function.frame.number gets the frame number for a function
#' being traced
#' @return the frame number of the function being traced.
#' Returns NULL if there is no occurrence of .doTrace
#' on the stack.
#' @noRd
.ddg.get.traced.function.frame.number <- function() {
.ddg.get.frame.number.for.func (".doTrace") - 1
}
#' .ddg.get.frame.number.for.func gets the frame number for a function
#' being called
#' @return the frame number of the function being called.
#' Returns NULL if there is no occurrence of the function
#' on the stack.
#' @noRd
.ddg.get.frame.number.for.func <- function (func.name) {
calls <- sys.calls()
calls <- mapply( `[[`, calls, 1, SIMPLIFY = TRUE )
func.frame <- which( calls == func.name )
if( length(func.frame) > 0 )
{
# Return the last one
return (func.frame[length(func.frame)])
}
else
{
return (NULL)
}
}
#' .ddg.is.call.to determines if the call passed in is a call to the passed in function
#' @param call a parse tree for a function call
#' @param func the name of a function
#' @return TRUE if the call passed in is a call to the function name passed in
#' @noRd
.ddg.is.call.to <- function (call, func) {
# Check for function name
if (is.symbol(call[[1]])) {
return (as.character(call[[1]]) == func)
}
# Check for a function name qualified by its package
if (is.call(call[[1]])) {
if (call[[1]][[1]] == "::" || call[[1]][[1]] == ":::") {
return (as.character(call[[1]][[3]]) == func)
}
}
return (FALSE)
}
#' .ddg.num.calls.to returns the number of calls to the passed in function
#' @param func the name of a function to look for
#' @return the number of calls to the function on the stack
#' @noRd
.ddg.num.calls.to <- function (func) {
calls.found <- sapply (sys.calls(), .ddg.is.call.to, func )
return (sum(calls.found))
}
#' .ddg.inside.call.to returns True if there is a call to the passed in
#' function anywhere on the call stack.
#' @param func The name of a function
#' @return True if there is a call to the passed in function
#' @noRd
.ddg.inside.call.to <- function (func) {
calls.found <- sapply (sys.calls(), .ddg.is.call.to, func )
return (any (calls.found))
}
#' .ddg.get.call.to returns the most recent call on the stack that
#' is to the named function.
#' @param func The name of a function
#' @return The call to that function
#' @noRd
.ddg.get.call.to <- function (func) {
return (Find(function(call).ddg.is.call.to(call, func), sys.calls(), right=TRUE))
}
################## Functions to handle tracing of read functions ##################
#' .ddg.create.file.read.functions.df initialize the information about functions
#' that read from files
#' @return a data frame consisting of one row for each input function.
#' Each row contains the function name, and the name of the paramter that
#' holds the file argument.
#' @noRd
.ddg.create.file.read.functions.df <- function () {
# Functions that read files
function.names <-
c ("read.table",
"read.dcf",
"readRDS",
"readLines", "readBin", "readChar", "scan", "load", "readRenviron",
# Sometimes source calls readLines but not always. readLines is called
# when called from RStudio, but not when called from Rscript.
"source")
# The argument that represents the file name
param.names <-
c ("file",
"file",
"file",
"con", "con", "con", "file", "file", "path",
"file")
package.names <-
c ("",
"",
"",
"", "", "", "", "", "",
"")
return (data.frame (function.names, param.names, package.names, stringsAsFactors=FALSE))
}
#' .ddg.clear.input.file clears out the list of input files. This should be
#' called on initialization and after the file nodes are created.
#' @return nothing
#' @noRd
.ddg.clear.input.file <- function () {
.ddg.set ("input.files", character())
}
#' .ddg.add.input.file adds a file name to the input list.
#' @param fname the name of the file to add to the list, or a connection object
#' @return nothing
#' @noRd
.ddg.add.input.file <- function (fname) {
input.files <- .ddg.get("input.files")
if (.ddg.is.connection(fname)) {
fname <- showConnections(TRUE)[as.character(fname), "description"]
}
# Only add the file to the list if it is not already there. It could be
# there if there are multiple functions called indirectly in one R statement
# that read from the same file, like readLines and scan.
if (!(fname %in% input.files)) {
.ddg.set ("input.files", c(input.files, list(fname)))
}
}
#' .ddg.trace.input is called when one of the input functions is called in a script.
#' This function saves the name of the file that is being read from in
#' the input.files variable so that the proper nodes can be created when
#' the statement doing the output is complete.
#' @return nothing
#' @noRd
.ddg.trace.input <- function () {
#print ("In .ddg.trace.input")
# Get the frame corresponding to the output function being traced
frame.number <- .ddg.get.traced.function.frame.number()
#print ("Got frame number")
# Filter out some calls based on what function called the input function.
# The is.symbol test is used because it is possible that the caller is a
# closure and thus does not have a name.
input.caller <- sys.call (frame.number - 1)[[1]]
#print ("Got input.caller")
if (is.symbol (input.caller)) {
#print ("input.caller is symbol")
input.caller.name <- as.character(input.caller)
#print ("got input.caller.name")
# Check if the function that called the input function is any ddg function.
# If it is, ignore this call. .ddg.load.history is an example of a
# function that does input that we would want to ignore.
if (startsWith (input.caller.name, "ddg") ||
startsWith (input.caller.name, ".ddg") ||
startsWith (input.caller.name, "prov")) {
return()
}
}
#print ("Checking for library, loadNamespace, .ddg.json.string")
# Don't collect provenance when loading library packages. Also, when writing out the
# json, files get read in order to identify package version numbers.
if (.ddg.inside.call.to ("library") ||
.ddg.inside.call.to ("packageDescription") ||
.ddg.inside.call.to ("packageVersion") ||
.ddg.inside.call.to ("packageDate") ||
.ddg.inside.call.to ("loadNamespace") ||
.ddg.inside.call.to ("readCitationFile") ||
.ddg.inside.call.to (".ddg.json.string")) {
return()
}
# Get the name of the input function
call <- sys.call (frame.number)
if (typeof(call[[1]]) == "closure") {
# print (sys.calls())
return()
}
fname <- as.character(call[[1]])
# Remove the package name if present
if (!is.symbol (fname) && length(fname > 1)) {
fname <- fname[length(fname)]
}
#print (paste ("Input function traced: ", fname))
#print ("Checking for source")
# If we are sourcing a script, record the file as a sourced script instead of
# as an input file.
if (fname == "source") {
#print ("Tracing source")
sourced.file.name <- eval (as.symbol ("file"), envir=sys.frame(frame.number))
if (.ddg.is.connection(sourced.file.name)) {
sourced.file.name <- showConnections(TRUE)[as.character(sourced.file.name), "description"]
}
# Store script number & name.
snum <- .ddg.store.script.info (sourced.file.name)
# Save a copy of the script
sname <- basename(sourced.file.name)
file.copy(sourced.file.name, paste(.ddg.path.scripts(), sname, sep="/"))
return ()
}
if (.ddg.inside.call.to ("source")) {
#print("Reading sourced file")
source.frame.number <- .ddg.get.frame.number.for.func ("source")
if (source.frame.number == frame.number - 1) {
# This read call is what is actually reading the sourced file.
# The information was recorded when the call to source was found.
return()
}
}
#print ("Getting ready to save input info")
# Get the name of the file parameter for the input function
file.read.functions <- .ddg.get ("ddg.file.read.functions.df")
file.param.name <-
file.read.functions$param.names[file.read.functions$function.names == fname]
#print (paste ("Input file parameter:", file.param.name))
# calling.env <- sys.frame(frame.number)
# print (ls (calling.env))
# cat ("file.param.name = ", file.param.name)
# file.param.value = calling.env[[file.param.name]]
# if (is.null (file.param.value)) {
# cat ("value is NULL")
# }
# else {
# cat ("value is ", file.param.value)
# }
tryCatch (
{
# Get the value of the file parameter
input.file.name <- eval (as.symbol(file.param.name), sys.frame(frame.number))
#print (paste ("type of input.file.name is ", .ddg.get.val.type.string(input.file.name)))
#print (paste ("input.file.name =", input.file.name))
# Save the file name so the file node can be created when the statement is complete.
# we do not want to create the nodes because the procedure node to connect to does not
# exist yet. If it is a raw vector rather than a file name, do not save it.
if (!is.raw(input.file.name)) {
.ddg.add.input.file (input.file.name)
}
},
error = function (e) { } # If the file parameter is missing, there is nothing to save.
)
}
#' .ddg.create.file.read.nodes.and.edges creates file nodes and data in edges for any files
#' that were read during execution of the last R statement
#' @return nothing
#' @noRd
.ddg.create.file.read.nodes.and.edges <- function () {
# Get the list of files that have been read by the last statement.
files.read <- .ddg.get ("input.files")
# Adds the files read to ddg.infilenodes for use in determining reads
# and writes in the hashtable.
.ddg.add.infiles (files.read)
for (file in files.read) {
# print (paste ("file read: ", file))
# Use URL node for URLs and for socket connections
if (grepl ("://", file) || startsWith (file, "->"))
{
if (grepl ("://", file) ) {
# Save the Web page
url.copy <- .ddg.url.copy (file)
.ddg.url.node(file, url.copy)
}
else {
# Maybe we should change the node type to be "Remote" or something?
.ddg.url.node(file, file)
}
.ddg.data2proc(file, environmentName(.GlobalEnv))
}
# Handle files
else {
# Only create the node and edge if there actually is a file
if (file.exists(file)) {
# Create the file node and edge
if( ! .ddg.data.node.exists(.ddg.calculate.file.node.label(file), dscope="undefined", dtype="File") )
.ddg.file.copy(file)
.ddg.data2proc(.ddg.calculate.file.node.label(file), dscope="undefined")
}
# If the filename contains a :, then it is referencing a file within
# a zip file, so checck that the zip file exists.
else if (grepl(":", file)) {
zipfile <- sub (":.*", "", file)
if (file.exists (zipfile)) {
# Create the file node and edge
.ddg.file.copy(zipfile, file, NULL)
.ddg.data2proc(file, dscope="undefined")
}
}
}
}
# Clear the list of input files now that they have been handled.
.ddg.clear.input.file ()
}
#' .ddg.url.copy saves the contents of a web page referenced by a URL in the data
#' directory
#' @param url the URL as a string
#' @return the name of the file where the copy is stored. This is
#' a relative path beginning with the data directory.
#' @noRd
.ddg.url.copy <- function (url) {
# Get last part of the url.
file.name <- basename(url)
# Add number to file name.
dfile <- paste(.ddg.dnum()+1, "-", file.name, sep="")
# Get path plus file name to where the file will be copied
dpath <- paste(.ddg.path.data(), "/", dfile, sep="")
# Download and save the webpage
curl::curl_download (url, dpath)
if (.ddg.debug.lib()) print(paste("url.copy: ", url))
return (paste(.ddg.data.dir(), dfile, sep="/"))
}
################## Functions to handle tracing of write functions ##################
#' .ddg.create.file.write.functions.df initialize the information about functions
#' that write to files
#' @return a data frame consisting of one row for each output function.
#' Each row contains the function name, and the name of the parameter that
#' holds the file argument.
#' @noRd
.ddg.create.file.write.functions.df <- function () {
# Functions that write files. We include the lowest level functions
# used in R. For example, write.csv is not in the list because it
# uses write.table to do the output.
function.names <-
c ("write.table", "write", "writeLines",
"writeChar", "writeBin",
"saveRDS", "save", "dput", "dump",
"data")
# The argument that represents the file name
param.names <-
c ("file", "file", "con",
"con", "con",
"file", "file", "file", "file",
"...")
package.names <-
c ("", "", "",
"", "",
"", "", "", "",
"")
return (data.frame (function.names, param.names, package.names, stringsAsFactors=FALSE))
}
#' .ddg.clear.output.file clears out the list of output files. This should be
#' called on initialization and after the file nodes are created.
#' @return nothing
#' @noRd
.ddg.clear.output.file <- function () {
.ddg.set ("output.files", character())
.ddg.set ("ddg.output.data", character())
}
#' .ddg.add.output.file adds a file name to the output list.
#' @param fname the name of the file to add to the list, or a connection object
#' @return nothing
#' @noRd
.ddg.add.output.file <- function (fname) {
output.files <- .ddg.get("output.files")
# Only add the file to the list if it is not already there. It could be
# there if there are multiple functions called indirectly in one R statement
# that write to the same file.
if (!(fname %in% output.files) && is.character(fname) &&
!endsWith (fname, ".snapshot")) {
#print (paste ("Adding output file", fname))
#print (sys.calls())
.ddg.set ("output.files", append(output.files, fname))
}
}
#' .ddg.add.output.data adds a name to the output list.
#' @param fname the name of the dataset to add to the list
#' @return nothing
#' @noRd
.ddg.add.output.data <- function (dname) {
if (length(dname) == 0) return()
output.data <- .ddg.get("ddg.output.data")
# Only add the file to the list if it is not already there. It could be
# there if there are multiple functions called indirectly in one R statement
# that write to the same file.
if (!(dname %in% output.data) && is.character(dname)) {
#print (paste ("Adding output file", fname))
#print (sys.calls())
.ddg.set ("ddg.output.data", append(output.data, dname))
}
}
#' .ddg.trace.output is called when one of the output functions is called in a script.
#' This function saves the name of the file that is being written in
#' the output.files variable so that the proper nodes can be created when
#' the statement doing the output is complete.
#' @return nothing
#' @noRd
.ddg.trace.output <- function () {
#print ("In .ddg.trace.output")
# Get the frame corresponding to the output function being traced
frame.number <- .ddg.get.traced.function.frame.number()
# Check if the function that called the output function is a ddg function.
# If it is, ignore this call. The is.call check is here because it is
# possible that the caller is a closure and thus does not have a name.
# The frame.number might be 1 if we are in console mode.
if (frame.number > 1) {
output.caller <- sys.call (frame.number - 1)[[1]]
if (is.symbol (output.caller)) {
output.caller.name <- as.character(output.caller)
if (startsWith (output.caller.name, "ddg") ||
startsWith (output.caller.name, ".ddg") ||
startsWith (output.caller.name, "prov")) {
return()
}
}
}
# Check that the function is not being called due to saving a snapshot file.
if (length (grep ("^.ddg.save.snapshot", sys.calls())) > 0) {
return()
}
# Get the name of the output function
call <- sys.call (frame.number)
fname <- as.character(call[[1]])
# Remove the package name if present
if (length(fname > 1)) {
fname <- fname[length(fname)]
}
#print (paste ("Output function traced: ", fname))
# Set a flag to indicate that a new plot is started but
# its name is not known yet.
if (fname == "ggplot") {
.ddg.set ("ddg.ggplot.created", TRUE)
.ddg.set ("ddg.last.ggplot", "")
}
else if (fname == "data") {
# The as.character gives us a vector that includes "vector" as its first element
# The [-1] removes that element.
output.data <- as.character(substitute(vector (...), env = sys.frame(frame.number)))[-1]
lapply (output.data, .ddg.add.output.data)
}
else {
# Get the name of the file parameter for the output function
file.write.functions <- .ddg.get ("ddg.file.write.functions.df")
file.param.name <-
file.write.functions$param.names[file.write.functions$function.names == fname]
#print (paste ("Output file parameter:", file.param.name))
# Get the value of the file parameter
output.file.name <- eval (as.symbol(file.param.name), envir = sys.frame(frame.number))
#print (paste ("output.file.name =", output.file.name))
# Save the file name so the file node can be created when the statement is complete.
# we do not want to create the nodes because the procedure node to connect to does not
# exist yet, and the file has not been written to yet.
.ddg.add.output.file (output.file.name)
}
}
#' .ddg.create.file.write.nodes.and.edges creates file nodes and data out edges for any files
#' that are written by the last statement executed. It knows what the files are by looking
#' in the output.files variable stored in the ddg environment.
#' @return nothing
#' @noRd
.ddg.create.file.write.nodes.and.edges <- function () {
# Get the list of files that have been written by the last statement.
files.written <- .ddg.get ("output.files")
for (file in files.written) {
#print (paste (".ddg.create.file.write.nodes.and.edges file written: ", file))
if (.ddg.is.connection(file)) {
conn <- as.numeric(file)
# If it is a closed connection, use the file it is connected to
# If it is still open, don't use it because the contents on disk won't
# be correct until it is closed.
if (.ddg.is.connection.open(conn)) {
next
}
file <- .ddg.get.connection.description(conn)
}
# Check that the file exists. If it does, we will assume that
# it was created by the write call that just executed.
if (file.exists (file)) {
# Create the file node and edge
#print ("Copying file")
.ddg.file.out (file)
}
}
# If this file is written by ggsave and the plot was implicit,
# add an input edge for the last plot.
if (.ddg.get ("ddg.implicit.plot")) {
.ddg.data2proc (.ddg.get("ddg.last.ggplot"), dscope=NULL)
# Clear the flag
.ddg.set ("ddg.implicit.plot", FALSE)
}
# If Rplots was surprisingly created by Travis, delete it!
# This seems to happen because Travis runs headless.
if (.ddg.get ("ddg.remove.Rplots") && file.exists("Rplots.pdf")) {
unlink ("Rplots.pdf")
if (file.exists("Rplots.pdf")) {
.ddg.set("ddg.ignore.rplots", TRUE)
}
.ddg.set ("ddg.remove.Rplots", FALSE)
}
# Handle data sets loaded with the data function.
datasets <- .ddg.get ("ddg.output.data")
sapply (datasets,
function (dataset) {
#print (paste ("Handling dataset", dataset))
# Only create the node if we can find the dataset in memory. It might not be in the
# global environment.
tryCatch (
{
.ddg.data.node ("Data", dataset, eval(as.name(dataset), envir=globalenv()), environmentName(globalenv()))
.ddg.lastproc2data (dataset)
},
error = function(e) {}
)
}
)
# Clear the list of output files now that they have been handled.
.ddg.clear.output.file ()
}
#' .ddg.file.out creates a data node of type File. The label
#' is the filename with the directory removed.
#' It copies the file to the DDG directory. A data flow edge
#' is also created from creating procedure node pname to the new file node.
#'
#' @param filename name of the file. The name should include the path
#' to the file if it is not in the working directory.
#' @return the full path to the file that is saved.
#' @noRd
.ddg.file.out <- function(filename) {
#cat (".ddg.file.out: filename = ", filename, "\n")
# Adds the files written to ddg.outfilenodes for use in determining reads
# and writes in the hashtable.
.ddg.add.outfiles (filename)
dname <- .ddg.calculate.file.node.label(filename)
# Create output file node called filename and copy file.
saved.file <- .ddg.file.copy(filename, dname)
# Create data flow edge from operation node to file node.
.ddg.lastproc2data (dname)
return (saved.file)
}
################ Functions to manage connections ####################3
#' .ddg.is.connection returns true if the object passed in is a connection
#' @param value an R object
#' @return true if the R object is a connection used to do I/O
#' @noRd
.ddg.is.connection <- function (value) {
return ("connection" %in% class(value))
}
#' .ddg.get.open.connections returns a matrix containing the list of open connections
#' @return a matrix containing information about all open connections
#' @noRd
.ddg.get.open.connections <- function () {
return (showConnections(FALSE))
}
#' .ddg.get.connection.description returns the thing that the connection connects to.
#' This can be a filename, URL, socket, etc.
#' @param conn a connection. This can either be a connection object
#' or the number associated with the connection.
#' @return a description of the input/output connected to
#' @noRd
.ddg.get.connection.description <- function (conn) {
return (showConnections(TRUE)[as.character(conn), "description"])
}
#' .ddg.is.connection.open returns true if the connection is still open.
#' @param conn a connection. This can either be a connection object
#' or the number associated with the connection.
#' @return TRUE if the connection is open
#' @noRd
.ddg.is.connection.open <- function (conn) {
return (showConnections(TRUE)[as.character(conn), "isopen"] == "opened")
}
#' .ddg.can.read.connection returns true if the given connection was opened for reading,
#' whether or not the connection is currently open.
#' @param conn a connection. This can either be a connection object
#' or the number associated with the connection.
#' @return true if the given connection is readable
#' @noRd
.ddg.can.read.connection <- function (conn) {
return (showConnections(TRUE)[as.character(conn), "can read"] == "yes")
}
#' .ddg.can.write.connection returns true if the given connection was opened for writing,
#' whether or not the connection is currently open.
#' @param conn a connection. This can either be a connection object
#' or the number associated with the connection.
#' @return true if the given connection is writable
#' @noRd
.ddg.can.write.connection <- function (conn) {
return (showConnections(TRUE)[as.character(conn), "can write"] == "yes")
}
#' .ddg.create.file.close.functions.df initializes the information about functions
#' that read from files
#' @return a data frame containing 2 columns:
#' names of functions that close connections, and
#' name of the parameter that holds the connection
#' @noRd
.ddg.create.file.close.functions.df <- function () {
# Functions that close connections
function.names <- c ("close.connection")
# The argument that represents the connection name
param.names <- c ("con")
return (data.frame (function.names, param.names, stringsAsFactors=FALSE))
}
#' .ddg.trace.close is called when any of the functions to close connections
#' is called. This will add the description of any connection that was open for
#' writing to the list for which output file nodes should be created.
#' There are a few exceptions where a close function is called but
#' no node will be created: if called directly from a ddg function, or if
#' any call on the stack is to capture.output, parse, or .ddg.snapshot,
#' or if there is any read or write function on the call stack. If one of
#' the read or write functions is closing the connection, then we will
#' already be creating the right nodes.
#' @return nothing
#' @noRd
.ddg.trace.close <- function () {
#print ("In .ddg.trace.close")
# Get the frame corresponding to the close function being traced
frame.number <- .ddg.get.traced.function.frame.number()
# Check if the function that called the close function is a ddg function.
# If it is, ignore this call. The is.symbol check is here because it is
# possible that the caller is a closure and thus does not have a name.
close.caller <- sys.call (frame.number - 1)[[1]]
if (is.symbol (close.caller)) {
close.caller.name <- as.character(close.caller)
if (startsWith (close.caller.name, "ddg") ||
startsWith (close.caller.name, ".ddg") ||
startsWith (close.caller.name, "prov")) { #
#print ("Returning - inside a ddg function")
return()
}
}
# Check that the function is not being called due to a call to capture output (used to
# hide standard output), parse (used to read the script being executed), or
# .ddg.snapshot (used to save copies of complex data values)
if (.ddg.inside.call.to ("capture.output") || .ddg.inside.call.to ("parse")
|| .ddg.inside.call.to (".ddg.snapshot")
|| .ddg.inside.call.to(".ddg.save.annotated.script")) {
#print ("Returning -- inside capture.ouput, parse or .ddg.snapshot")
return()
}
# Check that we are not inside any read or write functions. If we are,
# the appropriate nodes will be created by those functions
read.funs <- .ddg.get("ddg.file.read.functions.df")$function.names
if (any (sapply (read.funs, .ddg.inside.call.to))) {
#print ("Returning -- inside a read function")
return()
}
write.funs <- .ddg.get("ddg.file.write.functions.df")$function.names
if (any (sapply (write.funs, .ddg.inside.call.to))) {
#print ("Returning -- inside a write function")
return()
}
#print(paste("ddg.trace.close: close.caller =", close.caller))
# Get the name of the close function
call <- sys.call (frame.number)
fname <- as.character(call[[1]])
# Remove the package name if present
if (length(fname > 1)) {
fname <- fname[length(fname)]
}
# print (paste (".ddg.trace.close: fname = ", fname))
if (fname == "ggsave") {
filename <- eval (as.symbol("filename"), envir=sys.frame(frame.number))
.ddg.add.output.file (filename)
full.call <- match.call (ggplot2::ggsave, call, envir=sys.frame(frame.number))
param.names <- names(full.call)
# The plot parameter is optional in ggsave. If not provided,
# we need to link to the last plot created. Set a flag so
# that is done after the statement completes.
if (!("plot" %in% param.names)) {
.ddg.set("ddg.implicit.plot", TRUE)
}
# Remember that Rplots.pdf did not exist and was not
# explicitly requested. If ggsave creates it, we
# will delete it after ggsave completes so the node
# does not appear in the ddg. This is a Travis issue,
# which I believe happens because Travis runs headless, resulting
# in an extra node in the ddg.
if (filename != "Rplots.pdf" && !file.exists("Rplots.pdf")) {
.ddg.set ("ddg.remove.Rplots", TRUE)
}
}
else {
# Get the name of the connection parameter for the close function
file.close.functions <- .ddg.get ("ddg.file.close.functions.df")
file.param.name <-
file.close.functions$param.names[file.close.functions$function.names == fname]
#print (paste (".ddg.trace.close: fname = ", fname))
#print (paste (".ddg.trace.close: file.param.name = ", file.param.name))
# Get the value of the connection parameter
close.conn <- eval (as.symbol(file.param.name), envir = sys.frame(frame.number))
# If the connection was opened for writing, then add the connection
# to the list for which we create output file nodes. We do not need
# to do anything if the connection was only open for reading because the
# read code will have already created the node.
if (.ddg.can.write.connection (close.conn)) {
.ddg.add.output.file (.ddg.get.connection.description(close.conn))
}
}
}
#' .ddg.create.file.nodes.for.open.connections creates nodes for any writable connections
#' that are open. This is intended to be called when a script is finishing, so that we will
#' have the connections associated with files that may have been written to, but not closed.
#' @return nothing
#' @noRd
.ddg.create.file.nodes.for.open.connections <- function () {
openConns <- .ddg.get.open.connections()
lapply (openConns[openConns[, "can write"] == "yes", "description"],
.ddg.add.output.file)
.ddg.create.file.write.nodes.and.edges ()
}
################ Functions to track graphics calls ####################
#' .ddg.create.graphics.nodes.and.edges creates all the nodes and edges associated with
#' graphics functions executed in the last line of R code.
#' @return nothing
#' @noRd
.ddg.create.graphics.nodes.and.edges <- function () {
.ddg.add.graphics.device.node()
.ddg.add.graphics.io ()
.ddg.capture.graphics()
.ddg.clear.device.nodes ()
}
#' .ddg.clear.device.nodes clears the information that we need to reset with each
#' R statement executed.
#' @return nothing
#' @noRd
.ddg.clear.device.nodes <- function () {
.ddg.set ("ddg.new.device.nodes", character())
.ddg.set ("ddg.rplots.pdf.saved", FALSE)
.ddg.set ("ddg.captured.devices", numeric())
}
#' .ddg.add.device.node adds a device node.
#' .ddg.new.device.nodes is the list of device nodes created in the previous
#' R statement. Since an R statement may result in multiple calls to graphics
#' functions, we want to remember which dev nodes we have created so we don't
#' end up with duplicates attached to the same node.
#' @return nothing
#' @noRd
.ddg.add.device.node <- function (new.device.node) {
device.nodes <- .ddg.get ("ddg.new.device.nodes")
.ddg.set ("ddg.new.device.nodes", append(device.nodes, new.device.node))
}
#' .ddg.create.device.table creates an empty device table to remember which file
#' names are associated with each graphic device
#' @return nothing
#' @noRd
.ddg.create.device.table <- function() {
device.table <-
data.frame(device.number = numeric(),
file.name = character(),
stringsAsFactors = FALSE)
.ddg.set ("ddg.device.table", device.table)
}
#' .ddg.add.to.device.table adds a binding between a device number and a file name
#' to the device table.
#' @param device.number the number of the graphics device
#' @param file.name the name of the file being written to
#' @return nothing
#' @noRd
.ddg.add.to.device.table <- function (device.number, file.name) {
device.table <- .ddg.get ("ddg.device.table")
# If the number is in the table, update the associated file name
if (device.number %in% device.table$device.number) {
device.table$file.name[device.table$device.number == device.number] <- file.name
}
# Add a new entry for the device number and file name
else {
device.table <- rbind (device.table, data.frame (device.number, file.name,
stringsAsFactors = FALSE))
}
.ddg.set ("ddg.device.table", device.table)
}
#' .ddg.get.file.for.device returns the file name associated with a graphics device
#' @param device.number the number of the graphics device to look up
#' @return the name of the file associated with the device number.
#' Returns an empty string if the device number is not in the table.
#' @noRd
.ddg.get.file.for.device <- function (device.number) {
device.table <- .ddg.get ("ddg.device.table")
if (device.number %in% device.table$device.number) {
return (device.table$file.name[device.table$device.number == device.number])
}
else {
return ("")
}
}
#' .ddg.create.graphics.functions.df initialize the information about functions that
#' initialize graphics devices
#' @return a data frame consisting of one row for each function.
#' Each row contains the function name, and the name of the parameter that
#' holds the file argument.
#' @noRd
.ddg.create.graphics.functions.df <- function () {
sysname <- Sys.info()[["sysname"]]
# Functions that read files and the names of the arguments that hold file names
if (sysname == "Windows") {
function.names <-
c ("pdf", "cairo_pdf", "postscript", "cairo_ps", "bmp", "jpeg",
"png", "svg", "tiff", "x11", "X11", "windows")
param.names <-
c ("file", "filename", "file", "filename", "filename", "filename",
"filename", "filename", "filename", NA, NA, NA)
}
else if (sysname == "Darwin") { # Running on a Mac
function.names <-
c ("pdf", "cairo_pdf", "postscript", "cairo_ps", "bmp", "jpeg",
"png", "svg", "tiff", "x11", "X11", "quartz")
param.names <-
c ("file", "filename", "file", "filename", "filename", "filename",
"filename", "filename", "filename", NA, NA, NA)
}
else { # Running on Linux
function.names <-
c ("pdf", "cairo_pdf", "postscript", "cairo_ps", "bmp", "jpeg",
"png", "svg", "tiff", "x11", "X11")
param.names <-
c ("file", "filename", "file", "filename", "filename", "filename",
"filename", "filename", "filename", NA, NA)
}
return (data.frame (function.names, param.names, stringsAsFactors=FALSE))
}
#' .ddg.trace.graphics.open is called when a function that opens a graphics device is called.
#' If this call was due to a call to .ddg.capture.graphics or .ddg.trace.graphics.update,
#' the function returns without doing anything.
#' Otherwise, if a file was created to hold the graphics, it records the file name.
#' It also sets the .ddg.add.device.output flag so that when the current R statement completes
#' the appropriate nodes and edges can be created.
#' @return nothing
#' @noRd
.ddg.trace.graphics.open <- function () {
if (.ddg.inside.call.to (".ddg.capture.graphics") ||
.ddg.inside.call.to (".ddg.trace.graphics.update") ||
.ddg.inside.call.to (".ddg.graphic.snapshot") ||
.ddg.inside.call.to ("ggsave")) {
return()
}
#print ("In .ddg.trace.graphics.open")
#print (sys.calls())
# Get the frame corresponding to the graphics function being traced
frame.number <- .ddg.get.traced.function.frame.number()
call <- sys.call (frame.number)
# Normally, we would expect to be tracing a function that we have asked
# to trace. However, if this inside an R Markdown file that the user
# is running from console mode, we end up getting a closure instead.
# In that case, the plot is going into the on-screen R Markdown display,
# We will capture the output the same way as if it was going to an
# X11 window or something similar.
if (rlang::is_closure (call[[1]])) {
.ddg.set("ddg.no.graphics.file", TRUE)
.ddg.set("ddg.last.graphics.file", "")
.ddg.set ("ddg.add.device.output", TRUE)
return()
}
# Get the name of the graphics function
fname <- as.character(call[[1]])
# Remove the package name if present
if (length(fname) > 1) {
fname <- fname[length(fname)]
}
#print(paste (".ddg.trace.graphics.open: fname =", fname))
# Get the name of the file parameter for the graphics function
graphics.functions <- .ddg.get ("ddg.graphics.functions.df")
file.param.name <-
graphics.functions$param.names[graphics.functions$function.names == fname]
# X11 and quartz device writes to the screen so there is no file parameter
if (is.na (file.param.name)) {
.ddg.set("ddg.no.graphics.file", TRUE)
.ddg.set("ddg.last.graphics.file", "")
}
else {
#print(paste (".ddg.trace.graphics: file.param.name =", file.param.name))
# Get the value of the file parameter
file <- eval (as.symbol(file.param.name), envir = sys.frame(frame.number))
#print(paste (".ddg.trace.graphics.open: file =", file))
if (!is.null(file)) {
.ddg.set("ddg.no.graphics.file", FALSE)
.ddg.set ("ddg.last.graphics.file", file)
}
}
# Set the flag to tell .ddg.add.graphics.device.node that it has work to do
# when it gets called. We cannot call that function here because we
# need to wait until the R statement completes execution so that the
# procedure node exists before we create the graphics data nodes and edges.
.ddg.set ("ddg.add.device.output", TRUE)
}
#' .ddg.add.graphics.device.node creates an output node for a graphics device and
#' connects it to the last procedural node. Does nothing if the last R statement
#' did not write to a graphics device.
#' @return nothing
#' @noRd
.ddg.add.graphics.device.node <- function() {
# Check if a graphics device was written to
if (!.ddg.get ("ddg.add.device.output")) {
return()
}
#print ("In .ddg.add.graphics.device.node")
#print (paste ("dev.list =", grDevices::dev.list(),
# names(grDevices::dev.list()), collapse=", "))
#print (paste ("dev.cur =", grDevices::dev.cur()))
if (!names(grDevices::dev.cur()) %in% c("RStudioGD", "quartz", "quartz_off_screen", "windows")) {
# Record the binding between the current device and the graphics file, if
# a file is being used.
if (.ddg.is.set ("ddg.last.graphics.file") &&
.ddg.get("ddg.last.graphics.file") != "") {
.ddg.add.to.device.table (grDevices::dev.cur (),
.ddg.get ("ddg.last.graphics.file"))
}
else {
.ddg.set("ddg.no.graphics.file", TRUE)
}
tryCatch(
# Allows dev.print to work when we want to save the plot.
# Only do this if the graphics is going to a file. It seems
# that it should also work if the output is going to the screen, but
# it doesn't.
grDevices::dev.control("enable"),
error = function (e) return()
)
}
# Add the newly-opened graphics device to the list of open devices
.ddg.set("ddg.open.devices", union(.ddg.get("ddg.open.devices"), grDevices::dev.cur()))
# Create a node for the graphics device and connect it to the last procedural node.
dev.node.name <- paste0("dev.", grDevices::dev.cur())
# Create graphics device node and edge if ddg.details is True.
if (.ddg.details()) {
.ddg.device.node(dev.node.name)
.ddg.lastproc2data(dev.node.name)
}
# Remember that the device node was created for this statement to avoid duplicates.
.ddg.set ("ddg.add.device.output", FALSE)
.ddg.add.device.node (dev.node.name)
}
#' .ddg.trace.graphics.update is called when a function that updates graphics is called.
#' If the call is within a call to .ddg.capture.graphics, it does nothing.
#' Otherwise, it sets a flag so that we create the device node with
#' input and output edges when the R statement completes.
#' @return nothing
#' @noRd
.ddg.trace.graphics.update <- function () {
if (.ddg.inside.call.to (".ddg.capture.graphics") || .ddg.inside.call.to ("ggsave")) {
return()
}
#print ("In .ddg.trace.graphics.update")
#print (sys.calls())
.ddg.set ("ddg.add.device.io", TRUE)
}
#' .ddg.add.graphics.io adds data in and data out nodes that represent the
#' current device.
#' @return nothing
#' @noRd
.ddg.add.graphics.io <- function () {
# Check if the last R statement updated graphics
if (!.ddg.get ("ddg.add.device.io")) {
return ()
}
#print ("In .ddg.add.graphics.io")
dev.node.name <- paste0("dev.", grDevices::dev.cur())
# Make sure we did not already create the device node for this statement.
if (!(dev.node.name %in% .ddg.get ("ddg.new.device.nodes"))) {
# Check if there is already a node for this device.
if (grDevices::dev.cur() %in% .ddg.get("ddg.open.devices")) {
# Create graphics device node and edges if ddg.details is True
if (.ddg.details()) {
# Create an input edge from that node to the last procedure node
.ddg.data2proc(dev.node.name, dscope = NULL)
# Add an output node with the same name and make it an output from
# the last procedure node.
.ddg.device.node(dev.node.name)
.ddg.lastproc2data(dev.node.name)
}
# Remember that the node was created.
.ddg.add.device.node (dev.node.name)
}
# If there is no previous device node for this device, it means
# that the output is going to the default graphics device, not a file,
# so there has been no call like pdf or jpg that would have created the data node.
# In that case, treat this like a device creation, rather than an update.
else {
# Add the newly-opened graphics device to the list of open devices
.ddg.set ("ddg.add.device.output", TRUE)
.ddg.add.graphics.device.node ()
return()
}
}
# Clear the flag to prepare for the next statement.
.ddg.set ("ddg.add.device.io", FALSE)
}
#' .ddg.trace.graphics.close is called when a graphics device is closed.
#' If the graphics is going to the screen, it saves it to a file,
#' since we need to do that before the device closes. If it is
#' going to a file, we need to wait until after the device is
#' closed to copy the file.
#' @return nothing
#' @noRd
.ddg.trace.graphics.close <- function () {
if (.ddg.inside.call.to (".ddg.capture.graphics") || .ddg.inside.call.to ("ggsave")) {
return()
}
#print ("In .ddg.trace.graphics.close")
#print (paste ("dev.list =", grDevices::dev.list(),
# names(grDevices::dev.list()), collapse=", "))
#print (paste ("dev.cur =", grDevices::dev.cur()))
# Set the flag so that .ddg.capture.graphics executes after the
# R statement completes.
.ddg.set ("ddg.add.device.close", TRUE)
.ddg.set("ddg.dev.number", grDevices::dev.cur())
# Output is going to the screen
if (.ddg.get("ddg.no.graphics.file") || names(grDevices::dev.cur()) == "RStudioGD") {
# Write the graphics to a file and record the file name
# in the device table.
file <- .ddg.capture.current.graphics()
.ddg.set("ddg.no.graphics.file", FALSE)
if (!is.null(file)) {
.ddg.set ("ddg.last.graphics.file", file)
.ddg.add.to.device.table (grDevices::dev.cur (), file)
}
}
}
#' .ddg.capture.graphics captures the screen graphics to a file
#' @param called.from.save If true, it will recursively capture the graphics
#' from all open devices.
#' @return nothing
#' @noRd
.ddg.capture.graphics <- function(called.from.save = FALSE) {
if (!.ddg.get ("ddg.add.device.close") && !called.from.save) {
return()
}
#print ("In .ddg.capture.graphics")
# Determine which device to capture graphics for. When called.from.save
# we will be capturing graphics from all open devices.
if (called.from.save) {
dev.number <- grDevices::dev.cur()
# Device 1 is standard output. When this comes up as dev.cur, it
# means we are done capturing graphics.
if (dev.number == 1) {
return()
}
}
else {
dev.number <- .ddg.get("ddg.dev.number")
}
#print (paste ("ddg.capture.graphics: Device being captured: ", dev.number))
# Remove from the open.devices list so that we do not get a device node created
.ddg.set("ddg.open.devices", setdiff(.ddg.get("ddg.open.devices"), dev.number))
# If graphics is going to a file, determine what file
dev.name <- .ddg.get.file.for.device (dev.number)
if (dev.name == "") {
# Capture screen graphics
graphics.file <- .ddg.capture.current.graphics()
}
else {
graphics.file <- .ddg.get.file.for.device (dev.number)
# Check if the device is still open and close it if it is
# We need to do this so that the file.out call can
# copy the file.
if (dev.number %in% grDevices::dev.list() && dev.number != 1) {
grDevices::dev.off(dev.number)
}
}
# If going to a file, copy the file and create a node for it.
if (!is.null (graphics.file)) {
# print (paste ("graphics file: ", graphics.file))
.ddg.file.out (graphics.file)
# Delete files that were created by capturing the screen
if (startsWith (graphics.file, "dev.off") && file.exists(graphics.file)) {
file.remove (graphics.file)
}
# Add an input edge from the current device
dev.node.name <- paste0("dev.", dev.number)
# If the device was opened but never written to there will be no previous node.
# so don't try to create the edge in that case.
if (.ddg.data.node.exists (dev.node.name)) {
.ddg.data2proc(dev.node.name, NULL)
}
# Clear this flag to indicate that the graphics file has been saved.
.ddg.set ("ddg.no.graphics.file", TRUE)
}
# If called from save, we should capture all the open graphics devices
if (called.from.save) {
# Remember which devices have been captured
.ddg.set ("ddg.captured.devices", c(.ddg.get("ddg.captured.devices"), dev.number))
# If the device just captured is still the current device, move on to the next
# open device. If it is not the current device, use the current device.
if (dev.number == grDevices::dev.cur()) {
grDevices::dev.set()
}
# If the current device has not been captured yet, recurse to save the next one.
if (!(grDevices::dev.cur() %in% .ddg.get("ddg.captured.devices"))) {
.ddg.set("ddg.dev.number", grDevices::dev.cur())
.ddg.capture.graphics (TRUE)
}
}
.ddg.set ("ddg.add.device.close", FALSE)
return()
}
#' .ddg.capture.current.graphics captures what is on the current display to a file,
#' creates a file node and connects to the ddg.
#' @return the name of the file containing the captured graphics
#' @noRd
.ddg.capture.current.graphics <- function() {
#print ("In .ddg.capture.current.graphics")
#print(sys.calls())
# Create the file name to save the screen graphics to
file <- paste0("dev.off.", .ddg.dnum()+1, ".pdf")
# Save the graphic to a file temporarily
file.written <- NULL
# dev.print fails when running from the test scripts, or Rscript in general
# In that case, check for the existence of Rplots.pdf, which is
# where Rscript places plots sent to the default graphics.
if (names(grDevices::dev.cur()) == "pdf" && !.ddg.get("ddg.ignore.rplots")) {
if (file.exists ("Rplots.pdf") && !.ddg.get("ddg.rplots.pdf.saved")) {
if (grDevices::dev.cur() != 1) {
grDevices::dev.off()
}
.ddg.set ("ddg.rplots.pdf.saved", TRUE)
return("Rplots.pdf")
}
}
tryCatch (
{
# Try to save the graphics to a file
grDevices::dev.print(device=grDevices::pdf, file=file)
file.written <- file
},
error = function(e) {
# If the dev.off file was created, delete it.
if( file.exists(file) )
file.remove(file)
}
)
return(file.written)
}
.ddg.trace.vroom.functions <- function () {
#print ("In .ddg.trace.vroom.functions")
function.names <- c("vroom_write", "vroom_write_lines")
param.names <- c("file", "file")
package.names <- c("vroom", "vroom")
vroom.write.funcs <- data.frame(function.names, param.names, package.names)
write.functions.df <- .ddg.get("ddg.file.write.functions.df")
write.functions.df <- rbind (write.functions.df, vroom.write.funcs)
#print (write.functions.df)
.ddg.set("ddg.file.write.functions.df", write.functions.df)
#print ("Adding tracing for vroom write function")
# Works when vroom is not initially loaded!!!
lapply (function.names,
function (function.name) {
tryCatch (utils::capture.output(
utils::capture.output(
trace(function.name,
tracer = function () .ddg.trace.output (),
#tracer = quote(print ("Tracing a vroom write function")),
# Do not want to use the where argument if the library has been attached
#where = asNamespace("vroom"),
print=FALSE),
type="message")),
error = function (e) {
utils::capture.output(
utils::capture.output(trace(function.name,
tracer = function () .ddg.trace.output (),
#tracer = quote(print ("Tracing a vroom write function")),
# Do not want to use the where argument if the library has been attached
where = asNamespace("vroom"),
print=FALSE),
type="message"))
})
})
#print ("Back from adding vroom output tracing")
function.names <- c("vroom", "vroom_lines")
param.names <- c("file", "file")
package.names <- c("vroom", "vroom")
vroom.read.funcs <- data.frame(function.names, param.names, package.names)
#print ("Back from trace.oneInput")
read.functions.df <- .ddg.get("ddg.file.read.functions.df")
read.functions.df <- rbind (read.functions.df, vroom.read.funcs)
#print (read.functions.df)
.ddg.set("ddg.file.read.functions.df", read.functions.df)
lapply (function.names,
function (function.name) {
tryCatch (utils::capture.output(utils::capture.output(trace(function.name,
tracer = function () .ddg.trace.input(),
#tracer = quote(print ("Tracing a vroom read function")),
#where = asNamespace("vroom"),
print=FALSE),type="message")),
error = function (e) {
utils::capture.output(
utils::capture.output(trace(function.name,
tracer = function () .ddg.trace.input(),
#tracer = quote(print ("Tracing a vroom read function")),
where = asNamespace("vroom"),
print=FALSE),
type="message"))
})
})
}
.ddg.untrace.vroom.functions <- function () {
tryCatch({
# If tracing due to vroom being loaded, need to specify the namespace
utils::capture.output(untrace ("vroom_write", where = asNamespace("vroom")), type="message")
utils::capture.output(untrace ("vroom_write_lines", where = asNamespace("vroom")), type="message")
utils::capture.output(untrace ("vroom", where = asNamespace("vroom")), type="message")
utils::capture.output(untrace ("vroom_lines", where = asNamespace("vroom")), type="message")
},
error = function (e) { })
tryCatch({
# If tracing due to vroom being attached with the library function, need to omit the namespace
utils::capture.output(untrace ("vroom_write"), type="message")
utils::capture.output(untrace ("vroom_write_lines"), type="message")
utils::capture.output(untrace ("vroom"), type="message")
utils::capture.output(untrace ("vroom_lines"), type="message")
},
error = function (e) { })
}
.ddg.untrace.ggplot2.functions <- function () {
tryCatch ({
utils::capture.output(untrace ("ggplot", where = asNamespace("ggplot2")), type="message")
utils::capture.output(untrace ("ggsave", where = asNamespace("ggplot2")), type="message")
},
error = function (e) { })
tryCatch ({
utils::capture.output(untrace ("ggplot"), type="message")
utils::capture.output(untrace ("ggsave"), type="message")
},
error = function (e) { })
}
.ddg.trace.ggplot2.functions <- function () {
#print ("Tracing ggplot2")
tryCatch (
{
utils::capture.output(
utils::capture.output(trace ("ggplot",
function () .ddg.trace.output (),
print=FALSE,
where = asNamespace("ggplot2")),
type="message"))
utils::capture.output(
utils::capture.output(trace ("ggsave",
function () .ddg.trace.close (),
print=FALSE,
where = asNamespace("ggplot2")),
type="message"))
},
error = function (e) {
tryCatch (
{
utils::capture.output(
utils::capture.output(trace ("ggplot",
function () .ddg.trace.output (),
print=FALSE),
type="message"))
utils::capture.output(
utils::capture.output(trace ("ggsave",
function () .ddg.trace.close (),
print=FALSE),
type="message"))
},
error = function (e) { warning ("ggplot and ggsave functions might not be traced", Call. = FALSE)})
})
}
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.