# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : console_utils.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 : NA # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # findDTbyCol ( cols, envir=globalenv() ) # # D <- .DataBrowser ( i=TRUE, x=.getDTcols(), appendToMainCols=TRUE, DT=.getDT() ) # # s ( i=TRUE, tbls=c("DT.split_percs.unexpanded", "DT.mgmtr_summary_tall", "DT.merged"), nrow=18 # # , cols.ignore=c("budget_last_modified", "gross_last_modified", "budget") ) # # undo.bank ( x ) # # undo ( ) # # term ( x, indent=4, all.terminal=TRUE ) # # quoteme ( x, semi=FALSE, copy=(.Pfm == "Darwin"), no.c=FALSE, C=" " ) # # semi ( ..., copy=TRUE, fixeq=TRUE ) # # dictAlign ( key, value=key, collect=c("c", "list"), cleanNames=FALSE, verbose=TRUE, header.key="KEY" # # , header.value="VALUE", copy=TRUE, quoteNulls=FALSE ) # # us ( ... ) # # b ( ) # # updated ( ) # # o ( ..., ignore.missing=FALSE ) # # reveal ( f, showWarnings=TRUE, sublimetext=TRUE ) # # w ( verbose="minimal" ) # # myf ( funcname, copy=TRUE, envir=.GlobalEnv, quiet=FALSE ) # # lettersplit ( x ) # # columnise ( x ) # # checkWidth ( max.width.to.check=300 ) # # setWidth ( n, confirm=TRUE, max.width.to.check=300 ) # # email ( ... ) # # subl ( f ) # # rx ( vec, r=2 ) # # dateInfo ( DT, incl.byname=TRUE, date.pat="date|month|year|day", principle="date", verbose=FALSE ) # # findColumnInDT ( namelike, DT_namelike="", all=FALSE, envir=globalenv() ) # # TEST_FUNC ( no.Default, EmptyString="", noString=character(), nullArg=NULL, naArg=NA # # , na_realArg=NA_real_, blankSpace=" " ) # # print.function ( x, max=35, ... ) # # p ( x, ... ) # # setDT ( DT.nm, envir=parent.frame() ) # # addDTcols ( cols, envir=parent.frame(), ... ) # # minusDTcols ( cols, envir=parent.frame(), ... ) # # setDTcols ( cols, envir=parent.frame(), singlecol=FALSE, showWarnings=TRUE ) # # getDT ( just.nm=FALSE, envir=parent.frame() ) # # getDTcols ( ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # # These are a collection of functions to help me interact with the console more quickly. # Not necessarilly used within a program # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## A lot of these should be sublime snipetts # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .ljo <- function(x=clipPaste(), envir=globalenv()) { ## A quick call to loadFromJesus that includes a paste and removing of quotes x %<>% removeText(pat="^\"|\"$") %>% trim loadFromJesus(x, overwrite.ifexists=TRUE, envir=envir) } findDTbyCol <- function(cols, envir=globalenv()) { DT.nms <- lsosdt(envir=envir)$name ret <- nwhich(sapply(DT.nms, function(x) any(cols %in% names(get(x))))) unname(cbind(ret, gapply(ret, function(x) commaSep(names(x))))) } .updated <- function() { # Basic time stamp of when the file was last updated. clipCopy(paste("message(\"", timestamp(pre="This File Updated: ", suffix=""), "\")" )) } .rx <- function(vec, r=2) { if (is.data.table(vec)) return(vec[, lapply(.SD, .rx, r=r)]) if (is.data.frame(vec)) return(as.data.table(vec)[, lapply(.SD, .rx, r=r)]) if (!is.numeric(vec)) vec else round(vec, r) } .setDT <- function(DT.nm, envir=parent.frame()) { if (is.data.table(DT.nm)) { DT.nm <- as.call(substitute(DT.nm)) } else { err.msg <- "DT.nm must be either (1) a data.table or (2) a single-length string, name of a data.table or (3) an expression that evaluates to a data.table" if (length(DT.nm) != 1 || !is.character(DT.nm)) stop(err.msg) if (!is.data.table(get(DT.nm, envir=envir))) stop("Could not find a data.table with name '", DT.nm, "'") } options(currentDT=DT.nm) return(invisible(DT.nm)) } .addDTcols <- function(cols, envir=parent.frame(), ...) { force(envir) currentCols <- .getDTcols() .setDTcols(unique(c(currentCols, cols)), envir=envir, ...) } .minusDTcols <- function(cols, envir=parent.frame(), ...) { force(envir) currentCols <- .getDTcols() .setDTcols(setdiff(currentCols, cols), envir=envir, ...) } .setDTcols <- function(cols, envir=parent.frame(), singlecol=FALSE, showWarnings=TRUE) { if (!is.character(cols)) stop("`cols` should be a vector of column names") if (!singlecol && length(cols)==1 && exists(cols, envir=envir)) { gcols <- get(cols, envir=envir) if (is.character(gcols)) { if (showWarnings) warning("pulled cols from envir . Use `singlecol=TRUE` to prevent this.") cols <- gcols } } if (showWarnings && !is.null(getOption("currentDT"))) { nms <- names(.getDT()) wh <- cols %in% nms if (!all(wh)) warning(warningCols("The following columns are not in the default DT", cols[!wh])) } options(currentDTcols=cols) return(invisible(cols)) } .getDT <- function(just.nm=FALSE, envir=parent.frame()) { nm <- getOption("currentDT") if (is.null(nm)) stop("You have not set the current data.table. Please run: \n\n .setDT( DT.nm )") if (identical(as.character(as.expression(substitute(just.nm))), "nms")) just.nm <- "nms" if (isTRUE(just.nm)) return(nm) ## If it's a quoted call, return the data.table it evaluates to if (is.call(nm)) { if (is.data.table(eval(nm))) return(eval(nm)) else stop("\nThe value of .getDT() is a quoted call, but it does not evaluate to a data.table\n\nTry re-setting using .setDT( __ )") } if (!exists(nm, envir=envir)) stop ("Could not find a data.table named ", nm, "\n") ## ELSE if (identical(just.nm, "nms")) { return(names(get(nm, envir=envir))) } return(get(nm, envir=envir)) } .getDTcols <- function() { cols <- getOption("currentDTcols") if (is.null(cols)) stop("You have not set the current cols. Please run: \n\n .setDTcols( cols )") return(cols) } .D <- .DataBrowser <- function(i=TRUE, x=.getDTcols(), appendToMainCols=TRUE, DT=.getDT()) { ## This is a helper function to help me display cols with less typing # eg: # maincols <- c("download_date", ".hasr", "upc", "oid", "cid", "pid" # , "artist", "title", "product", "customer_price", "wasFree", "badDataRow") # if (missing(DT) && is.null(getOption("currentDT"))) # stop("You have not set the current data.table. Please run: \n\n .setDT( DT.nm )") # if (missing(x) && is.null(getOption("currentDTcols"))) # stop("You have not set the current default columns. Please run: \n\n .setDTcols( cols )") i.sub <- substitute(i) if (toupper(as.character(substitute(x)))[[1]]=="B") { x <- setdiff(c(.getDTcols(), "badDataRow", "NOTES") , "sale_return") DT <- DT[(badDataRow)][order(NOTES, artist, pid)] } cmiss <- missing(x) if (is.data.table(x)) { DT <- x x <- .getDTcols() cmiss <- TRUE } if (identical(key(DT)[[1]], "oid")) { if (is.numeric(x) && x > nrow(DT)) { x <- as.character(x) DT <- setcolorderpt(DT[.(x)], "download_date") x <- .getDTcols() } } if (is.logical(x) || is.numeric(x)) x <- names(DT)[x] if (isTRUE(as.logical(appendToMainCols))) { x <- c(.getDTcols(), x) } cols <- intersect(x, names(DT)) # if (cmiss) # return(invisible(DT)) return(DT[i=eval(i.sub)][, cols, with=FALSE]) } .s <- function(i=TRUE, tbls=c("DT.split_percs.unexpanded", "DT.mgmtr_summary_tall", "DT.merged"), nrow=18, cols.ignore=c("budget_last_modified", "gross_last_modified", "budget")) { ## Using this for Mgmtr ... can be adjusted for others cls(4) h1 <- "\t\t ~~~~~~~~~~~~~~~~~~~~~ %s ~~~~~~~~~~~~~~~~~~~~~\n" tbl.nms <- tbls selfname_(tbl.nms) tbl.nms[["DT.split_percs.unexpanded"]] <- "DT.split_percs.unexpanded (OA) " tbl.nms[["DT.mgmtr_summary_tall"]] <- "DT.mgmtr_summary_tall (GL) " for (tbl in tbls) { cat(sprintf(h1, tbl.nms[[tbl]])) if (!exists(tbl)) { message (sprintf("%30s Table '%s' does not exist\n", "", tbl)) next } ignoring <- intersect(cols.ignore, names(get(tbl))) browser(expr=FALSE) i.sub <- {if (isErr(get(tbl)[eval(substitute(i))])) TRUE else substitute(i) } if (length(ignoring)) print(get(tbl)[eval(substitute(i.sub)), !ignoring, with=FALSE], nrow=nrow) else print(get(tbl)[eval(substitute(i.sub))], nrow=nrow) } } .undo.bank <- function(x) { if (missing(x)) x <- clipPaste .undo.bak <<- clipPaste() } .undo <- function() { clipCopy(.undo.bak) return(invisible(.undo.bak)) } .term <- function(x, indent=4, all.terminal=TRUE) { ## given a copied console output, cleans it up if (missing(x)) x <- clipPaste() splat <- strsplit(x, "\n")[[1]] if (all.terminal) { input <- grepl("^>", splat) output <- !input } else { stop("don't know how to handle !all.terminal") } splat[output] <- paste0("# ", splat[output]) splat[input] <- gsub("^> ", "", splat[input]) splat <- paste0(pasteR(" ", indent), splat, collapse="\n") clipCopy(splat) if (.Pfm != "Darwin") cat(splat) return(invisible(splat)) } .quoteme <- function(x, semi=FALSE, copy=(.Pfm == "Darwin"), no.c=FALSE, C=" ") { missing_x <- missing(x) ## allow for .quoteme(TRUE) if (!missing_x && isTRUE(x)) { semi <- TRUE missing_x <- TRUE } ## OLD: # if(missing(x)) { # x <- clipPaste() # x <- paste(x, collapse=" ") # splat <- strsplit(x, "\\(|\\)")[[1]] # if (length(splat) > 1) { # x.pre <- splat[1L] # x.sub <- splat[-1L] # } else { # x.pre <- "" # x.sub <- splat # } # x.sub <- gsub("\\\\?\"", "", x.sub) # x.sub <- unlist(strsplit(x.sub, ","), use.names=FALSE) # x.sub <- gsub("^\\s*|\\s$", "", x.sub) # x.sub <- c(x.pre, x.sub) # } # ## If x is not missing, grab as characters. Allow for unquoted string # else { # x.sub <- as.character(substitute(x)) # } if(missing_x) { x <- clipPaste() } x <- paste(x, collapse=C) ## Apply this method to x, regardless if explicit or pasted splat <- strsplit(x, "\\(|\\)")[[1]] if (length(splat) > 1) { x.pre <- splat[1L] x.sub <- splat[-1L] } else { x.pre <- "" x.sub <- splat } x.sub <- gsub("\\\\?\"", "", x.sub) x.sub <- unlist(strsplit(x.sub, ","), use.names=FALSE) x.sub <- gsub("^\\s*|\\s$", "", x.sub) x.sub <- c(x.pre, x.sub) if (!length(x.sub)) return(NULL) ## If semi is not explicitly false, and there are no commas but yes several spaces, then make semi TRUE if (missing(semi) && !any(grepl("\\,", x.sub)) && any(grepl("(.+\\s){2,}", x.sub))) semi <- TRUE if (semi) x.sub <- .semi(...=x.sub, copy=FALSE) ret <- pasteQ(unlist(x.sub[-1L], use.names=FALSE), q='"') ret <- paste0(x.sub[[1L]], ret) ret <- capture.output(cat(ret)) if (!no.c && grepl("^\\(.+\\)", ret)) ret <- paste0("c", ret) if (copy) clipCopy(ret) cat(ret, "\n") return(invisible(ret)) } .semi <- function(..., copy=TRUE, fixeq=TRUE) { # Converts commas to semicolons. ## it is possible for ...=x to be set explicitily if (!missing(...)) { x <- unlist(list(...), use.names=FALSE) } else { if(!length(list(...))) { x <- clipPaste() } else { x <- paste0(as.expression(substitute(list(...))), collapse="") x <- gsub("^list\\(|\\)", "", x) x <- gsub("\\\\?\"", "", x) if (fixeq) x <- gsub(" = ", "=", x) } } ## if there are commas, replace with semicolons. ## otherwise, replace spceas with commas, trimming out edge spaces first if (any(grepl(",", x))) x <- gsub("\\s*,", ";", x) else if (any(grepl("\n", x))) x <- gsub("\n", ",", x) else { x <- trim(x) x <- gsub("( |\\t)+", ", ", x) } ret <- sapply(x, function(x1) capture.output(cat(x1))) ret[x==""] <- "" ret <- unlist(ret, use.names=FALSE) if (copy) clipCopy(ret) # cat(ret) return(invisible(ret)) } dictAlign <- function(key, value=key, collect=c("as.dict", "c", "list"), cleanNames=FALSE , verbose=TRUE, header.key="KEY", header.value="VALUE", copy=TRUE, quoteNulls=FALSE) { # formats code for R dictionary-style collect <- match.arg(collect) # check for names if (missing(value) && !is.null(names(key))) { value <- key key <- names(key) } # if only one specified if (length(c(header.key, header.value))==1) { header.value <- paste0("# ", header.value) header.key <- paste0("# ", header.key) } # Add quotes to `value`, checking for NULLs & NA. # This also serves to force `value` first if (!quoteNulls) NNNIs <- sapply(value, is.NNNI) else NNNIs <- FALSE value[!NNNIs] <- paste0("\"", value[!NNNIs], "\"") if (cleanNames) key <- make.names(key) else if (!identical(key, make.names(key))) key <- paste0("\"", key, "\"") key <- c(key, header.key) value <- c(value, header.value) ret <- paste0(collect, "(\n ", paste( paste0(center(key, align="right"), " = ", value) , collapse="\n , "), "\n)") if (length(gregexpr("\n", ret)[[1]]) > 2) { ret <- strsplit(ret, "\n")[[1]] ret <- moveTo(ret, length(ret)-1, 2) ret[[2]] <- gsub("^(\\s*),", "\\1#", ret[[2]], perl=TRUE) ret <- paste(ret, collapse="\n") } if (copy) clipCopy(ret) if (verbose) catn(ret) return(invisible(ret)) } ## Shorthand functions for commonly used in interactive mode .a <- args .us <- function(...) { if (exists("utilSource")) utilSource(...) else { utilFile <- "~/git/misc/rscripts/utilsRS.r" if (file.exists(utilFile)) { tryCatch(source(utilFile), error = function(e) {e$message <- paste("utilFile was found, but could not be reloaded. Error thrown was: \n", e$message); stop(e)}) if (exists("utilSource")) utilSource(...) else stop("utilFile was reloaded, but utilSource still not found.\nFile loaded was: '", utilFile, "'\n") ## utilFile not found } else { stop ("utilSource not found and default utilFile not found either.\nFile attempted was: '", utilFile, "'\n") } } # // end else (for original utilSource not found) } # // end .us() .b <- function() { link <- "http://bit.ly/3Ft8Ck2" cat("Quick link: ", link, "\n") clipCopy("3Ft8Ck2") return(invisible(NULL)) } .o <- function(..., sublauto=TRUE, ignore.missing=FALSE) { ## wrapper function to open files, usually excel files. ## Avoids having to {print/copy/open_finder/navigate/open} dots <- gsub("^\\s+|\\s+$", "", ...) x <- as.path(dots) # if no files in the current dir, try dataDir if (areEqual(dirname(x)) && !any(basename(x) %in% dir(dirname(x))) && exists("dataDir")) { ## if the base name is in the if (any( x %in% dir(dataDir) )) x <- as.path(dataDir, x) else if (any( basename(x) %in% dir(dataDir) )) { warning("Files not found in given directory, but they were in the `dataDir`.\nOpening from ", dataDir,"\n") x <- as.path(dataDir, basename(x)) } } if (ignore.missing) { x <- x[file.exists(x)] } # if nothing to open, exit quietly if (!length(x)) return(invisible(NULL)) ## Ship it to subl if (isTRUE(sublauto) && all(grepl("\\.(csv|logr|txt|tsv)$", x))) { return(subl(x)) } ## # I was attempting to catch any errors, but forgot that the system errors are not R errors ## caught <- vector(mode="character", length=length(x)) for (i in seq_along(x)) { ## escape any single quotes, since we will throw the whole thing in single quotes x[[i]] <- gsub(pattern="'", replacement="\\\\'", x[[i]]) ## try to open the file system(paste0("open '", path.expand(x[[i]]), "'") ) } } reveal <- function(f, showWarnings=TRUE, sublimetext=TRUE, rprofile_file="~rsaporta/git/misc/rscripts/RickysRprofile.R") { ## wrapper function to open in finder the parent directory of the file, or the function f if (!is.character(f) || is.function(f)) f <- as.character(substitute(f)) ## If parent folder exists, reveal it or it's path if (file.exists(f)) { if (!isdir(f, showWarnings=FALSE)) f <- dirname(f) .o(f) return(invisible(f)) } ## ELSE fun <- try(match.fun(f), silent=TRUE) if (!isErr(fun)) { loc <- locate(fun) cat(loc, "\n") if (getPfm() == "Darwin" && isTRUE(sublimetext)) { if (loc == ".Rprofile") loc <- rprofile_file subl(loc) } else { tryCatch(.o(loc), error=function(e) .o(dirname(loc))) } } else verboseMsg(showWarnings, "Could not find file or function \"", f, "\"", time=FALSE) return(invisible(loc)) } .w <- function(verbose="minimal") { #wrapper for who am I and where am I working Who <- system("whoami", TRUE) Where <- system("pwd", TRUE) What <- Sys.info()[['sysname']] if (What == "Darwin") What <- "Mac OS X" ret <- list(Who=Who, What=What, Where=Where) if (identical(verbose, "minimal")) cat("\n", paste("\ [", Who, "]\n\ [", What, "]\n\ [", Where, "]"), "\n\n", sep="") else cat("\n", paste("\tYou are [", Who, "]\n\tWorking on a [", What, "] system.\n\tCurrent dir is [", Where, "]"), "\n\n", sep="") return(invisible(ret)) } # ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # .myf <- function (funcname, copy=TRUE, envir=.GlobalEnv, quiet=FALSE) { ## finds a function matching funcname and copies it to clipboard ## while also outputting other possible matches ## eg: `.myf(mkQ)` to find `makeQuery` # wrapper function around strsplit that checks if first char is "^" lettersplit <- function(x) { splat <- strsplit(x, "")[[1]] if (splat[[1]] == "^") { splat[[2]] <- pasteC(splat[1:2]) splat <- splat[-1L] } splat } funcname <- as.character(substitute(funcname)) force(envir) # ret <- lsos(type="f", copy=FALSE, all.names=TRUE, b=1, functions.returned.normally=TRUE) Names <- nwhich(sapply(ls(envir=envir, all.names=TRUE), function(x) is.function(get(x)))) # old searchpat_01 <- paste0("^", funcname) # old searchpat_02 <- funcname # old searchpat_03 <- paste(strsplit(funcname, "")[[1]], collapse="(.{1,2})") # one or two letters between # old searchpat_all <- paste(strsplit(funcname, "")[[1]], collapse="(.*)") # any amount of letters in between searchpat_01 <- paste0("^", funcname) searchpat_02 <- funcname searchpat_03 <- paste(lettersplit(funcname), collapse="(.{1,2})") # one or two letters between searchpat_all <- paste(lettersplit(funcname), collapse="(.*)") # any amount of letters in between ## so as to not have to search the whole list everytime found <- grep(searchpat_all, Names, ignore.case=TRUE, value=TRUE) results <- c() searchpats <- list(searchpat_01, searchpat_02, searchpat_03) for (pat in searchpats) { l <- length(results) for (TF in c(FALSE, TRUE)) results <- c(results, setdiff(grep(pat, found, ignore.case=TF, value=TRUE), results)) if (length(results) > l) results <- c(results, "\n") } remaining <- setdiff(found, results) if (!quiet) { columnise <- function(x) gsub("\\s*\\n\\s*", "\n", paste_l(x, spacer=" ", sameWidth=TRUE, cols=3)) out <- columnise(results) out <- c(out, pasteR(66), columnise(remaining), "\n") out <- paste0(gsub("^\\s*", "", out), collapse="\n") out <- gsub("(^|\n)", "\\1 ", out) cat("\n", out, "\n", sep="") } results <- unique(setdiff( c(results, remaining) ,"\n")) if (copy && exists("clipCopy")) { if (!length(results)) clipCopy(results) else clipCopy(results[[1L]]) } return(invisible(results)) } checkWidth <- function(max.width.to.check=300, common_widths=c(101, 118, 142, 170, 211, 238, 251, 286)) { ## Pastes the digits 0:9 repeatedly, with every iteration, indicating the tens digit .prev.width <- options(width=max.width.to.check) [["width"]] max.width.adj <- (max.width.to.check - (trunc(log(300, 10))-1)) / 10 w <- ceiling(max.width.adj) ch <- c(as.character(1:9), "0") # ch[1:2] <- c("+") # ch[10] <- "*" dec <- paste(ch, collapse="") decs <- replicate(w, dec) for (i in seq( floor(max.width.adj) )) { nc <- nchar(i) # nc is always at least 1 substr(decs[[i]], 11 - nc, 10) <- as.character(i) substr(decs[[i]], 10 - nc, 10 - nc) <- " " if (i < w) substr(decs[[i+1]], 2, 2) <- "," } out <- paste(decs, collapse="") out <- substr(out, 1, max.width.to.check) if (length(common_widths)) { common_widths %<>% sort mins_cw <- c(0, head(common_widths, -1)) cw <- sapply(seq_along(common_widths), function(i) { common_widths[[i]] %>% {. - mins_cw[[i]] - nchar(.)} %>% pasteR(x=".") }) %>% paste0(common_widths, collapse="") out %<>% c(cw, "\n", .) } cat("\n", out, "\n", sep="") options(width=.prev.width) } setWidth <- function(n, confirm=TRUE, max.width.to.check=378, dont.shrink=FALSE) { if (missing(n)) { checkWidth(max.width.to.check=max.width.to.check) n <- readline("Input width or copy+paste one line> ") if (tolower(n) %in% c("q", "x")) return(invisible(NULL)) n <- as.numeric(n) } # normally called after `checkWidth()` if (is.character(n)) n <- nchar(strsplit(n, "\n")[[c(1,1)]]) ## check against current width current <- getWidth(actual=TRUE) if (dont.shrink && n < current) { cat(sprintf("Will not change the width since the selected value (%i) is less than the current width (%i)\n", n, current)) return(invisible(current)) } ret <- options(width=n) if (confirm) { cat("Width set to ", n, ". Confirming :\n", sep="") checkWidth(max.width.to.check=n) info <- ifelse(n>72, " <~~~~~ { The 'x' should be the first char on the next line if exact }", "") cat(paste(c("[", rep("-", n-2), "]x"), collapse=""), info, "\n", sep="") } return(invisible(ret)) } .email <- function(...) { EmailStatusUpdate(...) } subl <- function(f) { # system(sprintf("subl %s", shellClean(trim(f)))) f %>% trim %>% shellClean %>% sprintf("subl %s", .) %>% system } dateInfo <- function(DT, incl.byname=TRUE, date.pat="date|month|year|day", principle="date", verbose=FALSE) { DT.nm <- capture.output(substitute(DT)) ## identify date cols by class Date dateCols.byClass <- nwhich(sapply(DT, inherits, "Date")) ## identify date cols by date.pat dateCols.byName <- extract(date.pat, DT, ignore.case=TRUE) ## byName will only be used to add to byClass dateCols.byName <- setdiff(dateCols.byName, dateCols.byClass) ## simple return. TODO: clean output dateCols <- unique(c(dateCols.byClass, dateCols.byName)) ret <- rbindlist( lapply(dateCols, function(col) { x <- DT[[col]] x.isdate <- inherits(x, c("Date", "POSIXct", "POSIXlt")) as.data.table(list( column = col, minDate = as.Date(if (x.isdate) minn(x) else NA), maxDate = as.Date(if (x.isdate) maxn(x) else NA), min_NonDate = as.character(if (!x.isdate) minn(x) else NA), max_NonDate = as.character(if (!x.isdate) maxn(x) else NA), hasNAs = any(is.na(x)), colIsDate = x.isdate, class = class(x)[[1]] )) }) ) if (all(is.na(ret[, list(min_NonDate, max_NonDate)]))) ret[, c("min_NonDate", "max_NonDate") := NULL ] l.byClass <- length(dateCols.byClass) l.byName <- length(dateCols.byName) msg.out <- sprintf("%s has %i date columns", DT.nm, l.byClass) if (l.byName) msg.out <- sprintf("%s with an additional %i columns whose name matches '%s'", msg.out, l.byName, date.pat) if (principle %in% names(DT)) msg.out <- sprintf("%s\n'%s' is a column in %s and ranges from %s to %s", msg.out, principle, DT.nm, minn(DT$date), maxn(DT$date)) if (verbose) cat(msg.out, "\n\n") return(ret) } findColumnInDT <- function(namelike, DT_namelike="", all=FALSE, envir=globalenv()) { ls.objs <- ls(pattern=DT_namelike, all=all, envir=envir) dts <- ls.objs[gapply(ls.objs, is.data.table, simplify=TRUE)] if (!length(dts)) { warning ("No data.tables found", if (DT_namelike == "") " in environment" else paste0(" matching pattern '", DT_namelike, "'")) return() } dt_cols <- gapply(dts, function(DT) grep(namelike, names(DT), value=TRUE)) dt_cols <- dt_cols[sapply(dt_cols, length) != 0] cat(sprintf(" %-25s :: %s", names(dt_cols), sapply(dt_cols, pasteC, C=", ")), sep="\n") # ret <- lapply(names(dt_cols), function(nm.DT) c(nm.DT, get(nm.DT)[, sprintf("%s (%s)", names(.SD), sapply(.SD, class)), .SDcol=dt_cols[[nm.DT]] ]) ) return(invisible(dt_cols)) } slowList <- function(ll) { ## outputs a single list one element at a time, requiring user input between elements inds <- seq_along(ll) nms <- ifelseNULL(names(ll), no=names(ll), sprintf("Element %02i", inds)) for (i in inds) { cat(sprintf("\n\t ---- %s ----\n", nms[[i]] )) print(ll[[i]]) readline() } return(invisible(NULL)) } TEST_FUNC <- function(no.Default, EmptyString="", noString=character(), nullArg=NULL, naArg1=NA, naArg2=NA, naArg3="NA", na_realArg=NA_real_, blankSpace=" ") { ## This is an example for print.function print.default(TEST_FUNC) TEST_FUNC TEST_FUNC %P% . ggLinegraph ## other test: sum range as.num.as.char read.table debug(print.function) } print.function <- function(x, max=35, ..., verbose=TRUE) { args <- formals(x) ## some primitive functions, sum() range() etc, yield NULL for formals(x) if (!length(args)) { cat(clean.capture.output(print.default(args(x))), fill=TRUE, sep="\n") return(invisible(NULL)) } e.working <- environment() ## Find which are blank characters is_blank_char <- args %>% unlist %>% sapply(function(x) is.character(x) && trim(x) == "") %>% {if (length(.)) which(.) %>% "+"(1) else .} # is_blank_char <- args %>% unlist %>% sapply(function(x) is.character(x) && x == "") %>% which %>% "+"(1) ## find which are actual blanks as opposed to no default is_actually_blank <- which(sapply(args, function(x) !(is.character(x)) && x == "")) + 1 trim2 <- function(x) if (any(grepl("^\\s+$", x))) x else trim(x) args[] <- sapply(args, function(a) {z <- clean.capture.output(a, envir=e.working, pipe_ok=TRUE); pasteC({trim2(z)}, C=" ")}) ## capture different types on NA -- ie NA_real_ NA_character_ wh.na <- nwhich(args == "NA") if (length(wh.na)) { solid_args <- capture.output(print.default(args(x))) %>% gsub("^\\s+", "", .) %>% pasteC(C=" ") for (a in wh.na) { pat <- paste0(".*\\b", a, "\\s*=\\s*(\"?NA(_[a-z]+_)?\"?)\\b.*") args[[a]] <- gsub(pat, "\\1", solid_args) %>% ifelse(.=="\"NA", "\"NA\"", .) if (args[[a]] == solid_args) args[[a]] <- "NA (? print.function)" } } x_contains_gg_GenericProcessing <- (body(x) %>% as.character %>% tail(10) %>% grepl(pat="gg_GenericProcessing") %>% any) ## use print.dict for the clean output maxdots <- ifelse(x_contains_gg_GenericProcessing, 50, 30) force(maxdots) # browser(text="clean-captu") out <- clean.capture.output(print.dict(args, quote=FALSE, maxdots=maxdots), pipe_ok=TRUE) ## Change the "KEY" to "ARG" out[[1]] <- gsub(" \\[ KEY \\] \\.", "[ ARG ] .", out[[1]]) ## replace NULLS nulls <- sapply(args, is.null) if (any(nulls)) { nulls <- which(nulls) + 1 out[nulls] <- gsub(" character\\(0\\)", "........ NULL", out[nulls]) } ## pad it to the right a little bit out[2:length(out)] <- paste0(pasteR(" ", 4), out[2:length(out)]) ## args with out a default get their dots removed ## Update 2015-06-21: Some functions, like write, have default arguments that are blank spaces, but not an empty string. ## These issue problems. Thus now handling with forloop ## OLD: out[is_actually_blank] <- gsub("^(\\s*[A-Za-z].*? )\\.+", "\\1", out[is_actually_blank]) ## NEW: for (nm in names(is_blank_char)) { pat <- sprintf("\\.{1,%i}(\\s*$)", nchar(args[[nm]]) + 3) repl <- sprintf(" \"%s\"\\1", args[[nm]]) out[is_blank_char[[nm]]] <- gsub(pat, repl, out[is_blank_char[[nm]]]) } if (x_contains_gg_GenericProcessing) { if (!identical(body(x), body(gg_GenericProcessing))) out <- c(" ---- gg_GenericProcessing ---- ", print.function(gg_GenericProcessing, verbose=FALSE) %>% tail(-5), "\n", out) } # ## I had the idea of heading this with the function name, but that will not work # ## when simply typing the function name into the console # fun.nm <- paste0(capture.output(substitute(x)), "( )") # out <- c(paste0(pasteR(" ", maxn(0, (mnchar(out) - nchar(fun.nm)) / 2)), fun.nm), out) if (verbose) # cat(substr(out, 5, nchar(out)), sep="\n") cat(out, sep="\n") return(invisible(out)) } ## READ LOG FILE rlf <- function(x) { trim(x) %>% readLines %>% catn("\n",. , sep="\n", "") } ## CLASSIC PRINT FUCNTION ## Two ways of calling it. `%P%` <- function(LHS, ...) { ## alternate for quicker typing. eg: ## ggLinegraph ## ggLinegraph %P%. print.default(LHS) } .p <- function(x, ...) { print.default(x, ...) } .ml <- function(folder) { if (!nchar(getProjName(showWarnings=FALSE))) setScience(proj="Looker", subProj="MakingXLSX", subl=FALSE, load=FALSE) else sourceSupportFns(proj="Looker") catn( " Functions Are: -------------------------------- create_lookml_from_tbl (schema=schema, tbl=tbl, dbname=dbname, wh=wh) create_lookml_model (schema=schema, tbl=tbl, dbname=dbname, wh=wh) create_lookml_model_from_schema (schema=schema, tbl=tbl, dbname=dbname, wh=wh) cleanLookerHeaders(file.fullpath=f, is_applemusic=FALSE) combine_looker_exports_to_excel(folder=fold, ext='csv', force=FALSE) ") if (!missing(folder) && is.character(folder) && length(folder) ==1 && file.exists(folder)) { message("Executing combine_looker_exports_to_excel(folder) ... ") return(combine_looker_exports_to_excel(folder)) } else { return(invisible(NULL)) } }