# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : debugging.r # # Last Updated Funclist : 08 Feb 2015, 5:14 AM (Sunday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : NA # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # func1 ( skip=0L ) # # func2 ( skip=0L ) # # brwsr ( text=sys.call(sys.parent(.skip)), expr=inDebugMode(flag=flags, or=or), flags="default" # # func3 ( skip=0L ) # # , or=NULL, .skip=1L ) # # func4 ( skip=0L ) # # BackUpOrRestore ( obj.nm, envir=parent.frame(), bak.nm=paste0(obj.nm, postfix), postfix=".bak", clear=FALSE # # , forceBak=FALSE, info=NULL # # , verbose=getOption("verbose.BackUpOrRestore", TRUE), verboseRestore=verbose ) # # showDebugFlags ( verbose=TRUE ) # # inDebugMode ( flag=NULL, ..., default="default", skip=c(), ignore.case=TRUE ) # # debugOn ( flag="default", all=FALSE, only=NULL, verbose=FALSE ) # # debugOff ( flag="default", all=FALSE, verbose=FALSE, showWarnings=verbose ) # # debugOffAll ( ) # # clearDebugFlags ( verbose=TRUE ) # # btext ( copy=FALSE ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # # debugging.r brwsr <- function(text=sys.call(sys.parent(.skip)), expr=inDebugMode(flag=flags, or=or), flags="default", or=NULL, .skip=1L) { # A cleaner wrapper for browser, where inDebugMode # eval(browser(text=text, expr=expr, skip=.skip), envir=parent.frame()) # browser(text=text, expr=expr, skip=.skip) browser(text=text, expr=expr) } if (is.null(getOption("verbose.BackUpOrRestore"))) options("verbose.BackUpOrRestore"=TRUE) # rm(list=ls(pattern="^DT.*\\.bak(_.+)?$")) # rm(list=ls(pattern="\\.bak(_.+)?$")) BackUpOrRestore <- function(obj.nm, envir=parent.frame(), bak.nm=paste0(obj.nm, postfix), postfix=".bak", clear=FALSE , forceBak=FALSE, info=NULL, verbose=getOption("verbose.BackUpOrRestore", TRUE), verboseRestore=verbose) { ## This function creates a copy of obj.nm in envir, naming it bak.nm ## This is useful for checkpointing when dev'ing ## ## clear : Deletes the backup if (!is.null(info)) postfix <- paste(postfix, info, sep="_") force(envir) force(bak.nm) if (!is.character(obj.nm)) stop("obj.nm should be the _name_ of the object, not the object itself. Please use quotes.") if (any(c(obj.nm, bak.nm) %in% c("obj.nm", "bak.nm", "postfix", "envir"))) stop("obj.nm & bak.nm cannot have values equal to argument names of this function") ## If clear is set, then delete the backup and return NULL if (clear) { if (exists(bak.nm, envir=envir)) { verboseMsg(verbose, "\t -= DELETING Backup '", bak.nm, "' =-\n", simple=TRUE) rm(list=bak.nm, envir=envir) } else { verboseMsg(verbose, "\t -= There was no Backup of ", obj.nm, "' to delete =-\n", simple=TRUE) } return(invisible(NULL)) } # ---- ---- ---- ---- # ## OTHERWISE, either take a backup or restore it if (forceBak || !exists(bak.nm, envir=envir)) { ## CHECK if object exists... it might not if this function is called at the top of creating the object if (!exists(obj.nm, envir=envir)) { return(warning(sprintf("%s does not exist. Nothing to backup or restore", obj.nm))) } verboseMsg(verbose, "\t -= Creating Backup of ", obj.nm, " =-\n", simple=TRUE) assign(bak.nm, copy(get(obj.nm, envir=envir)), envir=envir) } else { verboseMsg(verboseRestore, "\t -= Restoring ", obj.nm, " from Backup (", bak.nm, ") =-\n", simple=TRUE) assign(obj.nm, copy(get(bak.nm, envir=envir)), envir=envir) } } showDebugFlags <- function(verbose=TRUE) { ## Undecided which to use blankValue <- "[not set]" blankValue <- NA blankValue <- FALSE ## Commonly used flags otherflags <- c("makeQry_bottom", "Qry") ## Grab the current flags flags <- getOption("debug.flags") flags_toadd <- setdiff(otherflags, names(flags)) flags_toadd <- setNames(obj=rep(blankValue, length(flags_toadd)), flags_toadd) flags <- c(flags, flags_toadd) if (verbose) print.dict(flags, nrow=60) return(invisible(flags)) } inDebugMode <- function(flag=NULL, ..., default="default", skip=c(), ignore.case=TRUE) { ## Will return TRUE if any of the flags in either 'flag' or 'or' are TRUE ## Note that if the user does not want 'default' to be checked, simply set default=NULL ## ## skip : any flags listed in skip, even if TRUE will be ignored ## ... : additional flags addlflags <- unlist(list(...), use.names=TRUE) if (identical(default, FALSE)) default <- NULL # combine flag with or flag <- c(flag, addlflags, default) ## Grab the current flags flags <- getOption("debug.flags") ## If ignoring case, coerce all to upper if (ignore.case) { if (!is.null(names(flags))) names(flags) <- toupper(names(flags)) flag <- toupper(flag) skip <- toupper(skip) } ## If we have no flag set with current name, then return FALSE if (!any(flag %in% names(flags))) return(FALSE) skipping <- flags[skip] using <- flags[flag] skipping <- skipping [!is.na(skipping)] using <- using [!is.na(using)] ## We will check that flags are set, and the skip flag is not explicitly set to FALSE ## Note that any(NULL) will return FALSE any(unlist(using, use.names=FALSE)) && !any(unlist(sapply(skipping, isFALSE), use.names=FALSE)) } debugOn <- function(flag="default", all=FALSE, only=NULL, verbose=FALSE) { ## Get the current flags flags <- getOption("debug.flags") ## Allow for a function to be a flag, and we will take the name of the function as the flag if (is.function(flag)) flag <- capture.output(substitute(flag)) ## The option might not have ever been set yet. if (is.null(flags)) flags <- list(default=FALSE) ## if ALL set flag to alll the names of flags, plus its original value if (isTRUE(all)) flag <- unique(c(flag, names(flags))) ## if only, then set all other flags to FALSE if (!is.null(only)) { flag <- only flags[] <- FALSE } ## SET ## flags[flag] <- TRUE ## output for user others <- nwhich(flags[names(flags) %ni% flag]) verboseMsg(verbose, "Debugging is turned on for '", flag, "'", if (length(others)) {paste0("\n\tas well as for ", pasteQ(others, w=NULL, and="&")) }, "\nRemember to use btext().", sep="", time=FALSE) options(debug.flags=flags) return(invisible(flags)) } debugOff <- function(flag="default", all=FALSE, verbose=FALSE, showWarnings=verbose) { ## Get the current flags flags <- getOption("debug.flags") ## Allow for a function to be a flag, and we will take the name of the function as the flag if (is.function(flag)) flag <- capture.output(substitute(flag)) ## if ALL set flag to alll the names of flags, plus its original value if (isTRUE(all)) flag <- unique(c(flag, names(flags))) ## Check if any were missing if (showWarnings && any(wh <- flag %ni% names(flags))) warning (pasteQand(flag[wh]), " was not a previously-set debugging flag") ## TURN OFF flags[flag] <- FALSE ## SET options(debug.flags=flags) ## Output for user verboseMsg(verbose, "Debugging is now turned off for ", pasteQand(flag), time=FALSE) return(invisible(flags)) } debugOffAll <- function() debugOff(all=TRUE) clearDebugFlags <- function(verbose=TRUE) { ## Removes the option 'debug.flags' by setting to NULL ## Returns the previous value flags <- getOption("debug.flags") # Show previous flags, just in case of mistake out <- sprintf("list(%s)", pasteC(sprintf("%s=%s", names(flags), flags), C=", ") ) verboseMsg(verbose, "Clearning all flags. Previous flags were:\n ", out, time=FALSE) options("debug.flags"=NULL) return(invisible(flags)) } btext <- function(copy=FALSE) { ## allow for quick btext(c) if (identical(as.character(substitute(copy)), "c")) copy <- TRUE text <- browserText() if (!is.character(text)) text <- capture.output(text) if (!grepl("\\n\\s*$", text)) text <- paste0(text, "\n") cat(text) ## Only copy the last portion, to find by searching if (copy && exists("clipCopy")) clipCopy(tail(strsplit(text, "\n\\s*")[[1]], 1)) return(invisible(text)) } ####### ------------------------------------------------------------------------ ####### ### THESE ARE JUST SOME EXAMPLES if (FALSE) { for (i in 1:4) cat( sprintf('func%i <- function() { cat(rep("\\t", %1$i), "In Func %1$i\\n") func%i() cat(rep("\\t", %1$i), "Back in Func %1$i\\n") } ', i, i+1)) func1 <- function(skip=0L) { cat(rep("\t", 1), "In Func 1\n") func2(skip=skip) cat(rep("\t", 1), "Back in Func 1\n") } func2 <- function(skip=0L) { cat(rep("\t", 2), "In Func 2\n") func3(skip=skip) cat(rep("\t", 2), "Back in Func 2\n") } func3 <- function(skip=0L) { cat(rep("\t", 3), "In Func 3\n") func4(skip=skip) cat(rep("\t", 3), "Back in Func 3\n") } func4 <- function(skip=0L) { cat(rep("\t", 4), "In Func 4\n") ## OLD: browser(expr=inDebugMode(), text=sys.call(sys.parent(skip)), skipCalls=skip) ## NEW: bdebug(expr=inDebugMode()) cat(rep("\t", 4), "Back in Func 4\n") } startDebug() func1(1L) btext() c btext() browser(skip=3) match.call(call=2) match.call(call=sys.call(1)) Q }