# logTools.R
#
# Utility functions logging and object metadata
#
# ==== logFileName() ===========================================================
#' Define the log file name
#'
#' \code{logFileName} returns path and name of a file for logging events, or
#' sets the global option rete.logfile.
#'
#' If fPath is missing, the function checks whether getwd() contains a
#' directory called "logs". If yes, log files will be written to that
#' directory, if no, getwd() will be used as the path. This default behaviour
#' also defines the initial log file path and name on loading the package. A
#' single "/" (or "\"), path separator is removed from fPath if present, since
#' the file.path() function will add a path separator which would result in
#' doubling it otherwise. The default file name is structured as
#' "rete_YYY-MM-DD.d.log" where YYY-MM-DD is the value of Sys.Date() and d is
#' an integer that is one larger than the highest integer in a filename
#' structured this way in the fPath directory. Thus the file name is unique.
#' If the requested filename does not end with the extension ".log", that
#' extension is added. If you must have a logfile named with a different
#' extension, you can set it directly via options("rete.logfile") <-
#' <my.special.name>. If setOption is TRUE, the function sets the global
#' option rete.logfile to which \code{\link{logMessage}} appends log events.
#'
#' @param fPath A path to a log-file directory. If missing the path is set to
#' getwd().
#' @param fName Name of file to which log messages will be appended. If
#' missing, a new filename is generated.
#' @param setOption Whether to set the global option rete.logfile.
#' Defaults to FALSE.
#' @return Path and name of a file that can be used to log events.
#'
#' ## @family TBD
#'
#' ## @seealso \code{\link{logMessage}} ...
#'
#' @examples
#' logFileName()
#' \dontrun{
#' logFileName(fPath = "./logs", setOption = TRUE)
#' }
#' @export
logFileName <- function(fPath, fName, setOption = FALSE) {
# === SET fPath DEFAULT ====================================================
if (missing(fPath)) {
if (dir.exists(file.path(getwd(), "logs"))) {
# "logs" subdirectory exists ...
fPath <- file.path(getwd(), "logs")
} else {
# "logs" subdirectory does not exist ...
fPath <- getwd()
}
}
# === VALIDATE fPath =======================================================
r <- .checkArgs(fPath, like = "DIR", checkSize = TRUE)
if(length(r) > 0) {
stop(r)
}
# ensure path does not end with a "/" or "\" because we later use
# file.path() and that adds a separator
fPath <- gsub("[/\\]$", "", fPath)
# === SET UNIQUE fName DEFAULT =============================================
if (missing(fName) || fName == "") {
today <- Sys.Date()
files <- list.files(path = fPath,
pattern = paste(today,
"\\.[0-9]+\\.log$",
sep = ""),
all.files = TRUE)
if (length(files) > 0) {
# get highest version of today's existing files
m <- regexec("\\.([0-9]+)\\.log$", files)
num <- max(as.numeric(unlist(regmatches(files, m))[c(FALSE, TRUE)]))
} else {
num <- 0
}
fName <- paste("rete_", Sys.Date(), ".", num + 1, ".log", sep = "")
}
# === VALIDATE fName, setOption ============================================
r <- c(r, .checkArgs(fName, like = "a", checkSize = TRUE))
r <- c(r, .checkArgs(setOption, like = TRUE, checkSize = TRUE))
if(length(r) > 0) {
stop(r)
}
# === add ".log" extension if there is none ================================
if (! grepl("\\.log$", fName)) {
fName <- paste(fName, ".log", sep = "")
}
# === SET GLOBAL OPTION IF REQUESTED =======================================
if(setOption) {
options(rete.logfile = file.path(fPath, fName))
}
return(file.path(fPath, fName))
}
# ==== logMessage() ============================================================
#' Write a message to the current log file.
#'
#' \code{logMessage} uses cat() to append a message to the current log
#' file. The file name is taken from the rete.logfile global option.
#'
#' The function will stop() if message is not of mode, type and class character.
#' On windows systems, cat() replaces \\n linebreaks with \\r\\n. Therefore
#' logMessage() converts all linebreaks internally to \\n before handing them to
#' cat().
#'
#' @param msg a character object or vector of character objects.
#' @return N/A. This function is invoked for its side-effect to appended text to
#' the current logfile.
#'
#' @family log file functions
#'
#' ## @seealso \code{\link{logFileName}}
#'
#' @examples
#' \dontrun{
#' msg <- c("note > ", Sys.Date(), "Re-run analysis.")
#' logMessage(msg)
#' }
#' @export
logMessage <- function(msg) {
# Check that argument is of mode character
r <- .checkArgs(msg, like = character())
if(length(r) > 0) { stop(r) }
# Remove all line-end linebreaks
msg <- gsub("[\r\n]+$", "", msg)
# Remove all \r characters to convert windows into unix linebreaks
msg <- gsub("\r", "", msg)
# Add \n to line-ends
msg <- gsub("$", "\n", msg)
# Append msg to log file
cat(msg,
file = unlist(getOption("rete.logfile")),
sep = "",
append = TRUE)
}
# ==== getUUID() ===========================================================
#' get a UUID to attach to an object
#'
#' \code{getUUID} uses the uuid package to prepare a UUID suitable to
#' be attached to an object identified by objectName.
#'
#' The overwrite flag can be understood as follows:
#' - if the object does not have a $UUID attribute, a UUID is returned
#' - if the object has a $UUID attribute and "overwrite" is TRUE
#' a new UUID is returned.
#' - if the object has a $UUID attribute and "overwrite" is FALSE, the
#' old UUID is returned.
#'
#' Note: no check is done whether the original $UUID attribute
#' is a valid UUID.
#'
#' @param objectName char. Name of an R object
#' @param overwrite logical. Flag to control whether an existing UUID should be
#' overwritten. Default FALSE.
#' @return the value of the original UUID attribute, or a new UUID
#'
#' @family log file functions
#'
#' ## @seealso \code{\link{logFileName}}
#' ## @seealso \code{\link{logMessage}}
#' ## @seealso \code{\link{logEvent}}
#' ## @seealso \code{\link{findUUID}}
#' ## @seealso \code{\link{getProvenance}}
#'
#' @examples
#' \dontrun{
#' tmp <- "c"
#' getUUID("tmp")
#' }
#' @export
getUUID <- function(objectName, overwrite = FALSE) {
found <- FALSE
for (frame in rev(sys.parents())) {
if (exists(objectName, frame = frame, inherits = FALSE)) {
obj <- get(objectName, envir = sys.frame(frame))
found <- TRUE
break()
}
}
if (! found) { stop(sprintf("Object \"%s\" does not exist.", objectName)) }
if (is.null(obj)) {
stop(sprintf("Object \"%s\" is NULL.",
objectName))
}
# if (! is.null(get0(objectName, envir = parent.frame(99)))) {
# obj <- get(objectName, envir = parent.frame(99))
# } else {
# obj <- get(objectName)
# }
if (is.null(attr(obj, "UUID")) || overwrite) {
UUID <- uuid::UUIDgenerate()
} else {
UUID <- attr(obj, "UUID")
}
return(UUID)
}
# ==== .extractAttributes() ====================================================
.extractAttributes <- function(obName, role) {
# Non-exported helper function returns all of the attributes that are
# attached to an object identified by objectName, formatted for logging.
# Function looks for the object first in the parent.frame(), then on the
# normal search path. This fixes a problem that object could not be found if
# the function was called via the test_that environment.
# Format of the extracted attributes:
# event | input | attribute | <attrNameN> | <attrValueN>
# ... or
# event | output | attribute | <attrNameN> | <attrValueN>
#
# Parameters:
# obName: char. Name of a non-NULL R object
# role: <input|output|using> signifies the object role in the calling
# function's workflow.
# Value:
# A zero-length string if no attributes are extracted,
# a vector of formatted attribute descriptions otherwise.
supportedRoles <- c("input", "output", "using")
# ==== PARAMETER CHECKS ====================================================
if (missing(role)) {
stop("role parameter must be provided.")
}
r <- character()
r <- c(r, .checkArgs(obName, like = "a", checkSize = TRUE))
r <- c(r, .checkArgs(role, like = "a", checkSize = TRUE))
if(length(r) > 0) {
stop(r)
}
if (! role %in% supportedRoles) {
stop(sprintf("Expecting role from (\"%s\"), but got \"%s\".",
paste(supportedRoles, collapse = "\", \""), role))
}
# ==== GET OBJECT ==========================================================
found <- FALSE
for (frame in rev(sys.parents())) {
if (exists(obName, frame = frame, inherits = FALSE)) {
myOb <- get(obName, envir = sys.frame(frame))
found <- TRUE
break()
}
}
if (! found) { stop(sprintf("Object \"%s\" does not exist.", obName)) }
if (is.null(myOb)) {
stop(sprintf("Object \"%s\" is NULL.", obName))
}
# ==== COMPILE OUTPUT STRING ===============================================
result <- character()
for (name in names(attributes(myOb))) {
if (length(attr(myOb, name)) == 1) {
att <- paste("\"",
attr(myOb, name),
"\"",
sep = "")
} else if (length(attr(myOb, name)) <= 3) {
att <- paste("(",
paste(attr(myOb, name), collapse = ", "),
")",
sep = "")
} else {
att <- paste("(",
paste(attr(myOb, name)[1:3], collapse = ", "),
", ... (",
length(attr(myOb, name)),
") )",
sep = "")
}
result <- c(result,
sprintf("event | %-6s | attribute | %-12s | %s",
role, name, att))
}
return(result)
}
# ==== logEvent() ==============================================================
#' Formats an event description to be sent for attaching to the log file.
#'
#' \code{logEvent} generates an event message with:
#' - the event title
#' - the event call
#' - attributes of the input object
#' - attributes of the output object
#' - date and time of the event
#' - function version (TODO)
#' - file hashes of input (TODO)
#'
#' Format of the event description is as follows:
#' event | title | <eventTitle>
#' event | time | <eventDateTime>
#' event | call | <eventCall>
#' (ToDo: event | functionVersion | <functionVersion>)
#' event | input | attribute | <inputAttrName1> | <inputAttrValue1>
#' event | output | attribute | <outputAttrName1> | <outputAttrValue1>
#' event | end
#'
#'
#' The event message is terminated by an "end event" marker, and a blank
#' line, and it is handed off to logMessage() to append it to the
#' log file referenced in the global variable options("rete.logfile")
#'
#'
#' @param eventTitle the title of the event, from a
#' predetermined categorization of events
#' @param eventCall the function call in which the event occurred
#' @param input vector of object names with an "input" role in the calling
#' function's workflow
#' @param notes a vector of strings comprising text to be
#' incorporated into the event description.
#' @param output vector of object names with an "output" role in the calling
#' function's workflow
#' @return N/A A message is appended to the log file
#' via \code{\link{logMessage}}.
#'
#' @family log file functions
#'
#' ## @seealso \code{\link{logFileName}}
#' ## @seealso \code{\link{logMessage}}
#' ## @seealso \code{\link{getUUID}}
#' ## @seealso \code{\link{findUUID}}
#' ## @seealso \code{\link{getProvenance}}
#'
#' @examples
#' \dontrun{
#' logEvent(eventTitle = "Test event",
#' eventCall = "function1(test = \"test\")")
#' }
#' @export
logEvent <- function(eventTitle,
eventCall,
input = character(),
notes = character(),
output = character()) {
# check parameters
if (missing(eventTitle)) {
stop("eventTitle is missing with no default.")
}
if (missing(eventCall)) {
stop("eventCall is missing with no default.")
}
# validate parameter structure
r <- character()
r <- c(r, .checkArgs(eventTitle, like = "a", checkSize = TRUE))
r <- c(r, .checkArgs(eventCall, like = "a", checkSize = TRUE))
r <- c(r, .checkArgs(input, like = character()))
if (length(notes) > 0) {
r <- c(r, .checkArgs(notes, like = character()))
}
r <- c(r, .checkArgs(output, like = character()))
if(length(r) > 0) {
stop(r)
}
# validate objects
for (obName in c(input, output)) {
# find the object
for (frame in rev(sys.parents())) {
if (exists(obName, frame = frame, inherits = FALSE)) {
myOb <- get(obName, envir = sys.frame(frame))
found <- TRUE
break()
}
}
if (! found) { stop(sprintf("Object \"%s\" does not exist.", obName)) }
# validate the object
if (is.null(myOb)) {
stop(sprintf("Object \"%s\" is NULL.", obName))
}
}
msg <- character()
msg <- c(msg, paste("event | title | ", eventTitle, sep = ""))
msg <- c(msg, paste("event | time | ", Sys.time(), sep = ""))
msg <- c(msg, paste("event | call | ", eventCall, sep = ""))
# main event logging
for (i in input) {
msg <- c(msg, sprintf("event | input | \"%s\"", i))
msg <- c(msg, .extractAttributes(i, "input"))
}
for (note in notes) {
msg <- c(msg, sprintf("event | note | %s", note))
}
for (o in output) {
msg <- c(msg, sprintf("event | output | \"%s\"", o))
msg <- c(msg, .extractAttributes(o, "output"))
}
msg <- c(msg, "event | end") # attach end marker
msg <- c(msg, "") # attach an empty line for better readability
logMessage(msg)
}
# ==== findUUID() ==============================================================
#' Finds a specific UUID in logged events
#'
#' \code{findUUID} returns the event blocks that contains mentions of a
#' requested UUID from the log files found in a given directory.
#'
#' @param uuid a universally unique identifier (UUID). Checked for valid format.
#' @param logDir the directory path in which to search the logfiles.
#' Defaults to the path component of getOption("rete.logfile").
#' @param ext file extension regex pattern. Defaults to "\\.log$".
#' @param recursive Whether to descend into subdirectories. Defaults
#' to TRUE.
#' @return character() if uuid is not found in the log files.
#' Otherwise, a vector with one complete event block per element, which
#' has the filename that conteined the event attaches as a names()
#' attribute.
#'
#' @family log file functions
#'
#' ## @seealso \code{\link{logFileName}}
#' ## @seealso \code{\link{logMessage}}
#' ## @seealso \code{\link{getUUID}}
#' ## @seealso \code{\link{logEvent}}
#' ## @seealso \code{\link{getProvenance}}
#'
#' @examples
#' \dontrun{
#' NULL
#' }
#' @export
findUUID <- function(uuid,
logDir,
ext = "\\.log$",
recursive = TRUE) {
if (missing(logDir)) {
logDir <- dirname(unlist(getOption("rete.logfile")))
}
# check parameters
r <- character()
r <- c(r, .checkArgs(uuid, like = "UUID", checkSize = TRUE))
r <- c(r, .checkArgs(logDir, like = "DIR", checkSize = TRUE))
r <- c(r, .checkArgs(ext, like = "a", checkSize = TRUE))
r <- c(r, .checkArgs(recursive, like = TRUE, checkSize = TRUE))
if (length(r) > 0) {
stop(r)
}
allLogs <- list.files(path = logDir,
pattern = ext,
full.names = TRUE,
recursive = recursive)
if (length(allLogs) == 0) {
stop(sprintf("No logfiles found in %s.", logDir))
}
allEvents <- character()
for (fn in allLogs) {
# read entire file into one string, then strsplit on the
# boundaries of an event block
tmp <- unlist(strsplit(readChar(fn, file.info(fn)$size),
"(?=\\nevent \\| title)|(?<=event \\| end)",
perl = TRUE))
# find events that contain the UUID
tmp <- tmp[grepl(uuid, tmp)]
# attach the filename as name attribute
names(tmp) <- rep(fn, length(tmp))
allEvents <- c(allEvents, tmp)
}
# add two platform-appropriate linebreaks to each event block
if (length(allEvents) > 0) {
NL2 <- paste0(.PlatformLineBreak(), .PlatformLineBreak())
for (i in 1:length(allEvents)) {
allEvents[i] <- gsub("$", NL2, allEvents[i])
}
}
return(allEvents)
}
#' Reconstructs provenance of object
#'
#' \code{getProvenance} reconstructs the provenance of an object back via its
#' intermediaries, to all input files that contributed
#' to it.
#'
#' Format of the output... TBD.
#'
#'
#' @param uuid a universally unique identifier (UUID). Checked for valid format.
#' @param logDir the directory path in which to search the logfiles.
#' Defaults to the path component of getOption("rete.logfile").
#' @param ext file extension regex pattern. Defaults to "\\.log$".
#' @param recursive Whether to descend into subdirectories. Defaults
#' to TRUE.
#' @return Informative message if uuid is not found in the log files.
#' Otherwise, a structured report that describes the provenance of
#' the object that is identified by uuid.
#'
#' @family log file functions
#'
#' ## @seealso \code{\link{logFileName}}
#' ## @seealso \code{\link{logMessage}}
#' ## @seealso \code{\link{attachUUID}}
#' ## @seealso \code{\link{findUUID}}
#' ## @seealso \code{\link{logEvent}}
#'
#' @examples
#' \dontrun{
#' NULL
#' }
#' @export
getProvenance <- function(uuid,
logDir,
ext = "\\.log$",
recursive = TRUE) {
# if (missing(logDir)) {
# logDir <- dirname(unlist(getOption("rete.logfile")))
# }
# # check parameters
# r <- character()
# r <- c(r, .checkArgs(uuid, like = "UUID", checkSize = TRUE))
# r <- c(r, .checkArgs(logDir, like = "DIR", checkSize = TRUE))
# r <- c(r, .checkArgs(ext, like = "a", checkSize = TRUE))
# r <- c(r, .checkArgs(recursive, like = TRUE, checkSize = TRUE))
# if (length(r) > 0) {
# stop(r)
# }
#
# mentions <- character()
# # Try finding uuid. Report if it could not be found at all.
# mentions <- c(mentions,
# findUUID(uuid = uuid,
# logDir = logDir,
# ext = ext,
# recursive = recursive))
#
# if (length(mentions) == 0) {
# stop("Requested UUID was not found in the log files.")
# }
#
# # Otherwise build a tree
# # - root is the event that has uuid as output. There must
# # only be one such node.
# # - children are events that are linked via (inputUUID -> outputUUID)
# # - leafs are events in which the outputUUID is created from file.
# # (Functions that create objects from file must write a
# # structured event message to that effect.)
# # Needs a tree list structure that identifies nodes, and children
# # Needs helper function to parse an event and insert it's information
# # into the tree list.
#
# # Traverse the tree depth first.
# # summarize each node, (what happened), and its children (how
# # many, what are they, what are their UUIDs)
#
# # Output report.
return("Not yet implemented.")
}
# [END]
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.