# --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : desc and getInfo.r # # Last Updated Funclist : 17 Feb 2015, 5:57 PM (Tuesday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : NA # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # setDateCol ( x, dateCol, showWarnings=TRUE ) # # getInfo_lastupdated ( x ) # # hasInfo ( x ) # # desc ( ll, simplify=TRUE, listlist=is.list(ll[[1]]), notClassy=FALSE, cols=4, maxWidth=130 # # , sort=FALSE, quiet=FALSE, tight.out=hasInfo(ll) || haskey(ll), warn.use.desc=TRUE # # , showInfo=!quiet, showKey=!quiet ) # # areclassy ( ll, verbose=!quiet, cols.verbose=4, maxLineWidth.verbose=88, sort=FALSE, quiet=FALSE # # , tight.out=hasInfo(ll) || haskey(ll) ) # # getDateCol ( x, value.if_null, guess.if_null=TRUE, showWarnings=TRUE ) # # appendInfoFromMany ( ..., more=NULL, func=c("merge", "rbind", "cbind", "join", "outter-join", "inner-join") ) # # assignWithInfo ( name # # , value, info=if (exists(orig.DT, inherits=TRUE)) paste0("modified from ", orig.DT) else stop("Please provide 'info', since orig.DT cannot be determined"), info.orig=if (exists(orig.DT, inherits=TRUE)) getInfo(get(orig.DT, inherits=TRUE), showWarnings=FALSE, verbose=FALSE) # # , envir=globalenv(), warnOnEnvir.nonmatch=TRUE ) # # previousInfo_text ( nm, bar="-", endl=TRUE, nc.DT=13 ) # # setInfo ( x, info, width.to.chop.to=120 ) # # clearInfo ( x, info ) # # appendInfo ( new.info, orig.info, DT.nm="previous DT", DT, showWarnings=TRUE ) # # getInfo ( x, verbose=!quietly, showWarnings=!quietly, x.nm=NULL, quietly=FALSE ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # setDateCol <- function(x, dateCol, showWarnings=TRUE) { x.nm <- capture.output(substitute(x)) ## used for output messages if (dateCol %ni% names(x)) verboseMsg(showWarnings, "in setDateCol() ", x.nm, " does not contain dateCol='", dateCol, "'") ## TODO: Consider including pasteQ(names(x)) setattr(x, "dateCol", dateCol) return(invisible(x)) } getDateCol <- function(x, value.if_null, guess.if_null=TRUE, showWarnings=TRUE) { x.nm <- capture.output(substitute(x)) ## used for output messages ret <- attr(x, "dateCol", exact=TRUE) ## if ret is a value, return it -- although first check that it is a column of x if (!is.null(ret)) { if (ret %ni% names(x)) verboseMsg(showWarnings, "dateCol='", dateCol, "' is not a column of ", x.nm) return(ret) } if (is.null(ret) && !missing(value.if_null)) { if (value.if_null %ni% names(x)) verboseMsg(showWarnings, x.nm, "does not have a dateCol attribute AND value.if_null=',", value.if_null, "' is NOT a column name") return(value.if_null) } ## if we are NOT dealing with a data.table, do not try to guess. Return whatever we have upuntil this point if (!is.data.table(x)) { ## throw a warning if it looks like user meant to use getDateColForTBL() if (is.null(ret) && is.character(x) && length(x) == 1 && grepl("staging|fact|analytics|accounting|sales|raw|dim", x) && !grepl("SELECT |FROM ", x) && nchar(x) > 60) warning ("'", x, "' does not have a date attribute\n\n HINT: did you mean to call\n\n getDateColForTBL('", x, "') \n ", call.=FALSE) return(ret) } ## Otherwise, try to guess the dateCol. ## Look for cols with date attributes and with possible names guessing_candidates <- c("date", "accounting_month", "accounting_date", "download_activity_date", "activity_month", "activity_date") guessed.byClass <- getDateColNames(x, byName=FALSE, byClass=TRUE) guessed.byName <- intersect(guessing_candidates, names(x)) if (identical(sort(guessed.byName), sort(guessed.byClass))) { if (length(guessed.byName) > 1) { verboseMsg(showWarnings, "Multiple matches found for guessed result -- returning NULL. Please use 'value.if_null'\nFound results are: ", pasteQ(guessed.byName, w="")) return(NULL) } message("Guessing dateCol to be '", guessed.byName, "'") return(guessed.byName) } verboseMsg(showWarnings, x.nm, " does not have a dateCol attribute and we were unable to guess one -- returning NULL.\nPlease use 'value.if_null'") return(NULL) } appendInfoFromMany <- function(..., more=NULL, func=c("merge", "rbind", "cbind", "join", "outter-join", "inner-join")) { ## func :: can be NULL ## TODO: Add option to not evaluate the dots in the string output if (!is.null(func)) func <- match.arg(func) dots <- list(...) wrongArgs <- c("fun", "Func", "Fun") if (any(wh <- wrongArgs %in% names(dots))) { warning("Detected argument(s) in appendInfoFromMany() similar to 'func' -- was this intentional? Arguments detected are: ", pasteQ(wrongArgs[wh], w="")) } ## If no dots, return more -- unless more is NULL, in which case fail so as to not accidentally overwrite existing info if (!length(dots)) { if (is.null(more)) stop("No info to append") warning("No info to append. If this was intentional consider using the simpler setInfo(..) ") return(more) } ## Grab the names from the dots nms.dots <- names(dots) if (is.null(nms.dots)) nms.dots <- rep("", length(dots)) ## Grab the names / values from match.call() nms.mc <- as.character(unlist(as.list(match.call(expand.dots=FALSE)[["..."]]))) ## Identify which are DTs are_DT <- sapply(dots, is.data.table) ## identify which dots have nms has_nms <- nms.dots != "" ## any non-DT with no given names is an issue if (any(!are_DT & !has_nms)) warning("Some additonal arguments to appendInfoFromMany() have no names", call.=FALSE) ## if it's a DT and has not been giving a name, use the match.call name (ie, the DT name in the previous envir) nms.using <- ifelse(are_DT & !has_nms, nms.mc, nms.dots) args_string <- pasteQ(sprintf("%s%s%s", nms.using[!are_DT], ifelse(has_nms[!are_DT], "=", ""), substr(sapply(dots[!are_DT], pasteC), 1, 400) ), w="", q="") ret <- paste0( if (!is.null(func)) paste(func, "of ") , pasteQand(nms.using[are_DT], q="") , if (nchar(args_string)) paste("\nusing args", args_string) , if (!is.null(more)) "\n" , more ) ## infos <- sapply(dots[are_DT], getInfo, quiet=TRUE) ret <- paste0(ret, "\n\n", pasteC(.previousInfo_text(nms.mc[are_DT], bar="="), ifelse(sapply(infos, is.null), "< None Found >", infos), C="\n")) return(ret) } assignWithInfo <- function( name , value , info = if (exists(orig.DT, inherits=TRUE)) paste0("modified from ", orig.DT) else stop("Please provide 'info', since orig.DT cannot be determined") , info.orig = if (exists(orig.DT, inherits=TRUE)) getInfo(get(orig.DT, inherits=TRUE), showWarnings=FALSE, verbose=FALSE) , envir = globalenv() , warnOnEnvir.nonmatch = TRUE ) { ## warnOnEnvir.nonmatch :: useful when calling assignWithInfo() from within another function and the target envir is different than parent.frame ## If this is TRUE, this function checks that the target envir matches parent.frame and wanrs if that is not the case ## Assigns name <- value, then sets attribute of name with info ## Check where assigning to if (!identical(parent.frame(), envir) && warnOnEnvir.nonmatch) { warning ("Assigning to ", cleanEnvirString(envir), " where as parent.frame() is ", cleanEnvirString(parent.frame())) } ## 'name' can be a quoted or unquoted string. If we are overwriting a data.table, it might be the name of an existing data.table e.working <- environment() ## the current working environment, needed for substitute name <- tryCatch( expr = if (suppressWarnings(is.character(name))) name else as.character(substitute(name, env=e.working)) , error = function(e, e.w=parent.frame(2)) {as.character(substitute(name, env=e.working))} ) ## we will try to match the original DT(s) used in 'value'. ## The following are known functions that might be val.sub[[1]] that are not DT names funcs_not_DTs <- c("[", "copy", "(", ")", "merge", "rbind", "rbind.data.table", "cbind") val.sub <- substitute(value) as.list(val.sub) orig.DT <- val.sub[[1]] if (as.character(orig.DT) %in% funcs_not_DTs) { orig.DT <- val.sub[[2]] while (is.call(orig.DT) && as.character(orig.DT[[1]]) %in% funcs_not_DTs) orig.DT <- orig.DT[[2]] ## TODO: orig.DT.join ?? } orig.DT <- capture.output(orig.DT) message("assignWithInfo:: Using orig.DT = '", orig.DT, "'") if (missing(info)) { if (!exists(orig.DT, inherits=TRUE)) { warning("info was not provided and we could not auto-determine the source of value.\nPlease provide 'info' (and perhaps investigate assignWithInfo() for bugs)") derived <- "[UNKNOWN SOURCE]" } else derived <- orig.DT info <- sprintf("Derived from '%s' (assignWithInfo)", derived) } orig.info <- getInfo(value, quietly=TRUE) if (is.null(orig.info) && exists(orig.DT, inherits=TRUE)) orig.info <- getInfo(get(orig.DT, inherits=TRUE), quietly=TRUE) info <- appendInfo(info, orig.info, DT.nm=orig.DT) # if (!is.null(info.orig) && is.character(info.orig) && !info.orig == "") # info <- sprintf("%s\n\n-------------- Previous Info for %s: -------------- \n%s\n", info, orig.DT, info.orig) assign(name, value, envir=envir) setInfo(get(name, envir=envir), info=info) return(invisible(get(name, envir=envir))) } .previousInfo_text <- function(nm, bar="-", endl=TRUE, nc.DT=13) { endl <- ifelse(isTRUE(endl), "\n", "") hr <- pasteR(bar, n=16) frmt <- paste0(" %s [ Previous Info for %-",nc.DT,"s: ] %1$s%s") sprintf(frmt, hr, nm, endl) } setInfo <- function(x, info, width.to.chop.to=120) { ## chop it if it is very long if (!is.null(width.to.chop.to) && is.finite(width.to.chop.to)) info <- chopAfterWord(info, " ", maxLength=width.to.chop.to, split=TRUE, C="\n") setattr(x, "info", info) setattr(x, "info_lastupdated", sprintf("The info attribute was last updated on %s", now())) return(invisible(x)) } clearInfo <- function(x, info) { setattr(x, "info", NULL) setattr(x, "info_lastupdated", sprintf("[ info was cleared on %s ]", now())) return(invisible(x)) } appendInfo <- function(new.info, orig.info, DT.nm="previous DT", DT, showWarnings=TRUE) { if (is.data.table(new.info)) stop ("new.info should be a string. It is set to be a data.table\nHINT: If you want to modify the info of the data.table, for now you have to use\n setInfo(DT, appendInfo(new.info, DT=DT))") if (missing(orig.info)) { if (!missing(DT)) orig.info <- getInfo(DT, quiet=TRUE) else if (!missing(DT.nm)) orig.info <- getInfo(get(DT.nm, inherits=TRUE), quiet=TRUE) else stop("orig.info is missing and neither DT not DT.nm were given") } if (is.data.table(orig.info)) { if (missing(DT) && missing(DT.nm)) { DT.nm <- capture.output(substitute(orig.info)) DT <- orig.info } orig.info <- getInfo(DT, quiet=TRUE) } ## NOTE: DT is not used right now, as I am not confident in the nesting nature if (!missing(DT)) { ## if DT.nm was not given, use the one just determined ## otherwise, since both DT.nm and DT were given, check that they match ## (ie, check that my coding of environments is correct) if (missing(DT.nm)) { DT.nm <- capture.output(substitute(DT)) } else { check.DT.nm <- substitute(DT, env=parent.frame()) check.DT.nm <- capture.output(check.DT.nm) if (check.DT.nm != DT.nm && showWarnings) warning ("DT.nm ('", DT.nm, "') does NOT match the auto-substituted name ('", check.DT.nm, "') in appendInfo") # else # message("DT.nm ('", DT.nm, "') was confirmed in appendInfo, matching substitute() value") } } ## Collapse the infos if they are splat'ed if (length(new.info) > 1) new.info <- pasteC(new.info, C="\n") if (length(orig.info) > 1) orig.info <- pasteC(orig.info, C="\n") if (!length(orig.info) || !is.character(orig.info) || !nchar(orig.info)) ret <- sprintf("%s\n(No previous info available for %s)", new.info, DT.nm) else { ret <- ## consider alternate HR := -------------- Previous Info for %s: -------------- sprintf("%s\n---------------- [Previous Info for %s:] ----------------\n%s\n(previous info last updated %s)" # sprintf("%s\n-- [ info from %s] --\n%s\n(previous info last updated %s)" , new.info, DT.nm, orig.info, getInfo_lastupdated(orig.info)) } return(ret) } getInfo <- function(x, verbose=!quietly, showWarnings=!quietly, x.nm=NULL, quietly=FALSE) { ## The difference between quietly and verbose is that quietly turns off warnings and outputs ## verbose only controls output, but leaves warnings unchanged. ## Manually setting quietly AND (verbose or showWarnings) is the equivalent to manually setting just verbose and showWarnings ## For messages if (is.null(x.nm)) x.nm <- capture.output(substitute(x)) info <- attr(x, "info", exact=TRUE) last_updated <- getInfo_lastupdated(x) ## IF NULL, issue either warning or show the cleared time if (is.null(info)) { if (is.null(last_updated) || !grepl("cleared on", last_updated)) { verboseMsg(showWarnings, x.nm, " has no info attribute") return (invisible(NULL)) } verboseMsg(verbose, boxit(last_updated), "\n", simple=TRUE, time=FALSE) return(invisible(NULL)) } last_updated <- getInfo_lastupdated(x) setattr(info, "info_lastupdated", last_updated) # cat(boxit(paste0(info, "\n", pasteR("-", 35), "\n", attr(x, "info_lastupdated"), "\n")), "\n") if (verbose) { info_box <- boxit(paste0(info, "\n", pasteR("-", 35), "\n", last_updated, "\n"), min_width=90) heading <- sprintf("------------=:{ %s }:=--------------", x.nm) cat(pasteR(" ", (mnchar(unlist(strsplit(info_box, "\n"))) - nchar(heading)) / 2), heading, "\n", info_box, "\n", sep="") } return(invisible(info)) } getInfo_lastupdated <- function(x) { ret <- attr(x, "info_lastupdated", exact=TRUE) if (is.null(ret)) return ("[unknown time]") return(ret) } hasInfo <- function(x) { !is.null(attr(x, "info")) } desc <- function(ll, simplify=TRUE, listlist=is.list(ll[[1]]), notClassy=FALSE, cols=4, maxWidth=130, sort=FALSE, quiet=FALSE, tight.out=hasInfo(ll) || haskey(ll), warn.use.desc=TRUE, showInfo=!quiet, showKey=!quiet) { ## check if ll is a vector of DT names is.DT.names <- is.vector.of.object.names(ll, class.to.check.for="data.table") if (is.DT.names && isTRUE(attr(is.DT.names, "group.class"))) { cat("\n\n") tight.out <- ifelse(missing(tight.out), TRUE, tight.out) return(invisible(lapply(ll, function(x) {cat(sprintf("\n ---++====<{ %s }>====++---", sprintfcenter(x, mn=ll))) desc(get(x), notClassy=notClassy, cols=cols, maxWidth=maxWidth, sort=sort, quiet=quiet, tight.out=tight.out, warn.use.desc=FALSE ) } ))) } if (!length(ll)) { warning("`", as.character(as.expression(substitute(ll))), "` has no length. Returning NULL") return(invisible(NULL)) } if (length(ll) > 1e5 && is.atomic(ll)) { if (!allow.long.vector) stop ("input to desc was a vector - was this on purpose? Printing the output on such a long vector will be costly. \n\nTo force-run, use: allow.long.vector=TRUE") } if (showInfo) getInfo(ll, x.nm=capture.output(substitute(ll)), showWarnings=FALSE) if (showKey && is.data.table(ll)) cat(" KEY COLS : ", ifelse(haskey(ll), paste0("c", pasteQ(key(ll))), " [ unassigned ]"), "\n", print.dims(ll), "\n\n") if (listlist) { # if all the same length, return a nice table. Else return a list. if (areEqual(sapply(ll, length))) return(t(sapply(ll, desc, notClassy=TRUE, quiet=quiet))) else return(invisible(lapply(ll, desc, notClassy=notClassy, quiet=quiet))) } if (!notClassy && is.data.frame(ll)) return(areclassy(ll, cols.verbose=cols, maxLineWidth.verbose=maxWidth, sort=sort, quiet=quiet, tight.out=tight.out)) else return(sapply(ll, function(x) is(x)[[1]], simplify=simplify)) } areclassy <- function(ll, verbose=!quiet, cols.verbose=4, maxLineWidth.verbose=88, sort=FALSE, quiet=FALSE, tight.out=hasInfo(ll) || haskey(ll)) { ## Error check if (!length(ll)) { warning("`", as.character(as.expression(substitute(ll))), "` has no length. Returning NULL") return(invisible(NULL)) } cl <- desc(ll, listlist=FALSE, simplify=TRUE, notClassy=TRUE, showInfo=FALSE, showKey=FALSE) cl.u <- unique(unlist(cl, use.names=FALSE)) ret <- rbindlist(lapply(cl.u, function(r) data.table(Class=r, Columns=names(which(cl==r))))) ## Order the Classes according to this manual order classOrder <- c( "Date", "POSIXct", "POSIXlt" , "idcol", "character", "factor", "integer", "numeric", "perc" , "list", "data.table", "data.frame") classOrder <- c(classOrder, setdiff(ret[["Class"]], classOrder)) # classOrder <- rightjoin(classOrder, ret[["Class"]]) ret[, Class.factor := factor(Class, levels=classOrder)] ## sort just by `Class` or by `Class` & `Column`? if (sort) setkey(ret, Class.factor, Columns) else setkey(ret, Class.factor) if (verbose) { cols <- cols.verbose ## Determine the length of chracters per row. If too long, take down the # -------------------------------------------------------------------- # .nc.left <- ret[, 4 + max(nchar(as.character(Class)))] while (cols > 1 && { ret[, list(Columns, Class, .R.Row=(seq_along(Columns)-1) %/% cols), by=Class][, list(.nc= (cols-1) * (2+max(nchar(Columns))) + nchar(tail(Columns, 1)) + .nc.left ), by=list(Class, .R.Row)][, any(.nc >= maxLineWidth.verbose)] }) { cols <- cols - 1 } # -------------------------------------------------------------------- # ret.out <- ret[, list(Class.str= c(Class, rep(pasteR(" ", Class), ceiling(.N/cols))) , Columns= c(paste_l(Columns, space=", ", eol=TRUE, endl="", cols=cols, preline=" ", collapse=NULL, sameWidth=FALSE), " ") ) , by=Class] out <- ret.out[, sideByside(center(Class.str, align="left"), center(Columns, align="left"), sep=": ")] out <- gsub("\\s*$", "", out) continued.line <- grepl("^ +\\:", out) out[continued.line] <- gsub(" \\:", " ", out[continued.line]) if (tight.out) out <- out[!grepl("^\\s+$", out)] cat(ifelse(tight.out, "", "\n"), out, "", sep="\n") } ret[, Class.factor := NULL] setkey(ret, Class) return(invisible(ret)) }