# --------------------------------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : jesus.r # # Last Updated Funclist : 28 Jan 2015, 2:22 PM (Wednesday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : stringr # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # whereIsJesus ( copy=.Pfm == "Darwin" ) # # saveit ( obj # # , dir=ifelse(exists("dataDir"), dataDir, as.path(getwd(), "out")), subDir=TRUE # # , pos=1, addTimeStamp=TRUE, useSeconds=FALSE, RDS=TRUE ) # # jesusSafety.NoGo ( ) # # jesusSafety.Go ( ) # # jesusSafety.ClearAll ( ) # # jesusForData ( ..., dir=dataDir, info="", sub=FALSE, stampFile=TRUE, stampDir=FALSE, pos=1 # # , envir=globalenv(), updateBackupFile=TRUE, RDS=TRUE, verbose=FALSE # # , showWarnings=TRUE, git=(.Pfm == "Linux") # # , safety=getOption("jesus_safety", FALSE), using.safety=getOption("jesus_using.safety", FALSE), dont.reset.safety=FALSE # # , objNames=NULL, doNothing=FALSE ) # # savethem <- jesus ( ..., dir=ifelse(exists("dataDir"), dataDir, as.path(getwd(), "out")), info="" # # , info.sep=get_jesus_sep.minor(), subDir=sub, sub=TRUE, pos=1, envir=globalenv() # # , stampDir=TRUE, stampFile=FALSE, summary=TRUE, failIfMissing=FALSE # # , verbose=TRUE, showWarnings=TRUE, justDir=FALSE, git=(.Pfm == "Linux") # # , updateBackupFile=TRUE # # , backUpsFile=as.path(srcDir, "_latestBackups.r"), objNames=NULL, RDS=TRUE ) # # updateLatestBackups ( objNames, fileWithPaths, TF_inds=TRUE # # , fileToSource=as.path(srcDir, "_latestBackups.r"), unexpandPath=TRUE # # , verbose=TRUE, git=TRUE, gitcommit=git, gitpush=git, gitpullFirst=git # # , showWarnings=TRUE ) # # g.p0 ( ... ) # # saveErrorHandle ( e ) # # mkSaveFileNameWithPath ( objName, objNameWithInfo=objName, dir, addTimeStamp=FALSE # # , ext=ifelse(isTRUE(RDS), ".RDS", ".Rda"), RDS=TRUE, sep=get_jesus_sep.major() # # , envir=globalenv(), pos="DEPRECATED" ) # # get_jesus_sep ( ops=NULL, useDefaultIfNotSet=TRUE, ignore.case.ops=TRUE ) # # dimToString ( objName, envir=globalenv(), prefix="", markers="", pos="DEPRECATED" ) # # stringToDim ( fileName, envir=globalenv(), prefix=get_jesus_sep.major(), markers="!" # # , simplify=FALSE, pos="DEPRECATED" ) # # loadFromJesus.manyobjs ( objectsToLoad, pos=1, verbose=TRUE, envir=globalenv(), overwrite.ifexists=FALSE # # , SAMPreplace=FALSE, ... ) # # loadIfNotExists ( objToLoad, srcDir=src.p(proj=projName), projName=getProjName() , envir=globalenv() # # , inherits=TRUE, verbose=FALSE ) # # loadFromJesus ( objToLoad, backuplist.file=as.path(srcDir, "_latestBackups.r"), assignTo=NULL # # , verbose=TRUE, pos=1, envir=globalenv(), debug=FALSE, overwrite.ifexists=FALSE # # , dont.fail.ifexists=FALSE, SAMPreplace=FALSE, file=NULL # # , srcDir=src.p(proj=projName), projName=getProjName() ) # # showBackUpsAvailable ( backuplist.file="_latestBackups.r", replace.dataDir=TRUE, quiet=FALSE # # , folder=src.p(proj=projName), projName=getProjName() , sep=get_jesus_sep.major() # # , ts.tz=getOption("default.tz"), ts.local=getOption("default.tz"), debug=FALSE # # , pat=NULL, ignore.case.for_pat=TRUE ) # # showAllAllScienceBackups ( pat=NULL, search.in=c("both", "obj", "srcDir"), ignore.case=TRUE # # , path.shown=FALSE # # , dir=if (exists("srcDir")) dirname(srcDir) else "~/git/orch/src", quiet=FALSE # # , nrows=40, load=c() ) # # showForecastBackups ( dir=data.p("forecasting"), ... ) # # print.tableOfBackups ( DT, all.show=FALSE, nrows=30, replace.dataDir=TRUE, path.shown=FALSE # # , na.rm.col=TRUE, ts.local=attr(DT, "ts.local") ) # # get_jesus_sep.major ( ) # # get_jesus_sep.minor ( ) # # get_jesus_sep.time ( ) # # set_jesus_sep ( major, minor ) # # get_jesus_sep.DefaultValues ( ) # # set_jesus_sep.toDefaultValues ( onlyIfUnset=TRUE ) # # isset_jesus_sep ( ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------- # # --------------------------------------------------------------------------------------------------------------------------------------------------------- # # FIX THIS ERROR: # R> loadFromJesus() # The following objects are available to load: # Time Obj (With Info) Ext Rows Cols Bytes Addl1 # 1: May 07 (Wed) 11:05a Counts (Just Free to Paid) RDS 126 4 NA # 2: May 07 (Wed) 11:05a Counts RDS 126 4 NA # 3: May 07 (Wed) 11:05a DB.Spotify+AGE_+_GENDER_ ( Scrubbed ) RDS 30,480,964 14 NA _Prod_Changes # 4: May 07 (Wed) 11:05a FreeToPaid RDS 285,315 14 7.37 MB # 5: May 07 (Wed) 10:05a years RDS NA - 812 B 126 # 6: May 06 (Tue) 5:05p DT.conversions (Filtered off of DB.Spotify) RDS 23,969,588 11 595.48 MB # 7: Feb 28 (Fri) 11:02a DB.Spotify (Scrubbed ) RDS 19,391,398 9 NA _Prod_Changes # 8: Feb 28 (Fri) 10:02a DB.Spotify (raw pull for product conversion) RDS 19,391,398 5 NA # 9: Feb 28 (Fri) 10:02a DT.conversions.using (Just created) RDS 7,811,261 10 NA # Please Select an object (or row number) to load > 1 # Object(s) selected: 'Counts' # Error in loadFromJesus() : # `Counts` has more than one match (due to info). # Options are: # Counts # Counts+Just_Free_to_Paid # Please be more specific. ## STORING: # TotalTime, ObjClass, ObjectSize, ObjLength, FileType, FileSize, FilePath, OSX, RVersion whereIsJesus <- function(copy=.Pfm=="Darwin") { # This is meant to show where is the directory that `jesus()` saves to, # but this doesn't work due to time stamps ret <- jesus(justDir=TRUE) if (copy) { clipCopy(ret) return(invisible(ret)) } return(ret) } #==========================================================================# #--------------------------------------------------------------------------# # SAVEIT & SAVETHEM & JESUS # # mkSaveFileNameWithPath & dimToString # # # # depends: detectAssignment, timeStamp, as.path, cleanChars # #__________________________________________________________________________# ## TODO: I dont really use this dir setup anymore for data archiving. ## Instead using `jesusForData` along with the `workspace.R` functions. ## Clean this up so it is usable again get_jesus_sep <- function(ops=NULL, useDefaultIfNotSet=TRUE, ignore.case.ops=TRUE) { ## error check -- did user forget to wrap in c() if (is.character(useDefaultIfNotSet)) stop ("'useDefaultIfNotSet' must be TRUE/FALSE.\n\nHINT: It looks like the T/F flags are set to a string.\nHINT: Did you forget to wrap the 'ops' argument in c()") ## Grab the defaults. Their names will have the valid option names defaults <- get_jesus_sep.DefaultValues() op.nms <- names(defaults) op.nms.full <- paste0("jesus.filename_sep.", op.nms) ## if flagged not to use defaults, set to NULL if (!useDefaultIfNotSet) defaults <- list(NULL) ## getOption, specifying default value ret <- mapply(getOption, x=op.nms.full, default=defaults, SIMPLIFY=FALSE) ## clear long name names(ret) <- sub("^jesus.filename_sep.", "", names(ret)) ## if user specified which ops to get, use those if (!is.null(ops)) ret <- extractMatch(ops, ret, use.names=TRUE, duplicate=FALSE, fail.on.unmatched=TRUE, ignore.case=ignore.case.ops) return(ret) } get_jesus_sep.major <- function() { get_jesus_sep()[["major"]] } get_jesus_sep.minor <- function() { get_jesus_sep()[["minor"]] } get_jesus_sep.time <- function() { get_jesus_sep()[["time_from_date"]] } set_jesus_sep <- function(major, minor) { ## error check, must be a character of length 1 msg <- "'%s' is not a character vector of length 1 or NULL" if (!missing(major) && !(is.null(major) || (is.character(major) && length(major)==1))) stop(sprintf(msg, "major")) if (!missing(minor) && !(is.null(minor) || (is.character(minor) && length(minor)==1))) stop(sprintf(msg, "minor")) if (!missing(major)) options("jesus.filename_sep.major" = major) else major <- NA if (!missing(minor)) options("jesus.filename_sep.minor" = minor) else minor <- NA return(invisible(list(major=major, minor=minor))) } get_jesus_sep.DefaultValues <- function() { defaults <- list( major = "-" # hyphen , minor = "+" , time_from_date = "_" # underscore ## TIP: Do not use any of the seps as replace values , space_replace = " " # set to " " to allow spaces , badchar_replace = "." ) return(defaults) } set_jesus_sep.toDefaultValues <- function(onlyIfUnset=TRUE) { allseps <- get_jesus_sep.DefaultValues() names(allseps) <- paste0("jesus.filename_sep.", names(allseps)) if (onlyIfUnset) { for (op.nm in names(allseps)) # allseps[[op.nm]] <- getOption(paste0("jesus.filename_sep.", op.nm), allseps[[op.nm]]) allseps[[op.nm]] <- getOption(op.nm, allseps[[op.nm]]) } options(allseps) return(invisible(allseps)) } isset_jesus_sep <- function() { allseps <- get_jesus_sep.DefaultValues() major <- getOption("jesus.filename_sep.major", default=NULL) minor <- getOption("jesus.filename_sep.minor", default=NULL) return(c(major=!is.null(major), minor=!is.null(minor))) } ## EXECUTE set_jesus_sep.toDefaultValues(onlyIfUnset=TRUE) saveit <- function(obj, dir=ifelse(exists("dataDir"), dataDir, as.path(getwd(), "out")) , subDir=TRUE, pos=1, addTimeStamp=TRUE, useSeconds=FALSE , RDS=TRUE) { ## Like savethem() but only takes a single obj argument ## The advantage of using saveit() is not having to ## type 'dir=...'. ## Yep, that is all. (this func also was written first then modified to get savethem()) ## ## saves obj to file of type .Rda and with ## name of file same as name of obj + time stamp ## in location: dir ## subDir: if TRUE, will create subdirectory data_bak ## inside dir and use that folder. (if alreaddy exists, will just use) ## ## returns: the path/to/file.Rda where obj was saved e <- parent.frame(pos) # get object from the parent environment objName <- as.character(match.call()[[2]]) #----- EVAL IN OBJ NAME ------# ## this allows the use of, eg, saveit(eval(paste0("model.", bestVal)), outDir) # that is, if obj begins with eval(), then eval-parse it for the correct string if(objName[[1]]=="eval") objName <- eval(parse(text=objName)) #----- EVAL IN OBJ NAME ------# #----- ERROR CHECKS ------# # If multiple arguments passed to saveit, this may detect the mistake. if(!is.character(dir) || !is.logical(subDir)) warning("Did you mean to use savethem() instead of saveit()?") # If any of the assignment operators are found in the list, throw an error if(detectAssignment(objName)) stop("Cannot assign in the call to this function.") #----- ERROR CHECKS ------# # use subdirectory data_bak unless indicated not to (create it if needed) if (isTRUE(subDir)) dir <- as.path(dir, "data_bak") else if (is.character(subDir)) dir <- as.path(dir, subDir) # Create dir if needed dir.create(dir, recursive=TRUE, showWarnings=FALSE) # Create Suffix (based on dim, if applicable, and append timeStamp if required) suffix <- dimToString(objName, pos=pos+1) if(addTimeStamp) suffix <- paste0(suffix, get_jesus_sep.major(), timeStamp(seconds=useSeconds)) # create the filename, cleaning objName of bad chars fileName <- objName fileName <- gsub(pat=" ", repl=get_jesus_sep("space_replace"), fileName) ## clean spaces fileName <- cleanChars(fileName, repl=get_jesus_sep("badchar_replace")) ## clean bad characters fileName <- paste0(filename, suffix, ifelse(isTRUE(RDS), ".RDS", ".Rda") ) ## add suffix fileWithPath <- as.path(dir,fileName) # Save the object if (isTRUE(RDS)) do.call(saveRDS, args=c( list(get(objName, envir=e)), file=fileWithPath) ) else do.call(save, args=c(list(objName), envir=e, file=fileWithPath) ) # return the path/to/file return(fileWithPath) } #------------------------------------------------------------------------# ## WRAPPER jesusSafety.NoGo <- function() { options(jesus_using.safety=TRUE) options(jesus_safety=FALSE) } jesusSafety.Go <- function() { ## Does not turn off 'jesus_using.safety' options(jesus_using.safety=TRUE) options(jesus_safety=TRUE) } jesusSafety.ClearAll <- function() { ## Turns off both jesus safety options options(jesus_using.safety=FALSE) options(jesus_safety=FALSE) } jesusForData <- function(..., dir=data.p(proj=projName), info="", sub=FALSE, stampFile=TRUE, stampDir=FALSE , objNames = NULL , pos=1, envir=globalenv() , updateBackupFile=TRUE , projName = getProjName() , git=(.Pfm=="Linux") , safety=getOption("jesus_safety", FALSE), using.safety=getOption("jesus_using.safety", FALSE), dont.reset.safety=FALSE , RDS=TRUE , doNothing=FALSE , showWarnings=TRUE , verbose.git=verbose , verbose=FALSE ) { ### The purpose of 'safety' ### ---------------------------------------------------------------------------------------- ### ### Sometimes, when shipping code to iTerm, the buffer cuts off and random pieces of code run. Normally it is the code towards the end, ## and often the calls to jesus are towards the end. Since saving large data is costly, we do not want to run this function unintentionally ## Thus, if using.safety is TRUE, then safety must be TRUE. ## if using.safety is TRUE, but safety is FALSE, then do not run ## if using.safety is FALSE, then this function willl run as normal (safety is disregarded) ## When using.safety is on, safety is always switched off after every single run, unless 'dont.reset.safety' is TRUE ## Inside some functions, we only sometimes want to save the intermediate steps, and we allow the user to set a flag as to whether or not to save ## Having the flag be an argument keeps the code ever so slightly cleaner. if (doNothing) return(invisible(NULL)) ## if using.safety: Check safety. If off, warn and don't run. If on, toggle it off then continue running if (using.safety) { if (!safety) { warning("Cannot save in jesusForData() because safety switch is FALSE.\n\t\tSet options(jesus_safety=TRUE) at a proper point before the call to jesusForData()\n") return(invisible("NOTHING SAVED. 'safety' was set to FALSE")) } else if(!dont.reset.safety) { options(jesus_safety=FALSE) } } ### ---------------------------------------------------------------------------------------- ### ## 20141014 - phasing out 'pos' argument and replacing with 'envir' argument. Warn if pos is still being used. if (!missing(pos)) { envir <- parent.frame(pos) warning("pos was used in jesusForData() -- can we deprecate it?") } browser(expr=inDebugMode("jesus"), text="in jesusForData(), right before calling jesus") # If no objects specified, save all the DT's if (length(list(...)) > 0L || !is.null(objNames)) jesus(..., objNames=objNames, dir=dir, info=info, sub=sub, stampFile=stampFile, stampDir=stampDir, envir=envir, updateBackupFile=updateBackupFile, RDS=RDS, verbose=verbose, showWarnings=showWarnings, git=git, projName=projName) else { nms <- cbind(ls(envir=envir)[gapply(ls(envir=envir), inherits, "data.table", simplify=TRUE)]) jesus(eval(nms), dir=dir, sub=sub, stampFile=stampFile, stampDir=stampDir, envir=envir, updateBackupFile=updateBackupFile, RDS=RDS, verbose=verbose, showWarnings=showWarnings, git=git, projName=projName) } } ### savethem <- jesus <- function(..., dir=ifelse(exists("data.p"), data.p(proj=projName), as.path(getwd(), "out")) , info="", info.sep=get_jesus_sep.minor() , subDir=sub, sub=TRUE , pos=1, envir=globalenv() , stampDir=TRUE, stampFile=FALSE, summary=TRUE , failIfMissing=FALSE, showWarnings=TRUE, justDir=FALSE, git=(.Pfm=="Linux") , updateBackupFile=TRUE , backUpsFile=src.p("_latestBackups.r", proj=projName) , objNames = NULL , projName=getProjName() , RDS=TRUE , verbose.git=verbose , verbose=TRUE) { ## RECENT (untested) UPDATE: subdir can now be logical or a string. ## If TRUE, will set to data_bak. ## If a character, will set sub directory to that value. ## All other values, no sub directory set ## Like saveit() but can take multiple objects as arguments ## ## saves objects passed as (...) arguments to file of type .Rda and with ## name of file same as name of obj + time stamp ## in location: dir ## subDir: if TRUE, will create subdir data_bak ## inside dir and use that folder. (if alreaddy exists, will just use) #S sub: a synonym for subDir. (since use of ... does not allow for partial matches) ## ## returns: the path/to/file.Rda where objects were saved ## ## justDir : used for `whereIsJesus` ## clear git safety if (updateBackupFile) .rg() start.time <- proc.time() ## 20141014 - phasing out 'pos' argument and replacing with 'envir' argument. Warn if pos is still being used. if (!missing(pos)) { envir <- parent.frame(pos) warning("NOTE TO RICK: We are attempting to deprecate pos.\n It was just used in jesusForData() -- check where specifically and if we can we deprecate it?") } # ## For when testing: # obj1 <- "wrong obj1, in jesus" # obj2 <- "wrong obj2, in jesus" # browser() ## NOTE TO SELF: You cannot use `dots.list` and `list(...)` interchangeably in substitute ## dots.list <- list(...) browser(expr=inDebugMode(c("jesus", "jesusonly")), text="in jesus(), at the very top") ## if objNames was not given explicitly, take it from the dots if (is.null(objNames)) { # get objects from dots objNames <- as.list(as.character(substitute(list(...)))[-1L]) # 20141014 TODO: Change this to is.eval or is.call etc # check for arguments being (eval(...)) whichAreEval <- sapply(objNames, function(x) grepl("^eval\\(.+\\)$", x)) if (any(whichAreEval)) { # confirm they are calls whichAreCalls <- sapply(substitute(list(...))[-1], is.call) # proceed only if they match if (identical(whichAreCalls, whichAreEval)) { objNames2 <- list(...)[whichAreCalls] objNames <- unlist(c(objNames2, objNames[!whichAreCalls])) } } } ### TODO: June 2013. Apparently the `eval(vector.of.obj.names)` was not working. I wrote the part immediately above this. ### Confirm all is working correctly. # -- check this -- # # TODO: double-check pos value. It might be off. # -- check this -- # # check any value is eval(XX), if so parse it. Collect all values into a single vector. # -- check this -- # objNames <- unlist( lapply(objNames, function(ob) # -- check this -- # if(substr(ob, 1, 5)=="eval(") eval(parse(text=substr(ob, 6, nchar(ob)-1)), envir=ifelse(is.environment(envir), envir, parent.frame(pos+1)) ) else ob # -- check this -- # ) ) # No need to save any object twice objNames <- unique(objNames) #----- ERROR CHECKS ------# # If any of the assignment operators are found in the list, throw an error if (detectAssignment(objNames)) stop("Cannot assign in the call to this function.") #----- ERROR CHECKS ------# # Check that the objects to be saved exist NotPresent <- !(sapply(objNames, exists, envir=envir)) if (any(NotPresent)) { msg <- paste0("The following ", plrl("objects were", sum(NotPresent)) ," not found and hence could not be saved:\n ", paste_l(objNames[NotPresent], spacer=" "), "\n") if (failIfMissing) stop(msg) ## ELSE warning(msg) objNames <- objNames[!NotPresent] } # if no objects remain, do not continue. if (!length(objNames)){ warning("NOTHING SAVED.\nThere are no objects indicated to save (at least none that could be found).") return(invisible(NULL)) } # Dont use summary when only one file given, unless explicitly told to do so if (missing(summary) && length(objNames) == 1) summary <- FALSE # if flag is true, add appropriate subdir if (isTRUE(subDir)) dir <- as.path(dir, "data_bak") else if (is.character(subDir)) dir <- as.path(dir, subDir) if (justDir) cat("\n", as.path(dir), "\n") # add timeStamp to dir if required if(stampDir) dir <- paste0(as.path(dir), "_", timeStamp()) ## OUTPUTS WHERE THE DIR IS, GENERALLy fOR DEFAULTS if (justDir) return(as.path(dir)) # Create dir if needed dir.create(as.path(dir), recursive=TRUE, showWarnings=FALSE) ## CREATE 'objNamesWithInfo' ## ADD info to FILES if (is.null(info)) info <- "" if (length(info)!=1L && length(info) != length(objNames)) stop(sprintf("info has length %i while objname has length %i.\nThese must match, or info must be length 1.\n", length(info), length(objName))) ## For Debugging the info split browser(expr=inDebugMode("jesus_info"), text="In jesus().\n\nRight before parsing info") if (grepl("\\+", info)) { warning("\nThe `info` value should NOT contain a plus (+) sign\nsince this is reserved for parsing the filename.\nIt is being gsub'd with a '&' sign instead.") info <- gsub("\\+", "&", info) } ## Clean 'info' then replace spaces with underscores info <- gsub(" ", get_jesus_sep("space_replace"), info) info <- cleanChars(info, replacement=get_jesus_sep("badchar_replace")) ## We will separate info from the objName with the info.sep. However, ## we only want the info.sep to appear if info has actual text objNamesWithInfo <- paste0(objNames, ifelse(nchar(info), info.sep, ""), info) ## Note that if info is blank, then objNamesWithInfo will be same as objNames # create the file paths, cleaning objNames of bad chars # fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, dir=dir, info=info, addTimeStamp=stampFile, RDS=RDS) fileWithPath <- mapply(mkSaveFileNameWithPath, objName=objNames, objNameWithInfo=objNamesWithInfo , MoreArgs=list(dir=dir, addTimeStamp=stampFile, RDS=RDS, envir=envir)) # ------------------------------------------------------------------------------- # # Save the object # # ------------------------------------------------------------------------------- # SAVE.EXPR <- { if (isTRUE(RDS)) quote({ do.call(saveRDS, args=list(get(obj, envir=envir), file=thefile) ) return(TRUE) }) else quote({ do.call(save, args=list(obj, envir=envir, file=thefile) ) return(TRUE) }) } succeeded <- mapply(function(obj, thefile) tryCatch(error = saveErrorHandle, expr=eval(SAVE.EXPR) ) # Args to mapply: , objNames, fileWithPath) if (showWarnings && any(!succeeded)) { warning(warningCols(pre=paste0("The following ", sum(!succeeded) ," (out of ", length(objNames) ,") objects were NOT saved:"), objNames[!succeeded])) } # ------------------------------------------------------------------------------- # if (updateBackupFile) { caught.update <- try({ updateLatestBackups(objNamesWithInfo, fileWithPath, TF_inds=succeeded, fileToSource=backUpsFile, showWarnings=showWarnings, git=git, verbose=verbose.git) }, silent=TRUE) ## reminder: do not escape the '<|>' in regex if (showWarnings && isErr(caught.update)) warning("Attempt to updateLatestBackups failed", if (any(grepl("(<{3,}|>{3,})", readLines(backUpsFile)))) "\n HINT: It appears that there may be an unresolved git merge conflict in the file (angled brackets were detected)", "\n ORIGINAL ERROR: ", caught.update[[1]]) } # output time it took to complete end.time <- proc.time() if (verbose) { file.sizes <- file.info(fileWithPath)$size file.counts <- sum(!is.na(file.sizes)) if (file.counts != length(fileWithPath)) file.counts <- paste0(file.counts, " (out of ", length(fileWithPath), ")") tot.size <- formatBytes(sum(file.sizes, na.rm=TRUE)) cat("Time it took to save the ", file.counts, " files (", tot.size ,") was ", fwTDiff(start=start.time, end=end.time), ".\n\n", sep="") } # return the path/to/files or just a summary if (summary) return(list(summary=paste(length(fileWithPath), "files were created in:"), dir=dir)) return(path.unexpand(fileWithPath)) } updateLatestBackups <- function(objNames, fileWithPaths , TF_inds=TRUE , fileToSource=src.p("_latestBackups.r", proj=projName) , unexpandPath=TRUE, verbose=TRUE , git=TRUE # A quick value for all gits. ## TODO, get rid of the deprecated arguments and have only gitcommit (which will also pick up git) , gitcommit=git, gitpush="DEPRECATED", gitpullFirst="DEPRECATED" , projName=getProjName() , showWarnings=TRUE ) { ## TF_inds is a flag of indeces of which items to save. It should have length, othwerwise nothing will be saved if (!length(TF_inds)) { if (showWarnings) warning("\nupdateLatestBackups() was called but the `TF_inds` indicating\nwhich objects to save is empty (meaning \"don't save any objects\")") TF_inds <- FALSE } if (!is.logical(TF_inds)) stop("`TF_inds` should be logical") # in case either is alist, such as with `jesusForData` if (length(objNames) == length(fileWithPaths)) { objNames <- unlist(objNames, use.names=FALSE) fileWithPaths <- unlist(fileWithPaths, use.names=FALSE) TF_inds <- unlist(TF_inds, use.names=FALSE) } if (verbose) cat("updating", fileToSource, "\n with ", if(any(TF_inds)) paste(c(objNames[TF_inds], if (any(!TF_inds)) "but any of"), collapse=", ") else (".. actually NONE. They're all excluded."), if(any(!TF_inds)) paste(objNames[!TF_inds], collapse=", "), "\n\n") # Create file if not exists if (!file.exists(fileToSource)) { dir.create(dirname(fileToSource), showWarnings=FALSE, recursive=TRUE) write(x="# This should always be in as.path(srcDir, \"_latestBackups.r\")\n\n.latestBackups <- list(\n# ObjName = \"path/to/fileName.RDS\"\n)" , file=fileToSource, append=TRUE) } # Import the lastest iteration of the list source(fileToSource) # If there is nothing to update, return the list, doing nothing. if (!any(TF_inds) || !length(objNames)) return(invisible(.latestBackups)) ## add tilde's back in if (unexpandPath) { # OLD: fileWithPaths[TF_inds] <- unpath.expand(fileWithPaths[TF_inds]) # NEW (20140915): fileWithPaths[TF_inds] <- path.unexpand(fileWithPaths[TF_inds]) # homefull <- paste0("^", path.expand("~")) # fileWithPaths[TF_inds] <- gsub(homefull, "~", fileWithPaths[TF_inds]) } ## Update the list .latestBackups[unlist(objNames[TF_inds])] <- unlist(fileWithPaths[TF_inds]) out <- strsplit(dictAlign(.latestBackups, copy=FALSE, verbose=FALSE), "\n")[[1]] # preserve the first four lines, which is what assigns out <- c("", "", out) ## add two blank line out[1:4] <- readLines(fileToSource, 4) ## WRITE TO TEMP ## OLD: write(x=out, file=fileToSource, append=FALSE) writeViaTempFile(x=out, file=fileToSource, append=FALSE) # commit after each write if (isTRUE(gitcommit)) { # f.dummy_tmp <- tempfile() # sinkOn(file=f.dummy_tmp, verbose=FALSE, zarchive=FALSE) g.p0 <- function(...) paste0("cd ~/git; ", paste0(...)) gitaddcmd <- g.p0("git add '", path.expand(fileToSource), "'") gitaddcmd <- gsub("\\!", "\\!", gitaddcmd) try(system(gitaddcmd, TRUE), silent=TRUE) ## create a message and commit gitmsg <- paste0("latestBackups.r @ ", projName, basename(dirname(fileToSource)) %>% {if (projName != .) sprintf(" (dir: %s)", .)}) gitcmd <- g.p0("git commit -m \'", gitmsg ,"\'") suppressWarnings(try(system(gitcmd, TRUE), silent=TRUE)) ## pull & push ## I may have been in correct in using .g() ## NOPE: suppressWarnings(try(capture.output(.g(verbose=FALSE, utilsReload=FALSE, supportFnsReload=FALSE)))) ## I may have been incorrect in deprecating if (identical(gitpush, "DEPRECATED")) gitpush <- TRUE if (identical(gitpullFirst, "DEPRECATED")) gitpullFirst <- TRUE if (gitpush && gitpullFirst) suppressWarnings(try(system(g.p0("git pull --quiet"), FALSE, FALSE), silent=TRUE)) if (gitpush) suppressWarnings(try(system(g.p0("git push --quiet"), FALSE, FALSE), silent=TRUE)) ## sink does not work either # sinkOff() # unlink(f.dummy_tmp) } return(invisible(.latestBackups)) } #__________________________________________________________________________# #--------------------------------------------# saveErrorHandle <- function(e) { if(grepl("error writing to connection", e)) { warning("Could not write to connection. Object has not been saved.\n Check that the disk is not full.") return (FALSE) } else warning(paste("ERROR. File did not save. Error received was:\n", e)) return(FALSE) } mkSaveFileNameWithPath <- function(objName, objNameWithInfo=objName, dir # , info="", info.sep=get_jesus_sep.minor() , addTimeStamp=FALSE , ext=ifelse(isTRUE(RDS), ".RDS", ".Rda"), RDS=TRUE , sep=get_jesus_sep.major() , envir=globalenv() , pos="DEPRECATED" ) { ## This is a helper function for jesus() ## It creates a string to be used as the file name of a saved object ## of the format ObjName_TimeStamp_DimOrLen.RDS ## ## Depends on: dimToString() ## ## objName : the name of the object in the envrionment. This is used for grabbing object info, such as dim ## objNameWithInfo : the output name of the object. ie, "DB.using+After_test_run" # info : if (length(info) > 1L) { # info : stop("For now, info must be of length 1. To give each object its own info,\n use separate calls to jesus() or jesusForData().\n (This message is from 'mkSaveFileNameWithPath()')") # info : } ## DEPRECATED if (!missing(pos)) stop("'pos' has been deprecated in mkSaveFileNameWithPath() -- use 'envir'") # error check if (!is.character(objName)) stop("objName should be character. Did you forget quotation marks?") # Create Suffix (based on dim, if applicable, and append timeStamp if required) suffix <- dimToString(objName, envir=envir) if(addTimeStamp) suffix <- paste0(sep, timeStamp(), sep, suffix) # info : ## ADD info to FILES # info : if (length(info)!=1L && length(info) != length(objName)) { # info : stop(sprintf("info has length %i while objname has length %i.\nThese must match, or info must be length 1.\n", length(info), length(objName))) # info : } else { # info : ## Clean 'info' then replace spaces with underscores # info : info <- gsub(" ", "_", cleanChars(info, replacement="-")) # info : # info : ## add info to the front of the suffix (seperated by a "_"). # info : ## We will separate info from the objName with the info.sep. However, # info : ## we only want the info.sep to appear if info has actual text # info : suffix <- paste0(ifelse(nchar(info), info.sep, ""), info, suffix) # info : } # create the filename, cleaning objName of bad chars # return the file path as.path(dir, paste0(cleanChars(objNameWithInfo, repl=get_jesus_sep("badchar_replace")), suffix), ext=ext) } #--------------------------------------------# dimToString <- function(objName, envir=globalenv(), prefix="", markers="", pos="DEPRECATED") { # gets the dimensions or length of an object and converts it to a string # in the format rowsxcols or length_len # # markers: a string of length 1 or 2 that will go on the outside of the object # such as "!" or c("[", "]") # prefix : a string that will go at the start of the returned string ## DEPRECATED if (!missing(pos)) stop("'pos' has been deprecated in mkSaveFileNameWithPath() -- use 'envir'") # error check if (!is.character(objName)) stop("objName should be character. Did you forget quotation marks?") obj <- get(objName, envir=envir) obj.dim <- dim(obj) if (is.null(obj.dim)) obj.dim <- paste0(length(obj), "_len") # allow for left & right markers mLeft <- markers[[1L]] mRight <- if (length(markers)==2L) markers[[2L]] else markers[[1L]] ret <- paste0(prefix[[1L]], mLeft, paste(obj.dim, collapse="x"), mRight) return(ret) } #--------------------------------------------# stringToDim <- function(fileName, envir=globalenv(), prefix=get_jesus_sep.major(), markers="!", simplify=FALSE, pos="DEPRECATED") { # extracts the dims from a file name, if the file was saved using jesus() or saveit() # example file name: "artist_and_dates-!47082x7!-20130607_1846.Rda" ## DEPRECATED if (!missing(pos)) stop("'pos' has been deprecated in mkSaveFileNameWithPath() -- use 'envir'") # error check if (!is.character(fileName)) stop("objName should be character. Did you forget quotation marks?") # string pattern to search for pat <- paste0(markers, ".*", markers) dims <- stringr::str_extract(string=fileName, pattern=pat) # remove the markers dims <- gsub(markers, "", dims) # split on the x dims <- strsplit(dims, "x") # convert to numeric dims <- lapply(dims, as.numeric) # convert to numeric, simultaneously adding names if 2-dimensional dims <- lapply(dims, function(x) if (length(x)==2) setNames(as.numeric(x), c("rows", "cols")) else as.numeric(x)) # dims will be a list. However, if only one file name sent we want to return a vector if (length(fileName)==1) return(dims[[1]]) if (!simplify) return(dims) # else, simplify # if not all the same length, cannot simplify. Return the list as is if (!areEqual(lapply(dim, length))) return(dims) # otherwise, simplify return(data.frame(do.call(rbind, dims))) } #--------------------------------------------# #__________________________________________________________________________# #==========================================================================# # loadFromJesus(c("DB.raw", "DB.all.count"), overwrite.ifexists=TRUE) ## NOTE TO SELF: # In workspace.r I already have a function named 'LoadFromBackup' which right now just loads .RData files # Look into combining the two or changing this loadFromJesus.manyobjs <- function(objectsToLoad, pos=1 , info=NULL, info.sep=get_jesus_sep.minor() , verbose=TRUE, envir=globalenv() , overwrite.ifexists=FALSE, SAMPreplace=FALSE, ... ) { ## TODO: Combine this into loadFromJesus where I just check if there are any missing objects, and remove them and move on. if (!missing(pos)) { warning("'pos' was used in loadFromJesus.manyobjs. can we deprecate pos ?") envir <- parent.frame(pos) } # envir.string <- capture.output(print(envir)) envir.string <- cleanEnvirString(envir) # allow for something like showBackUpsAvailable(quiet=TRUE)[1:4] to be an input if (is.data.table(objectsToLoad)) { if (all(c("obj", "ext", "time") %in% names(objectsToLoad))) objectsToLoad <- gsub("^\\s*|\\s*$", "", objectsToLoad[["obj"]]) else stop ("do not know how to load from such a data.table") } if (anyDuplicated(objectsToLoad)) stop("There are duplicate objects requested: ", paste(objectsToLoad[duplicated(objectsToLoad)], collapse=", ")) ls.before <- ls(envir=envir) if (SAMPreplace) { pat <- "^SAMP\\." if (wh <- anyDuplicated(gsub(pat, "", objectsToLoad))) stop("Replacing SAMP will create duplicate object names: ", paste(objectsToLoad[wh], collapse=", ")) } for (obj in objectsToLoad) { try(loadFromJesus(obj, verbose=FALSE, pos=pos+1, overwrite.ifexists=overwrite.ifexists, ...)) } ret <- setdiff(ls(envir=envir), ls.before) if (verbose) cat("The following object were created in ", envir.string, ": \n ", paste(ret, collapse=", "), "\n", sep="") return(invisible(ret)) } loadIfNotExists <- function(objToLoad, colsNeeded=NULL, info=NULL, info.sep=get_jesus_sep.minor() , srcDir=src.p(proj=projName), projName=getProjName() , envir=globalenv(), inherits=TRUE, verbose=FALSE) { ## allow unquoted argument objToLoad <- as.character(substitute(objToLoad)) ## Ensure only one obj at a time if (length(objToLoad) > 1) stop ("loadIfNotExists is NOT vecotirzed. One objToLoad at a time please") ## Check that there is a srcDir, since loadFromJesus() has a check for missing caught <- try(force(srcDir), silent=TRUE) if (isErr(caught)) { e.msg <- parent.frame() stop("There is no 'srcDir' object in ", capture.output(e.msg), "\n HINT: have you called setScience() or setScienceIfNot()") } ## Check if the object currently exists objExists <- exists(objToLoad, envir=envir, inherits=inherits) colsPresent <- is.null(colsNeeded) || (objExists && all(colsNeeded %in% names(get(objToLoad, envir=envir, inherits=inherits)))) if (verbose) { if (!objExists){ message("'", objToLoad, "' does not yet exist. Will attempt to load from jesus") } else { if (colsPresent) message("'", objToLoad, "' already exists as expected. No need to reload") else message("'", objToLoad, "' exists, however cols are NOT as expected. Will attempt to load from jesus") } } if (!(objExists && colsPresent)) loadFromJesus(objToLoad, srcDir=srcDir, envir=envir, info=info, info.sep=info.sep) } loadFromJesus <- function(objToLoad , backuplist.file=as.path(srcDir, "_latestBackups.r") , assignTo=NULL , info=NULL , info.sep=get_jesus_sep.minor() , verbose=TRUE , pos=1 , envir=globalenv() , debug=FALSE , overwrite.ifexists=FALSE , dont.fail.ifexists=FALSE , SAMPreplace=FALSE , file=NULL , dont.setDT = FALSE , srcDir=src.p(proj=projName) , projName=getProjName() ) { ## This is just a manual switch function with a whole lot of error checking. ## The file `backuplist.file` should be an r file that when sourced creates ## an object named `.latestBackups`, a dictionary, whose ## names is the objToLoad and whose ## values are the files to load ## ## dont.setDT :: When loading a data.table from disk, the memory-reference might not be correct ## the current (2015-01-25) fix is to use setDT on the table ## if dont.setDT is not set to TRUE (ie the default behavoir) ## setDT(.) will be called on: ## * any objToLoad that starts with '^DT' ## * any obj that is loaded and then confirmed to be a DT. It will then be assigned back to itself ## ## Pull from git, for latest backups try(.g()) if (!missing(srcDir) && !file.exists(srcDir)) { try1 <- as.path(getwd(), srcDir) try2 <- as.path("~/git/orch/src", srcDir) if (file.exists(try1)) srcDir <- try1 else if (file.exists(try2)) srcDir <- try2 else stop ("cannot find folder srcDir = '", srcDir, "'\n") } ## environment ## -----–-----– if (!missing(pos)) { warning("'pos' was used in loadFromJesus.manyobjs. can we deprecate pos ?") envir <- parent.frame(pos) } force(envir) # envir.string <- capture.output(print(envir)) envir.string <- cleanEnvirString(envir) ## -----–-----– missing.objToLoad <- missing(objToLoad) ## Default value for selection is NULL. However, will be set to a slection number if objToLoad is a number. selection <- NULL ## Check if the first argument (ie, objToLoad) is actually a file name and not an object. if (!missing.objToLoad && missing(file) && length(objToLoad) == 1) { ## A number is treated as a selection in the menu if (is.numeric(objToLoad)) { selection <- objToLoad objToLoad <- NULL missing.objToLoad <- TRUE ## If it's a file name, use that file } else if (grepl("/", objToLoad) && grepl("\\.rd[as]", objToLoad, ignore.case=TRUE)) { file <- objToLoad objToLoad <- NULL missing.objToLoad <- TRUE } } ## If file is given, try to grab it. if (!is.null(file)) { if (!is.character(file)) stop ("invalid file name. File should be a string vector") ## iterate over each file if (length(file) > 1) { ret <- list() for (f in file) ret[[f]] <- loadFromJesus(file=f, envir=envir, verbose=verbose, overwrite.ifexists=overwrite.ifexists, dont.fail.ifexists=dont.fail.ifexists, srcDir=srcDir, dont.setDT=dont.setDT ) return(unlist(ret)) } if (!all(file.exists(file))) { ## remove line breaks, sometimes find their way in if copied from terminal if (grepl("\\n", file)) file <- gsub("\\n", "", file) verboseMsg(verbose, "File not found, attempting to pull it from server.") sapply(file, bringme) } ## Don't clean the file until AFTER bringme, since "~" in scp will be 'root' or 'ubuntu' file <- unpath.expand(file) if (!any(file.exists(file))) stop(sprintf("Could not find file\n\t'%s'\n Attempted bringing it, but still not found.", file)) else verboseMsg(verbose, "File found, will now load it.", time=TRUE) ## OLD 20141014 : envir <- parent.frame(pos) ## OLD 20141014 : envir.string <- capture.output(print(envir)) ## Parse out the object name objToLoad <- parseBackUpFile(file)[["obj"]] fileToLoad <- file ## File not specified. Two alternatives, either Object name is ## (1) specified (load it) ## (2) not specified (offer options from available backups) } else { ## Not specified if (missing.objToLoad) { ## If there is no selection or obj chosen, prsent options and a menu if (is.null(selection)) { cat("The following objects are available to load:\n") avails <- showBackUpsAvailable(quiet=FALSE, debug=debug, folder=srcDir) browser(expr=isTRUE(debug) | inDebugMode("jesus"), text="in loadFromJesus, right after avails <- showBackUpsAvailable();") objToLoad <- readline("\nPlease Select an object (or row number) to load > ") } else { avails <- showBackUpsAvailable(quiet=TRUE, debug=debug, folder=srcDir) objToLoad <- selection } # check if given object is not in the available objects. If not check if it is a number. Else fail if (!(objToLoad %in% avails[["obj"]])) { if (isNumber(objToLoad)) { verboseMsg(verbose, "Object(s) selected: ", pasteQ(avails[as.numeric(objToLoad), obj], wrap=""), time=FALSE) fileToLoad <- avails[as.numeric(objToLoad), file] objToLoad <- avails[as.numeric(objToLoad), obj] } else { # "x" to quit if (isQuit(objToLoad)) { message("Quitting without loading an object.\n") return(invisible(NULL)) } # otherwise, error stop("Invalid input. '", objToLoad, "' is an invalid input.") } } # ELSE: objToLoad is valid and proceed as normal. objToLoad <- gsub("\\s*$", "", objToLoad) } browser(exp=inDebugMode("jesus", "loadFromJesus", "loadFromJesus_middle"), text="in loadFromJesus() at middle") ## From here forward, objToLoad is assumed specified ## ## -------------------------------------------------- ## ## Allow for unquoted objToLoad if (!is.character(objToLoad)) objToLoad <- as.character(substitute(objToLoad)) if (!length(objToLoad)) stop("Invalid input. objToLoad has no length.") if (length(objToLoad) > 1) return(loadFromJesus.manyobjs( objToLoad, envir=envir, backuplist.file=backuplist.file , overwrite.ifexists=overwrite.ifexists, dont.fail.ifexists=dont.fail.ifexists , dont.setDT=dont.setDT, verbose=verbose)) ## OLD 20141014 : envir <- parent.frame(pos) ## OLD 20141014 : envir.string <- capture.output(print(envir)) ## If the file to load has not already been selected, then use the following to find it if (!exists("fileToLoad") || is.null(fileToLoad) || fileToLoad == "") { ### TODO: If the obj was selected not by number, but there is more than one similarly named obj ### then the match might be off ## Confirm that the text file listing the backups available exists if (!file.exists(backuplist.file)) stop("file '", backuplist.file, "' could not be found.\nThis is the file that should contain the list of backups for the current project.") source(backuplist.file) if (!exists(".latestBackups")) stop("could not find object `.latestBackups`\n\nHINT: Check the contents of the backup file '", backuplist.file, "' \n\t which is where this object should have been loaded from.\n") ## objToLoad should match the name of a .latestBackups ## HOWEVER, if it has info attached to it, then matching needs an extra step nms <- names(.latestBackups) ## TODO 2015-01-27 -- this is a sloppy implemention of applying info. Need to clean this up ## NEW METHOD # note that in jesus() the code is: objNamesWithInfo <- paste0(objNames, ifelse(nchar(info), info.sep, ""), info) objAndInfo <- paste0(objToLoad, ifelse(nchar(info), info.sep, ""), info) matched <- nms == objAndInfo ## IF NO MATCHES IN NEW METHOD, TRY OLD METHOD if (!any(matched)) { objAndInfo <- strsplit(objToLoad, "\\+")[[1]] matched <- sapply(strsplit(nms, "\\+"), function(n) all(n[seq(objAndInfo)]==objAndInfo) ) ## Matched will have NA's if seq(objAndInfo) is longer than n matched[is.na(matched)] <- FALSE } ## If multiple matches, ask user to be more specific if (sum(matched) > 1) stop("`", objToLoad, "` has more than one match (due to info).\n\n Options are: ", paste0("\n\t ", nms[matched]), "\n\nPlease be more specific.") if (sum(matched) == 0) stop("`", objToLoad, "` is not a name of `.latestBackups`\n\n Use showBackUpsAvailable() or showAllAllScienceBackups() to see available backups") fileToLoad <- .latestBackups[[which(matched)]] } } ## // end else-if !is.null(file) ## Check if file exists. If not, try to load it. If still not, then fail if (!file.exists(fileToLoad)) { if (.Pfm == "Darwin") { if (verbose) cat("Note: File was not present. Attempting to pull from remote.... ") try(bringme(gsub("~/", "~rsaporta/", fileToLoad), verbose=verbose)) } ## Check if still not present. If still not, then fail. if (!file.exists(fileToLoad)) stop("\nfile '", fileToLoad, "' could not be found\n.`", objToLoad, "` was not loaded.") else cat(" Success!\n") } ## OLD 20141014 : ext <- toupper(substr(fileToLoad, nchar(fileToLoad)-3, nchar(fileToLoad))) ext <- sapply(splitOnLast(fileToLoad, "."), tail, 1) ## Only these two types of files can be loaded. Others are error if (ext %ni% c("RDA", "RDS")) stop("\nDo not know how to import file of type '", ext, "'\nThe following file was not loaded: '", fileToLoad, "'\n\nHINT: Check the file extension.\n If it is one of .RDS or .RDA then there is a bug in loadFromJesus().\n If it is some other type, how should it be loaded?" ) # Ensure that the value was loaded. ls.before <- ls(envir=envir) if (SAMPreplace) { if (overwrite.ifexists) { warning("overwrite.ifexists is ignored when SAMPreplace is TRUE. Please manually remove any objects to be overwritten") overwrite.ifexists <- FALSE } pat <- "^SAMP\\." if (grepl(pat, objToLoad)) objToLoad <- gsub(pat, "", objToLoad) } ## What to call object assigning to if (is.null(assignTo)) assignTo <- sapply(objToLoad, function(s) strsplit(s, "\\+")[[1]][[1]]) # remove any info info ## Check if already loaded, and if overwrite is FALSE if (objToLoad %in% ls.before && !overwrite.ifexists) { ## if flagged not to fail, simply notify and return nothing if (dont.fail.ifexists) { message("'", objToLoad, "' was previously loaded.") return(invisible()) } stop("\nALREADY EXISTS:\n\t `", objToLoad, "` already exists in environment ", envir.string, "\n\nUse argument ( ..., overwrite.ifexists = TRUE ) if you would like to load anyway.") } if (verbose) cat("Loading ", objToLoad, " into environment ", envir.string ," from file ", if (nchar(fileToLoad) > getWidth() - 80) "\n ", "'", fileToLoad, "'\n", sep="") if (ext == "RDS") { # old 2015-02-10 : ## check if the objToLoad will be a DT. In which case we need to call setDT on it. # old 2015-02-10 : ## However, this is hard to determine JUST FROM the name. # old 2015-02-10 : if (grepl("^DT", objToLoad) && grepl("\\.(list|ll$)", objToLoad)) # old 2015-02-10 : assign(assignTo, setDT(readRDS(fileToLoad)), envir=envir) # old 2015-02-10 : else # old 2015-02-10 : assign(assignTo, readRDS(fileToLoad), envir=envir) # NEW 2015-02-10 : ## First assign, then check if is a data.table and has the wrong truelength, in which case, call setDT on it assign(assignTo, readRDS(fileToLoad), envir=envir) if (is.data.table(get(assignTo, envir=envir)) && !truelength(get(assignTo, envir=envir))) { s.t(assign(assignTo, setDT(get(assignTo, envir=envir)), envir=envir), msg="Time it took to setDT and reassign. ", quiet.if.less.than = 1) } } if (ext == "RDA") { if (objToLoad != assignTo) warning("Do not know how to auto-assign the load from an .RDA file. Use .RDS files instead.") load(fileToLoad, envir=envir) } browser(expr=inDebugMode("loadFromJesus", "loadFromJesus_bottom", "jesus", skip="jesus"), text="at bottom of loadFromJesus_bottom() right after loading before confirmation") # Check that object loaded properly ret <- setdiff(ls(envir=envir), ls.before) something.added <- as.logical(length(ret)) ## If something was NOT added and the object was not already in the ls(). if (!something.added && objToLoad %ni% ls.before) warning("Object may not have loaded properly.\nWe could not detect a change in the before & after of ls() for environment ", envir.string ) ## if Something was added but not what was expected else if (something.added && !identical(ret, objToLoad)) warning("Object created, but with different name: `", ret, "`") ## All was succesful. Optionally notify of success else verboseMsg(verbose, "Object `", ifelse(something.added, ret, objToLoad) , "` succesfully created in ", envir.string, ".\n", simple=TRUE) ## Before returning -- Check if it is a data.table and if so, check the truelength if (length(ret)) { X <- get(ret, envir=envir, inherits=FALSE) if (is.data.table(X) && !truelength(X)) { warning ("truelength of the data.table '", ret, "' is 0. Will setDT and reassign") assign(ret, setDT(X), envir=envir) } } return(invisible(ret)) } showBackUpsAvailable <- function(backuplist.file="_latestBackups.r", replace.dataDir=TRUE, quiet=FALSE, folder=src.p(proj=projName), projName=getProjName() , sep=get_jesus_sep.major(), ts.tz=getOption("default.tz"), ts.local=getOption("default.tz"), nrows=200, debug=FALSE, pat=NULL, ignore.case.for_pat=TRUE) { # reads in the text file of backups and outputs the info in a nice DT # the backuplist.file will contain a list in the form of # ObjName="/path/to/FileName-ObjInfo-ObjInfo.ext" # This will parse out the ObjInfo # TODO: # All of the '#p' comments is code removed and put into print.tableOfBackups. If it is working well, go ahead and delete it. # Concat filename with folder backuplist.file <- as.path(folder, backuplist.file) # Confirm file exists if (!file.exists(backuplist.file)) stop("file '", backuplist.file, "' could not be found.") # Load it in, which creates an object ".latestBackups". Keep it local source(backuplist.file, local=TRUE) if (!exists(".latestBackups")) stop("could not find object `.latestBackups`") fls <- unlist(.latestBackups, recursive=FALSE, use.names=FALSE) ## For debugging. browser(expr=inDebugMode("showBackUpsAvailable", "jesus", skip="jesus"), text="In showBackUpsAvailable(), right BEFORE 'tbl' ") ## MAIN PORTION ## tbl <- parseBackUpFile(fls, MayContainPath=TRUE) [order(time)] ## clean tbl ## --------------------------- setFactorsToChars_ (tbl) ## add filepath from .latestBackups ## ------------------------------------ uld <- unlist(.latestBackups) ## TODO (20140826) -- this will yield NAs if chars where cleaned tbl[, filepath := uld[pmatch(names(uld), basename(file))]] tbl[is.na(filepath), filepath := file] ## count size tbl[, bytes := file.info(filepath)[["size"]]] tbl[is.na(bytes), bytes := file.info(file)[["size"]]] ## match pattern ## ------------------------------------ if (!is.null(pat)) { if (!any(grepl(pat, tbl$obj, ignore.case=ignore.case.for_pat))) warning("pat not matched to any obj") else tbl <- tbl[grepl(pat, obj, ignore.case=ignore.case.for_pat)] } ## assign the ts.local as an attribute setattr(tbl, "ts.local", ts.local) ## set class to tableOfBackups --- useful for print setattr(tbl, "class", c("tableOfBackups", class(tbl))) ## output if (!quiet) print(tbl, replace.dataDir=replace.dataDir, nrows=nrows) return(invisible(tbl)) } showAllAllScienceBackups <- function(pat=NULL, search.in=c("both", "obj", "srcDir"), ignore.case=TRUE, path.shown=FALSE, dir=if (exists("srcDir")) dirname(srcDir) else "~/git/orch/src", quiet=FALSE, nrows=40, load=c() ) { ## load: a list of indeces. Will load those in to mem dirs <- dir.info(dir, all=TRUE, output=FALSE)[c(isdir), path] dirs.nms <- gsub(paste0("^", path.expand(dir), "/"), "", dirs) setattr(dirs, "names", dirs.nms) Backups <- lapply(names(dirs), function(nm) tryCatch(showBackUpsAvailable(folder=dirs[nm], quiet=TRUE)[, srcDir := nm], error=function(e){NULL})) browser(expr=inDebugMode("jesus", skip="showAllAllScienceBackups"), text="in showAllAllScienceBackups, right after Backups created.") # i <<- 0 # invisible(sapply(Backups, function(D) {i<<-i+1; cat("i: ",i,"\n"); if ("obj" %in% names(D)) print(D[obj == "DT.Spotify.Counts.by.date.product.mobile.country.user"])})) # Backups[[4]] ## No backups found if (all(sapply(Backups, is.null))) { warning("Could not find any backups. This could be an issue in the parsing. (HINT: Explore showBackUpsAvailable() ).\nReturning empty data.table") return(data.table()) } ret <- rbindlist.fill(Backups) by.cols <- c("srcDir", "obj", "info") setcolorderpt(ret, by.cols) ret <- unique(ret, by=by.cols) if (!nrow(ret)) { stop ("No rows returned") } if (!is.null(pat)) { search.in <- match.arg(search.in) # browser() if (search.in == "both") { matches <- lapply(c("obj", "srcDir"), function(col) grepl(pat, ret[[col]], ignore.case=ignore.case)) matches <- do.call("|", matches) } else { matches <- grepl(pat, ret[[search.in]], ignore.case=ignore.case) } if (!any(matches)) { warning ("No rows match pattern '", pat, "'.") return(invisible(ret[matches])) } ret <- ret[matches] } setattr(ret, "class", c("tableOfBackups", class(ret))) for (l in load) { f.load <- ret[l, filepath] verboseMsg(verbose, "Loading: '", f.load, "' \n", sep="", time=FALSE) loadFromJesus(f.load, verbose=verbose) } if (!quiet && !length(load)) print(ret, nrows=nrows, path.shown=path.shown) return(invisible(ret)) } showForecastBackups <- function(dir=data.p("forecasting"), ...) { files <- extractFilesFromFolder(dir, ext=c("RDS", "RDA")) parseBackUpFile(files, ...) } print.tableOfBackups <- function(DT, all.show=FALSE, nrows=30, replace.dataDir=TRUE, path.shown=FALSE, na.rm.col=TRUE, ts.local=attr(DT, "ts.local"), projName=getProjName()) { requiredCols <- c("info", "obj", "rows", "cols") if (!all(requiredCols %in% names(DT)) && !all.show) { warning(warningCols("Columns required for print.tableOfBackups() missing: ", setdiff(requiredCols, names(DT)), "will use regular ol' print()", endl=0)) all.show <- TRUE } ## Take a copy DT <- copy(DT) ## if we want to show all, drop the 'tableOfBackups' class and then print() if (all.show) { class(DT) <- setdiff(class(DT), "tableOfBackups") return(print(DT, nrows=nrows)) } ## ------------------------------------------------ ## ## CREATE .str versions of almost all columns ## ## ------------------------------------------------ ## ## Rows & Cols DT[, c("rows.str", "cols.str") := lapply(.SD, formnumb, selfRound=FALSE), .SDcols=c("rows", "cols")] ## replace 'NA's with "-" DT[is.na(cols), cols.str := "-"] DT[is.na(rows), rows.str := "-"] ## time cols if (is.null(ts.local)) ts.local <- getOption("default.tz") datetimeCols <- nwhich(sapply(DT, is.date_or_time)) if (length(datetimeCols)) DT[, paste0(datetimeCols, ".str") := lapply(.SD, readableTime, ts.local=ts.local, year.included=TRUE), .SDcols=datetimeCols] ## Bytes if (!"bytes" %in% names(DT)) { ## Ideally use filepath for file info if available. Else use file if ("filepath" %in% names(DT)) DT[, bytes := file.info(filepath)[["size"]]] else DT[, bytes := file.info(file)[["size"]]] } DT[, bytes.str := formatBytes(bytes)] DT[is.na(bytes.str), bytes.str := "? "] ## file DT[, file.str := path.unexpand(file)] if (replace.dataDir) { ## dataDir gets replaced if (exists("dataDir")) { pat.dd <- paste0("^", gsub("/git(Data)?/", "/git(Data)?/", path.unexpand(data.p(proj=projName)))) DT[, file.str := gsub(pat.dd, "[dataDir] ", file.str)] } if (exists("outDir")) { pat.od <- paste0("^", path.unexpand(out.p(proj=projName))) DT[, file.str := gsub(pat.od, "[outDir] ", file.str)] } } ## Obj with info into one col DT[, 'Obj (With Info)' := ifelse(nchar(info) # This sprintf simply pads the space between "obj (info)", trying to line up the info column, without sacrificing too much space , sprintf(paste0("%-", min(12, mnchar(obj[nchar(info)>1])) ,"s (%s)"), obj, gsub("_", " ", cropStringTo(info, 40))) # If no info, just use plain obj , obj)] nms <- names(DT) ## Drop any columns where there exists a '.str' version colsToDrop <- nms[paste0(nms, ".str") %in% nms] ## also drop 'obj' & 'info' colsToDrop <- c(colsToDrop, "obj", "info") ## Drop them suppressWarnings(DT[, c(colsToDrop) := NULL]) ## Drop the filepath if (!path.shown) suppressWarnings(DT[, filepath := NULL]) ## DROP any columns that are fully NA or blank if (na.rm.col) { cols.that.are.na <- colSums(is.na(DT) | DT == "") == nrow(DT) if (any(cols.that.are.na)) DT[, nwhich(cols.that.are.na) := NULL] } if (all(DT$ext == "RDS")) DT[, ext := NULL] ## Ordering setcolorderpt(DT, c("time.str", "Obj (With Info)", "bytes.str", "rows.str", "cols.str") , endCols=c(extract("^Addl\\d+$", DT), "ext", "file.str", "file", "filepath") , showWarnings=FALSE, failOnMissingCols=FALSE ) ## Pad some right-hand spaces for each of these colsPadRight <- c("Obj (With Info)", "file.str", "time.str") colsPadRight <- intersect(colsPadRight, names(DT)) if (length(colsPadRight)) { s.fmt <- paste0("%-", DT[, lapply(.SD, mnchar), .SDcols=colsPadRight], "s") names(s.fmt) <- colsPadRight for (col in colsPadRight) DT[, (col) := sprintf(s.fmt[[col]], get(col))] setnames(DT, colsPadRight, sprintf(paste0(" ", s.fmt), gsub("\\.str$", "", colsPadRight))) } ## Clean the column names setnames(DT, gsub("\\.str$", "", names(DT))) setnames(DT, topropper(names(DT))) ## Drop the class and then call regular print() class(DT) <- setdiff(class(DT), "tableOfBackups") print(DT, nrows=nrows) } # jesus2 # ## -------------------------- ATTEMPT AT jesus2 -------------------- ## # jesus2 # ## 2015-02-10: There had been an issue with jesus() for matrices # jesus2 # ## I no longer remember the details. # jesus2 # ## However, jesus2() never quite worked either. # jesus2 # ## At this point, jesus2 is over a year old and is mostly useless (since many new changes have been made to jesus()) # jesus2 # ## however, it would be worth going through jesus2 and seeing what attempts I had made and incorporating those # jesus2 # ## into the original jesus() # jesus2 # ## # jesus2 # # jesus2 # ## SIMILAR TO JESUS, BUT USES write.table() FOR MATRIX-LIKE OBJECTS THAT DO NOT HAVE LIST-LIKE COLUMNS # jesus2 # ## Once confirmed that this works properly, replace `jesus()` # jesus2 # jesus2 <- function(..., dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=sub, # jesus2 # pos=1, sub=TRUE, stampDir=TRUE, stampFile=FALSE, summary=TRUE, envir="", # jesus2 # tablesAsCSV=TRUE, row.names=FALSE, col.names=FALSE) { # jesus2 # ## Like saveit() but can take multiple objects as arguments # jesus2 # ## # jesus2 # ## saves objects passed as (...) arguments to file of type .Rda and with # jesus2 # ## name of file same as name of obj + time stamp # jesus2 # ## in location: dir # jesus2 # ## tablesAsCSV: if TRUE, matrix-like (2-dim objects) will be written to csv # jesus2 # ## subDir: if TRUE, will create subdir data_bak # jesus2 # ## inside dir and use that folder. (if alreaddy exists, will just use) # jesus2 # #S sub: a synonym for subDir. (since use of ... does not allow for partial matches) # jesus2 # ## # jesus2 # ## returns: the path/to/file.Rda where objects were saved # jesus2 # # jesus2 # ## NOTE TO SELF: You cannot use `dots.list` and `list(...)` interchangeably in substitute # jesus2 # ## dots.list <- list(...) # jesus2 # # jesus2 # # jesus2 # # get objects from dots # jesus2 # objNames <- as.list(as.character(substitute(list(...)))[-1L]) # jesus2 # # jesus2 # # check for arguments being (eval(...)) # jesus2 # whichAreEval <- sapply(objNames, function(x) grepl("^eval\\(.+\\)$", x)) # jesus2 # # jesus2 # if (any(whichAreEval)) { # jesus2 # # confirm they are calls # jesus2 # whichAreCalls <- sapply(substitute(list(...))[-1], is.call) # jesus2 # # proceed only if they match # jesus2 # if (identical(whichAreCalls, whichAreEval)) { # jesus2 # objNames2 <- list(...)[whichAreCalls] # jesus2 # objNames <- unlist(c(objNames2, objNames[!whichAreCalls])) # jesus2 # } # jesus2 # } # jesus2 # # jesus2 # ### TODO: June 2013. Apparently the `eval(vector.of.obj.names)` was not working. I wrote the part immediately above this. # jesus2 # ### Confirm all is working correctly. # jesus2 # # -- check this -- # # TODO: double-check pos value. It might be off. # jesus2 # # -- check this -- # # check any value is eval(XX), if so parse it. Collect all values into a single vector. # jesus2 # # -- check this -- # objNames <- unlist( lapply(objNames, function(ob) # jesus2 # # -- check this -- # if(substr(ob, 1, 5)=="eval(") eval(parse(text=substr(ob, 6, nchar(ob)-1)), envir=ifelse(is.environment(envir), envir, parent.frame(pos+1)) ) else ob # jesus2 # # -- check this -- # ) ) # jesus2 # # jesus2 # # jesus2 # # No need to save any object twice # jesus2 # objNames <- unique(objNames) # jesus2 # # jesus2 # #----- ERROR CHECKS ------# # jesus2 # # If any of the assignment operators are found in the list, throw an error # jesus2 # if(detectAssignment(objNames)) # jesus2 # stop("Cannot assign in the call to this function.") # jesus2 # #----- ERROR CHECKS ------# # jesus2 # # jesus2 # # Check that the objects to be saved exist # jesus2 # NotPresent <- !(sapply(objNames, exists)) # jesus2 # if (any(NotPresent)) { # jesus2 # warning("The following objects were not found and hence could not be saved:\n ", paste(objNames[NotPresent], collapse=" "), "\n") # jesus2 # objNames <- objNames[!NotPresent] # jesus2 # } # jesus2 # # jesus2 # # if flag is true, add appropriate subdir # jesus2 # if (isTRUE(subDir)) # jesus2 # dir <- as.path(dir, "data_bak") # jesus2 # else if (is.character(subDir)) # jesus2 # dir <- as.path(dir, subDir) # jesus2 # # jesus2 # # add timeStamp to dir if required # jesus2 # if(stampDir) # jesus2 # dir <- paste0(as.path(dir), "_", timeStamp()) # jesus2 # # jesus2 # # Create dir if needed # jesus2 # dir.create(as.path(dir), recursive=TRUE, showWarnings=FALSE) # jesus2 # # jesus2 # # jesus2 # if (tablesAsCSV) { # jesus2 # # jesus2 # ## Determine which are matrix-like # jesus2 # twoDimmed <- gapply(objNames, is.twodim, pos=pos+1, simplify=TRUE) # jesus2 # # determine which have list columns # jesus2 # hasLists <- gapply(objNames, has.listColumn, pos=pos+1, simplify=TRUE) # jesus2 # # keep only two dimmed that do not have list columns # jesus2 # twoDimmed <- (twoDimmed) & !(hasLists) # jesus2 # # jesus2 # # Track any failures ## CURENTLY NOT IMPLEMENTED # jesus2 # failed <- as.character(c()) # jesus2 # # jesus2 # # isolate just those that will be CSV'd # jesus2 # csv.objNames <- objNames[twoDimmed] # jesus2 # # jesus2 # # create the file paths, cleaning objNames of bad chars # jesus2 # csv.fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, ext=".csv", dir=dir, addTimeStamp=stampFile) # jesus2 # # jesus2 # for (i in seq_along(csv.objNames)) { # jesus2 # obj <- get(csv.objNames[[i]], envir=pos+1) # double check pos # jesus2 # fil <- csv.fileWithPath[[i]] # jesus2 # # jesus2 # ## TODO: add try() and save any failures to `failed` # jesus2 # write.table(obj, file=fil, append=FALSE, quote=TRUE, sep="|", # jesus2 # row.names=row.names, col.names=col.names, qmethod="escape", fileEncoding="UTF-8") # jesus2 # } # jesus2 # # jesus2 # # clear out those saved as CSV # jesus2 # objNames <- objNames[!twoDimmed] # jesus2 # objNames <- c(objNames, failed) # jesus2 # } # jesus2 # # jesus2 # # create the file paths, cleaning objNames of bad chars # jesus2 # rda.fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, ext=".rda", dir=dir, addTimeStamp=stampFile) # jesus2 # # jesus2 # # Save the object # jesus2 # tryCatch(mapply(function(obj, thefile) # jesus2 # # note that with the save+do.call we are going in an extra two environments, hence pos + 2 (also, tested with pos+1, pos+3, both wrong) # jesus2 # do.call(save, args=list(obj, envir=parent.frame(pos+2), file=thefile) ) # pos + 3 will be off if # jesus2 # , objNames, rda.fileWithPath), # jesus2 # error = saveErrorHandle) # jesus2 # # jesus2 # ## This does NOT work. # jesus2 # # filesCreated <- do.call(saveit, args=list(objNames, pos=pos+1, dir=dir, addTimeStamp=stampFile)) # jesus2 # # return(filesCreated ) # jesus2 # # jesus2 # # jesus2 # ret.fileWithPath <- c(csv.fileWithPath, rda.fileWithPath) # jesus2 # # return the path/to/files or just a summary # jesus2 # if (summary) # jesus2 # return(list('quantity'=paste(length(ret.fileWithPath), "files were created in:"), 'dir'=dir)) # jesus2 # return('back.up.files'=ret.fileWithPath) # jesus2 # } # jesus2 # ## -------------------------- ATTEMPT AT jesus2 -------------------- ## # SAVE # # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # # SAVE # # SAVE # ## THESE FUNCTIONS CO-EXIST IN .Rprofile. I AM NOT CLEAR WHERE TO KEEP THEM. # SAVE # # ACTUALLY, I AM PRETTY SURE THEY SHOULD BE KEPT THERE. # SAVE # # MY ONLY CONCERN IS THAT THEY MAKE THE PROFILE CUMBERSOME # SAVE # # # SAVE # # I will try for a while with them being removed from here and existing only in the .RProfile # SAVE # # # SAVE # # SAVE # # Wrappers for quick exit # SAVE # qn <- quitn <- function() { # SAVE # ## quits R without saving work # SAVE # setwd(dir) # SAVE # quit('no') # SAVE # } # SAVE # # SAVE # qy <- quity <- function(dir='~/', verbose=FALSE) { # SAVE # ## quits R and saves the .RData and .Rhistory to dir # SAVE # ## First exectuing time stamp # SAVE # setwd(dir) # SAVE # setSaveTime(verbose=verbose) # SAVE # if (verbose) { # SAVE # cat("\n") # SAVE # Sys.sleep(2.5) # SAVE # cat("\n") # SAVE # } # SAVE # quit("yes") # SAVE # } # SAVE # # SAVE # setSaveTime <- function(envir=.GlobalEnv, SaveObj=".time.image.last.saved", verbose=TRUE) { # SAVE # if (verbose) # SAVE # cat("\nSetting 'Time Last Saved' to:", format(Sys.time(), format="%l:%M %p"), "\n") # SAVE # assign(SaveObj, Sys.time(), envir=envir) # SAVE # } # SAVE # # SAVE # rmSaveTime <- function(envir=.GlobalEnv, SaveObj=".time.image.last.saved") { # SAVE # ## Returns NA if object not found. # SAVE # ## T if object found and removed # SAVE # ## F if object found and unremoved # SAVE # if (!exists(SaveObj, envir=envir)) # SAVE # return(invisible(NA)) # SAVE # ## ELSE # SAVE # rm(list=SaveObj, envir=envir) # SAVE # # SAVE # ## Object should no longer be found # SAVE # if (!exists(SaveObj, envir=envir)) # SAVE # return(invisible(TRUE)) # SAVE # ## ELSE error # SAVE # warning("Unable to remove '", SaveObj, "' from ", capture.output(envir), "\n") # SAVE # return(invisible(FALSE)) # SAVE # } # SAVE # # SAVE # getSaveTime <- function(envir=.GlobalEnv, SaveObj=".time.image.last.saved", verbose=TRUE) { # SAVE # if (!exists(SaveObj, envir=envir)) { # SAVE # warning("No there is no object called '", SaveObj, "' in ", capture.output(envir), "\n ", # SAVE # "Possible cause for this is that `setSaveTime()` was not called prior to save.\n") # SAVE # return(NULL) # SAVE # } # SAVE # ## ELSE # SAVE # datetime <- get(SaveObj, envir=envir) # SAVE # time <- format(datetime, format="%l:%M %p") # SAVE # date <- as.Date(datetime) # SAVE # # SAVE # ## Formatting # SAVE # if (verbose) { # SAVE # today <- Sys.Date() # SAVE # date.msg <- ifelse (date == today, "Today", ifelse(date==(today-1), "Yesterday", as.character(date))) # SAVE # cat("This image was last saved ON OR AFTER:", date.msg, "at" ,time, "\n") # SAVE # } # SAVE # return(invisible(datetime)) # SAVE # } # SAVE # # SAVE # save.image <- function(..., verbose=TRUE) { # SAVE # setSaveTime() # SAVE # if (verbose) # SAVE # cat("Saving with time stamp of ", as.character(getSaveTime(verbose=FALSE)), "\n") # SAVE # base::save.image(...) # SAVE # rmSaveTime() # SAVE # } # SAVE # # SAVE # load <- function(..., envir=.GlobalEnv, SaveObj=".time.image.last.saved", load.envir=parent.frame()) { # SAVE # # SAVE # cat("In Overwritten Load\n") # SAVE # # SAVE # ## Check if previously existed, if so bank that value. If not, set to arb value, such as FALSE # SAVE # .saved.Time.Before.Loading <- { # SAVE # if (!exists(SaveObj, envir=envir)) FALSE # SAVE # else # SAVE # get("SaveObj", envir=envir) # SAVE # } # SAVE # # SAVE # ret <- base::load(..., envir=load.envir) # SAVE # # SAVE # ## Check if exists now # SAVE # if (exists(SaveObj, envir=envir) && !identical(.saved.Time.Before.Loading, get(SaveObj, envir=envir))) { # SAVE # getSaveTime() # SAVE # } # SAVE # return(invisible(ret)) # SAVE # } # SAVE # # SAVE # # SAVE # # SAVE #