# --------------------------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : workspace.R # # Last Updated Funclist : 19 Feb 2015, 12:52 PM (Thursday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : base, stringr # # # # ------------------------------------------------------------------------------------------------------------------------------------------------- # # # # zArchiveExceptLatest ( file, folder=as.path(dirname(file), subfolder), subfolder="zArchive" ) # # ssh_exists ( f, ssh_host ) # # ssh_ls ( f, ssh_host ) # # ssh_cmd ( command, ssh_host, verbose=FALSE ) # # ssh_lastAccess ( pathToFile, ssh_host, verbose=FALSE ) # # isdir ( x ) # # create_dir.p_functions ( grp=getOption("dos.grp", default=list("data", "out", "src", "ingest", "ImageSaves", "notes")), envir=globalenv() ) # # s.p ( ..., expand=FALSE, proj=NULL ) # # workspace.p ( original, ..., expand=FALSE, proj=NULL, setnames=FALSE ) # # source.p ( ... ) # # RESET ( save=FALSE, utils=FALSE, dt=TRUE, width=c(NA, 262, 314), notify.startup=FALSE # # , defaultpackages.clearall=FALSE, envir=globalenv(), verbose.fresh=TRUE ) # # fresh ( save=FALSE, utils=TRUE, dt=TRUE, profile.load=TRUE, first=TRUE, all=NULL # # , preserve=c(), clean_only.dont_restore=FALSE, env=parent.frame() # # , options.clearall=TRUE, verbose=TRUE, namespaces.clearall=FALSE # # , defaultpackages.clearall=FALSE, working.dir="~", profile.file=NULL # # , clearD, notify.startup=NULL, verbose.debug=FALSE ) # # cat.debug ( ... ) # # zArchive ( file, folder=as.path(dirname(file), subfolder), subfolder="zArchive" # # , createIfNotExists.folder=TRUE, overwrite=FALSE, verbose=TRUE ) # # inDebugMode ( ... ) # # srcOther ( new.src, old.src=getProjName(), path=srcDir ) # # saveImageTo ( projName, subProj=getSubProj(pos=pos + 1), appendImgSave=TRUE, stamp=TRUE # # , fresh=FALSE, extension="Rda" # # , dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves") # # , .Pfm=Sys.info()[["sysname"]], pos=1, verbose=TRUE ) # # loadImageOf ( projName, appendImgSave=TRUE, stamp=TRUE # # , dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves") # # , subProj=getSubProj(pos=pos + 1), alldirs=FALSE, .Pfm=Sys.info()[["sysname"]] # # , listdirs=FALSE, pos=1, envir=globalenv(), preserveCurrentWrkDir=FALSE # # , verbose=TRUE, emailWhenDone=FALSE, dont.change.prompt=FALSE, file ) # # imagesInDir ( dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves"), NBS=FALSE # # , alldirs=FALSE, .Pfm=Sys.info()[["sysname"]], hyphen="_-", nbs=NBS ) # # cleanImageFiles ( projName, appendImgSave=TRUE, stamp=TRUE, subProj=NULL # # , dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves") # # , .Pfm=Sys.info()[["sysname"]], verbose=TRUE, doNotPrompt=FALSE, pos=1 ) # # LoadFromBackUp ( objToLoad, BackUpDir, CheckSubs=TRUE, DateFormat="%Y%m%d_%H%M", utilsReload=TRUE # # , returnTimeStamps=FALSE, pos=1, verbose=TRUE, hyphen="[-_]", imgload=FALSE # # , showPath=imgload, dir=NULL, subProj="", envir=globalenv() ) # # checkAndLoad ( objToLoad, BackUpFrom, pos=1, force=FALSE, verbose=FALSE, envir=globalenv() ) # # file.exists.ssh ( f, ssh_host=getOption("default.ssh_host"), verbose=FALSE, user="rsaporta" ) # # findBackUps ( objName="", dir="", allDirs=TRUE, ext=c("Rda", "Rdata"), noImg=TRUE # # , hyphens=c("-", "_") ) # # extractTimeStamp ( x, hyphens=c("-", "_"), alphaHyphen=FALSE ) # # getScreen ( prefix="", suffix="" ) # # get_defaultOptionsToNotClear ( showWarnings=TRUE ) # # rm_OptionsToNotClear ( optionsToRemove, showWarnings=TRUE ) # # set_OptionsToNotClear ( optionsToNotClear=c() ) # # get_OptionsToNotClear ( optionsToNotClear=c() ) # # clearAllOptions ( preserve.option=c() ) # # shipme ( ... ) # # shipit ( file.to.ship, ... ) # # bringmeFolder ( file.to.bring, ... ) # # bringme ( file.to.bring, ssh_host=getOption("default.ssh_host"), user.remote="rsaporta" # # , verbose=TRUE, useOld=FALSE, ship.it=FALSE, recursive.folder=FALSE ) # # bringMeData ( folder=NULL, files="*", ext=NULL, local=dataDir, open.folder=FALSE, verbose=FALSE # # , showWarnings=verbose, ssh_host="ubuntu@107.20.192.2", checkExist=TRUE # # , dontExecute=FALSE ) # # checkForFiles ( files, ssh_host, showAlts=TRUE ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------------------------- # # --------------------------------------------------------------------------------------------------------------------------------------------------- # # "/data01/r_data/Ricks/data/Concerts" # if ssh $ssh_host test -e $file; then echo $file exists; else echo $file does not exist; fi if (is.null(getOption("ImageSavesDir"))) options("ImageSavesDir" = "~/gitData/ImageSaves") # options("default.ssh_host" = "root@107.20.201.0") ## Rbox2 # options("default.ssh_host" = "root@10.100.2.194") ## Rbox3 # options("default.ssh_host" = "rsaporta@10.100.23.106") ## Rbox4 aka $AWS options("default.ssh_host" = "rsaporta@10.100.12.96") ## Rbox4 aka $AWS # ~~~~~~~~~~~~~~~~~~~~~~ # zArchiveExceptLatest <- function(file, folder=as.path(dirname(file), subfolder), subfolder="zArchive") { if (length(file) > 1) stop ("file must have length 1.\nHINT: use lapply(file, zArchiveExceptLatest") force(subfolder) force(folder) files <- filesByTimeStamp(file) ## If no files, return named character() if (!length(files)) return(invisible(setNames(nm=character(0L)))) return(invisible(zArchive(files, folder=folder, subfolder=subfolder))) } zArchive_if_flagged <- function(flag, file.out, nm_flag=substitute(flag), use_hint=TRUE) { ## This is a wrapper to the six lines of code that are commonly repeated ## Checks if file exists: ## if not, do nothing; ## if yes, check if flagged to zArchive ## if yes, then zArchive and move on ## if not, then fail ## ## Note that without the 'flag' argument (or if we default the flag argument to TRUE) then this function is identical to zArchive() ## check for swapped args if (is.logical(file.out) && is.character(flag)) { tmp <- file.out file.out <- flag flag <- tmp message("pssst... you have your arguments to zArchive_if_flagged(flag, file.out) swapped\n'flag' comes first to enforce that it not be forgotten") } if (missing(flag)) stop ("The 'flag' argument must be included in zArchive_if_flagged();\nif not flag is needed, then just use zArchive() directly", call.=FALSE) errmsg <- sprintf("file '%s' already exist", file.out) if (use_hint) errmsg %<>% paste0("\n\nHINT: use ", nm_flag, "=TRUE") ## Check if file exists, if so zArchive it if (file.exists(file.out)) { if (flag) zArchive(file.out, addTimeStamp=TRUE) else stop (errmsg) } } zArchive <- function(file, folder=as.path(dirname(file), subfolder), subfolder="zArchive", createIfNotExists.folder=TRUE, addTimeStamp=FALSE, overwrite=FALSE, verbose=TRUE) { if (!all(file.exists(file))) stop (plrl("files", file), pasteQ(file, w=""), " sent to zArchive() ", plrl("do", file)," not exist") force(subfolder) force(folder) newFile <- as.path(folder, basename(file)) ## insert time stamp at end of file, before ext if file has ext if (addTimeStamp) { ext <- gsub(".*(\\..+)$", "\\1", newFile) repl <- "+zarchived" %>% timeStamp(seconds=TRUE) %>% paste0(ext) pat.ext <- ext %>% escapeRegEx %>% paste0("$") newFile <- gsub(pat.ext, repl, newFile) } if (any(file.exists(newFile)) && !overwrite) stop("Cannot zArchive the file since the folder already contains a file with the same name. ie, file \n \"", file, "\"\nHINT: set overwrite=TRUE") if (any(!file.exists(folder))) { if (createIfNotExists.folder) for (ff in unique(folder[!file.exists(folder)])) { verboseMsg(verbose, "Creating folder '", ff, "'", simple=TRUE, endl=TRUE) dir.create(ff, recursive=TRUE, showWarnings=FALSE) } else warning("Folder '", folder, "' does not exist.\nHINT: set createIfNotExists.folder=TRUE") } file.rename(file, newFile) return(setNames(nm=file, obj=newFile)) } file.exists.ssh <- function(f, ssh_host=getOption("default.ssh_host"), verbose=FALSE, user="rsaporta") { stop(" ## NONE OF THESE COMMANDS WORK") # if (!is.null(user)) # f <- gsub("~", paste0("~", user), f) # # ssh user@server 'bash -c "if [ -e /path/to/remote/file ] ; then true ; fi"' # command <- sprintf("ssh %s 'bash -c \"if [ -e %s ] ; then true ; fi\"'", ssh_host, f) # # command <- sprintf( # 'if ssh %s "[ -f %s ]" # then # echo "file exists" # else # echo "no file (or ssh failure)" # fi', ssh_host, f) # # if (verbose) # cat("executing shell command:\n ", command, "\n") # ret <- system(commaand, TRUE) } downloadWeTransfer <- function(url, basename, folder=ingestDir, ext=NULL, verbose=TRUE) { is.char_of_length1(url, fail=TRUE) prefix <- "https://www.wetransfer.com/downloads/" params <- removeText(prefix, url) %>% strsplit("/") %>% unlist if (length(params) == 2) params %<>% {c(.[[1]], "", .[[2]])} if (length(params) != 3) stop ("Not correct number of paramters in the original URL") params %<>% setNames(nm=c("file_id", "recipient_id", "security_hash")) %>% as.list ## This URI gives a directlink uri.intermediate <- with(params, sprintf("https://www.wetransfer.com/api/v1/transfers/%s/download?recipient_id=%s&security_hash=%s&password=&ie=false", file_id, recipient_id, security_hash) ) directlink.json <- RCurl::getURI(uri.intermediate) directlink.list <- jsonlite::fromJSON(directlink.json) if ("direct_link" %in% names(directlink.list)) { ## extract the link for the actual file uri.download <- directlink.list[["direct_link"]] ## extract basename from file is missing if (missing(basename) || is.null(basename)) { basename <- gsub("(.*)(filename.+?%22)(.+?)(%22.*)", "\\3", uri.download) } f.out <- downloadWithWGET(uri.download, basename=basename, ext=ext, folder=folder, intern=TRUE) } else { # stop ("Was unable to parse the directlink.json as expected -- no field named 'direct_link'\nHere is the original JSON:\n \n",directlink.json, "\n ") stop ("Havent figured out how to POST() this yet. Here it is in python else: file_name = download_data['fields']['filename'] r = requests.post(download_data['formdata']['action'], data=download_data[\"fields\"], stream=True) ") f.out <- httr::POST(url=directlink.list$formdata$action, body=directlink.list$fields) } if (!file.exists(f.out)) { stop ("internal error. File '%s' (the intended destination file) is not found") } else { verboseMsg(verbose, sprintf("Downloaded:\t%s \t(%s)", f.out, formatBytes(fileSize(f.out))), minw=88) } return(f.out) } downloadWithWGET <- function(url, basename, folder=out.p(), full.filename=as.path(folder, basename, ext=ext), ext=NULL, intern=FALSE) { if (missing(full.filename) && (missing(basename) || is.null(basename))) stop ("please either specify the 'basename' or 'full.filename'") if (!grepl("\\.", basename(full.filename))) warning ("the destination file has no extension. Should it be ZIP, CSV, etc?") force(full.filename) # ## NOTE TO SELF: python script almost works. Cannot tell it where to place file. Saves it to getwd() # if (grepl("www.wetransfer.com/downloads", url)) # fmt <- "python /usr/local/lib/python_scripts/py-wetransfer/wetransfer.py -u '%s' '%s'" # else # fmt <- "wget --user-agent Mozilla/4.0 '%s' -O %s" fmt <- "wget --user-agent Mozilla/4.0 '%s' -O %s" cmd <- sprintf(fmt, url, full.filename) ret <- system(cmd, intern=intern) if ((!intern && ret == 8) || (intern && identical(8, attr(ret, "status")))) warning ("the cmd had status 8, which might be 403 Forbidden") return(full.filename) } syncIngestDir <- function(subFolder="/", proj=NULL, recursive.folder=TRUE, preserve_times=TRUE, size_only=TRUE, archive=TRUE, rsync=TRUE, ssh_host=getOption("default.ssh_host")) { file.to.ship <- ingest.p(subFolder, proj=proj) if (isdir(file.to.ship)) file.to.ship %<>% paste0("/") shipit(file.to.ship, ignore_existing=TRUE, preserve_times=preserve_times, size_only=size_only, archive=archive, recursive.folder=recursive.folder, rsync=rsync) } # shipme <- function(...) { # stop ("you meant to use the function shipit()") # } shipit <- function(file.to.ship, recursive.folder=TRUE, ...) { if (!file.exists(file.to.ship)) stop("Local file '", file.to.ship, "' cannot be found") bringme(file.to.bring=file.to.ship, ship.it=TRUE, recursive.folder=recursive.folder, ...) } bringmeFolder <- function(file.to.bring, recursive.folder=TRUE, rsync=TRUE, ...) { ## note: there is some sloppiness here, since if the desitnation folder exists locally ## the current settings might create a subfolder inside of it warning("bringmeFolder might be outdated -- bringme() might be just fine now") ## call gitpull since likely that the backup file list changed too .g() if (!grepl("/\\.?$", file.to.bring)) file.to.bring <- paste0(file.to.bring, "/.") bringme(file.to.bring=file.to.bring, ..., rsync=rsync, recursive.folder=recursive.folder) } make_rsync_cmd <- function(base_cmd, ignore_existing=TRUE, preserve_times=TRUE, size_only=FALSE, archive=TRUE, recursive=FALSE) { ## http://linux.about.com/library/cmd/blcmdl1_rsync.htm # -a, --archive # This is equivalent to -rlptgoD. It is a quick way of saying you want recursion and want to preserve almost everything. # Note however that -a does not preserve hardlinks, because finding multiply-linked files is expensive. You must separately specify -H. # -r, --recursive # This tells rsync to copy directories recursively. If you don't specify this then rsync won't copy directories at all. paste("rsync --rsh='ssh' -vz --progress --partial" , if (ignore_existing) "--ignore-existing" , if (preserve_times) "--times" , if (size_only) "--size-only" , if (archive) "--archive" , if (recursive) "--recursive" ) } bringme <- function(file.to.bring, ssh_host=getOption("default.ssh_host"), user.remote="rsaporta", verbose=TRUE, useOld=FALSE, ship.it=FALSE, recursive.folder=FALSE , rsync=TRUE ## rsync flags , overwrite=FALSE , ignore_existing=!overwrite , preserve_times=TRUE , size_only=FALSE , archive=TRUE ## JUST FOR downloadWeTransfer , basename=NULL , folder=ingest.p() , ext=NULL ) { ## Note to self: I am using user.remote at points where I should be using user.local ## ## rsyn cmd is ## rsync --rsh='ssh' -avz --progress --partial if (!missing(ignore_existing) && !missing(overwrite)) warning("'overwrite' is simply a synonym for !ignore_existing -- It will be not be used when 'ignore_existing' is explicict") if (!is.character(file.to.bring)) stop ("file.to.bring must be a quoted string") file.to.bring %<>% trim if (grepl("www.wetransfer.com/downloads", file.to.bring)) { f.out <- downloadWeTransfer(file.to.bring, basename=basename, folder=folder, ext=ext) if (grepl("\\.zip$", f.out, ignore.case=TRUE)) { folder.out <- f.out %>% removeText("\\.zip$", .) %>% paste0("/") dir.create(folder.out, showWarnings=FALSE) f.out %>% {file.rename(from=., to=as.path(folder.out, basename(.)))} f.out %<>% {as.path(folder.out, basename(.))} if (!file.exists(f.out)) stop ("internal error - tried to move the zip file, then lost it. expected location: \n\t", f.out) system(sprintf("unzip %s", f.out)) unzip(f.out, exdir=folder.out) ## print output print(sapply(dir(folder.out, full=TRUE), fileSize)) return(folder.out) } return(f.out) } if (missing(file.to.bring)) file.to.bring <- clipPaste() %>% gsub("(\\[\\s*\\d+\\]|\")", "", .) file.to.bring <- trim(file.to.bring) if (grepl("data_bak(_\\d{8}_\\d{4,6})?$", basename(file.to.bring))) { message("calling bringmeFolder()") return (bringmeFolder(file.to.bring=file.to.bring)) } if (tolower(file.to.bring) == "image") { file <- system(sprintf("ssh %s 'su rsaporta -c \"ls --time=ctime '%s' | head -n 1\";'", ssh_host, ImageSavesDir), intern=TRUE) cat("using image file '", file, "'", "\n", sep="") file.to.bring <- ImageSaves.p(file) } if (useOld) ssh_host <- "ubuntu@107.20.192.2" browser(expr=inDebugMode(c("bringme", "shipit", "file")), text="in bringme() at top") ## If there is more than one file, iterate over each if (length(file.to.bring) > 1) { files.brought <- list() for (ftb in file.to.bring) { files.brought[[length(files.brought) + 1]] <- try(bringme(ftb, ssh_host=ssh_host, verbose=verbose, ship.it=ship.it)) } return(invisible(files.brought)) } ## Error check (After iteration) if (!is.character(file.to.bring)) { stop("invalid input. file.to.bring must be a string or a list of stirngs") } ## This is for personal use: I have my git & gitData files synce from there forward, but not from before then. ## Needed for when copying the entire remote dir if (grepl("git", file.to.bring)) localfile <- gsub(".*(/git.*)", sprintf("~%s\\1", user.remote), file.to.bring) else localfile <- path.unexpand(file.to.bring, user=user.remote) # if (grepl(" ", localfile)) # warning ("A space was detected in the file name. This may not work.") if (grepl("^~/", file.to.bring)) file.to.bring <- gsub("^~/", "~rsaporta/", file.to.bring) ## clean up strings, for spaces etc names(localfile) <- localfile ## used in dir.create # localfile <- shellClean(localfile) # file.to.bring <- shellClean(file.to.bring) rsync_cmd <- make_rsync_cmd(ignore_existing=ignore_existing, preserve_times=preserve_times, size_only=size_only, recursive=recursive.folder, archive=archive) cp_cmd <- if (isTRUE(rsync)) rsync_cmd else "scp" ## If we are shipping a file, then swap localfile/file.to.bring ## and create the directory remotely. Otherwise, create dir locally if (ship.it) { is_shipping_folder <- isdir(file.to.bring) ## 'Swamp' and Add the user home dir back in, otherwise, it will be root file.to.ship <- file.to.bring remotefile <- localfile ## When shipping a whole folder, it MUST end in "/" if (is_shipping_folder && !grepl("/$", file.to.ship)) file.to.ship %<>% paste0("/") ## remotedir will be created on the remote server (if not exists) ## if we are shpping a whole folder, remotedir is that same folder (on remote server) ## otherwise, it is the dirname. However, we cannot use dirname() because it expands path, so we use gsub remotedir <- ifelse(is_shipping_folder, remotefile, gsub("(/.+)+(/.+$)", "\\1", remotefile)) ## 2015-09-20: I believe that creating the dir is NOT needed with rsync cmd, only with SCP ## remotedir will fail if only one bracket, like "/test.r" if (remotefile == remotedir && !is_shipping_folder) remotedir <- sapply(strsplit(remotefile, "/"), function(x) pasteC(head(x, -1), C="/")) mkdir_command <- sprintf("ssh %s 'su rsaporta -c \"mkdir -p %s\";'", ssh_host, remotedir) # scp_command <- sprintf("scp %s%s \"%s\":\"%s\";\n\tssh %3$s 'chown %s %4$s'", ifelse(recursive.folder, "-r ", ""), file.to.ship, ssh_host, remotefile, user.remote) scp_command <- sprintf("%s %s%s \"%s\":\"%s\";\n\tssh %4$s 'chown %s %5$s'", cp_cmd, ifelse(recursive.folder, "-r ", ""), shellClean(file.to.ship), ssh_host, shellClean(remotefile), user.remote) command <- paste(mkdir_command, scp_command, sep=";\n\t") } else { ## CHECK IF REMOTE FILE EXISTS if (!ssh_exists(file.to.bring, ssh_host=ssh_host)) stop ("Remote file '", file.to.bring, "' does not exist on host") ## Check if folder is_bringing_folder <- ssh_is_dir(file.to.bring, ssh_host=ssh_host) ## if bringing a whole folder but does not end in "/", add it if (is_bringing_folder && !grepl("/$", file.to.bring)) file.to.bring %<>% paste0("/") ## Create the local directory if not exist dir.create(dirname(names(localfile)), showWarnings=FALSE, recursive=TRUE) command <- paste0(cp_cmd, " ", ifelse(recursive.folder, "-r ", ""), ssh_host, ":\"", shellClean(file.to.bring), "\" ", shellClean(localfile)) } if (verbose) { msg <- "executing shell command:" hr <- pasteR(n=msg) # cat(paste("\n ", c(msg, hr, chopLine(paste0(" ", command), width=75L, flex=45L, showWarnings=FALSE, maxNumberOfBreaks=100L, padToSecond=TRUE, collapse=NULL))) cat("\n\t", msg, "\n\t", hr, "\n\t", command, "\n\n", sep="") } ## Execute the scp command system(command) return(if (ship.it) remotefile else localfile) } bringMeData <- function(folder=NULL, files="*", ext=NULL , local=dataDir , open.folder=FALSE, verbose=FALSE, showWarnings=verbose , ssh_host=getOption("default.ssh_host") , checkExist=TRUE, dontExecute=FALSE , rsync=TRUE ## rsync flags , ignore_existing=TRUE , preserve_times=TRUE , archive=TRUE ) { ## Personal wrapper function that executes an SCP command from R box on EC2 to a local dir warning("This function, `bringMeData`, is a little sloppy and could use work.\nTry `bringme(full/remotepath/file)` instead", call.=FALSE) ## allow for `brindMeData( __ , o)` if (identical("o", as.character(substitute(files)))) { files <- "*" open.folder <- TRUE } # I believe the correct way in linux to get all files in a directory is "." if (length(files)==1 && files=="*") files = "." remoteFiles <- as.path("/", folder, files, ext=ext) if (checkExist) { if (verbose) cat("\nChecking if", plrl(c("files", "exist"), remoteFiles), "on server... ") ## Search for files found <- checkForFiles(files=remoteFiles, ssh_host=ssh_host, showAlts=verbose) ## Keep only found files remoteFiles <- remoteFiles[found] ## Output information if (verbose) cat(if(all(found)) ifelse(length(remoteFiles)>1, " ALL FOUND.", " FILE FOUND"), "\n") } if (!length(remoteFiles)) { if (showWarnings) warning("No files copied.") return(invisible(NULL)) } # ELSE ## show time stamp for single file if (verbose && length(remoteFiles) == 1) { lastAcc <- ssh_lastAccess(remoteFiles, ssh_host, verbose=FALSE) diffs <- round( lastAcc[["CurrentTime"]] - lastAcc[["LastAccessed"]], 2) cat("File was last accessed on ", cleanPosix(lastAcc[["LastAccessed"]]) , "\t (", diffs, " ", attr(diffs, "units") ," ago)\n", sep="") } rsync_cmd <- make_rsync_cmd(ignore_existing=ignore_existing, preserve_times=preserve_times, recursive=recursive.folder, archive=archive) cp_cmd <- if (isTRUE(rsync)) rsync_cmd else "scp" command <- paste0(cp_cmd, ssh_host, ":", remoteFiles, " ", local) if (verbose) { msg <- "executing shell command:" hr <- pasteR(n=msg) cat(paste("\n ", c(msg, hr, chopLine(paste0(" ", command), width=60L, flex=40L, showWarnings=FALSE, maxNumberOfBreaks=100L, padToSecond=TRUE, collapse=NULL))) , "\n\n", sep="") } ## create if not exists ## # ---------------------- # # grab a list of folders to create local.folders <- unique(ifelse(isdir(local), local, dirname(local))) # creat them recursively sapply(local.folders, dir.create, showWarnings=FALSE, recursive=TRUE) # ---------------------- # if (open.folder) { # If the location is a folder, open it. Otherwise, open its dirname try(.o(local.folders, ignore.missing=TRUE )) } if (dontExecute) { return(invisible(command)) } ## Execute the scp command system(command) if (verbose) { msg <- "files copied to:" hr <- pasteR(n=msg) cat(paste("\n ", c(msg, hr, chopLine(paste0(" ", local), width=60L, flex=40L, showWarnings=FALSE, maxNumberOfBreaks=100L, padToSecond=TRUE, collapse=NULL))) , "\n\n", sep="") } return(invisible(command)) } checkForFiles <- function(files, ssh_host, showAlts=TRUE) { if (anyDuplicated(files)) stop ("\nDuplicate values detected in argument `files`.", "\nOffending values are\n\t", paste(files[duplicated(files)], collapse="\n\t")) # set the names as the files themselves, for easier handling files <- setNames(nm=files) ## Cannot run `sshExists` on files of the form "*.ext") whichExists <- sapply(files, ssh_exists, ssh_host=ssh_host) if (all(whichExists)) return(whichExists) if (!length(which(whichExists))) files.unsure <- files else files.unsure <- files[-which(whichExists)] dirs <- dirname(files.unsure) ## The bottle neck is the calls over ssh. Thus ## instead of simply doing `sapply(dirs, ssh_ls)` ## we check for duplicate dirs, and use only the unique ones # run `ls` commads in each directory fileListings <- lapply(setNames(nm=unique(dirs)), ssh_ls, ssh_host=ssh_host) # get the base names of each file, we will check it against the ls listings baseFiles <- setNames(obj=basename(files.unsure), nm=files.unsure) # check the files against the listings files.present <- mapply(fileInListing, baseFiles, fileListings[dirs], SIMPLIFY=FALSE) files.present.vector <- unlist(files.present) whichExists[nwhich(files.present.vector)] <- TRUE whichExists[nwhich(!files.present.vector)] <- FALSE if (any(is.na(whichExists))) { stop ("\n\nINTERNAL ERROR: There should not be any NA values in vector 'whichExists' -- here is the dput(whichExists) : \n\n", cordl(dput(whichExists), collapse=" "), "\n\n") } if (showAlts && !all(whichExists)) { cat("\n", sum(!whichExists), plrl("files", which(!whichExists)), "not found. Possible alternates in the same directory listed below.\n") for (fp in nwhich(!whichExists)) { cat("\n ", fp, "\n") alts <- attr(files.present[[fp]], "alternate") cat( paste(" .... ", paste_l(removeNA(alts), none=" < none found >") ), sep="\n") } } return(whichExists) } # // end checkForFiles # ssh_exists("~rsaporta/git/orch/ingest/VidServData/test/file_in_subf1.txt", ssh_host=ssh_host); # ssh_exists("~rsaporta/git/orch/ingest/VidServData/test/file_in_subf1.txt", is_dir=TRUE, ssh_host=ssh_host); # ssh_ls("~rsaporta/git/orch/ingest/VidServData/test/file_in_subf1.txt", ssh_host=ssh_host) ssh_is_dir <- function(file_or_folder, ssh_host) { return(ssh_exists(file=file_or_folder, is_dir=TRUE, ssh_host=ssh_host)) } ssh_exists <- function(file, is_dir=FALSE, ssh_host) { file %<>% shellClean() flags <- ifelse(is_dir, 'd', 'e') cmd <- sprintf( "if [ -%s %s ] then echo \"TRUE\" else echo \"FALSE\" fi" , flags %>% pasteC , file ) as.logical(ssh_cmd(cmd, ssh_host=ssh_host)) } ## OLD: ssh_exists <- function(f, ssh_host) { ## OLD: if (grepl("\\*", f)) ## OLD: return(NA) ## OLD: as.logical( ## OLD: system(command=paste0("if ssh ", ssh_host, " test -e ", f, ";", ## OLD: "then echo TRUE; else echo FALSE; fi") ## OLD: , intern=TRUE) ## OLD: ) ## OLD: } ssh_ls <- function(f, ssh_host) { command <- paste0("ls ", f) ssh_cmd(command, ssh_host) } ssh_cmd <- function(command, ssh_host, verbose=FALSE) { fullCommand <- paste0("ssh ", ssh_host, " \"", command, "\"") if (verbose) cat("Executing: \n\n\t", fullCommand, "\n\n") system( command=fullCommand, intern=TRUE) } ssh_lastAccess <- function(pathToFile, ssh_host, verbose=FALSE) { CMD=paste0("paste -d'|'") AT= paste0("<(stat -c '%y' '", pathToFile ,"')") DT= paste0("<(date +'%F %T')") command <- paste(CMD, AT, DT) res <- ssh_cmd(command, ssh_host, verbose=verbose) splat <- as.POSIXct(strsplit(res, "\\|")[[1]], tz="UTC") names(splat) <- c("LastAccessed", "CurrentTime") splat[["diffTime"]] <- splat[["CurrentTime"]] - splat[["LastAccessed"]] return(splat) } is.dir <- function(f, showWarnings=TRUE) { warning ("is.dir(f) has been deprecated. Please use isdir(f) instead") return(isdir(f=f, showWarnings=showWarnings)) # if (length(f) > 1) # return(sapply(f, is.dir, showWarnings=showWarnings)) # if (!file.exists(f)) { # verboseMsg(showWarnings, "file or path \"", f, "\" does not exist", time=FALSE) # return(FALSE) # } # file.info(f)$isdir } isdir <- function(f=x, showWarnings=FALSE, x="DEPRECATED") { if (missing(f) && missing(x) && f == "DEPRECATED") stop ("Please provide a valid 'f'") if (!is.character(f)) stop ("f must be a string. It is a ", class(f), ".") if (!length(f)) { verboseMsg(showWarnings, "The x send to `isdir()` had no length. Returning logical(0L)", call.=FALSE) return(logical(0L)) } # if (length(f) > 1) # return(sapply(f, isdir)) ret <- file.info(f)[, "isdir"] ## note that if f is not found, file.info will be all NA's. nas <- is.na(ret) if (any(nas)) { verboseMsg(showWarnings, pasteQand(f[nas], w=""), " does not exist. When f is not found, isdir(f) will return either TRUE or FALSE based on whether f ends in '/' (TRUE) or not (FALSE)", call.=TRUE) ret[nas] <- grepl("/$", f) } return(ret) } # ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # fresh ( save=TRUE, utils=TRUE, dt=TRUE, env=parent.frame(), all=NULL ) # # getProjName ( appendImgSave=FALSE, fresh=FALSE, pos=1 ) # # saveImageTo ( projName, appendImgSave=TRUE, stamp=TRUE, fresh=FALSE, extension="Rda", dir="~/gitData/ImageSaves", .Pfm=Sys.info()[['sysname']], pos=1 ) # # loadImageOf ( projName, appendImgSave=TRUE, stamp=TRUE, dir="~/gitData/ImageSaves", alldirs=FALSE, .Pfm=Sys.info()[['sysname']], nbs=FALSE, listdirs=FALSE, pos=1, verbose=TRUE ) # # imagesInDir ( dir="~/gitData/ImageSaves", NBS=FALSE, alldirs=FALSE, .Pfm=Sys.info()[['sysname']], hyphen="_-", nbs=NBS ) # # cleanImageFiles ( projName, appendImgSave=TRUE, stamp=TRUE, dir="~/gitData/ImageSaves", .Pfm=Sys.info()[['sysname']], verbose=TRUE, doNotPrompt=FALSE, pos=1 ) # # LoadFromBackUp ( objToLoad, BackUpDir="/data01/r_data/Ricks/data/", CheckSubs=TRUE, DateFormat="%Y%m%d_%H%M", returnTimeStamps=FALSE, pos=1, verbose=TRUE, hyphen="[-_]", imgload=FALSE, showPath=imgload ) # # checkAndLoad ( objToLoad, BackUpFrom, pos=1, force=FALSE ) # # LoadFromNBSData ( objToLoad, pos=1, .Pfm=Sys.info()[['sysname']], force=FALSE ) # # NBSUtils ( ) # # findBackUps ( objName="", dir="", allDirs=TRUE, ext=c("Rda", "Rdata"), noImg=TRUE, hyphens=c("-", "_") ) # # extractTimeStamp ( x, hyphens=c("-", "_"), alphaHyphen=FALSE ) # # # # ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # =================================================================== # dataDir.base <- "~/gitData" outDir.base <- "~/gitOut" srcDir.base <- "~/git" # =================================================================== # #----------------------------------- # WORKSPACE FUNCTIONS #----------------------------------- ## WRAPPER Functions to avoid as.path(outDir, ...) ## CREATE THEM ALL AUTOMATICALLY .create_dir.p_functions <- function(grp=getOption("dos.grp", default=list("data", "out", "src", "sublws", "ingest", "ImageSaves", "notes", "plots", "log")), envir=globalenv()) { ## eg: ## data.p <- function(..., proj=NULL) ## .workspace.p(original="dataDir", ..., proj=proj) ## Create comment indicating function was created programatically thisfuncs.name <- as.character(as.list(match.call())[[1]]) # using this in case function name changes comment <- sprintf("## This function was generated programatically using %s()", thisfuncs.name) ## Create each function ## NOTE TO SELF: I do not like how I created this. If re-writing use formals(.workspace.p) Funcs <- sprintf("%s.p <- function(..., expand=FALSE, proj=NULL) {\n%s\n\n .workspace.p(original='%1$sDir', ..., expand=expand, proj=proj)\n}", grp, comment) for (F in Funcs) eval(parse(text=F), envir=envir) } ## EXECUTE THIS ONE FUNCTION .create_dir.p_functions() .workspace.p <- function(original, ..., expand=FALSE, proj=NULL, setnames=FALSE) { ## this is the function that is called by src.p(), out.p(), plot.p(), data.p() etc ## this function should not be called directly ## if (!exists(original)) stop (original, " does not exist.\nDid you run setScience() or setProject()", call.=FALSE) browser(expr=inDebugMode("src.p", 'srcDir'), text="in one of the functions created off of .workspace.p()") ddir <- get(original) if (!is.null(proj)) ddir <- srcOther(new.src=proj, path=ddir) if (any(sapply(list(...), is.logical))) warning ("a logical value has been detected in the *.p function.\nWas this intended to be a flag?\nHINT: check the spelling of the flags", call.=FALSE) ret <- as.path(ddir, ..., expand=expand) if (isTRUE(setnames)) { setattr(ret, "names", gsub(paste0(escapeRegEx(as.path(ddir, expand=expand)), "/?"), "", ret)) } return(ret) } source.p <- function(...) { source(src.p(...)) } .RESET <- function(save=FALSE, utils=FALSE, dt=TRUE, width=c(NA, 262, 314), gitBranchToSystem=TRUE, notify.startup=FALSE, defaultpackages.clearall=FALSE, envir=globalenv(), verbose.fresh=TRUE) { ## A wrapper for sourcing utils and fresh force(envir); force(save); force(utils); force(dt); force(width); if (exists("inDebugMode")) browser(expr=inDebugMode(c("reset", "fresh")), text="at the top of .RESET()") ## if utilSource is not loaded, try sourcing the file - or where it should be if (!exists("utilSource")) try(source("~/git/misc/rscripts/utilsRS.r")) ## copy utilSource to this environment so that it does not utilSource <- get("utilSource") ## the multiple values in 'width' are simply as a reminder to myself for which values work well for my monitors width <- width[[1]] suppressPackageStartupMessages( utilSource() ) if (gitBranchToSystem) setGitBranchToSystem() .g(verbose=FALSE) fresh(save=save, utils=utils, dt=dt, env=envir, defaultpackages.clearall=defaultpackages.clearall, notify.startup=notify.startup, verbose=verbose.fresh) eval(utilSource(), envir=envir) if (!is.na(width)) setWidth(width, confirm=FALSE) } fresh <- function(save=FALSE, utils=TRUE, dt=TRUE, profile.load=TRUE, first=TRUE, all=NULL, preserve=c() , width=NULL , clean_only.dont_restore=FALSE, env=parent.frame() , options.clearall=TRUE, verbose=TRUE , namespaces.clearall=FALSE , defaultpackages.clearall=FALSE , working.dir = "~" , profile.file=NULL , dev.off=TRUE , clearD ### <-- I clearly started to type someting here, not sure what? , notify.startup=NULL , verbose.debug=FALSE) { # all : a shortcut argument. If set, all of the other flags will get the same value. # TODO: Many more falgs have been added since I originally was using 'all' - consider changing it # profile.file : if NULL, checks current directory then home directory # working.dir : if NULL, will leave unchanged if (!is.logical(clean_only.dont_restore) || is.na(clean_only.dont_restore)) stop ("clean_only.dont_restore should be either TRUE or FALSE", call.=FALSE) if (dev.off) { while(!is.null(dev.list())) dev.off() } ## if utilSource is not loaded, try sourcing the file - or where it should be if (!exists("utilSource")) try(source("~/git/misc/rscripts/utilsRS.r")) cat.debug <- function(...) { if (verbose.debug) cat(" ----+* ", ..., "\n") } ## User can set an option called "dont.refresh" which, ## if TRUE, will not allow the executing of this function if (isTRUE(getOption("dont.refresh", FALSE))) { message("\n\n --- DID NOT REFRESH ---\nsince option 'dont.refresh' is flagged to TRUE.\n") return(invisible(NULL)) } ## Error checks ## ------------------------ ## if (length(preserve) && !is.character(preserve)) stop("'preserve' should be the NAME of the object, not the object itself. (ie, use quotes)") if (!(is.null(all) || is.logical(all))) stop ("'all' must be logical or NULL") ## ------------------------ ## ## Force the environment object to make sure it points correctly force (env) ## few blank lines to start us off if (verbose) cat("\n\n\n") if (!is.null(all)) save <- utils <- dt <- all ## options.clearall might want to be set separate from all if (missing(options.clearall) && !is.null(all)) options.clearall <- all if(save) saveImageTo(fresh=TRUE) ### ------- PRESERVE THESE FUNCTIONS FOR USE IN fresh() AFTER CLEARNING env ------- ### ## we will need these functions, so pull them into this environment to ## keep them from being deleted funcs_needed_here <- c("as.path", "sourceManyFiles", "sourceEntireFolder", "isErr" , "rm_OptionsToNotClear", "clearAllOptions", "get_defaultOptionsToNotClear", "get_OptionsToNotClear" , "inDebugMode", "getGitBranch") ## TODO: The method of saving these functions might fuck with the 'preserve' argument ## check for conflict. If there is, double simply using assign(func, get(func), envir=.e) ## It's possible that before, I had .e incorrect .e <- environment() for (func in funcs_needed_here) { ## explanation of this line. Essentially, we would like to do ## environment(func) <- .e -- this does not work, since it changes the object func, not the function is referencing by name ## environment(get(func)) <- .e -- this does not work, because get inside since it changes the object func, not the function is referencing by name ## `environment<-`(get(func), value=.e) -- this ALMOST works, but returns the function with an environment ## thus, assigning the results of this last part gets us what we want if (exists(func)) assign(func, `environment<-`(get(func), value=.e), envir=.e) else warning("function '", func, "' does not exist. Could not use it in fresh()") } ### ------- END: PRESERVE THESE FUNCTIONS FOR USE IN fresh() AFTER CLEARNING env ------- ### ## For debugging if (exists("inDebugMode")) browser(expr=inDebugMode("fresh"), text="in fresh() right after assigning local functions") ### -------------------------------------------- ### ## CLEAN UP - remove packages, namespaces, objects, connections ### -------------------------------------------- ### cat.debug("beginning cleanup") ## Close all db connections try(dbDisconnectAll(), silent=TRUE) ## close all connections -- unlike db connections, this applies to file, url, sink, stdind, stout etc if (isSinkOn()) { sinkfile <- getSinkFile() sinkOff(verbose=FALSE) closeAllConnections() sinkOn(sinkfile, append=TRUE, verbose=FALSE) verboseMsg(TRUE, " -------- FRESH / RESET HAPPENED HERE -------- ", pasteR(" ", 12), time=TRUE) } else { closeAllConnections() } ## Clear Options ## ------------------ if (options.clearall) { cat.debug("clearing options") try(rm_OptionsToNotClear(names(options()), showWarnings=FALSE)) ## dont clear dt options if dt is TRUE OR if we are not clearning the namespaces (they will not reload) opts.preserve <- if (dt || !namespaces.clearall) grep("^datatable", names(options()), value=TRUE) else c() try(clearAllOptions(preserve.option=opts.preserve)) } if (!is.null(width) && is.numeric(width) && !is.na(width) && length(width) == 1 && width > 10 && width < 1000) options(width = width) ## Remove all Packages ## ------------------ .pkgs <- names(sessionInfo()$otherPkgs) if (dt) ## for now, with data.table unload issue, we can expect some namespaces to remain .pkgs <- setdiff (.pkgs, "data.table") ## for now, with data.table unload issue, we can expect some namespaces to remain ## dont detach base64enc - there is something wrong with it # .pkgs <- setdiff(.pkgs, "base64enc") if (!defaultpackages.clearall) { ## identify which are the default pakcages to keep defaultPackages <- getOption("defaultPackages") if (is.null(defaultPackages) || all(defaultPackages %in% c(" ", ""))) defaultPackages <- c("datasets", "utils", "grDevices", "graphics", "stats", "methods") .pkgs <- setdiff (.pkgs, defaultPackages) } cat.debug("removing packages: ", paste(.pkgs, collapse=", ")) if (length(.pkgs)) # suppressWarnings(sapply(paste0("package:", .pkgs), detach, character.only=TRUE, force=TRUE, unload=TRUE)) suppressWarnings(sapply(paste0("package:", .pkgs), detach, character.only=TRUE, force=TRUE)) #, unload=TRUE ## remove all (most) namespaces. ## ------------------ ## THIS DOES NOT QUITE WORK (messes up some connection with C for DT. Temp removing this) if (namespaces.clearall) { # dependencies are listed as a comma delimd string. # split on the commas and count the number. # value of 1, usually indicates a dependency on ver # # Start with the highest number and work down attempts <- 13 for (i in 1:attempts) { # get all the namespaces .ns <- sessionInfo()$loadedOnly # note, using loadedNamespaces() give insufficent information cat.debug("i is", i, "clearing", length(.ns), "ns's") ## If .ns is empty, that means that all the namespaces have been cleared. break out of the for-loop (ie, quit trying) if (!length(.ns)) break # count the number of dependancys .counts <- sapply(.ns, function(x) ifelse(is.null(x$Depends), 0, length(strsplit(x$Depends, ",")[[1]]))) # attempt to remove them, starting with the one with the highest count ### TODO: Grab the message from try, parse it for the package name that holds the dependency. eg: `Error: package ‘ffbase’ is required by ‘RecordLinkage’ so will not be detached` suppressWarnings(invisible(sapply(names(.ns[order(.counts)]), function(ns) try(unloadNamespace(ns), TRUE)))) } # // end attempts for loop if (i == attempts) if (!dt) ## for now, with data.table unload issue, we can expect some namespaces to remain warning("namespaces may not have been properly cleared") cat.debug("i is", i, "remaining ns's are: ", paste(names(.ns), collapse=", ")) } # // end namespaces.clearall cat.debug("removing objects") # remove all objects objsToRemove <- ls(all=TRUE, envir=env) ## Do not remove the 'preserve' objects objsToRemove <- setdiff(objsToRemove, preserve) ## remove rm(list=objsToRemove, envir=env) ## colect garbage. Call twice, as the second time it may pick up a few stragglers gc(reset = TRUE) gc(reset = TRUE) ### -------------------------------------------- ### ## There might be a bug with setDefaultEmails() if (verbose.debug) { if (!exists("inDebugMode")) inDebugMode <- function(...) TRUE if (!exists("debugOn")) options("debug.flags"=list(setDefaultEmails=TRUE)) else debugOn("setDefaultEmails") } ### ----------------------------------------------------------- ### ### Setup Workspace ### ### ----------------------------------------------------------- ### if (!clean_only.dont_restore) { ## for verbose output. Initiate to empty vector msg.out <- c() addl.msg <- c() ### Working dir and .Pfm ### -------------------------------------------- ### ## set path to home dir if (!is.null(working.dir)) setwd(working.dir) ## setting this option now as a reminder as to the proper spelling of the option options('dont.refresh'=FALSE) # create platform variable in the global environment assign(".Pfm", value=Sys.info()[['sysname']], envir=.GlobalEnv) ### -------------------------------------------- ### ## Function to cleanly output the names of the files loaded cleanFilesLoaded <- function(utilsLoaded, addlUtilsLoaded) { files_loaded <- names(which(c(utilsLoaded, addlUtilsLoaded))) parent_folders <- rep("", length(files_loaded)) has <- grepl("/", files_loaded) parent_folders[has] <- sub("/.*", "", files_loaded[has]) ## note to self: We are expecting at least one blank. Otherwise more if statements required if (all(has)) warning ("Internal Error: No 'blank' parent_folders -- this will mess up the [-1L] \n\nHINT: This is probably due to every util file being in a sub folder") files_cleaned <- sub(".*?/", "", files_loaded) names(files_cleaned) <- parent_folders ordering <- order(parent_folders) files_cleaned <- files_cleaned[ordering] parent_folders <- parent_folders[ordering] colWidth <- max(nchar(files_cleaned)) + 1 halfWidth <- max(as.integer(colWidth/2) - 12 , 1) # halfWidth <- as.integer(colWidth/2) fmt <- sprintf("%%-%is ======================================={ %%s }=======================================", halfWidth) { paste(unlist( lapply(unique(parent_folders), function(nm) { c(if (nm != "") sprintf(fmt, "", nm, "", "") , paste_l2(files_cleaned[names(files_cleaned) == nm], cols=3, colWidth=colWidth -1) ) }) , use.names=FALSE), sep="\n", collapse="\n") } } ### Source Utils ### -------------------------------------------- ### if(utils) { ## turn off option to send cat.debug("sourcing utilsRS") utilFile <- "utilsRS.r" utilsFolder <- "~/git/misc/rscripts" # ifelse(.Pfm=="Linux", "~/NBS-R/Ricks/src/", "~/git/misc/rscripts/") utilsLoaded <- sourceManyFiles(files=utilFile, dir=utilsFolder) if(any(!utilsLoaded)) warning("Primary utils file not loaded. File tried was: \n\t ", as.path(utilsFolder, utilFile), "\n") addlUtilsFiles <- extractFilesFromFolder(paste0(utilsFolder, "/utils"), all=TRUE, recursive=TRUE, full.names=TRUE , ignore.subfolders=c("Setup Info", getOption("ignore.subfolders"))) ## if we are sourcing the notify.r file, adjust the welcome message if (!is.null(notify.startup)) options("notify.startup"=notify.startup) cat.debug("sourcing other utils") addlUtilsLoaded <- sourceManyFiles(files=addlUtilsFiles) if (any(!addlUtilsLoaded)) warning("The following secondary util files were ", if(any(!utilsLoaded)) "also ", "not loaded. File tried was: \n\t ", paste(names(which(! addlUtilsLoaded)), collapse=", "), "\n") else if (verbose) # msg.out <- c(msg.out, msgBox("The following secondary util files were loaded **succesfully** \n\n", paste_l(names(which(c(utilsLoaded, addlUtilsLoaded))), spacer=3, sameWidth=FALSE, cols=3), collapse="", shiftLeft=0, silent=TRUE)) msg.out <- c(msg.out, boxit(c("The following secondary util files were loaded **succesfully** \n\n", cleanFilesLoaded(utilsLoaded, addlUtilsLoaded)), align="left")) } ### -------------------------------------------- ### ### data.table package ### -------------------------------------------- ### if (dt) { cat.debug("loading in data.table") suppressPackageStartupMessages(library(data.table)) } ### source .Rprofile ### -------------------------------------------- ### if (profile.load) { cat.debug("loading profile") ## if profile.file was not set, defaults are current directory, then home directory if (is.null(profile.file)) profile.file <- ifelse (file.exists(".Rprofile"), ".Rprofile", "~/.Rprofile") if (!file.exists(profile.file)) addl.msg <- c(addl.msg, "No .Rprofile Found.") else { profile.loaded <- try(source(profile.file)) addl.msg <- c(addl.msg, ifelse (isErr(profile.loaded) , yes = ".Rprofile Found but sourcing it resulted in error" , no = paste0(".Rprofile loaded from ", profile.file) )) } } # // end profile.load ### source .First ### -------------------------------------------- ### if (first && exists(".First")) { cat.debug("loading .First") .First(silent=TRUE) addl.msg <- c(addl.msg, ".First( ) has been executed") } # browser(text = "msg.out") ### ----------------------------------------------------------- ### ### Verbose Output to User ### ### ----------------------------------------------------------- ### ## Fancy output (TODO: this needs cleanup) ### -------------------------------------------- ### spacers <- paste(rep(" ", 5 + 24), collapse="") endBar <- if (is.character(msg.out) && length(msg.out) == 1) tail(strsplit(msg.out,"\n")[[1]], 1) else paste(rep(" ", 60), collapse="", sep="") msg.out <- c(msg.out, paste0(spacers, addl.msg), endBar) ## Fancy output continued (TODO: this needs cleanup) ### -------------------------------------------- ### if (verbose) { if (length(msg.out) && nchar(msg.out)) { # msg.out <- paste0("|", msg.out, sapply(max(nchar(msg.out))-nchar(msg.out), function(i) paste0(rep(" ", i), collapse="")) , "|") # lns <- grep("^\\| ----.*--- \\|", msg.out) # msg.out[lns] <- gsub("\\| ---", "\\+ ---", msg.out[lns]) # msg.out[lns] <- gsub("--- \\|", "--- \\+", msg.out[lns]) # msg.out <- paste(" ", msg.out) cat(msg.out, sep="\n") } cat(rep("\n", 4), rep(" ", 43), "** So Fresh and So Clean **", rep("\n", 7), sep="") } } ## // end clean_only.dont_restore return(invisible(TRUE)) } srcOther <- function(new.src, old.src=getProjName(), path=srcDir, confirm_exists=TRUE) { ## Takes the entire path of srcDir and changes just hte projName folder. ## Useuful for loading data from other projects, such as loadFromJesus(src=srcOther("example")) ## ## Confirm: Simply checks capitalization, etc and swaps in correct value if exactly one match exists pat <- paste0("/", old.src, "(/|$)") repl <- paste0("/", new.src, "\\1") ret <- gsub(pat, repl, path) ## if confirm, if it already exists, do nothing if (confirm_exists && length(ret) == 1 && !file.exists(ret)) { matches <- extract(basename(ret), dir(dirname(ret)), ignore.case=TRUE) if (length(matches) == 1) { warning(sprintf("\nUsing '%s' instead of '%s' in srcOther()", matches, new.src), call.=FALSE) ret <- srcOther(new.src=matches, old.src=new.src, path=ret) } else if (!length(matches)) { warning ("\n'", basename(ret), "' does not exist in '", path.unexpand(dirname(ret)), "'", call.=TRUE) } else { warning ("\n'", basename(ret), "' does not exist in '", path.unexpand(dirname(ret)), "'\nDid you mean ", pasteQand(matches, and="or"), call.=TRUE) } } return(ret) } saveImageTo <- function(projName, subProj=getSubProj(pos=pos+1, warnOnBlanks=FALSE), appendImgSave=TRUE, stamp=TRUE, fresh=FALSE, extension="Rda" , dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves"), .Pfm=Sys.info()[['sysname']], pos=1, verbose=TRUE) { # Saves the image to file projName (with stamps) in the folder 'dir' (assigned by default) # To load the image back, run `loadImageOf( )` # Note that default parameters are enviroment dependent, hence if using save/load, explicict params is recomended force(pos) force(subProj) start.time <- proc.time() if(missing(projName)) { projName <- getProjName(appendImgSave, fresh=fresh, pos=pos+1) NotMissing <- FALSE } else NotMissing <- TRUE ## ignore subProj if projName is blank OR if subProj is "MAIN" if (is.null(projName) || projName == "" || (is.null(subProj) || subProj == "MAIN")) subProj <- "" if (verbose) cat("Saving Image for [projName: ", projName, "] [subProj: ", subProj, "]\n", sep="") # switch dir if we're working on the science box if (missing(dir)) dir <- getOption("ImageSavesDir", default="~/gitData/ImageSaves") # if saving from fresh, append file name, to distinguish from manual saves if (fresh) projName <- ifelse(nchar(projName), paste0(projName, "_B4Fresh"), "ImageSave_B4Fresh") # save loaded libraries & projName pkgs.ignore <- c("Revobase", "RevoMods", "RevoScaleR") assign(x=".libs", value=setdiff(names(sessionInfo()$otherPkgs), pkgs.ignore), envir=parent.frame(pos)) # only assign projName if it was given explicitly in the call and there is no such value in the calling env. if (NotMissing && ! exists("projName", envir=parent.frame(pos), inherits=FALSE)) assign("projName", projName, envir=parent.frame(pos)) # create time stamp, if requested tms <- ifelse(stamp, paste0("_", timeStamp()), "") # extension may or may not already contain the dot, depending on user input. hence: if (substr(extension, 1, 1) != ".") extension <- paste0(".", extension) # create file name fname <- paste0(projName, if(nchar(subProj)) "_", subProj, tms, extension) # create directory if not exist if(!file.exists(dir)) dir.create(dir, recursive=TRUE) f <- as.path(dir, fname) ret <- try(save.image(file=f)) if(inherits(ret, "try-error")) stop("File was not saved successfully.\nAttempted to save.image with destination: \n\n\t", f, "\n\n") # output time it took to complete end.time <- proc.time() if (verbose) { loadSize <- formatBytes(file.info(f)$size) # cat("Time it took to save the ", loadSize, " image to\n'",fname,"' \n was ", round((end.time-start.time)[[3]] / 60, 2), " minutes.\n", sep="") cat("Time it took to save the ", loadSize, " image to\n'",fname,"' \n was ", fwTDiff(start=start.time, end=end.time), ".\n", sep="") cat("\n\n") } return(f) } loadImageOf <- function(projName, appendImgSave=TRUE, stamp=TRUE , dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves") , subProj=getSubProj(pos=pos+1, warnOnBlanks=FALSE) , alldirs=FALSE , .Pfm=Sys.info()[['sysname']], listdirs=FALSE , pos=1 , envir=globalenv() , preserveCurrentWrkDir=FALSE , verbose=TRUE # , nbs=FALSE , emailWhenDone=FALSE , dont.change.prompt=FALSE , file) { ## Used only for emailWhenDone flag start.time <- proc.time() ## Load either explicity file or look for which file to load by projName if (!missing(file)) { verboseMsg(verbose, "Loading File '", file, "'", func="message", sep="") base::load(file, envir=envir, verbose=FALSE) loaded <- TRUE projName <- getProjName(showWarnings=FALSE) verboseMsg(verbose, "Current project is '", projName, "'", func="message", sep="", time=FALSE) } else { ## PARAMETER FullDirsList <- unique(c(dir, getOption("ImageSavesDir", default="~/gitData/ImageSaves") )) # "~/NBS-R/Ricks/ImageSaves", "~/gitData/nbs/ImageSaves", if(missing(projName)) { projName <- getProjName(appendImgSave, pos=pos+1) NotMissing <- FALSE } else NotMissing <- TRUE # helper. Load file by number. Useful as a follow up call after using "?" if(is.numeric(projName) && projName < 100) { projName <- imagesInDir(dir=FullDirsList, alldirs=TRUE)[projName] cat("\n\nYOU SELECTED: [", projName, "]\n\n") return(loadImageOf(projName, subProj=subProj, pos=pos+1, alldirs=TRUE, emailWhenDone=emailWhenDone, verbose=verbose, preserveCurrentWrkDir=preserveCurrentWrkDir, envir=envir)) } # helper. List all files. First set `alldirs` to TRUE to grab all dirs to pass. if(projName=="?") alldirs <- TRUE if(tolower(substr(projName,1,2))=="?d") listdirs <- TRUE # the second part of this is another helper function. listdirs. if(alldirs || listdirs) { dir <- unique(c(dir, FullDirsList)) if (listdirs) return(cbind(dir)) } browser(expr=inDebugMode("load"), text="in loadImageOf() right before checking for '?' and setting projName") # helper. List all files if(projName=="?") return(cbind(imagesInDir(dir=dir, alldirs=TRUE))) # append suffix to projName if (appendImgSave && !grepl("ImageSave", projName) && !grepl("B4Fresh", projName)) projName <- paste(projName, "ImageSave", sep=ifelse(nchar(projName), "_", "")) # try to load. If failed, search again in all dirs before giving up. # second try denoted by alldirs=TRUE loaded <- try(LoadFromBackUp(projName, dir, pos=pos+2, imgload=TRUE, subProj=subProj, envir=envir)) # extra pos for "try(.)" if (inherits(loaded, "try-error")) { if (!alldirs) return(loadImageOf(projName, subProj=subProj, appendImgSave=appendImgSave, stamp=stamp, dir=dir, alldirs=TRUE , .Pfm=.Pfm, pos=pos+1, emailWhenDone=emailWhenDone, verbose=verbose, preserveCurrentWrkDir=preserveCurrentWrkDir, envir=envir)) stop(loaded) } } ## // end load by projName if(exists(".libs")) { .libs <- setdiff(.libs, c("Revobase", "RevoMods", "RevoScaleR")) pkgsLoaded <- setNames(sapply(.libs, function(x) eval(parse(text=paste0("suppressPackageStartupMessages(require(", x,"))")))), .libs) if (verbose) { cat("Packages Loaded:\n"); print(pkgsLoaded) } } # set the wrkDir to that of the package if(exists("wrkDir") && !preserveCurrentWrkDir) setwd(wrkDir) if (verbose) { cat("\n\n[eh ... is this line needed? 1429 in workspace.R] Some Environment Objects:\n") } ret <- suppressWarnings(lsos(n=12)) # Capture the output message info ret.str <- paste0(capture.output(print(ret)), collapse="\n") msg.details <- attr(loaded, "msg.for.email") msg.details <- paste0(msg.details, collapse="\n") msg.details <- paste0(c(msg.details, "\nSome of the Objects in Environment:", ret.str), collapse="\n") projName <- getProjName(showWarnings=FALSE) ## If it took a long time to load, and 'emailWhenDone' was not explicit, then send an email if (missing(emailWhenDone) && 300 < (proc.time() - start.time)[["elapsed"]]) emailWhenDone <- TRUE if (isTRUE(emailWhenDone) && exists("EmailStatusUpdate")) try(EmailStatusUpdate(status=paste("Finished Loading", projName), msg.details=msg.details, projName=projName, sms=TRUE, work=TRUE)) if (!dont.change.prompt) try(setPrompt()) cleanTrueLengthOfDTs(verbose=FALSE) return(ret) } imagesInDir <- function(dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves"), NBS=FALSE, alldirs=FALSE, .Pfm=Sys.info()[['sysname']], hyphen="_-", nbs=NBS) { # hyphen for splitting off time stamp if (is.null(dir)) warning("The 'dir' passed to imagesInDir() is NULL. Check your call stack.") h <- paste0("(", paste(unlist(strsplit(hyphen, "")), collapse="|"), ")") if(alldirs) { dir <- unique(c(dir, getOption("ImageSavesDir", default="~/gitData/ImageSaves") )) # "~/NBS-R/Ricks/ImageSaves", "~/gitData/nbs/ImageSaves", } # NBS # else if (nbs & missing(dir)) { # NBS # dir <- ifelse (.Pfm == "Linux", "/data01/r_data/Ricks/ImageSaves", "~/gitData/nbs/ImageSaves") # NBS # } # get list of files files.nms <- list.files(dir, recursive=TRUE) files.fullpaths <- list.files(dir, recursive=TRUE, full.names=TRUE) names(files.fullpaths) <- files.nms # remove extension splat <- sub("\\.Rda(ta)?$", "", files.nms, ignore.case=TRUE) splat <- strsplit(splat, h) # find Date Stamp by searching for 201X dateStampStart <- lapply(splat, function(x) max(0, (which(grepl("201[0-9]", x)) - 1)) ) # in case not found, use the whole length dateStampStart <- ifelse(dateStampStart < 1, lapply(splat, length), dateStampStart) # return the pasted string, minus anything after the date stamp ret <- mapply(function(S, d) paste(S[1:d], collapse=substr(hyphen,1,1)), splat, dateStampStart) # return unique(ret) } cleanImageFiles <- function(projName, appendImgSave=TRUE, stamp=TRUE, subProj=NULL, dir=getOption("ImageSavesDir", default="~/gitData/ImageSaves"), .Pfm=Sys.info()[['sysname']], verbose=TRUE, doNotPrompt=FALSE, pos=1) { # This function useful after having run `saveImageTo()` multiple times. # This cleans up the `dir` by finding all files of pattern `projName`, evaluating the time stamp, # and preserving the most recent one while deleting all the previous ones. # # Args: # Verbose: TODO (not yet implemented) # doNotPrompt: IF TRUE, function will not ask for user confirmation, instead will assume user input of "yes" # # Returns the list of files with pattern that remain in dir at end of the process. # That is, at a minimum, if all succesfull, returns a list of 1 file, the one preserved. # If user selected NO at prompt, then returns a list of all the files in dir that matched the pattern # If user selected YES, but there were errors in deleting the files, then returns a list of the # file deliberately not-deleted along with all the other files that matched the pattern that were unsucessfully deleted # TODO: Move to trash instead of deleting if(missing(projName)) { projName <- getProjName(appendImgSave, pos=pos+1) NotMissing <- FALSE } else NotMissing <- TRUE # append suffix to projName if (appendImgSave && !grepl("ImageSave", projName)) projName <- paste(projName, "ImageSave", sep=ifelse(nchar(projName), "_", "")) # NBS x - # search for "NBS" in either `getwd` and `dataDir` for "NBS" # NBS x - # if found, switch the folder # NBS x - if (missing(dir) && any(grepl("NBS", c(getwd(), if(exists("dataDir"))dataDir), ignore.case=TRUE))) # NBS x - dir <- getOption("ImageSavesDir") # get the file names with time stamps extracted files <- LoadFromBackUp(objToLoad=projName, BackUpDir=dir, pos=2, returnTimeStamps=TRUE, subProj=subProj, envir=envir) # sort them by time stamp, then grab just the names files <-sort(files, decreasing=TRUE) toDelete <- tail(names(files), -1) toDeleteDates <- tail(files, -1) toKeep <- setdiff(names(files), toDelete) toKeepDates <- setdiff(files, toDeleteDates) nfiles <- length(toDelete) # number of files to delete remain <- rep(TRUE, length(toDelete)) # flag for which files remain cat("Deleting:\n--------", rev(paste(toDelete, toDeleteDates, sep="\t")), "", sep="\n\t") cat("Keeping:\n-------", paste(toKeep, toKeepDates, sep="\t"), "", sep="\n\t") # get user confirmation if (isTRUE(doNotPrompt)) { proceed <- "y" } else { cat("Proceed?\n") proceed <- readline(paste("Delete the", nfiles, "files above? [y/n]: > ")) cat("\n") # add some blank lines, that is all. } # if user indicates to proceed if (tolower(substr(proceed, 1, 1))=="y"){ # deleted has value 0 if no failures, 1 if a failure deleted <- try(unlink(as.path(dir,toDelete)), silent=TRUE) # check if the files exists. all of `remain` should be FALSE remain <- file.exists(as.path(dir,toDelete)) # check for erros if (any(deleted, remain)) { countsMsg <- paste0("Attempted to delete ", nfiles, " files. ", sum(remain), " file remain", ifelse(sum(remain)>1,".", "s.")) if (deleted) { warning("Delete attempt returned failure code: `",deleted,"`\nFurther Details: ", countsMsg) } else warning(countsMsg) # return(c(toKeep, toDelete[remain])) # if no errors: } else { countsMsg <- paste0(nfiles, " files have been deleted succesfully.\n\n") cat("\n",countsMsg, "\n") } # return(toKeep) } else cat("\nNothing was deleted.\n\n") # return(files) return(c(toKeep, toDelete[remain])) } ## TODO: USAGE EXAMPLES NEED TO BE UPDATED #========================================================================================# # USAGE EXAMPLE #========================================================================================# ## Determine which objects to load # obj <- c("CAconcerts.rec", "CAconcerts_by_artist") ## If using `sapply`, use `pos=3` and set USE.NAMES to FALSE (so that toRemove keeps proper names) # toRemove <- sapply(obj, loadFromNBSData, pos=3, USE.NAMES=FALSE) # # -- OR -- # # toRemove <- sapply(obj, checkAndLoad, BackUpFrom="path/to/backups", pos=3, USE.NAMES=FALSE) ## toRemove is then flags for which objects to remove # names(toRemove)[toRemove] <~~ The objects to remove # if (cleanUpAfterOurselves) # rm(list = names(toRemove)[toRemove]) #========================================================================================# LoadFromBackUp <- function(objToLoad, BackUpDir, CheckSubs=TRUE, DateFormat="%Y%m%d_%H%M", utilsReload=TRUE, returnTimeStamps=FALSE , pos=1, verbose=TRUE, hyphen="[-_]", imgload=FALSE, showPath=imgload, dir=NULL, subProj="", envir=globalenv()) { ## TODO: allow for both `.Rda` and `.RData` -- or better yet, strip the file extension ## args: ## hyphen: possible hyphen arguments. Will be shortened to h ## CheckSubs: Whether or not to recursively check in BackUpDir h <- hyphen # Eventually I want to switch over the argument BackUpDir to just `dir`, as I have it in most other functions. For now, throw error if dir is used if(!is.null(dir)) { stop ("You used `dir` as an argument, but you meant to use `BackUpDir`. This will be changed in the future.") } if(missing(BackUpDir)) { if (exists("dataDir")) BackUpDir <- as.path(dataDir, "../") # one less than dataDir else BackUpDir <- "~/gitData/" } # intialize toLoad. Later will check if it already has a value toLoad <- "" browser(expr=inDebugMode("load"), text="in LoadFromBackUp(), right before identify the files") # ---------------------------------------------- # # ---- IDENTIFY THE FILES IN THE PATH ----- # # ---------------------------------------------- # { # identify file names, no path filesAndPath <- dir(BackUpDir, recursive=CheckSubs, include.dirs=FALSE, full.names=TRUE) # grab only the file name, and not the leading path files <- basename(filesAndPath) # grab only those paths with objToLoad filesUsing <- grepl(paste0("^",objToLoad, h), files) # crop out the unused files from our list files <- files[filesUsing] filesAndPath <- filesAndPath[filesUsing] # Error if no files found. if (!any(filesUsing)) stop("\n No files starting with, ", objToLoad, " in \n\t", paste(as.character(BackUpDir), collapse="\n\t") , "\n", ifelse(CheckSubs, paste0("or any of ", ifelse(length(BackUpDir)>1,"their", "its"), " sub directories.\n"), "Try using ` CheckSubs=TRUE `.\n") ) } # ---------------------------------------------- # # ---------------------------------------------- # # ---- CHECK FOR subProj ----- # # ---------------------------------------------- # ## The subProj might have more than word. Depending on what spacers where used when saved, the file might have spaces, or dots or dashes or underscores. ## So instead, we split the subProj into words, and then search the files for all of those words ## ## A Sepcific value of subProj = NULL indicates to force NO subProj ## In other words, even if a more recent ImageSave is available, but the newer file has a subProj associated ## to it use the older one. if (is.null(subProj) || toupper(subProj) == "MAIN") subProj <- "MAIN" # &&& in progress 2015-01-12 subProj == "" ==> Use the most recent, regardless of subProj. ie, ignore subProj # &&& in progress 2015-01-12 subProj == "MAIN" or subProj == NULL ==> Ensure there is NO subProj associated to file # &&& in progress 2015-01-12 subPorj == "!xx" ensure that specific subProj not associated # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 if (is.null(subProj)) # &&& in progress 2015-01-12 subProj <- "MAIN" # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 filesubProjs <- sapply(strsplit(files, "(_?ImageSave_?|_?\\d{8}_\\d{4,6}\\.Rd(a|s)$)"), "[[", 2) # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 &&& LEFT OFF HERE # &&& in progress 2015-01-12 ## Make sure that no subProj # &&& in progress 2015-01-12 if (subProj == "MAIN") { # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 } else if (grepl("^!", subProj)) { # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 } else { # &&& in progress 2015-01-12 # &&& in progress 2015-01-12 } ## TODO ## TODO ## TODO ## TODO: This is a quick sloppy fix. ## The better method: ## Create A function that parses the filename and returns a list if (subProj == "MAIN") { ## &&& 2015-02-12 -- There is a problem: Up until now I have been using "_" to separate subProj. ## However, many projnames and subProj use underscores as well. Thus it is hard to tell where the subProj begins ## TODO: Clarify the sep ## For now, anything after ImageSave_ upuntil the datestamp is considered subProj. ## However, keep in mind that some ImageSave files do not use the phrase "ImageSave" (why? which ones?) files_without_subProj <- grepl("ImageSave_(MAIN_)?\\d{8}_\\d{4,6}\\.Rd[as]$", files, ignore.case=TRUE) if (!any(files_without_subProj)) warning ("Could not find any files without subProj. Will load most recent file", call.=FALSE) else { files <- files[files_without_subProj] filesAndPath <- filesAndPath[files_without_subProj] } } else if (subProj != "") { # words.subProj <- strsplit(subProj, "\\s+")[[1]] # matches.subProj <- sapply(files, function(f) all(sapply(words.subProj, grepl, f, ignore.case=TRUE))) pat.subProj <- gsub(" ", "(\\\\b|\\s|\\.|_)", escapeRegEx(subProj)) matches.subProj <- grepl(pat.subProj, files) if (!any(matches.subProj)) warning("No matches found for subProj = '", subProj, "' Will load most recent file") else { files <- files[matches.subProj] filesAndPath <- filesAndPath[matches.subProj] } } # ---------------------------------------------- # # ------------------------------------------------- # # --- PARSE OUT THE DATE FROM THE FILE NAME --- # # ------------------------------------------------- # nc <- nchar(files) # check if seconds is in the file name time stamp # since the seconds will take up an additional two characters (19 instead of 17) sc <- ifelse(grepl(h, substr(files, nc-19, nc-19)), 2, 0) #TODO: This will be thrown off if the file has seoncds stamp AND has extension '.RData' instead of '.Rda' # However, by chance (ie 2 characters), this works if the file has no seconds, but uses `.Rdata` #--------------- ERROR CHECK ----------------- - - - - - # 17 + sc should be a hypon, ie, just before the time stamp # culp identifies which if(all(culp <- !(grepl(h, substr(files, nc-(17+sc), nc-(17+sc)))), na.rm=TRUE)) { culp[is.na(culp)] <- FALSE # if there is only one candidate file, then date stamp doesnt matter if (length(filesAndPath)==1) { toLoad <- filesAndPath[1] # if only some are missing dates, then remove those from list } else if (!all(culp)) { warning("\nSome files do not have identifiable dates: \n", paste(ifelse(culp, " ==> ", " "), files, collapse="\n"), "\n\nThose files will not be considered.") # otherise } else stop("\nMultiple files found, but none have identifiable date. Please be more specific with directory.\n\n", paste(" ", filesAndPath, collapse="\n\n"), "\n") } #--------------- ERROR CHECK ----------------- - - - - - # grab time stamp, without the second columns dates <- substr(files, nchar(files)-(16+sc), nchar(files)-(4+sc)) dates <- as.POSIXlt(dates, format=DateFormat) # ---------------------------------------------- # # if flagged just to return time stamps of the files: if (returnTimeStamps) return(setNames(dates, files)) # helper. List all files if(objToLoad=="?") { print(cbind(imagesInDir(dir=BackUpDir, alldirs=TRUE))) return(cbind(imagesInDir(dir=BackUpDir, alldirs=TRUE))) } # IDENTIFY THE FILE with the most recent time stamp # the ifelse is for the error check in the section with `culp` # ie, if no dates found, but only one file identified, just use that one. dateLoading <- max(dates, na.rm=TRUE) toLoad <- ifelse(toLoad=="", filesAndPath[which(dates==dateLoading)], toLoad) loadSize <- formatBytes(file.info(toLoad)$size) # output the path information if flagged filePath <- sapply(lapply(strsplit(toLoad, "/"), head, -1), paste, collapse="/") if(showPath) cat(paste0("\n\nLoading Backup of '", objToLoad,"' From: "), paste(filePath, as.character(dateLoading), loadSize, sep=" "), sep="\n\t" ) # LOAD: start.time <- proc.time() ## OLD as of 20140916: # caught <- try(load(toLoad, envir=parent.frame(pos))) ## NEW as of 20140916 (replacing pos with envir) caught <- try(base::load(toLoad, envir=envir)) end.time <- proc.time() msg.for.email <- c("") if(inherits(caught, "try-error")) stop("\n\nSomething went wrong, could not load the file") else { if (verbose || imgload) { msg <- paste("Time it took to load", loadSize, ifelse(imgload, "image", "file"), "was", fwTDiff(start=start.time, end=end.time)) msg.for.email <- c(msg.for.email, msg) cat (msg, "\n") } # output info on what was loaded if (verbose || verb.time) { msg <- paste("Loaded from file: \n\t", toLoad, "\n") msg.for.email <- c(msg.for.email, msg) cat(msg, "\n") } # re-load the utils, since they likely have changed since the image was last saved. if (utilsReload) { try(source(path.expand("~/git/misc/rscripts/utilsRS.r")), silent=TRUE) try(source(path.expand("~/git/misc/rscripts/utils/workspace.R")), silent=TRUE) if (exists("utilSource")) try(utilSource(update.lastran=FALSE), silent=TRUE) } } # check if object was loaded, but only if we were not loading a backup image if (!exists(objToLoad) & !imgload) stop("\n\nSomething went wrong. File loaded but cannot find `", objToLoad, "`\n") # OTHERWISE, ALL IS WELL if (verbose) cat("Object `", objToLoad, "` Loaded Succesfully.\n", sep="") ret <- TRUE attr(ret, "msg.for.email") <- msg.for.email return(ret) } # example: # LoadFromBackUp(objToLoad="CAconcerts.rec", BackUpDir="/data01/r_data/Ricks/data/") checkAndLoad <- function(objToLoad, BackUpFrom, pos=1, force=FALSE, verbose=FALSE, envir=globalenv()) { # Initialize wasLoadedIn <- FALSE # Check if object is already present. If so, do nothing if(!exists(objToLoad) || force) { # flag to indicate object was loaded in the call to this function (ie, it was not previously present) wasLoadedIn <- TRUE # Load the object LoadFromBackUp(objToLoad=objToLoad, BackUpDir=BackUpFrom, verbose=verbose, pos=pos+1, envir=envir) # there is an error check in LoadFromBackUp, this is just an extra double check stopifnot(exists(objToLoad)) } # retuns whether the specific object was loaded return(setNames(wasLoadedIn, objToLoad)) } # NBS x - LoadFromNBSData <- function(objToLoad, pos=1, .Pfm=Sys.info()[['sysname']], force=FALSE, verbose=FALSE) { # NBS x - # Wrapper function with the NBS data dir pre populated # NBS x - # NBS x - # set Dir to load backups from based on which system working from # NBS x - BackUpFrom <- "/data01/r_data/Ricks/data/" # NBS x - BackUpFrom <- ifelse(.Pfm=="Linux", BackUpFrom, "/Users/ricardosaporta/gitData/nbs/data") # NBS x - return(checkAndLoad(objToLoad, BackUpFrom, pos=pos+1, force=force, verbose=verbose)) # NBS x - } # NBS x - # NBS x - NBSUtils <- function() # NBS x - try(source(path.expand("~/NBS-R/utils/utils.r"))) ## %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ## ## ------------------------------------------------------------ ## ## THESE WERE MY ORIGINAL SCRIPTS, AND HAVE BEEN REPLACED WITH ## ## saveImageTo() and loadImageOf() ## ## ------------------------------------------------------------ ## ## # save and load default ## savdef <- savedef <- function(env=parent.frame()) ## eval(save.image(file="~/.default.RData"), envir=env) ## ## loadef <- function() ## load(file="~/.default.RData", envir=.GlobalEnv) ## ## # save and load images specifc to NBS ## savenbs <- function() ## eval(save.image(file="~/gitData/nbs/.NBS_image.RData"), envir=.GlobalEnv) ## ## loadnbs <- function() { ## load(file="~/gitData/nbs/.NBS_image.RData", envir=.GlobalEnv) ## setwd("~/git/nbs") ## } ## ------------------------------------------------------------ ## ## %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ## findBackUps <- function(objName="", dir="", allDirs=TRUE, ext=c("Rda", "Rdata"), noImg=TRUE, hyphens=c("-", "_")) { dir.all <- c(getwd(), dataDir, outDir) if (allDirs) dir <- unique(setdiff(c(dir, dir.all), "")) files <- list.files(dir, recursive=TRUE, full.name=TRUE) # find only those extensions ## remove dot from extension ext <- gsub("\\.", "", ext) files <- sapply(ext, function(ex) grep(paste0(ex,"$"), files, ignore.case=TRUE, value=TRUE)) files <- unname(unlist(files)) dates <- extractTimeStamp(files, hyphens=hyphens) fileNames <- sapply(strsplit(files, .Platform$file.sep), tail, 1) fileNames <- gsub(regOr(paste0("\\.", ext)), "", fileNames) h <- regOr(h.splat) fileNames <- mapply(function(f, d) gsub(paste0(h, d), "", f), fileNames, dates, USE.NAMES=FALSE) include <- TRUE if (noImg) include <- include & !grepl("ImageSave", fileNames) paths <- mapply(function(p, f) gsub(paste0(f, "\\.*$"), "", p), files, fileNames, USE.NAMES=FALSE) ret <- unique.data.frame(data.table(fileNames, dates, paths)) ret[!exclude, list(fileNames, dates)][order(tolower(fileNames), dates)] } extractTimeStamp <- function(x, hyphens=c("-", "_"), alphaHyphen=FALSE) { # TODO: alphahyphen h.splat <- unlist(strsplit(hyphens, "")) # h is just hyphens, hb is hyphens or word block hb <- regOr(c(h.splat, "\\b")) h <- regOr(h.splat) dateFormat <- c(sec="%Y%m%d_%H%M%S", min="%Y%m%d_%H%M") datePattern <- paste0(hb,"[0-9]{8}", h, "[0-9]{4}([0-9]{2})?", hb) dates <- stringr::str_extract(x, datePattern) dates <- gsub(paste0("(^",h,"|",h,"$)"), "", dates) return(dates) # TODO: no need to actually parse for now dates <- ifelse(nchar(dates)==15 , as.Pos(dates, format=dateFormat["sec"]) , as.Pos(dates, format=dateFormat["min"])) } getScreen <- function(prefix="", suffix="") { ## The screen info is in the prompt ## prefix & suffix are attached only if a value is found for screen x <- getOption("prompt") if (!length(x)) return("") ret <- gsub(" ?R(.*)(>|\\$) ?$", "", x, perl=TRUE) ret <- gsub("\\s*(>|\\$)\\s*$", "", ret) if (!nchar(ret)) return("") ## ELSE paste0(prefix, ret, suffix) } ### ----------------- Options Clearning - mostly useful for fresh() ----------------- ### get_defaultOptionsToNotClear <- function(showWarnings=TRUE) { defaults <- getOption(".default_optionsToNotClear") if (is.null(defaults) && showWarnings) warning("\n\n --- Option '.default_optionsToNotClear' not set ---\n") return(defaults) } rm_OptionsToNotClear <- function(optionsToRemove, showWarnings=TRUE) { ## note, to reset to default, use ## rm_OptionsToNotClear(names(options()), showWarnings=FALSE) ## we should not try to clear the R-set options defaults <- get_defaultOptionsToNotClear() if (length(wh <- intersect(optionsToRemove, defaults))) { if (showWarnings) warning("Some options designated to cleared are part of the default set and will NOT be set to clear. They are: \n ", paste(sprintf(" '%s'", wh), collapse=",")) optionsToRemove <- setdiff(optionsToRemove, defaults) } current <- get_OptionsToNotClear() new <- setdiff(current, optionsToRemove) options(.optionsToNotClear = new) } set_OptionsToNotClear <- function(optionsToNotClear=c()) { current <- get_OptionsToNotClear() new <- unique(c(current, optionsToNotClear)) options(.optionsToNotClear = new) } get_OptionsToNotClear <- function(optionsToNotClear=c()) { getOption(".optionsToNotClear", default=get_defaultOptionsToNotClear()) } clearAllOptions <- function(preserve.option=c()) { ## this function should not depend on any outside functions, since it will be called in fresh() optionNames <- names(options()) dontClear <- getOption(".optionsToNotClear", default=warning(".optionsToNotClear not set\n, this might cause some issues")) ## cannot use get_OptionsToNotClear() bceause scoping fails when running fresh() toClear <- setdiff(optionNames, c(dontClear, preserve.option)) ## remove them from .optionsToNotClear try(rm_OptionsToNotClear(toClear), silent=TRUE) ## rest a few basic options factory_fresh <- list( defaultPackages = c("datasets", "utils", "grDevices", "graphics", "stats", "methods") , digits = 7 , stringsAsFactors = TRUE , max.print = 99999 ) options(factory_fresh) ## set to NULL ## this is sames as emptylist(toClear) but that function may not be available namedNullList <- setNames(nm=toClear, obj=vector("list", length=length(toClear))) if (length(namedNullList)) options(namedNullList) return(invisible(NULL)) } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # ## DEFAULT OPTIONS options(.default_optionsToNotClear=c("add.smooth", "bitmapType", "browser", "browserNLdisabled", "CBoundsCheck", "check.bounds", "citation.bibtex.max", "continue", "contrasts", "defaultPackages", "demo.ask", "deparse.cutoff", "device", "device.ask.default", "digits", "dvipscmd", "echo", "editor", "encoding", "example.ask", "expressions", "help.search.types", "help.try.all.packages", "HTTPUserAgent", "internet.info", "keep.source", "keep.source.pkgs", "locatorBell", "mailer", "max.print", "menu.graphics", "na.action", "nwarnings", "OutDec", "pager", "papersize", "pdfviewer", "pkgType", "printcmd", "prompt", "repos", "rl_word_breaks", "scipen", "show.coef.Pvalues", "show.error.messages", "show.signif.stars", "str", "str.dendrogram.last", "stringsAsFactors", "texi2dvi", "timeout", "ts.eps", "ts.S.compat", "unzip", "useFancyQuotes", "verbose", "warn", "warning.length", "width", ".optionsToNotClear", "rxOptions", "sink", "gitBranch")) ## SET .optionsToNotClear set_OptionsToNotClear(get_defaultOptionsToNotClear()) ### --------------------------- Options Clearning --------------------------- ###