# --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : utilsRS.r # # Last Updated Funclist : 10 Feb 2015, 5:49 PM (Tuesday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : shiny, stringr # # Packages Used via NS : base, data.table, lubridate, pkgs[stringr, utils # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # getPfm ( ) # # zipperCombine ( x, y ) # # gcQuietly ( verbose=TRUE ) # # order.dec ( ..., decreasing=TRUE ) # # getErrorLineNumbers ( e ) # # tryToSource ( file, verbose=FALSE, showWarnings=TRUE ) # # msg.lineNumber ( x, width1=40 ) # # msg.string ( x, width1=40 ) # # errParse ( vec, width1=40, collapse="\n" ) # # minmax ( x, min.nm="minDate", max.nm="maxDate" ) # # rangeDateBy ( DT, dateCol, byCols, byCols.dict=byCols, na.rm=TRUE ) # # colNamesFromVector ( vec ) # # identical.data.table ( x, y, ... ) # # fixColTypes_ ( DT, integer=NULL, numeric=NULL, character=NULL, logical=NULL, idcol=NULL # # , Date=NULL, POSIXct=posix, POSIXct.milli=NULL, factor=NULL # # , factor_list=NULL, posix=NULL, allowFactorColToNA=FALSE # # , failOnMissingCols=TRUE, verbose=FALSE, showWarnings=verbose # # , origin=as.Date("1970-01-01", format="%Y-%m-%d") # # , origin.posix=as.POSIXct("1970-01-01 00:00:00", format="%Y-%m-%d %H:%M:%S", tz=tz.posix) # # , tz.posix="UTC", drop.these.columns=NULL ) # # getLabs ( nm ) # # getLevs ( nm ) # # as.int_or_num ( x, force.numeric=FALSE ) # # as.num.nowarn ( ... ) # # cleanPosix ( X, tz="" ) # # OneOrMany ( DT, colsToCheck, byCol, dateCol=NULL ) # # traceaback <- traceaback ( ) # # warningCols ( preMessage=NULL, columns, postMessage=NULL, sameWidth=FALSE, midbreak=1 # # , endl=1, cols=5 ) # # keepOnlyFilesLargerThan ( files, size=0 ) # # nwhich ( x, arr.ind=FALSE, useNames=TRUE ) # # getSpecialChars ( nm=c("regexChars", "shellChars") ) # # escapeSpecialChars ( x, charsToEscape=NULL, use=c("regexChars", "shellChars"), esc="\\" ) # # shellClean ( x, esc="\\" ) # # escapeRegEx ( x=ex, esc="\\", ex ) # # splitOnFirst ( string, splitOn=".", perl=FALSE ) # # splitOnLast ( string, splitOn=".", perl=FALSE ) # # splitOnF_L ( string, splitOn="." # # , first_or_last=c("first", "last"), funky="vx33xABCDEFGxvQQRRSSre456789" # # , perl=FALSE ) # # fileInListing ( f, listing ) # # chopLine ( line, collapse="\n", width=88L, flex=15L, padding=0L, maxNumberOfBreaks=2L # # , dotsBeyondMax=FALSE, padToSecondSpace=FALSE, trimSpace=TRUE # # , showWarnings=TRUE, splitOn="\\s+", dropTrimmedSpace=TRUE ) # # findCharBetween ( string, char.to.find=" ", from=1, to=nchar(string) ) # # findFirstCharBetween ( string, char.to.find=" ", from=1, to=nchar(string), findLAST=FALSE ) # # moveTo ( x, moveFrom, insertAt, showWarnings=TRUE ) # # ColsUniqueByKey ( DT ) # # isUniqueByGroup ( DT, colsToCheck=setdiff(names(DT), byCols), byCols=key(DT), verbose=TRUE # # , sampleThresh=5000 ) # # whereAreTheMultipleRowsPerGroup ( DT, colsToCheck=setdiff(names(DT), byCols), byCols=key(DT), verbose=TRUE ) # # TF.sample ( perc.T, n ) # # makeIndeciesInBatch ( x.to_seq_along, size.of.batch=20, number.of.batches="NOT YET IMPLEMENTED" ) # # regExUpperLower ( x ) # # gridPages ( Plots.list, File, rows=2, cols=3, width=11, height=17, noWarnings=TRUE # # , open=TRUE, main=NULL ) # # seq.exp ( from, to, by=1, base=10, length.out, exp.from, exp.to ) # # seq.log ( from, to, n=abs(from - to) + 1, bias=23, round=NULL, showWarnings=TRUE # # , tighter.end=c("from", "to") ) # # sapplyt ( ..., .c.t=NULL, .to.dt=TRUE ) # # keepOnlyTheseColumns ( x, cols, warn=FALSE ) # # canCoerceToDate ( D, n=100 # # , classesChecked=c("numeric", "integer", "character", "factor"), origin=.origin # # , warn.on.month.year=TRUE, silent=TRUE ) # # TryToConvert ( string, formats, origin=.origin, showWarnings=TRUE ) # # getDateColNames ( X, byClass=TRUE, byName=TRUE, ignoreCase=TRUE, ignore.case=ignoreCase # # , semiloose=FALSE, loose=FALSE ) # # setw ( x, width=max(nchar(x)), space=" " ) # # collectArgs ( except=c(), incl.dots=TRUE, envir=parent.frame(pos), pos=1 ) # # cleanWS ( x ) # # selfname_ ( x, clean=FALSE, e=parent.frame(), onlyIfBlank=FALSE # # , stopifnot.exists=FALSE, showWarnings=TRUE ) # # iter.debug ( name, restart=FALSE, verbose=TRUE, initializeTo=0L, endl="\n", pos=1 # # , coutFunc=c("cat", "message", "print") ) # # clearAllIterCounters ( verbose=TRUE ) # # resetCounter ( name, initializeTo=0, verbose=TRUE, pos=1 ) # # uniqueWithNames ( x ) # # createCombs ( X, groupSize=length(X), allowDups=TRUE, returnIndecies=is.atomic(X) ) # # anyEqualRows ( DF1, DF2=DF1 ) # # removeBlankCols_ ( DT, blanks="", NAs.full.column.as.blank=TRUE ) # # topLevs ( x, n=10, p=0.1, top=TRUE, orEqualTo=FALSE, usePerc=!missing(p) # # , showWarnings=TRUE, ... ) # # has_nchar ( x, na.as.FALSE=TRUE ) # # compress.string ( string, max.length, insert="...." ) # # allSetDiff ( A, B, names=FALSE, sep=" | ", quiet=FALSE, classcheck=is.list(A) # # , A.nm=NULL, B.nm=NULL, max.nm.char=17, nm.insert="..", none=" < none >" # # , showWarnings=TRUE, debug=FALSE ) # # commaToNumeric ( x ) # # currToNumeric ( x ) # # XinNamesDT ( X, DT, cleanIDcols=TRUE, ignore.case=TRUE, warnOnMissingX=TRUE ) # # compareDTs ( DT1, DT2, mem=TRUE, quiet=FALSE, colclass=TRUE # # , DT1.nm, DT2.nm, nchar.max.for.cols.compare=17, debug=FALSE ) # # reverseFactor ( x, ... ) # # setFactorOrder ( x, ordering=levels(x), last=NULL, reverse=FALSE, showWarnings=TRUE ) # # isNumber ( x, treat.ZeroLength.asNumeric=FALSE, ignore.general=FALSE # # , ignore.factors=ignore.general, ignore.dates=ignore.general # # , ignore.logical=ignore.general ) # # isNumberAll ( x, ... ) # # setnamestolower ( DT, ... ) # # setnamestoupper ( DT, ... ) # # cbind_out ( out.left, out.right, header.left=NULL, header.right=NULL, gap.length=6 # # MetricScaleNextRank ( pref, decreasing=TRUE, moveBy=mod, mod=1 ) # # , pregap.length=3 ) # # createMetricScale ( assignTo="MetricScale", envir=globalenv() ) # # regOr ( vec, brackets=TRUE, asterisk=NULL, escape=FALSE, whole=FALSE, whitespace=FALSE ) # # regexAll ( pattern, stringVec, replace="@@@", ignore.case=FALSE, fixed=FALSE # # , perl=FALSE, value=FALSE ) # # rbindFactorCheck ( l, silent=FALSE, preserveFactors=FALSE, checkAllForDT=FALSE, debug=FALSE ) # # dimCompare ( ..., decr=NA, decreasing=decr, sort=NA, sortOn=sort ) # # showProg ( flag, outp, header=FALSE, done=FALSE, tb=1 ) # # iterateByClass ( DT, classes, mc=sys.call(1), ... ) # # isXbiggerthanY ( X, Y, NAs.x.is=FALSE, NAs.y.is=!NAs.x.is ) # # locateFirstNonZeroDigit ( x ) # # padOutput ( mat, extrapad=0, minpad=0, maxpad=Inf, byColumn=FALSE, space=" " # # , align=c("left", "right"), ignore.column=c(NULL) ) # # cbindWithSep ( mat1, mat2, sep=" | ", rnames, cnames=NULL ) # # probMatrixGiven ( probMat, givenHistory, rnames=NULL, print=FALSE, probNames=NULL ) # # meantrm ( x, p=6 ) # # CMT <- getCMT <- getClassModeTypeof ( obj ) # # getNCMT <- getNameClassModeTypeof ( obj ) # # countNA01s ( vec ) # # insert ( lis, obj, at=0, objIsMany=FALSE ) # # makeDictFromCSV ( csvFile ) # # is.dir ( f, showWarnings=TRUE ) # # isSubstrAtEnd ( x, pattern, ignorecase=TRUE ) # # tbs ( n, nl=FALSE ) # # miniframe ( data, rows=200 ) # # makeDictWithIntegerKeys ( KVraw, applyLabels=TRUE ) # # chkp <- chkpt ( logStr, chkpOn=TRUE, final=FALSE ) # # pgDisconnectAll ( drv=dbDriver("PostgreSQL") ) # # mgsub ( pattern, replacement, x, ..., fixed=TRUE ) # # cleanChars ( text, replacement="_", Whitelist=NULL ) # # replaceBadCharsUnderscore ( str, WhiteList=NULL ) # # dateStamp ( x=NULL, frmt="%Y%m%d", tz="America/New_York", ... ) # # isInDateRange ( x, dateCol="date", minDate.allowed, maxDate.allowed, showWarnings=TRUE ) # # getWidth ( max.width=85, min.width=30 ) # # timeStamp ( x=NULL, seconds=FALSE, sep="_", pre.ext=FALSE, frmt="%Y%m%d_%H%M" # # , tz="America/New_York", human=FALSE ) # # detectAssignment ( obj, single=TRUE, simplify=FALSE ) # # plength <- printlength ( opt=200 ) # # reminder ( ) # # saveToFile_TabDelim ( obj, directory=getwd() ) # # retTst ( n ) # # allPosCombsList ( dat, choose=seq(ncol(dat)), yName="y" ) # # formulasList ( dat, yName="y", VARS.list=NULL, interact=TRUE, intercept=TRUE ) # # logscale ( range=2:5, intervals=2, base=10 ) # # lP <- listPacker ( receiver, ... ) # # locate ( fun, showWarnings=TRUE ) # # lsnf ( ... ) # # lsi ( what, invert=FALSE, rm=FALSE ) # # source.url ( ... ) # # coefTable ( model ) # # splitEvery ( string, n, remSpace=FALSE ) # # cls ( LINES=100 ) # # pkgFind ( toFind ) # # namesdetect ( x, pattern ) # # namesIn ( x, vec, positive=TRUE ) # # namesNotIn ( x, vec ) # # findLengthOfDateRange ( dateVector, units="month", origin=.origin ) # # orderedColumns ( DT, frontCols=NULL, ignoreCase=TRUE, endCols=NULL ) # # combineRows ( x ) # # wordCount ( obj, words, ignore.case=TRUE, preservePunct=FALSE ) # # dateCheck ( d ) # # is.allNA ( x ) # # invDict ( dict ) # # setNamesDict ( DT, dict, replaceMissing=NULL, silent=FALSE ) # # uniqueKeys ( DT ) # # convertClass ( DT, colnameVector, to, from=NULL, originDate="1970-01-01" # # , excelOriginName=".xlorigin" ) # # convertClass.default ( DT, ... ) # # convertNumberCols_ ( DT, verbose=TRUE ) # # convertClass.data.table ( DT, colnameVector, to, from=NULL, originDate="1970-01-01" # # , excelOriginName=".xlorigin" ) # # CamelCaseSplit ( string, flat=FALSE ) # # gapply ( X, FUN=identity, ..., simplify=FALSE, pos=1, verbose=FALSE ) # # xapply ( X, qFUN, ..., simplify=FALSE ) # # catTitle ( Title, pref="", suf="", tabs=1, topline=FALSE, dash="-", center=TRUE ) # # centerText ( x, eol="\n", padWith=" ", trim=TRUE, tabs="" ) # # alignText ( x, eol="\n", padWith=" ", trim=TRUE, tabs="", halign="center" ) # # printBox ( x, width=68, dash="~", sides="#", crop=FALSE, topspace=0, bottomspace=0 # # , tabs=1, header="" ) # # splitToWidth ( x, width, safetyBreak=100 ) # # isFALSE ( x ) # # modelDescrFromCall ( ... ) # # modelDescrFromCall.Arima ( M ) # # canBeNumeric ( DT, maxRows=1e+05 # # modelDescrFromCall.lm ( M ) # # , nonNumerics=c("POSIXct", "POSIXt", "POSIX", "POSIXlt", "Date", "logical", "list", "factor", "integer64", "idcol"), ignore.vals=c("", "NULL"), logicals.included=FALSE # # modelDescrFromCall.default ( M ) # # , posix.included=FALSE, idcol.include=FALSE, ignoreNumerics=FALSE # # modelDataSetFromCall ( ... ) # # , exclude.idCols.byname=FALSE, justNames.of.DT=FALSE ) # # modelDataSetFromCall.Arima ( M ) # # modelDataSetFromCall.lm ( M ) # # rangesFromInt ( int, numberOfRanges, sizeOfEach, pairs=TRUE, aslist=TRUE, sequence=TRUE # # , fractions=FALSE ) # # sortXbyY ( X, Y, justIndex=FALSE, names=FALSE, names.X=names, names.Y=names ) # # spacecnt ( x=clipPaste() ) # # dtWideToLong ( DT, cols=names(DT), cnames=c("Name", "Value") ) # # knito ( input, output=gsub("src", "out", dirname(input)), encoding="UTF-8", ... ) # # whichColsCanBeInteger ( DT, ignoreIntegers=TRUE, showWarnings=FALSE, .SDcols=names(DT) # # , convertChars=TRUE ) # # utilSource ( .Pfm=Sys.info()[["sysname"]], main=TRUE, notify.welcome=FALSE # # , update.lastran=TRUE, warn.on.erros=TRUE # # , supportFnsReload=getOption("supportFnsReload", FALSE), verbose=FALSE ) # # as.path ( ... ) # # plrl ( word.pluarl.form, ... ) # # inDebugMode ( ... ) # # tryToSource ( file, showWarnings=FALSE ) # # msg.lineNumber ( x, width1=fileNameWidth ) # # msg.string ( x, width1=fileNameWidth ) # # errParse ( vec, width1=fileNameWidth, collapse="\n" ) # # getLastRan ( x=NULL, tz="America/New_York", verbose=TRUE ) # # setLastRan ( x="utilSource", tz=getOption("default.tz", "America/New_York"), reset=FALSE ) # # canBeInteger ( x, ignoreIntegers=FALSE, ignoreFactors=TRUE, showWarnings=TRUE # # , .SDcols=names(x), convertChars=TRUE ) # # as.tz ( x=Sys.time() # # , tz=getOption("default.tz", "America/New_York"), tz.current=tz # # , origin=.origin.utc ) # # plrl ( word.pluarl.form, count, singular=(length(count) == 1), sep=" " # # , dontSumLogicals=FALSE, makePlrl=FALSE ) # # whichFactors ( x, names=FALSE ) # # getNamesFromDTCols ( DT, na.rm=TRUE, uniquify=TRUE ) # # orderedHeadTail ( x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE # # , value=FALSE, f=c("head", "tail") ) # # orderedHead ( x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE # # , value=FALSE ) # # orderedTail ( x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE # # , value=FALSE ) # # is.vector.of.object.names ( x, na.rm=FALSE, class.to.check.for=NULL ) # # is.char_of_length1 ( x, fail.if.not=FALSE, showWarnings=TRUE, hint=NULL ) # # sprintfcenter ( x, pad.each=1, mn=max(nchar(x)) ) # # findLastSpace ( x, space=" " ) # # cnt ( col, DT=defaultDT ) # # sourceManyFiles ( files=NULL, dir=NULL ) # # mergeDTlist ( DTlist, suffixes=NULL, checkKeys=TRUE, all=TRUE, all.x=all, all.y=all ) # # greplAny ( pattern, x, ignore.case=FALSE, perl=FALSE, fixed=FALSE, useBytes=FALSE ) # # removeWord ( word, removeFrom, ignore.case=TRUE, preSpaceIfLastWord=TRUE ) # # lunique ( x, ..., na.rm=FALSE ) # # runique ( x, ..., by=names(x) ) # # sunique ( x ) # # sumTheTableByDate ( DT, dateCol="date", ignoreCols=NULL, colsUsing=names(DT), quiet=FALSE ) # # makeIntervals ( vec, final.val.to.add=NULL ) # # chop ( DT, vec, simplify=FALSE, add.nrow=TRUE ) # # sepAt_ ( DT, at=(-1), sep="|", colname=".sep" ) # # remsep_ ( DT, colname=".sep" ) # # expandGridByRow ( DT, vec, suffixes=c(".DT", ".vec"), keyToUse=key(DT), preserveList.vec=TRUE ) # # showDicts ( ) # # getDict ( dict.name, justnames=FALSE ) # # existsl ( x, envir=e.this, ... ) # # sumTheTable ( DT, byCols=NULL, ignoreCols=NULL, colsUsing=names(DT) ) # # is.dict ( x ) # # print.dict ( x, nrow=35, quote=FALSE ) # # as.num.as.char ( x, noWarnOnChar=FALSE ) # # spliceOutDate.2.2.2 ( x, format="%m.%d.%y", simplify=TRUE ) # # meanIfThresh ( vec, thresh=12/15, len ) # # dputc ( ... ) # # copyAsCol ( ... ) # # s.t ( expr, msg="", verbose=TRUE, gcFirst=FALSE, title="", pause=0 # # , use=c("elapsed", "user", "system", "all"), message.instead.of.cat=TRUE # # , envir=parent.frame() ) # # clean.capture.output ( ..., file=NULL, append=FALSE, quote=FALSE, envir=parent.frame() ) # # verboseMsg ( verbose, ..., time=TRUE, sep=" ", stampFirstLine=TRUE, endl=1 # # , simple=FALSE, minw=62, frmt="%H:%M" # # , func=c("cat", "message", "warning"), call.=TRUE, .call=TRUE ) # # assignIfNotExist ( name.NoQuotes, value, envir=globalenv(), inherits=TRUE, verbose=FALSE ) # # is.twodim ( x ) # # has.listColumn ( x ) # # wnames ( x, selection=NULL, copy=TRUE ) # # scaleunif ( vec, min=0, max=1, round=FALSE ) # # runShiny ( shinyapp.name ) # # BetaFunc ( a, b ) # # Beta ( x, a, b ) # # make.rgba ( N, start=c(r=0, g=0, b=0, a=0), end=c(r=1, g=1, b=1, a=1) # # , color=c("linear", "log"), alpha=c("log", "linear"), final.alpha.gap=0.1 ) # # scaleColorLog ( N, start, end ) # # scaleColorLinear ( N, start, end ) # # stopIfFileMissing ( file, addl.info=NULL ) # # kWh_cost ( watts=c(lo=400, hi=1000), rate_per_hour=0.12 # # sn ( max, length.out=max, min=1 ) # # showCharIndex ( x, width=getOption("width"), silent=FALSE, replace.space.with="~" # # , single.digit.inds=TRUE, mod=10 ) # # sampleChunks.data.table ( DT, perc=0.1, NumberOfChunks=1000L, head=0, tail=0, plusHeadTail=FALSE # # , prserveOrder=TRUE ) # # sampleChunks ( x, ... ) # # sampleChunks.default ( ... ) # # rg ( ) # # gitfile ( file # # , msg=sprintf("Adding file %s from %s", gsub("~/git(/orch/(out|src|data)/)", "", file), ifelse(.Pfm == "Darwin", "local machine", "remote machine")), force=TRUE ) # # setGitBranch ( branch="master" ) # # getGitBranch ( default="master" ) # # g <- .gitPull ( dir="~/git", utilsReload=TRUE, branch=getGitBranch(), remote="origin" # # , supportFnsReload=getOption("supportFnsReload", FALSE), quiet_git=TRUE # # , onlyIfChanged=NULL, verbose=TRUE, intern=TRUE, maxSafety=14 ) # # padToLength ( x, len, pad.with=if (is.character(x)) "" else NA, showWarnings=TRUE ) # # , hours=c(`One Hour`=1, `One Day`=24, `Twenty Days`=24 * 20, `One Month`=24 * 30) ) # # us ( ... ) # # jofby ( BY=get(".BY", envir=parent.frame()), silent=FALSE ) # # change_colName_in_all_DTs ( old_colnames, new_colnames, DT.nms=lsosdt(pos=2)$name, verbose=TRUE ) # # showColDuplicates ( DT ) # # sumcolumns ( DT, na.rm=TRUE, colsToSum="*", round=0, by=NULL, unique=FALSE ) # # getOptionOrFail ( x ) # # setFactorsToChars_ ( DT, skip.these.cols=NULL ) # # dimofmerge ( DT1, DT2 ) # # getLLL ( times=3L, rev=TRUE ) # # sumf ( ... ) # # sum_abs ( x, na.rm=FALSE ) # # sumn ( ..., .char.to.NA=FALSE, exceptAllNA=FALSE ) # # minn ( ..., na.rm=TRUE ) # # maxn ( ..., na.rm=TRUE ) # # meann ( ..., na.rm=TRUE ) # # rangen ( ..., na.rm=TRUE ) # # msub ( pattern, replacement, x, ignore.case=FALSE, perl=FALSE, fixed=FALSE # # , useBytes=FALSE, whole=FALSE ) # # removeNonAlphaNumeric ( x, replace="_" ) # # mnchar ( x, ... ) # # convertLogicalToYN_ ( DT, cols.logical=nwhich(sapply(DT, is.logical)), yes="Y", no="N" ) # # spaceToUnderscore ( x ) # # spaceInNamesToUnderscore_ ( x ) # # setnamesSpaceToUnderscore_ ( x ) # # emptylist ( x, nm=names(x) ) # # truncDate ( x, origin=.origin.utc ) # # convertYYYYtodate ( x, warn.if.cannot.convert=TRUE ) # # setVerbose ( flag="default", value=TRUE ) # # getVerbose ( flag="default", default=FALSE ) # # classAppend_ ( X, classToAppend=NULL ) # # properRegex ( pat, unallowed=c(".^$()[]"), warnIfOffender=TRUE ) # # cleanEnvirString ( env, extraclean=FALSE ) # # columnTopN_ ( DT, col, valueCol, byCols=c(), TopN=5L, replaceWith="OTHER" # # , FUN.agg=c("sum", "mean"), make.factor=TRUE, showWarnings=FALSE ) # # isQuit ( selection, quitters=c("x", "Q"), ignore.case=TRUE ) # # coerceKeyColsAndSetKey_ ( DT, keyCols, classCols, verbose=TRUE ) # # getOutDir ( ) # # findDependentPakcages ( pkgname, self.include=FALSE, but.dont.include.if.not.loaded=TRUE ) # # trimToNChars ( s, n ) # # isYes ( x, ignore.whitespace=TRUE, ignore.case=TRUE ) # # cropStringTo ( x, maxchar=40 ) # # extractFilesFromFilesList ( fileslist, ext=c("R", "S"), ignore.case=TRUE, showWarnings=TRUE ) # # isBlankLine ( x ) # # findColWidth ( x, quant=0.85, max.char=Inf, verbose=FALSE ) # # shellCleanQuotes ( x, using.quotes.type=c("'", "\"") ) # # whatsOpened ( dir="~/git/" ) # # LinuxFlav ( ) # # SeshInfo ( ) # # sourceSupportFns ( dir, fail.on.missing=TRUE, verbose=FALSE, msg.on.errors=TRUE, showWarnings=TRUE ) # # rbindlist.fill ( LL, drop.nulls=TRUE, create.copy=TRUE, proceed.if.large=FALSE ) # # dtcheck ( x ) # # AddCol_and_OrderCols ( D ) # # getNamesWithClass ( DT ) # # uniqueByNamesAndValues ( x ) # # extractFilesFromFolder ( folder, pattern=NULL, all.files=TRUE, full.names=FALSE # # findDupsBy ( DT, by.cols=key(DT), warn=FALSE, showWarnings=warn, debug=FALSE ) # # , ext=c("R", "S"), minSize=-1, ignore.case=TRUE # # , ignore.case.pattern=ignore.case, ignore.case.ext=ignore.case # # sampleRows ( DT, n.rows, n.perc, chunksize=1, min.rows=NULL, max.rows=NULL, seed=NULL # # , showWarnings=TRUE, chunkSize="DO NOT USE" ) # # , ignore.subfolders=getOption("ignore.subfolders") # # sampleInChunks ( x, n, chunksize=1, seed=NULL, showWarnings=TRUE # # , hide.sample.in.chunks.warning=FALSE, chunkSize="DO NOT USE" ) # # DTlistPadAndBind ( DT.list, padWith=NA ) # # , showWarnings=TRUE, ... ) # # isErr ( x ) # # matchKey ( DT1, DT2, keyCols=if (haskey(DT2)) key(DT2) else key(DT1) # # , superset.ok=TRUE, organize=TRUE, verbose=FALSE ) # # getRFilesFromFolder ( folder, recursive=TRUE, all.files=TRUE # # , exts=c("r", "R", "s", "S", "Rprofile"), fail.on.folder.missing=TRUE # # , ignore=c("_latestBackups.r") ) # # beep ( howMany=3, delay=0.2 ) # # notTRUE ( x ) # # cot ( ... ) # # camelSplit ( x, alsoSplit=c(" ", "_", "-", "."), isolate="%" # # relativePath ( path, relativeTo, noStartingSlash=FALSE ) # # , dontUseNames.of.data.frame=FALSE ) # # formatBytes ( x, ... ) # # filesByTimeStamp ( prototypefile, ignore.latest=TRUE # # , folder=path.unexpand(dirname(prototypefile)) # # , pat.stamp="\\d{6,8}(-|_)+\\d{4,6}" ) # # sourceEntireFolder ( folderName, verbose=FALSE, showWarnings=TRUE, fail.on.missing.folder=TRUE # # , msg.on.errors=TRUE, ignore.subfolders=getOption("ignore.subfolders") ) # # copr ( x ) # # as.ch.as.exp ( x ) # # indexToLogical ( indexVector, totalLength, cleanNA=TRUE ) # # withinCutoff ( x, bottomPerc=0, topPerc=100, value=FALSE, inverse=FALSE, na.rm=TRUE ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # ## utilsRS.r if (FALSE) insertIntoFile_("/Users/rsaporta/git/misc/rscripts/utilsRS.r") ## TODO # add an identical(DT1, DT2) # to compareDTs(...) # -------------------------------------------------------------------------------- # ## These should have been loaded in RProfile ## Loading magrittr, data.table, etc suppressPackageStartupMessages( sapply(getOption("defaultPackages"), require, character.only=TRUE) ) ## Some of the utils are needed for utilSource() ## and thus need to be loaded early. ## Wrapping in `try` so that if fails, does not affect rest of the utils load try({ source(path.expand("~rsaporta/git/misc/rscripts/utils/dict functions.r")) source(path.expand("~rsaporta/git/misc/rscripts/utils/memoryFunctions.R")) source(path.expand("~rsaporta/git/misc/rscripts/utils/paste functions.r")) }, silent=TRUE) ## Constants .Pfm <- Sys.info()[['sysname']] .RForge <- "http://R-Forge.R-project.org" .origin <- as.Date("1970-01-01", format="%Y-%m-%d") .origin.utc <- as.POSIXct("1970-01-01 00:00:00", format="%Y-%m-%d %H:%M:%S", tz="UTC") # For dev'ing, to run tests again for corner cases. .bad.vals.list <- list(hello="hello", logic0=logical(0), `7`=7, N.A.=NA, `11`=11, intg0=integer(0), eight=8, charac2=character(2)) .bad.vals.vec <- unlist(.bad.vals.list) ## Options options(default.tz = "America/New_York") options(ignore.subfolders=c("_CleanThese", "DontSource", "NotSourced", "NeedsWork", "reference", "Reference", "Notes", "notes", "zNotSourced", "zarchived", "zArchived", "archived", "unused", "zunused", "zzunused")) options(git.origin=c("datascience")) options(git.defaultbranch=c("develop")) ## Set default branch to master, if nothing is set if (is.null(getOption("gitBranch"))) options("gitBranch"="master") `%ni%` <- Negate(`%in%`) catn <- function(...) cat(..., "\n") catnn <- function(...) cat(..., "", sep="\n") catheader <- function(..., prel=1, endl=2) { dash <- pasteR(n=20, "-") space <- pasteR(n=4, " ") pnl <- pasteC(rep("\n", prel)) enl <- pasteC(rep("\n", endl)) catn(pnl, dash, " [", space, ..., space, "] ", dash, enl, sep="") } # -------------------------------------------------------------------------------- # scale_to_plus_or_minus_one <- function(x) { ifelse(abs(x) < 2 , yes = (sqrt(abs(x)) / (1 + sqrt(abs(x)))) * sign(x) / 3 , no = sign(x) * abs(log10(abs(x)) / (1 + log10(abs(x)))) ) } avg_mode <- function(x, na.rm=FALSE) { ## "mode" as in mean, median, mode ## the base function mode() actually referes to the class-like meta info of the object. Not Mode, in the arithmatic sense if (na.rm) x <- x[!is.na(x)] table(x) %>% {.[which.max(.)]} %>% names %>% as(., class(x)) } exponential_avg <- function(x, a) { ## TODO: allow for missing values in time series if (a > 1 || a < 0) warning ("a in exponential_avg should be a value between 0 and 1") if (!length(x)) return(numeric()) weights <- a ^ seq(length(x), 1, by=-1) model <- lm(x ~ 1, weights=weights) mean <- coef(model)[[1]] return(mean) } addColumnIfNotExist <- function(DT, cols, fill_with=list(NA_character_)) { if (!length(fill_with)) stop("'fill_with' must have length") if (length(cols) != 1 && length(fill_with) != length(cols)) { if (length(fill_with) == 1 && length(fill_with[[1]]) == length(cols)) fill_with <- fill_with[[1]] else if (length(fill_with) == 1) fill_with <- rep(fill_with[[1]], length(cols)) else stop("incompatible lengths: fill_with has length ", length(fill_with), " while cols has length ", length(cols)) } for (i in seq_along(cols)) { col <- cols[[i]] fill <- fill_with[[i]] if (col %ni% names(DT)) DT[, (col) := fill] } } log10Digits <- function(x) { ## counts the number of digits log10, returning 0 for x == 0 ifelse(x==0, 0, sign(x) * trunc(log10(abs(x)))) } setdiffbyname <- function(x, y) { x[names(x) %in% setdiff(names(x), names(y))] } setdiff_preservename <- function(x, y) { x[x %ni% y] } is_wrapped_in_parens <- function(string, trim_first=TRUE) { ## Checks if a string is wrapped in parenthesis. ## if trim_first, then white space is removed ## "(SELECT HELLO WORLD)" returns TRUE ## "(SELECT HELLO WORLD" returns FALSE if (trim_first) string %<>% trim() grepl("^\\(", string) & grepl("\\)", string) } ## This is data.table/snowflake function convertBooleans_ <- function(DT, boolean_type = c("BOOLEAN", "INT", "VARCHAR(5)", "VARCHAR(1)"), NOTES = "This function coverts Logical columns in a DT to the designated type, prepping the DT for Ingestion into SF ---- use setBoolCols(DT) for the reverse") { if (!is.data.table(DT)) stop ("'DT' must be a data.table") boolean_type <- match.arg(boolean_type) if (boolean_type == "BOOLEAN") return(DT) if (boolean_type == "INT") func <- as.integer else if (boolean_type == "VARCHAR(5)") func <- as.character else if (boolean_type == "VARCHAR(1)") func <- {. %>% as.character %>% substr(1, 1)} else stop("Invalid boolean_type -- do not know how to convert", call.=FALSE) boolCols <- nwhich(sapply(DT, is.logical)) ## Convert if (length(boolCols)) DT[, (boolCols) := lapply(.SD, func), .SDcols=boolCols] return(invisible(DT)) } might_be_int64 <- function(x, thresh=1e-100) { ## sometimes a column in a DT might be saved as integer64 incorrectly ## it looks like this might be a consequence of rbinding, but not sure if (!length(x)) return(logical(0L)) any((x != 0) & (abs(x) < thresh), na.rm=TRUE) } isPkgLoaded <- function(pkg, ignore.case=TRUE, exact=TRUE) { pat <- "^package:" pkg <- "bit64" if (pkg == "int64") warning("Dumbsquat!! it's called BIT64 not INT64") matches <- extract(pat, search()) %>% removeText(pat, .) %>% extract(pat=pkg, string=., ignore.case=ignore.case) if (ignore.case) { pkg %<>% tolower matches %<>% tolower } if (exact) return(pkg %in% matches) else return(length(matches)) } cut_integers <- function(x, cuts, negative_inf=TRUE, positive_inf=TRUE, right=FALSE, sep=" ~ ", ...) { if (!length(cuts)) stop ("cuts has no length") if (negative_inf && cuts[[1]] != -Inf) cuts <- c(-Inf, cuts) if (positive_inf && tail(cuts, 1) != +Inf) cuts <- c(cuts, +Inf) cuts <- round(cuts) labels <- sapply(seq(length(cuts)-1), function(i) { to <- cuts[[i + 1]] - !right from <- cuts[[i]] - right frmt <- ifelse(to == from, "%2s", "%2s%s%s") sprintf(frmt, from, sep, to) }) labels %<>% sub(paste0("\\s*-Inf\\s*", sep), "< ", .) %>% sub(paste0(sep, "\\s*Inf\\s*"), "+ ", .) cut(x, breaks=cuts, labels=labels, right=right) } above_quantile <- function(x, q=0.5, showWarnings=TRUE) { q <- validPercentage(q, min=0, max=1, silent=!showWarnings) x > quantile(x, probs=q, na.rm=TRUE) } show_how_rep_works <- function () { catn(" rep(x, each=3)") catn("EACH : ", rep(c("1111", " ", "2222", " ", "3333"), each=3), sep=" ") catn("\n") catn(" rep(x, times=3)") catn("TIMES : ", rep(c("1111", "2222", "3333", " "), times=3), sep=" ") } showDataTables <- function(col=13, nms.DT=lsosdt()$name, lines_clear=5) { if (is.numeric(nms.DT) && missing(lines_clear)) { lines_clear <- nms.DT nms.DT <- lsosdt()$name } if (is.character(col)) { if (exists(col[[1]]) && is.data.table(get(col[[1]]))) { nms.DT <- col col <- 13 } else { stop("'col' should be a integer") } } cls(LINES=lines_clear) for (nm in nms.DT) { catn(nm, "\n-------") print(c4(get(nm), col=col)) catn() } invisible(NULL) } writeLinesUTF8 <- function(text, con=file_name, sep="\n", append=FALSE, file_name) { if (!xor(missing(con), missing(file_name))) stop ("Exactly one of con or file must be given. (They are synonyms)") is.char_of_length1(con, fail.if.not=TRUE) mode <- if (isTRUE(append)) "at" else "wt" con <- file(con, open=mode, encoding="UTF-8", raw=FALSE) ret <- writeLines(text=text, con=con, sep=sep, useBytes=FALSE) close(con) return(ret) } writeUTF8 <- function(x, file_name=file, ncolumns=if (is.character(x)) 1 else 5, sep = " ", append=FALSE) { is.char_of_length1(file_name, fail.if.not=TRUE) mode <- if (isTRUE(append)) "at" else "wt" con <- file(file_name, open=mode, encoding="UTF-8", raw=FALSE) ret <- write(x=x, file=con, sep=sep, append=append) close(con) return(ret) } # -------------------------------------------------------------------------------- # if (FALSE) { uniform_to_exponential(0:10 / 100, 5) uniform_to_exponential(0:10, 5) uniform_to_exponential(0:10 / 100, 5, TRUE) uniform_to_exponential(0:10, 5, TRUE) } uniform_to_exponential <- function(x, gamma=0.2, scale=missing(gamma), min=minn(x), max=maxn(x)) { ## Convert a uniform distribution to exponentional ## note that gamma is pointless if scaling uniform ret <- (exp(x) / gamma) if (scale) return(scaleunif(ret, min=min, max=max)) return(ret) } drag_it_out <- function(text, seconds.total, start=1, speed=0.8, endl=1) { ## the closer start and seconds.total are to each other, the more uniform the speed ## the further they are, the more ramp up. ## ## speed should be a value between [0.5, 1.5]; more extreme skews heavily, unless seconds.total is large is.char_of_length1(text, fail=TRUE) if (is.numeric(endl)) endl <- rep("\n", times=endl) if (seconds.total == start) { cat(text, endl) return(invisible(text)) } letters <- strsplit(text, "")[[1]] seconds.abs <- abs(seconds.total) to <- abs(start) from <- abs(seconds.total - start) + abs(start) times <- seq(from=from * speed, to=to * speed, length.out=length(letters)) %>% {if (seconds.total < 0) rev(.) else .} %>% uniform_to_exponential() %>% # uniform_to_exponential(min=abs(start), max=abs(seconds.total)) %>% {. * abs(seconds.total) / sum(.)} cat_sleep <- function(L, T) {cat(L, sep=""); Sys.sleep(T)} invisible(mapply(cat_sleep, letters, times)) cat(endl) return(invisible(text)) } # -------------------------------------------------------------------------------- # list_to_param_string <- function(ll, dropNulls=missing(null_value), null_value="null", C=collapse, collapse="&", sep="=") { ## set collapse to NULL to not paste if (!length(ll)) return("") if (is.null(names(ll))) stop("ll does not have a names attribute") ## having a straight empty string might mess up a URL call if (null_value == "" && !dropNulls) warning("null_value is \"\" --- did you mean null_value='\"\"'") ## DROP OR CLEAN NULLS wh.nulls <- sapply(ll, is.null) if (dropNulls) ll <- ll[!wh.nulls] else ll[wh.nulls] <- null_value ## RETURN sprintf("%s=%s", names(ll), ll) %>% pasteC(C=C) paste(names(ll), ll, sep=sep, collapse=C) } fileSize <- function(files) { file.info(files)$size %>% as.bytes } # -------------------------------------------------------------------------------- # identical_when_sorted <- function(x, y) { identical(sort(x), sort(y)) } uniqueIfOne <- function(x) { ## Note simplifies a list of vectors to a single vector ## ie, if x is a list of identical values ## unique(x) != uniqueIfOne(x) ## ## Example: ## x <- list("A", "A", "A") ## unique(x) ## uniqueIfOne(x) if (length(unique(x)) == 1) return(x[[1]]) return(x) } setdiffnocase <- function(x, y) { ## Takes the setdiff of two character sets, without regard for case if (!is.character(x) && !is.character(y)) { warning ("Both entries to setdiffnocase() should be strings") return(setdiff(x, y)) } x_u <- x %>% tolower %>% setNames(nm=x) y_u <- y %>% tolower %>% unique x_u <- x_u[!duplicated(x_u)] ## RETURN names(x_u)[unname(x_u) %ni% unname(y_u)] } findOption <- function(pat, ignore.case=TRUE) { extracted <- extract(pat, names(options()), useValues=FALSE, ignore.case=ignore.case) options()[extracted] } strsplitToDT <- function(x, ...) { as.data.table(do.call(rbind, strsplit(x, ...))) } alllength1 <- function(LL, empty.returns=FALSE) { if (!length(LL)) return(empty.returns) all(sapply(LL, length) == 1) } getPfm <- function() { Sys.info()[['sysname']] } isInDateRange <- function(x, dateCol="date", minDate.allowed, maxDate.allowed, showWarnings=TRUE) { ## checks that x$dateCol is within [minDate, maxDate] ## NOTE TO SELF: I do not know if to put this in date modifiers.r or in some DT utils file ? if (is.Date(dateCol) || !isErr(as.Date(dateCol))) { verboseMsg(showWarnings, "It appears that 'dateCol' is a date -- did you get the argument order mixed up?") } if (!is.null(dimnames(x))) { ## check for appropriate dateCols dateCol <- intersect(dateCol, colnames(x)) if (!length(dateCol)) { verboseMsg(showWarnings, "no matches between dateCol and colnames(x) -- returning FALSE for isInDateRange()") return(FALSE) } if (length(dateCol) > 1) stop ("isInDateRange() is not vectorized over dateCol") x <- range(x[[dateCol]], na.rm=TRUE) } return(minn(x) <= minDate.allowed && maxn(x) >= maxDate.allowed) } kWh_cost <- function(watts=c(lo=400, hi=1000), rate_per_hour=0.12, hours=c("One Hour" = 1, "One Day"=24, "Twenty Days"=24 * 20, "One Month" = 24 * 30)) { ## Calculates the hourly/monthly cost of an appliance using W watts at an R rate per hour kWh <- watts / 1000 print(asCurr(sapply(kWh * rate_per_hour, "*", hours)), quote=FALSE) } getLLL <- function(times=3L, rev=TRUE) { ## wrapper function for creating a group of pasteC(LETTERS, LETTERS, ....) LLL.nm <- paste0(rep("L", times=times), collapse="") if (exists(LLL.nm)) { LLL <- get(LLL.nm) if (is.character(LLL) && length(LLL) == 26^times && nchar(LLL[[1]]) == times) return(LLL) } if (length(times) != 1 || !is.numeric(times)) stop ("times argument should numeric with length exactly 1") if (times > 5) stop ("times must be less than 6. Note that 26^5 is almost 12M combinations") if (times < 1) stop ("times must be positive") if (rev) apply(do.call(expand.grid, rep(list(LETTERS), times=times))[, seq(times, 1)], 1, paste, collapse="") else apply(do.call(expand.grid, rep(list(LETTERS), times=times)), 1, paste, collapse="") } convertLogicalToYN_ <- function(DT, cols.logical=nwhich(sapply(DT, is.logical)), yes="Y", no="N") { if (!length(cols.logical)) return(invisible(DT)) force(yes) force(no) DT[, (cols.logical) := lapply(.SD, function(x) factor(ifelse(x, yes, no), levels=c(yes, no))), .SDcols=cols.logical] return(invisible(DT)) } cleanEnvirString <- function(env, extraclean=FALSE) { ## For cleaner output e.str <- capture.output(env) ## Check for gloabl environment e.str[e.str == ""] <- "GlobalEnv" if (extraclean) gsub("(", "", e.str) else gsub("()", "", e.str) } filegroup_adjust_for_snowflake <- function(files, pattern="\\s*[\\-_]\\s*snowflake", snowflake_inuse=getOption("snowflake_inuse", default=FALSE)) { ## Generally called on the output of extractFilesFromFolder() ## ## Takes a list of files were there exist "duplicate" snowflake versions, ## and remove the duplicates accroding to the snowflake_inuse flag. eg: ## ## store_view_snowflake.sql ## "[..]Views/store_view_snowflake.sql" ## store_view.sql ## "[..]Views/store_view.sql" if (missing(snowflake_inuse)) warning("\n\tfor now, snowflake_inuse should be set explicitly. Its current value is ", snowflake_inuse, "\n") nms.sf_specific <- extract(pattern, names(files), ignore.case=TRUE) if (length(nms.sf_specific)) { ## Either remove the non-snowflake files or the snowflake files depending on the flag if (snowflake_inuse) files <- files[names(files) %ni% gsub(pattern, "", nms.sf_specific, ignore.case=TRUE)] else files <- files[names(files) %ni% nms.sf_specific] names(files) <- gsub(pattern, "", names(files), ignore.case=TRUE) } return(files) } extractFilesFromFilesList <- function(fileslist, ext=c("R", "S"), ignore.case=TRUE, warn_on_no_extension=TRUE, showWarnings=TRUE) { ## REMINDER: Keep this function in utilsRS.r -- needed for fresh() ## takes a string vector of file names, and returns only those in the list which are ## of the given extension type source("~/git/misc/rscripts/utils/regex and string utils.r") if (!length(ext)) stop("ext must be a string\nHINT: to find files with no-extension, use ext=\"\"") if (!length(fileslist)) { verboseMsg(showWarnings, "fileslist was empty") return(fileslist) } filesbase <- basename(fileslist) files.with_blank_ext <- fileslist[!grepl("\\.", filesbase)] ext <- gsub("^\\.", "", ext) ## if "" is an extension, these files need to be extracted manually if ("" %in% ext) { ret <- files.with_blank_ext # fileslist[!grepl("\\.", filesbase)] ext <- setdiff(ext, "") } else { if (length(files.with_blank_ext) && all(ext %in% c("txt", "csv", "tsv"))) verboseMsg(warn_on_no_extension, "\nThe following files have no extension.", paste("\n ", files.with_blank_ext, collapse=""), "\nWhere they meant to be included?", func="warning") ret <- c() } ## remove any starting dot, to not duplicate it if (length(ext)) { pat <- sprintf("\\.%s$", regOr(ext)) ret <- c(ret, fileslist[grepl(pat, filesbase, ignore.case=ignore.case)]) } return(ret) } extractFilesFromFolder <- function(folder, pattern=NULL, all.files=TRUE, full.names=FALSE, ext=c("R", "S"), minSize=-1, ignore.case=TRUE, ignore.case.pattern=ignore.case, ignore.case.ext=ignore.case, ignore.subfolders=getOption("ignore.subfolders"), recursive=FALSE, showWarnings=TRUE, zeroFilesOK=FALSE, ...) { ## REMINDER: Keep this function in utilsRS.r -- needed for fresh() ## takes a folder, and all files in that folder of the given extension type ## The values will have as names the basename of the files (useful when using full.names=TRUE) if (length(folder) > 1) stop ("folder should be of length 1") files <- dir(path=folder, pattern=pattern, all.files=all.files, full.names=full.names, ignore.case=ignore.case.pattern, recursive=recursive, ...) if (!length(files)) { verboseMsg(showWarnings & !zeroFilesOK, "There are no files with pattern '", pattern, "' in folder '", folder, "'", func="warning") if (!zeroFilesOK & (recursive && !is.null(pattern))) warning("The 'pattern' artgument in dir() only applies to the basename of the found files; Not to the path") return(files) } ret <- extractFilesFromFilesList(files, ext=ext, ignore.case=ignore.case.ext, showWarnings=FALSE) ## unix specific if (!is.null(ignore.subfolders)) { pat.ignore <- sprintf("(/|\\b)%s(/|\\b)", regOr(ignore.subfolders)) not.these <- grepl(pat.ignore, {if (full.names) gsub(path.expand(folder), "", ret) else ret}, ignore.case=TRUE) ret <- ret[!not.these] } ## Chceck filesize, if flagged to do so if (minSize >= 0 && length(ret)) ret <- keepOnlyFilesLargerThan(ret, size=minSize) ## name them with the base file name or relative name names(ret) <- { if (full.names) relativePath(ret, relative=folder, noStartingSlash=TRUE) else basename(ret) } return(ret) } extractIngestFiles <- function(pattern=NULL, ext=c("csv","tsv"), subFolder=NULL, proj=NULL, ignore.case=TRUE, minSize=-1, full.names=TRUE, all.files=TRUE, recursive=FALSE, showWarnings=TRUE) { ext %<>% gsub("^\\.", "", .) %>% paste0(".", .) extractFilesFromFolder(folder=ingest.p(subFolder, proj=proj), pattern=pattern, ext=ext, ignore.case=ignore.case, minSize=minSize, full.names=full.names, all.files=all.files, recursive=recursive, showWarnings=showWarnings) } removeDuplicateFilesFromFileList.byName <- function(fs, time_name_conflict_use=c("time", "name"), pat.to_strip=NULL, perl=FALSE) { if (is.null(names(fs))) { warning ("fs must be a named list of files, such as what is returned from extractFilesFromFolder()\nIt has no names, and hence returning the whole list, unmodified") return(fs) } time_name_conflict_use <- match.arg(time_name_conflict_use) ## take a copy of the names for the msg.by_pat downstream nms_orig <- copy(names(fs)) if (!is.null(pat.to_strip)) { is.char_of_length1(pat.to_strip, fail=FALSE) names(fs) <- copy(removeText(pattern=pat.to_strip, x=nms_orig, perl=perl)) } dups <- names(fs) %>% {.[duplicated(.)]} %>% unique for (dup in dups) { msg.by_pat <- ifelse(identical(nms_orig == dup, names(fs) == dup), "for", "(after removing pattern) for *cleaned*") message("There are duplicates ", msg.by_pat, " base file_name: '", dup, "'") #, "'\n keeping only '", f.keeping, "'") # tmp_DT.file_info <- fs %>% {.[names(.) %in% dup]} %>% file.info %>% as.data.table(TRUE) # tmp_DT.file_info[, mtime := as.Date(mtime)] # tmp_DT.file_info[, ctime := as.Date(ctime)] tmp_DT.file_info <- fileInfo(fs[names(fs) %in% dup]) f.keeping_by_time <- tmp_DT.file_info[(ctime == max(ctime))][(mtime == max(mtime))][(size == max(size))]$file f.keeping_by_bname <- tmp_DT.file_info[, file[basename(file) == max(basename(file))]] ## There might be more than one file with the same ctime/mtime/size ## If so, take the one with the latest file name if (length(f.keeping_by_time) > 1) { warning ("Could not distinguish between multiple files for '", dup, "' -- chose the one with max basename") f.keeping_by_time <- max(f.keeping_by_time) } ## If the latest filename and the lastest time don't match, that's a red flag if (f.keeping_by_bname != f.keeping_by_time) { warning("Different decision on which file to keep for: '", dup, "'\n\t* By ctime/mtime : ", f.keeping_by_time, "\n\t* By max-basename : ", f.keeping_by_bname, "\n Going with ", ifelse(time_name_conflict_use=="time", "ctime/mtime", "max-basename")) } ## use time as the indicator of what to keep f.keeping <- ifelse(time_name_conflict_use=="time", f.keeping_by_time, f.keeping_by_bname) ## filter fs to those where ## NOT [the names are in the current batch of dup AND the file is the one keeping] ## in other words, drop the dup, except for the file being kept fs %<>% {.[!(names(.) == dup & . != f.keeping)]} } return(fs) } zipperCombine <- function(x, y) { ## Combines the elements of x and y one at a time, ie ## [1] "x1" "y1" "x2" "y2" "x3" "y3" "x4" "y4" "x5" "y5" c(x, y) [order(c(seq(x), seq(y)))] } colNamesFromVector <- function(vec, lower=FALSE, starToCount=(length(vec) < 1000), check_for_specials=TRUE) { ## if a value has a name, uses the name, ## otherwise, uses the value ## dont check for star on long vectors, since this will slow it down too much # if (starToCount) { # star <- vec == "*" # if (any(star)) { # nms <- names(vec) # if (is.null(nms)) # nms <- rep("", length(vec)) # nms[star & nms == ""] <- "count" # names(vec) <- nms # } # } if (is.null(vec)) return(names(vec)) nms <- names(vec) ## IF BLANK, USE THE VALUES if (is.null(nms)) ret <- vec else ret <- ifelse(nms == "", as.character(vec), nms) ## Check for special values, such as .RU and .rowcount if (check_for_specials || starToCount) { ## starToCount at times may not want to be replaced if (starToCount) ret[ret == "*"] <- "count" ret[ret == ".rowcount"] <- "rows" wh.RU <- grep(".RU", ret) if (length(wh.RU) == 1) ret <- insert(ret[-wh.RU], obj=c("revenue", "units"), at=wh.RU) if (length(wh.RU) > 1) warning ("More than one instance of '.RU' found in vec in colNamesFromVector(), therefore will ignore them. Results may be inaccurate") } if (lower) ret <- tolower(ret) return(ret) } keepOnlyFilesLargerThan <- function(files, size=0) { if (!is.character(files)) stop ("'files' is not a character") if (!length(files)) return(files) fsize <- file.info(files)$size if (is.null(fsize)) stop("couldnt find size") files[fsize > size] } makeIndeciesInBatch <- function(x.to_seq_along, size.of.batch=20, number.of.batches="NOT YET IMPLEMENTED") { if (!missing (number.of.batches)) stop ("'number.of.batches' is not yet implemented") if (!length(x.to_seq_along)) { warning ("x.to_seq_along has no length. returning NULL") return(NULL) } if (size.of.batch < 1) stop ("size.of.batch must be a positive integer") if (size.of.batch == 1) { return (as.list(seq_along(x.to_seq_along))) } l <- length(x.to_seq_along) if (size.of.batch > l) return (seq_along(x.to_seq_along)) lb <- floor(l/size.of.batch) lb_sz <- lb * size.of.batch ## return c(lapply(seq.int(lb), function(k) (k-1)*size.of.batch + seq(size.of.batch)) , if (lb_sz < l) list((lb_sz+1):l) ) } collectArgs <- function(except=c(), incl.dots=TRUE, envir=parent.frame(pos), pos=1) { args <- ls(envir=parent.frame()) args <- setdiff(args, except) data.table::setattr(args, "names", args) ret <- lapply(args, function(x) get(x, envir=envir) ) if (incl.dots && exists("...", envir=envir)) ret <- c(ret, eval(quote(list(...)), envir=envir)) return(ret) } has_nchar <- function(x, na.as.FALSE=TRUE) { ## Quick wrapper to replace NULLs with "" for objects expected to be characters if (is.null(x)) return (FALSE) if (na.as.FALSE) { ret <- as.logical(nchar(x)) ret[is.na(x)] <- FALSE return(ret) } else return(as.logical(nchar(x))) } cbind_out <- function(out.left, out.right, header.left=NULL, header.right=NULL, gap.length=6, pregap.length=3) { ## 20140926 ## Wrapper function for fancy output. ## Takes two outputs and combines them side-by-side. ## Check valid headers if ( is.null(header.left) && !is.null(header.right)) header.left <- "" if (!is.null(header.left) && is.null(header.right)) header.right <- "" if (!is.null(header.left)) { if ((!is.character(header.left) || length(header.left) > 1) || (!is.character(header.right) || length(header.right) > 1) ) stop ("'header.left' and 'header.right' should each be a string of length 1 (or NULL)") } if (!is.character(out.left)) out.left <- capture.output(print(out.left)) if (!is.character(out.right)) out.right <- capture.output(print(out.right)) out.left <- c(header.left, capture.output(cat(out.left, sep="\n"))) out.right <- c(header.right, capture.output(cat(out.right, sep="\n"))) ## Check that the lengths are not too wide, relative to getOption("width") if (max(nchar(out.left)) + quantile(nchar(out.right), .8) + gap.length + pregap.length > getOption("width", 80)) return(c(out.left, "", out.right)) n.l <- length(out.left) n.r <- length(out.right) if (n.l < n.r) out.left <- c(out.left, rep("", n.r-n.l)) if (n.r < n.l) out.right <- c(out.right, rep("", n.l-n.r)) nchar.left <- nchar(out.left) mxnchar.left <- max(nchar.left) padding.left <- sapply(mxnchar.left - nchar.left + gap.length, function(n) paste0(rep(x=" ", times=n), collapse="")) out.left <- paste0(out.left, padding.left) pre_padding <- paste0(rep(" ", pregap.length), collapse="") paste0(pre_padding, out.left, out.right) } ## ~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+= ## isXbiggerthanY <- function(X, Y, NAs.x.is=FALSE, NAs.y.is=!NAs.x.is) { ## checks if X > Y ## and also checks for NA ## ## If both NA, return NA ## If only Y is NA, return NAs.y.is ## If only X is NA, return NAs.x.is ret <- (X > Y) if (!any(is.na(ret))) return(ret) NAs.x <- is.na(X) NAs.y <- is.na(Y) ret[NAs.x & !NAs.y] <- NAs.x.is ret[!NAs.x & NAs.y] <- NAs.y.is return(ret) } getWidth <- function(max.width=85, min.width=30, actual=FALSE) { ## returns the current width setting, but capped at top and bottom width <- getOption("width", default=1) ## Return the plain width, if flagged to do so if (actual) return(width) ## If one is bigger, either fail or adjust the other if (max.width < min.width) { if (!missing(max.width) && !missing(min.width)) stop ("max.width cannot be less than min.width") if (missing(min.width)) min.width <- max.width else max.midth <- min.width } width <- min(max.width, width) width <- max(min.width, width) return(width) } ## ~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+= ## ## ~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+= ## locate <- function(fun, showWarnings=TRUE) { fun.matched <- try(match.fun(fun), silent=TRUE) if (isErr(fun.matched)) { verboseMsg(showWarnings, "Could not find function '", substitute(fun), "'", sep="", time=FALSE, func="warning") return(NA_character_) } filename <- attributes(attributes(fun.matched)$srcref)$srcfile$filename if (filename == "") { verboseMsg(showWarnings, "It appears that function '", substitute(fun), "' was sourced directly into the environment or does not exist.\nTry running .us() and then re-run locate(", substitute(fun), ") ", time=FALSE, sep="", func="warning") return (NA_character_) } return(path.unexpand(filename)) } findLengthOfDateRange <- function(dateVector, units="month", origin=.origin) { ## takes a date vecotr (or date like) and finds how many elements would be in the full range of min to max if (is.numeric(dateVector) || is.character(dateVector)) dateVector <- as.Date(dateVector, origin=origin) rng <- range(dateVector) return(length(seq.Date(from=rng[[1]], to=rng[[2]], by=units))) } ## ~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+=~+=+~+= ## # canBeNumeric <- function(x, ignoreNumerics=FALSE, maxElements.to.check=1e5, nonNumerics=c("Date"), ignore.vals=c("", "NULL"), showWarnings=TRUE) { # # if (!length(x)) { # if (showWarnings) # warning ("The object passed to canBeNumeric() has no length\nReturning NA") # return(NA) # } # # ... # TODO : Have canBeNumeric & canBeInteger match each other # } convertNumberCols_ <- function(DT, colsToIgnore=NULL, verbose=TRUE) { ## colsToIgnore :: Names of columns that will not be converted numericCols <- nwhich(canBeNumeric(DT, ignoreNumerics=TRUE)) integerCols <- nwhich(canBeInteger(DT, .SDcols=numericCols, ignoreIntegers=TRUE)) numericCols <- setdiff(numericCols, integerCols) numericCols %<>% setdiff(colsToIgnore) integerCols %<>% setdiff(colsToIgnore) if (verbose) { if (length(integerCols)) message(warningCols("The following cols will be converted to integer:", integerCols, cols=7)) else message("There are no columns to convert to integer") if (length(numericCols)) message(warningCols("The following cols will be converted to numeric:", numericCols, cols=7)) else message("There are no columns to convert to numeric") } if (length(numericCols)) DT[, (numericCols) := lapply(.SD, as.numeric), .SDcols=numericCols] if (length(integerCols)) DT[, (integerCols) := lapply(.SD, as.integer), .SDcols=integerCols] return(invisible(DT)) } canBeNumeric <- function(DT, maxRows=1e5, nonNumerics=c("POSIXct", "POSIXt", "POSIX", "POSIXlt", "Date", "logical", "list", "factor", "integer64", "idcol") , ignore.vals=c("", "NULL"), logicals.included=FALSE, posix.included=FALSE, idcol.include=FALSE, ignoreNumerics=FALSE , exclude.idCols.byname=FALSE , justNames.of.DT=FALSE) { ## exclude.idCols.byname :: specifically greps the column names for "id$" and "_id_" avoiding "byID" and "by_id" -- ignore case in all ## Note that this is in addition to class(x) == "idcol" ## ... update ... cannot implement this the way I have it set up ## TODO: 2015-01-24: consider changing the lapply(.SD, ...) to sapply(.SD, ...) ## (first check where this function is called) ## TODO: 2015-01-24: Are the recursive do.call(..., ARGS) efficient ## TODO: 2015-12-20 :: allow for an EXCLUDE argument. ## If a field is excluded, do not even check it; it would be a waste of time if (!is.data.table(DT)) stop ("Currently, canBeNumeric() is only implemented for data.tables ") if (!nrow(DT)) stop ("No rows in DT") if (isTRUE(justNames.of.DT)) { ARGS <- c(collectArgs(except="justNames.of.DT"), justNames.of.DT=FALSE) return(nwhich(do.call(canBeNumeric, ARGS))) } ## Can be generalized to: ColsToReturnFALSE <- .... idCols.byname <- {names(DT)}[grepl("(id$|\\bid\\b)", names(DT), ignore.case=TRUE) & !grepl("by(\\b)*id", names(DT), ignore.case=TRUE)] if (exclude.idCols.byname && length(idCols.byname)) { ARGS <- c(collectArgs(except=c("exclude.idCols.byname", "idCols.byname")), exclude.idCols.byname=FALSE) ret <- do.call(canBeNumeric, ARGS) ## TODO: If changing ret to a vector, this might need to be modified ret[, (idCols.byname) := FALSE] return(ret) } if (logicals.included) nonNumerics <- setdiff(nonNumerics, "logical") if (posix.included) nonNumerics <- setdiff(nonNumerics, extract("POSIX", nonNumerics)) if (idcol.include) nonNumerics <- setdiff(nonNumerics, "idcol") nrows <- min(maxRows, nrow(DT)) ## Chop index into three groups if (nrow(DT) > 3*nrows) { oneThird <- nrows/3 inds <- c( 1:oneThird , (1:oneThird) + round((nrow(DT) - oneThird) / 2) , (nrow(DT) - oneThird):nrow(DT) ) } else { inds <- 1:nrows } DT[inds, lapply(.SD, function(X) { if (is.numeric(X)) return (!ignoreNumerics) if (inherits(X, nonNumerics)) return(FALSE) if (all(is.na(X))) return(is.numeric(X) || NA) ## FALSE || NA ~~> NA ## ELSE X.char <- trim(as.character(X)) blanks <- X.char %in% ignore.vals NAs <- is.na(X) X.num <- suppressWarnings(as.numeric(X)) ## If no NAs introduced, other than blanks, consider numeric NAS.introduced <- is.na(X.num) & !( blanks | NAs ) ## NAS.introduced should be nothing but TRUE/FALSE. If otherwise, there is a bug in my code if (any(is.na(NAS.introduced))) warning ("NAs are present in the object 'NAS.introduced', which should be strictly TRUE or FALSE.\nThis is a sign of a potential bug in possibleNumerics()") return(!any(NAS.introduced)) })] } whichColsCanBeInteger <- function(DT, ignoreIntegers=TRUE, ignoreFactors=FALSE, ignoreIDCols=FALSE, showWarnings=FALSE, .SDcols=names(DT), convertChars=TRUE) { names(which(canBeInteger(DT, ignoreIntegers=ignoreIntegers, ignoreFactors=ignoreFactors, ignoreIDCols=ignoreIDCols, showWarnings=showWarnings, .SDcols=.SDcols, convertChars=convertChars))) } canBeInteger <- function(x, ignoreIntegers=FALSE, ignoreFactors=TRUE, ignoreIDCols=FALSE, showWarnings=TRUE, .SDcols=names(x), convertChars=TRUE) { ## TODO: Add a maxElements.to.check=1e5 argument ## ignoreIntegers is useful for when calling canBeInteger(DT) to subsequently coerce to intger. In this case, one does not normally want to coerce a column that is already of the correct type as this might have a large cost for large types force(x) force(.SDcols) if (!length(x)) { if (showWarnings) warning ("The object passed to canBeInteger() has no length\nReturning NA") return(NA) } if (is.data.table(x)) { if (missing(showWarnings)) showWarnings <- FALSE if (missing(convertChars) && nrow(x) < 500000) convertChars <- TRUE return(sapply(x[, .SDcols, with=FALSE], canBeInteger, ignoreIntegers=ignoreIntegers, ignoreFactors=ignoreFactors, ignoreIDCols=ignoreIDCols, showWarnings=showWarnings, convertChars=convertChars)) } if (is.list(x)) return(lapply(x, canBeInteger, showWarnings=showWarnings)) if (!is.numeric(x) && !(convertChars && is.character(x))) { if (showWarnings) warning ("The object passed to canBeInteger() is of class '", class(x)[[1]], "' not numeric (and if convertChars is TRUE, not a string either).\nReturning FALSE") return(FALSE) } if (inherits(x, "integer64")) return(FALSE) if (is.date_or_time(x)) return(FALSE) if (ignoreFactors && is.factor(x)) return(FALSE) if (ignoreIntegers && is.integer(x)) return(FALSE) if (ignoreIDCols && is.idcol(x)) return(FALSE) if (is.character(x)) { NAs.count <- sum(is.na(x)) x <- try(suppressWarnings(as.numeric(x)), silent=TRUE) if (isErr(x)) { warning("trying to coerce x to numeric produced an error; Assuming it is NOT an integer") return(FALSE) } if (sum(is.na(x)) > NAs.count) { ## TODO: Insert some message to user return(FALSE) } } ## If beyond the machine limit for integer bites if (max(abs(x), na.rm=TRUE) > .Machine$integer.max) return (FALSE) ## Otherwise, check that there are no values with decimals. If so, consider those integers ## In other words, sum of x mod 1 should be 0. (We take the absolute to avoid the case where decimals zero each otehr out) return(0 == (sumn(abs(x) %% 1))) } ## TESTS FOR is_T_or_F if (FALSE) { x <- NULL is_T_or_F(x) is_T_or_F(x, null_ok = TRUE) x <- c(TRUE, FALSE, NA, TRUE) is_T_or_F(x, null_ok = TRUE) is_T_or_F(x, null_ok = TRUE, vectorize=TRUE) is_T_or_F(x, null_ok = TRUE, vectorize=FALSE) is_T_or_F(x, null_ok = TRUE, vectorize=FALSE, showWarnings=FALSE) x <- list(TRUE, FALSE, NA, TRUE, NULL) is_T_or_F(x, null_ok = TRUE) is_T_or_F(x, null_ok = TRUE, vectorize=TRUE) is_T_or_F(x, null_ok = FALSE, vectorize=TRUE) is_T_or_F(x, null_ok = TRUE, vectorize=FALSE) is_T_or_F(x, null_ok = TRUE, vectorize=FALSE, showWarnings=FALSE) ## ERRORS EXPECTED: is_T_or_F(x, null_ok = TRUE, vectorize=TRUE, showWarnings=FALSE, fail.if.not=TRUE) is_T_or_F(x, null_ok = TRUE, vectorize=FALSE, showWarnings=FALSE, fail.if.not=TRUE) } is_T_or_F <- function(x, null_ok=FALSE, vectorize=TRUE, showWarnings=TRUE, simplify=TRUE, fail.if.not=FALSE) { if (length(x) > 1 || is.list(x)) { if (isTRUE(vectorize)) return(sapply(x, is_T_or_F, null_ok=null_ok, vectorize=vectorize, showWarnings=showWarnings, fail.if.not=fail.if.not, simplify=simplify)) else if (showWarnings) warning ("\nx has length ", length(x), " which will cause is_T_or_F(x) to return FALSE\nMake sure this is expected\n\nHINT: set vectorize=TRUE to check each element individually\n set showWarnings=FALSE to turn off this message") } if (isTRUE(null_ok) && is.null(x)) ret <- TRUE else ret <- identical(x, TRUE) || identical(x, FALSE) if (fail.if.not && !ret) { x.nm <- substitute(x) x.nm <- capture.output(x.nm) x.res <- if (is.list(x)) "a list" else clean.capture.output(eval(x)) stop(x.nm, " must be either TRUE or FALSE -- it is '", x.res, "'") } return(ret) } is.char_of_length1 <- function(x, fail.if.not=FALSE, showWarnings=TRUE, null_ok=FALSE, hint=NULL) { ## For verbose messaging x.nm <- substitute(x) x.nm <- capture.output(x.nm) is_nul <- is.null(x) is_str <- is.character(x) is_l1 <- length(x) == 1 ## CHECK FOR NULL, if null_ok if (null_ok && is.null(x)) return(TRUE) if (is_str && is_l1) return(TRUE) msg <- paste0("'", x.nm, "' must be a string vector of length 1", if (null_ok) " or NULL" ,".\n ") msg <- paste0(msg, ifelse(is.null(x), "It is NULL ", paste0("It has length ", length(x), ifelse(is_str, "", sprintf(", but it is not a string (it is a %s)", class(x)[[1]]) )))) if (!is.null(hint)) msg <- sprintf("%s\n \n HINT: %s", msg, hint) if (fail.if.not) stop(msg) if (showWarnings) warning(msg) return(FALSE) } sumTheTableByDate <- function(DT, dateCol="date", ignoreCols=NULL, colsUsing=names(DT), quiet=FALSE) { nms <- names(DT) if (dateCol %ni% nms) { grepd <- grep(dateCol, nms, ignore.case=TRUE, value=TRUE) searched <- getDateColNames(DT) ## Only replace if dateCol was not explicitly set if (missing(dateCol)) { if (length(grepd) == 1) dateCol <- grepd else if (length(searched) == 1) dateCol <- searched } ## if remains missing, fail if (dateCol %ni% nms) stop ("'", dateCol, "' is not a column of DT -- getDateColNames(DT) found the following columns:\n\t ", pasteQ(searched, w="")) # message if using a value other than grepd if (!quiet) message("Using '", dateCol, "' as dateCol") } ## // end error check sumTheTable(DT=DT, byCols=dateCol, ignoreCols=ignoreCols, colsUsing=colsUsing) } sumTheTable <- function(DT, byCols=NULL, ignoreCols=NULL, colsUsing=names(DT), na.rm=TRUE) { if (!is.data.table(DT)) stop ("DT must be a data.table") if (anyDuplicated(colsUsing)) warning ("there are duplicate columns in colsUsing and they will be ignored") if (any(colsUsing %ni% names(DT))) stop (warningCols("Some 'colsUsing' values are not in names(DT): ", setdiff(colsUsing, names(DT)))) if (any(byCols %ni% names(DT))) stop (warningCols("Some 'byCols' values are not in names(DT): ", setdiff(byCols, names(DT)))) colsUsing <- setdiff(colsUsing, ignoreCols) numbCols <- nwhich(sapply(DT[, colsUsing, with=FALSE], is.numeric)) numbCols <- setdiff(numbCols, byCols) if (!length(numbCols)) { warning("There are no numbCols to sum") return(DT) } if (is.null(byCols)) byCols <- setdiff(colsUsing, c(numbCols, ignoreCols)) return(DT[, lapply(.SD, function(x) sum(as.numeric(x), na.rm=na.rm)), by=byCols, .SDcols=numbCols]) } assignIfNotExist <- function(name.NoQuotes, value, envir=globalenv(), inherits=TRUE, verbose=FALSE) { ## Check if a variable exists in envir, and if not, assign it ## returns the existing value, if exists. else returns value name <- as.character(substitute(name.NoQuotes)) ## Check if object exists in envir. If not assign it, if so do nothing (other than verbose output) if (!exists(name, envir=envir, inherits=inherits)) { if (verbose) cat(sprintf("Assigning new value to %s in environment %s\n", name, capture.output(value))) assign(name, value, envir=envir) } else { if (verbose) cat(sprintf("Using exisitng value for %s from environment %s\n", name, capture.output(value))) } ## Note that instead of putting this in the 'else' clause above and then returning ret or value ## This allows an extra step of confirmation, since it is pulling what should definitely be the correct value ret <- get(name, envir=envir, inherits=inherits) return(ret) } stopIfFileMissing <- function(file, addl.info=NULL) { if (!length(file) || !nchar(gsub("\\s+", "", file))) stop("BUG IN YOUR CODE: The code is checking for a file to exist, but the file object (variable) is blank. Check the traceback") msg <- sprintf("could not find file\n '%s'\n", file) if (!is.null(addl.info)) msg <- paste0(msg, "\n", addl.info) if (!file.exists(file)) stop (msg) return(invisible(TRUE)) } padToLength <- function(x, len, pad.with=if(is.character(x)) "" else NA, showWarnings=TRUE) { ## fills 'x' with 'pad.with' until it is of length 'len' if (!(is.atomic(x) || is.list(x))) stop ("x must be an atomic vector or a list") if (length(len) > 1) len <- length(len) if (!is.numeric(len)) stop ("len should be a number") if (length(pad.with) != 1) stop ("pad.with should be of length 1") l.x <- length(x) if (len == l.x) return(x) if (l.x > len) { if (showWarnings) warning ("The length of x (", l.x, ") is greater than len (", len, "), the length to pad to.\n x will be returned unchanged") return(x) } filler <- rep(pad.with, len-l.x) if (is.list(x)) filler <- as.list(filler) return(c(x, filler)) } jofby <- function(BY=get(".BY", envir=parent.frame()), silent=FALSE) { ## Converts a .BY argument to a data.table and outputs a string version that can be copied and pasted. Useful for deving # if (missing(BY) && exists(".BY")) # BY <- .BY if (!length(BY)) { warning ("BY is NULL or has no length") return(invisible(BY)) } browser(expr=inDebugMode("jofby"), text="in jofby, after checking missing(BY) but before checking different classes for BY") { strings <- sapply(BY, is.character) NAs <- sapply(BY, is.na) dates <- sapply(BY, inherits, "Date") Multis <- sapply(BY, length) > 1 } ret <- sapply(BY, as.character) if (any(Multis)) ret[Multis] <- sapply(BY[Multis], function(x) sprintf("c(%s)", jofby(x))) if (any(strings)) ret[strings] <- paste0('"', ret[strings], '"') if (any(dates)) ret[dates] <- paste0('as.Date(', ret[dates], ')') if (any(NAs)) ret[NAs] <- NA.unparsed(BY[NAs], showWarnings=FALSE) names(ret) <- names(BY) out <- sprintf(".(%s)", pasteC(ret, C=", ")) if (!silent) cat(out, "\n") return(invisible(as.data.table(as.list(ret)))) } change_colName_in_all_DTs <- function(old_colnames, new_colnames, DT.nms=lsosdt(pos=2)$name, verbose=TRUE) { ## Finds all 'old_colnames' in DTs and changes them to 'new_colnames' (vectorized) ## new_colnames : can be a named vector if (missing(old_colnames) && !is.null(names(new_colnames))) { old_colnames <- names(new_colnames) } if (missing(new_colnames) && !is.null(old_colnames)) { message("dict detected. Using keys as old_colnames and values as new_colnames") new_colnames <- old_colnames old_colnames <- names(new_colnames) } if (length(old_colnames) != length(new_colnames)) stop("old_colnames is not the same length as new_colnames") if (!length(old_colnames) || !length(new_colnames)) { warning("There are no names to change (length == 0)") return(invisible()) } dups.old <- duplicated(old_colnames) dups.new <- duplicated(new_colnames) if (!identical(dups.old, dups.new)) { stop ("There are duplicates in either old_colnames or new_colnames.\nIf duplicates match up in old & new, then they are simply ignored.\nWhen duplicates do not match up, that is an error.\n") } if (any(dups.old)) { warning("There are duplicates in the column names. These will be ignored") old_colnames <- old_colnames[!dups.old] new_colnames <- new_colnames[!dups.new] } for (DT.nm in DT.nms) { if (is.data.table(DT.nm)) DT <- DT.nm else if (is.character(DT.nm)) DT <- get(DT.nm) else stop ("DT.nms must be a character or data.table") if (!is.data.table(DT)) stop ("get(DT.nm) did NOT resolve to a data.tabel for ", DT.nm) cols.present <- old_colnames %in% names(DT) if (any(cols.present)) { if (verbose) cat("Changing ", sum(cols.present), "column(s) in ", substitute(DT.nm), "\n") setnames(DT, old_colnames[cols.present], new_colnames[cols.present]) } } return(invisible(NULL)) } is_duplicate <- function(vec) { ## returns a BOOLEAN same length as VEC, where TRUE when that element of vec has a duplicate inside of vec ## if vec has no length, returns logical(0L) ## if vec is a data.table returns a data.table of same size, with function ran on each column ## Whereas duplicated() returns FALSE for the first element that has a duplicate, is_duplicate() will return TRUE for the same value # vec <- c("A", "A", "B") # duplicated(vec) # [1] FALSE TRUE FALSE # is_duplicate(vec) # [1] TRUE TRUE FALSE if (!length(vec)) return(logical(0L)) if (is.data.table(vec)) { if (nrow(vec) > 1e5) stop ("the data.table 'vec' is too large to run is_duplicate on all its columns", call.=FALSE) return(vec[, lapply(.SD, is_duplicate)]) } vec %in% vec[duplicated(vec)] } showColDuplicates <- function (DT) { ## Good example of when to comment -- what the hell is this is supposed to do? ## TODO: Needs work (setcolorder(cbind(DT, setnames(DT[, lapply(.SD, duplicated)], paste0(names(DT), ".d"))), order(c(seq(DT) * 2 - 1, seq(DT)*2)))) } sumcolumns <- function(DT, na.rm=TRUE, colsToSum="*", round=0, by=NULL, unique=FALSE) { if (identical(colsToSum, "*")) colsToSum <- setdiff(nwhich(sapply(DT, is.numeric)), by) if (unique) DT[, lapply(.SD, function(x) formnumb(sum(unique(x), na.rm=na.rm), round=0)), .SDcols=colsToSum, by=by] else DT[, lapply(.SD, function(x) formnumb(sum(x, na.rm=na.rm), round=0)), .SDcols=colsToSum, by=by] } getOptionOrFail <- function(x) { ## Attempts to getOption(x) -- if not set, pre <- if (grepl("db\\.default", x)) sprintf("No default %s has been set for the db connection.", gsub("db\\.default", "", x)) else "No default option set." msg <- sprintf("\n%s Use: \n\n\t options(%s = ____ )", pre, x) ## Note that it might be the case that a value is set to NULL, therefore, we need to check for something unique. err.value <- ".its.an.error_abcdefakdjlf" ret <- getOption(x, default=err.value) if (identical(ret, err.value)) stop(msg) else return(ret) } setFactorsToChars_ <- function(DT, skip.these.cols=NULL) { ## Converts factors to characters, by reference ## Capture all columns of class factor factorCols <- nwhich(DT[, lapply(.SD, is.factor)]) ## Drop any columns designated by user to ignore factorCols <- setdiff(factorCols, skip.these.cols) if (length(factorCols)) { DT[, (factorCols) := lapply(.SD, as.character), .SDcols=factorCols] } return(invisible(DT)) } dimofmerge <- function(DT1, DT2) { ## quick wrapper to display the dim of merging two data.tables cat("Keys are", ifelse(identical(key(DT1), key(DT2)), "the same", "different"), "\n") print(dim(DT1)) print(dim(DT2)) print(dim(merge(DT1, DT2, all=TRUE, allow=TRUE))) } sumf <- function(...) { formnumb(sum(...)) } sum_abs <- function(x, na.rm=FALSE) sum(abs(x), na.rm=na.rm) sumn <- function(..., .char.to.NA=FALSE, exceptAllNA=FALSE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## ## exceptAllNA : if TRUE and all of ... is NA, will return NA. Specifically, this is applied BEFORE char.to.find dots.vector <- c(...) if (exceptAllNA && all(is.na(dots.vector))) return(rep(as(NA, Class=class(dots.vector)[[1]]), length(dots.vector))) if (.char.to.NA && is.character(c(...))) return(rep(as(NA, Class=class(dots.vector)[[1]]), length(dots.vector))) sum(...=..., na.rm=TRUE) } min_nowarn <- function(..., na.rm=FALSE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded suppressWarnings(min(..., na.rm=na.rm)) } max_nowarn <- function(..., na.rm=FALSE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded suppressWarnings(max(..., na.rm=na.rm)) } minn <- function(..., na.rm=TRUE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded min(..., na.rm=TRUE) } maxn <- function(..., na.rm=TRUE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded max(..., na.rm=TRUE) } meann <- function(..., na.rm=TRUE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded mean(..., na.rm=TRUE) } rangen <- function(..., na.rm=TRUE) { ## Shorthand to keep the code cleaner, especially inside of DT[...] ## Note that we allow for the na.rm argument to not have a conflict in the dots, however it is disregarded range(..., na.rm=TRUE) } cumsumn <- function(x) { cumsum(removeNA(x, 0)) } msub <- function(pattern, replacement, x, ignore.case=FALSE, perl=FALSE, fixed=FALSE, useBytes=FALSE, whole=FALSE) { ## applies sub() to x iteratively over multiple pattern/replacement pairs ## pattern/replacement will be recycled ## whole := If TRUE, appends "^ .. $" to each pattern if (whole) { if (fixed) warning ("\n'fixed' and 'whole' are both TRUE.\nI am not sure if this will work correctly.") pattern <- paste0("^", pattern, "$") } if (sum(length(pattern), length(replacement)) > 1e4) stop ("This function is intended for only a small number of pattern-replacement pairs") l.p <- length(pattern) l.r <- length(replacement) ## If no length, return x as is if (l.p == 0 || l.r == 0) { warning ("\n'pattern' or 'replacement' has/have length 0.\nReturning 'x' unchanged.") return (x) } # One should be multiple of other if (l.p %% l.r != 0 && l.r %% l.p != 0) stop ("'pattern' and 'replacement' do not have matching lengths") if (l.p < l.r) pattern <- rep(pattern, times=l.r %/% l.p) if (l.r < l.p) replacement <- rep(replacement, times=l.p %/% l.r) for (i in seq(pattern)) x <- sub(pattern[[i]], replacement[[i]], x, ignore.case=ignore.case, perl=perl, fixed=fixed, useBytes=useBytes) return(x) } spaceInNamesToUnderscore_ <- function(x) { warning("spaceInNamesToUnderscore_() has been deprecated\nUse setnamesSpaceToUnderscore_()") setnamesSpaceToUnderscore_(x) } setnamesSpaceToUnderscore_ <- function(x) { if (!is.null(names(x))) data.table::setattr(x, "names", spaceToUnderscore(names(x))) return(invisible(x)) } emptylist <- function(x, nm=names(x)) { ## If x is a single number, take that as the length ## otherwise, use it's length if (!length(x) > 1 && is.numeric(x)) { L <- x } else { L <- length(x) } if (is.null(nm)) nm <- as.character(x) ## return: setNames(obj=vector("list", length=L), nm=nm) } truncDate <- function(x, origin=.origin.utc) { as.Date(strptime(x, format="%Y-%m-%d"), origin=origin) } convertYYYYtodate <- function(x, warn.if.cannot.convert=TRUE) { ## Takes a four-digit year as input and returns as.Date("YYYY-01-01") if (isNumber(x)) x <- as.numeric(x) if (is.numeric(x) && x >= 1900 && x <= 2100) return (as.Date(sprintf("%4i-01-01", x))) ## Else, could not convert if (warn.if.cannot.convert) warning ("Input x (", x, ") was not a 4-digit year. Returned as is.") return(x) } setVerbose <- function(flag="default", value=TRUE) { current.flags <- getOption("verbose2") current.flags[flag] <- value options(verbose2 = current.flags) return(invisible(current.flags)) } getVerbose <- function(flag="default", default=FALSE) { ret <- as.list(getOption("verbose2"))[flag] if (is.null(ret)) isTRUE(default) else any(sapply(ret, isTRUE)) } classAppend_ <- function(X, classToAppend=NULL) { newClasses <- unique(c(classToAppend, class(X))) data.table::setattr(X, "class", newClasses) invisible(X) } classUnappend_ <- function(X, classToUnappend) { newClasses <- setdiff(class(X), classToUnappend) data.table::setattr(X, "class", newClasses) invisible(X) } properRegex <- function(pat, unallowed=c(".^$()[]"), warnIfOffender=TRUE ) { valid <- setNames(nm=pat, obj=rep(TRUE, length(pat))) pat <- setNames(nm=pat) unallowed.pat <- paste0("\\", strsplit(unallowed, "")[[1]], collapse="|") valid <- sapply(pat, function(p) ## it should match itself, it should replace itself to empty, & it should have any unallowed chars. grepl(p, p) & (sub(p, "", p) == "") & !grepl(unallowed.pat, p) ) if (any(!valid) && warnIfOffender) warning("The following regex ", plrl("patterns are", !valid), " not valid", paste("\n\t", pat[!valid])) return(valid) } columnTopN_ <- function(DT, col, valueCol, byCols=c(), TopN=5L, replaceWith="OTHER", FUN.agg=c("sum", "mean"), make.factor=TRUE, showWarnings=FALSE) { ## Replaces with "OTHER" all values in DT[[col]] that are NOT in the TopN ## Useful for when there are lots of Countries, Labels, Genres, Etc.. too many to plot. FUN.agg <- match.fun(FUN.agg) bys <- names(DT)[ match(byCols, names(DT), nomatch=0L) ] if (showWarnings && any(!byCols %in% bys)) warning("Some values in bycols are not in names(DT): ", setdiff(byCols, bys), "\n") levs <- DT[, FUN.agg(get(valueCol)), by=c(bys, col)] [, get(col)[order(V1, decreasing=TRUE)][1:TopN], keyby=bys][, unique(V1)] DT[!get(col) %in% levs, c(col) := replaceWith] if (make.factor) DT[, c(col):= factor(get(col), levels=c(levs, replaceWith))] invisible(DT) } isQuit <- function(selection, quitters=c("x", "Q"), ignore.case=TRUE) { ## For use in readLine menu-options. case.func <- if (ignore.case) tolower else identity return( case.func(as.character(selection)) %in% case.func(as.character(quitters)) ) } coerceKeyColsAndSetKey_ <- function(DT, keyCols, classCols, verbose=TRUE) { if (!all(keyCols %in% names(DT))) stop ("Some keyCols are missing") if (length(keyCols) != length(classCols)) stop("keyCols & classCols are different lengths") ## TODO: make a coerce function for different non-standard classes. Factor check. Etc. for (i in seq_along(keyCols)) DT[, c(keyCols[[i]]) := as(get(keyCols[[i]]), classCols[[i]]) ] if (verbose) { cat("Modified DT: \n") desc(DT, tight.out=TRUE) } setkeyv(DT, keyCols) } getOutDir <- function() { if (exists("outDir")) outDir else getwd() } findDependentPakcages <- function(pkgname, self.include=FALSE, but.dont.include.if.not.loaded=TRUE) { res <- c() for (pkg in search()[-1L]) { if (grepl("^package:", pkg) && exists(".Depends", pkg, inherits = FALSE) && pkgname %in% get(".Depends", pkg, inherits = FALSE)) res <- c(res, pkg) # if (force) # warning(gettextf("package %s is required by %s, which may no longer work correctly", # sQuote(pkgname), sQuote(sub("^package:", "", # pkg))), call. = FALSE, domain = NA) # else stop(gettextf("package %s is required by %s so will not be detached", # sQuote(pkgname), sQuote(sub("^package:", "", pkg))), # call. = FALSE, domain = NA) } #// end for res <- sub("^package:", "", res) if (self.include) { if (!but.dont.include.if.not.loaded || grepl(paste0("[^\\:]", pkgname, "$"), search())) res <- c(res, pkgname) else {} } return(res) } trimToNChars <- function(s, n) { if (n < 3) return(substr(s, 1, n)) if (!length(s)) return(s) if (length(s) > 1) return(sapply(s, trimToNChars, n=n)) nc <- nchar(s) if (nc<= n) return (s) # else s <- gsub("\\[(...*)\\]", "[filtered]", s) if (nc <- nchar(s) > n) s <- gsub("\\[(...*)\\]", "[..]", s) if (nc <- nchar(s) > n) s <- paste0(substr(s, 1, n-2), "..") return(s) } # ------------------------ # # ------------------------ # isYes <- function(x, ignore.whitespace=TRUE, ignore.case=TRUE) { ## A Wrapper function for checking if a human input is "y" or "yes" if (!ignore.case) stop("the 'ignore.case' argument in this function is NOT implemented. It exists so that a user does not use the shorter 'ignore' argument, intending for 'ignore.case', but this function interpretting it as 'ignore.whitespace.'") if (nchar(x) == 1L) { return(tolower(x) == "y") } else { if (ignore.whitespace) x <- gsub("^\\s*|\\s*$", "", x) return(tolower(x) == "yes") } } cropStringTo <- function(x, maxchar=40) { if (!is.character(x)) x <- as.character(x) ifelse(nchar(x) <= maxchar, x, paste0(substr(x, 1, maxchar-2), "..")) } # ------ # isBlankLine <- function(x) { grepl("^\\s*$", x) } # ------ # findColWidth <- function(x, quant=0.85, max.char=Inf, verbose=FALSE) { ## Finds an "optimal" column width, which is the 'quant'th quantile of nchars of the column ## Value is returned in nchar spaces ## quant it the quantile percentage that will be used ## Iterate over the columns if (is.twodim(x)) { return(apply(x, 2, findColWidth, verbose=verbose, quant=quant, max.char=max.char)) } if (!is.null(dim(x)) || is.list(x)) stop ("x should be a one-dimensional vector") if (!length(x)) stop ("x has no length. Cannot find its width") quant <- validPercentage(quant) nc <- nchar(as.character(x)) res <- quantile(nc, quant) ## Do not exceed max.char res <- min(res, max.char) return(res) } # ------ # shellCleanQuotes <- function(x, using.quotes.type=c("'", '"')) { # This is different from shellClean() which escapes certain characters # # FROM : 'hel'lo' # TO : 'hel'"'"'lo' # using.quotes.type <- match.arg(using.quotes.type) ## shorthand for 'using' us <- using.quotes.type ## shorthand for 'not using' nu <- setdiff(c("'", '"'), us) # going to wrap any (us) in (nu us nu) # then need to close the prev (us) and open the next (us) on the outside of the wrap rep <- paste0(us, nu,us,nu, us) gsub(us, rep, x) } whatsOpened <- function(dir="~/git/") { ## Returns a list of the files within 'dir' that are opened. ## ## I dont think this works on Windows ## This only works in the linux sense of "open" cmd <- sprintf("lsof +D '%s'", shellCleanQuotes(dir)) ret <- suppressWarnings(system(cmd, intern=TRUE, ignore.stderr=TRUE)) if (!length(ret)) return("") ret <- read.table(text=ret, header=TRUE) return(as.character(ret$NAME)) } LinuxFlav <- function() { f <- "/etc/issue" if (!file.exists(f)) return("Linux") info <- readLines(f) gsub("( )(release|\\(Final\\))", "", info[[1]]) # the extra ( ) at the beggining is for the parser } SeshInfo <- function() { RV <- R.Version() SI <- sessionInfo(c("data.table", "dplyr")) # RV$system <- gsub("darwin", "Mac OSX ", RV$system) # RV$system <- gsub("linux-gnu", LinuxFlav(), RV$system) Sesh <- list( R = paste0(RV$major, ".", RV$minor) , DT = SI$otherPkgs$data.table$Version , DPLYR = SI$otherPkgs$dplyr$Version , Arch = RV$arch , OS = if (grepl("linux", RV$os)) LinuxFlav() else gsub("darwin", "Mac OSX ", RV$os) ) return(Sesh) } sourceSupportFns <- function(dir=src.p(proj=projName), fail.on.missing=TRUE, verbose=FALSE, msg.on.errors=TRUE, recursive=FALSE, showWarnings=TRUE, projName=getProjName()) { # # if 'dir' is not explicit, default to 'srcDir', if available, otherwise fail. # if (missing (dir)) { # verboseMsg(verbose, "dir was missing") # if (!exists("srcDir")) # stop("srcDir is not set. Run setProject() or dosDir()\n") # else # dir <- srcDir # verboseMsg(verbose, " ... it is now ", dir, "\n") # } ## Check if user accidentally had dir be the full directory to source if (grepl("supportFns(/)*$", dir)) warning("'dir' in 'sourceSupportFns(dir)' should be the PARENT directory to 'supportFns'\n It is currently set to ", dir, "\n HINT: use sourceEntireFolder() to load from folder other than '[srcDir]/supportFns/'") # Append the directory name folder <- as.path(dir, "supportFns") # Check if the file exists. If flagged to fail, will do so. if (!file.exists(folder)) { msg <- sprintf("Could not find folder\n '%s'\n\nHINT: did you mean to use the argument proj='%s'", folder, dir) if (fail.on.missing) stop(msg) # Otherwise, gentle message, if verbose. verboseMsg(verbose, msg, time=FALSE) return(invisible(FALSE)) } verboseMsg(verbose, sprintf("Loading in files from folder '%s'", folder), time=FALSE) # Source the actual folder sourceEntireFolder(folder, verbose=verbose, fail.on.missing.folder=fail.on.missing, msg.on.errors=msg.on.errors, showWarnings=showWarnings, recursive=recursive) } `%cont%` <- function(a, b, any.cont=TRUE, df.uses.names=TRUE) { ## TODO: This function is sloppy, especially with regards to its return values # wrapper function for grepl, ignore.case=TRUE # any: if FALSE returns a vector of results. if TRUE wraps results in any(ret) # df.uses.names: if TRUE and if a (or b) is a data.frame, uses it's names instead of it's values. if (isTRUE(df.uses.names) ) { if (is.data.frame(a)) a <- names(a) if (is.data.frame(b)) b <- names(b) } if (!length(a) || !length(b)) { warning("'a' or 'b' has zero length. `%cont%` is Returning FALSE.", if (isTRUE(df.uses.names)) "\nCheck the names of the data.frame(s).\n" ) return(FALSE) } if (length(b) > 1) { return (sapply(b, function(bb) `%cont%`(a=a, b=bb, any.cont=any.cont, df.uses.names=df.uses.names) )) } ret <- grepl(b, a, ignore.case=TRUE) if (any.cont) { return(length(ret) && any(ret)) } else return(ret) } # +============================================ + # ##### -------------------------------- ###### ##### DT Functions for rbindlist.fill ###### ##### -------------------------------- ###### rbindlist.fill <- function(LL, drop.nulls=TRUE, create.copy=TRUE, proceed.if.large=FALSE) { ## This will be slow for large data.tables. Make sure not too big siz <- object.size(LL) mx.size <- 20 * 1024 * 1024 if (siz > mx.size && !proceed.if.large) stop("Size exceeds ", formatBytes(mx.size), "\nTo proceed, use flag: proceed.if.large = TRUE") # ------ # if (drop.nulls) dtcheck <- function(x) {is.data.table(x) || is.null(x)} else dtcheck <- is.data.table if (!all(sapply(LL, dtcheck))) stop("Not all elements in the list are data.tables") nms.all <- lapply(LL, getNamesWithClass) nms.all <- uniqueByNamesAndValues(unlist(nms.all, use.names=TRUE)) ## TODO: Pick a class to coerce to if (anyDuplicated(names(nms.all))) stop("Differing classes (ie, there are duplicates in nms.all.)\nHint: Check ", pasteQand(names(nms.all)[duplicated(names(nms.all))]), "\n") AddCol_and_OrderCols <- function(D) { if (drop.nulls && is.null(D)) return(D) if (create.copy) D <- copy(D) nms.missing <- setdiff(names(nms.all), names(D)) if (length(nms.missing)) { for (nm in nms.missing) D[, c(nm) := as(NA, nms.all[nm]) ] } setcolorder(D, names(nms.all)) } rbindlist(lapply(LL, AddCol_and_OrderCols)) } getNamesWithClass <- function(DT) { nms <- names(DT) clss <- sapply(DT, function(x) class(x)[[1]]) return(setNames(nm=nms, obj=clss)) } uniqueByNamesAndValues <- function(x) { # TODO: Check if this is accurate ## EXAMPLE ## x <- c(A=1, A=2, A=3, A=3, B=1, B=2, B=2) ## correct <- c(F, F, F, T, F, F, T) ## ## A=1, A=2, A=3, A=3, B=1, B=2, B=2 ## F F F T F F T ## if (is.null(names(x))) { warning ("x was unnamed, so taking unique just by values") return(unique(x)) } DT.count <- data.table(nms=names(x), x=x) DT.count[, dup := .N>1, by="nms,x"] # keep the first of each duplicate DT.count[c(dup), dup := c(FALSE, rep(TRUE, .N-1)), by="nms,x"] return(DT.count[!(dup), setNames(nm=nms, obj=x)]) } ##### -------------------------------------- ###### ##### END: DT Functions for rbindlist.fill ###### ##### -------------------------------------- ###### findDupsBy <- function(DT, by.cols=key(DT), warn=FALSE, showWarnings=warn, debug=FALSE) { ## TODO: This duplicates DT, when key(DT) is not same as bycols if (!is.logical(showWarnings)) { stop("'showWarnings' (the third argument) should be logical.\n Did you accidentcally forget to encompass the argument to 'by.cols=' in c(.)?") } if (!haskey(DT) || !identical(key(DT), by.cols)) { if (showWarnings) warning("'by.cols' is not the same as key(DT) thus this function will have to take a copy() of the data.") DT <- setkeyv(copy(DT), by.cols) } ## TEMP BUG in data.table ## DT BUG: DT[DT[duplicated(DT, by=by.cols), by.cols, with=FALSE]] ## DT BUG: TODO: TEST WHICH IS FASTER ## DT BUG: DT[DT[, .N, by=by.cols][N>1, by.cols, with=FALSE]] browser(expr=isTRUE(debug), text="in findDupsBy() right before calculating 'dups' and before filtering") ## TODO: Test which is faster ## (a) dups <- unique(DT[duplicated(DT, by=by.cols), by.cols, with=FALSE], by=by.cols) dups <- DT[, .N, by=by.cols][N>1, by.cols, with=FALSE] if (!nrow(dups)) return(DT[FALSE]) else DT[dups] } sampleRows <- function(DT, n.rows, n.perc, chunksize=1, min.rows=NULL, max.rows=NULL, seed=NULL, showWarnings=TRUE, chunkSize="DO NOT USE") { ## min.rows / max.rows : If present, these values will cap and override n.rows and n.perc, if the sample size exceeds the min/max ## on 2014-07-08 I changed chunkSize to chunksize to allow for (..chunks=..) if (!missing(chunkSize)) stop("The argument 'chunkSize' has been deprecated.\nPlease use 'chunksize' (with lowercase 's')") if (!is.null(min.rows) && !is.null(max.rows) && min.rows > max.rows) stop(sprintf("min.rows (%s) cannot be greater than max.rows (%s)", min.rows, max.rows)) if (missing (n.rows) && missing(n.perc)) stop ("You must either specifiy the number of rows (n.rows) or the percent of original size (n.perc)") if (!missing(n.rows) && !missing(n.perc)) stop ("You cannot specifiy BOTH n.rows and n.perc.") if (!missing(n.perc)) { n.perc <- validPercentage(n.perc, min=0, max=1) n.rows <- nrow(DT) * n.perc } ## Cap n.rows NOTE that NULL values will be ignored n.rows <- max(min.rows, n.rows) n.rows <- min(max.rows, n.rows) DT[ sampleInChunks(DT, n=n.rows, chunksize=chunksize, seed=seed, showWarnings=showWarnings, hide.sample.in.chunks.warning=TRUE) ] } sampleInChunks <- function(x, n, chunksize=1, seed=NULL, showWarnings=TRUE, hide.sample.in.chunks.warning=FALSE, chunkSize="DO NOT USE") { ## on 2014-07-08 I changed chunkSize to chunksize to allow for (..chunks=..) if (!missing("chunkSize")) stop("The argument 'chunkSize' has been deprecated.\nPlease use 'chunksize' (with lowercase 's')") ## TODO: I have two similar functions written at different times. Clean these up. if (!hide.sample.in.chunks.warning) warning("\n\tNOTE TO SELF\n\t------------\n\tYou have TWO similar functions.\n\t sampleInChunks() & sampleChunks()\n\n ") ## Note: This function (sampleInChunks) gets called by sampleRows ## It alsosamples the index, which seems more applicable... but double check # samples from rows /length in consecutive chunks. # TODO: 1. Check if another similar function already exists # 2. Fix, if none-unique chunk if (!is.null(seed)) set.seed(seed) nr <- if (!is.null(nrow(x))) nrow(x) else length(x) if ((TOTAL.n <- n * chunksize) > nr) { if (showWarnings) warning("Total expected sample size (", TOTAL.n, ") exceeds total size (", nr, ")\n" ) return(seq(nr)) } if (chunksize==1) samp <- sort(sample(nr, n)) else { samp <- outer(sample(nr, n), seq(chunksize), "+") samp <- sort(unique(samp)) %% nr if (samp[[1L]]==0) samp <- samp[-1L] ## TODO: adjust the sample instead of throwing a warning if (length(samp) < TOTAL.n) warning("Sample size (", length(samp), ") is less than the expected sample size (", TOTAL.n, ")\n") } return (samp) } # +============================================ + # DTlistPadAndBind <- function(DT.list, padWith=NA) { ## Takes a list of data.tables, ensures they all have the same columns, then rbindlists them DT.list <- lapply(DT.list, copy) # Error Check if(!all(sapply(DT.list, inherits, "data.table"))) stop("Not all elements of the list are data.tables.") all.nms <- unique(unlist(sapply(DT.list, names), use.names=FALSE)) for (DT in DT.list) { if (length(missing <- setdiff(all.nms, names(DT)))) DT[, c(missing) := padWith] setcolorder(DT, all.nms) } rbindFactorCheck(DT.list) } isErr <- function(x) { # Boolean; Tries to evaluate the expresion; returns T if an error is thrown # Args: # x: Make sure to use x() to pass an x (dont use Strings) # Returns: # TRUE if x throws an Error // F if x is evaluated without error # NOTE: The actual evaluation of the x is NOT RETURNED # NOTE2: x does not need to be an expression, call, etc. # In fact, x can be the output of try(.) # Whilc eval(x) will succeed, the output will be an # object of class 'try-error' (in the event x is the # output of a previous failure) and hence the ultimate # expression evaluates to TRUE ("yes error") ## in SF_Utils, we add an "isErr" attribute to queries. Thus we check for it here ## First check the eval, since if we do the other way around, x will get evald twice return( inherits(try(suppressWarnings(eval(x)), silent=TRUE), "try-error") || (isTRUE(try(suppressWarnings(attr(x, "isErr")), silent=TRUE)))) } matchKey <- function(DT1, DT2, keyCols=if (haskey(DT2)) key(DT2) else key(DT1), superset.ok=TRUE, organize=TRUE, verbose=FALSE) { ## TODO: Verbose to indicate if key was set and on which DT. ## do this by capturing keys before and after if (is.null(keyCols)) { if (!missing(keyCols)) stop("keyCols must not be NULL") else stop("keyCols must be specified or one of DT1 or DT2 must have a key already set.\n") } ## For error messaging { DT1.nm <- pasteC(capture.output(substitute(DT1))) DT2.nm <- pasteC(capture.output(substitute(DT2))) not_in_DT1 <- keyCols[keyCols %ni% names(DT1)] not_in_DT2 <- keyCols[keyCols %ni% names(DT2)] msg <- paste0("" , if (length(not_in_DT1)) warningCols(paste(" Missing from", DT1.nm, " :"), not_in_DT1) , if (length(not_in_DT2)) warningCols(paste(" Missing from", DT2.nm, " :"), not_in_DT2) ) if (msg != "") { msg <- paste0("\nNot all key columns are in both data.tables\n", msg) stop(msg) } } templ <- paste0(" %", mnchar(c(DT1.nm, DT2.nm)), "s : ") if (verbose) cat(sprintf(templ, DT1.nm)) setkeyIfNot(DT1, keyCols, verbose=verbose, superset.ok=superset.ok, organize=organize) if (verbose) cat(sprintf(templ, DT2.nm)) setkeyIfNot(DT2, keyCols, verbose=verbose, superset.ok=superset.ok, organize=organize) return(invisible(keyCols)) } getRFilesFromFolder <- function(folder, recursive=TRUE, all.files=TRUE, exts=c("r", "R", "s", "S", "Rprofile"), fail.on.folder.missing=TRUE, ignore=c("_latestBackups.r")) { ## Check if the folder exists. Fail or message according to the flags if (!file.exists(folder)) { if (fail.on.folder.missing) stop(sprintf("Directory '%s' was not found", folder)) return(character(0)) } pats <- regOr(c(paste0("\\.", exts, "$"), "^Rprofile.site$")) files <- dir(folder, pattern=pats, full.names=TRUE, all.files=all.files , recursive=recursive, include.dirs=FALSE) ## TODO: vectorize for (ign in ignore) files <- files[!grepl(ign, files)] return(files) } beep <- function(howMany=3, delay=0.2) { for (i in seq(howMany)) { Sys.sleep(delay) alarm() } } notTRUE <- function(x) { # i am not sure when this would come in handy sapply(x, Negate(isTRUE)) } cot <- function(...){ if (all(is.character(...))) cat(..., "\n") else { out <- capture.output(...) out <- gsub("^\\[[0-9]+\\] ", "", out) cat(out, sep="\n") } } relativePath <- function(path, relativeTo, noStartingSlash=FALSE) { ## not sure if this correct pat <- paste0("^", escapeRegEx(path.expand(relativeTo))) if (noStartingSlash) pat <- paste0(pat, "/?") gsub(pat, "", path.expand(path)) } ## This is needed for one of the utilSource functions I believe if (!exists("formatBytes")) { formatBytes <- function(x, ...) { return(paste0(round(x/1000, 1), "kilobytes")) } } filesByTimeStamp <- function(prototypefile, ignore.latest=TRUE, folder=path.unexpand(dirname(prototypefile)), pat.stamp="\\d{6,8}(-|_)+\\d{4,6}") { if (!is.logical(ignore.latest)) stop("'ignore.latest' must be TRUE/FALSE") if (length(prototypefile) != 1) stop ("prototypefile must have length exactly one") splat <- splitOnLast(prototypefile, "\\.")[[1]] if (!length(splat) == 2 || !nchar(splat)) stop("file must have an extension") ext <- splat[[2]] file_base <- gsub(pat.stamp, "", basename(splat[[1]])) files <- extractFilesFromFolder(folder=folder, pattern=file_base, ext=ext, ignore.case.pattern=FALSE, ignore.case.ext=TRUE) if (!length(files)) return(files) if (length(files) == 1 && ignore.latest) return(setNames(nm=character())) times <- gsub(sprintf("(.*?)(%s)(.*)", pat.stamp), "\\2", files) if (ignore.latest) files <- files[!times == {sort(times, decreasing=TRUE)[[1]]} ] return(setNames(nm=names(files), as.path(folder, files))) } ## finds all .R files within a folder and soruces them sourceEntireFolder <- function(folderName, verbose=FALSE, showWarnings=TRUE, fail.on.missing.folder=TRUE, msg.on.errors=TRUE, ignore.subfolders=getOption("ignore.subfolders"), recursive=FALSE) { ## ------------------------------ ## ## Check if the folder exists. ## Fail or message according to the flags if (!file.exists(folderName)) { msg <- sprintf("Directory '%s' was not found", folderName) if (fail.on.missing.folder) stop(msg) else if (showWarnings) warning(msg) else if (verbose) cat(msg, "\n") return(invisible(FALSE)) } ## ------------------------------ ## ## Get all R files in the folder, taking the full directory name files <- extractFilesFromFolder(folderName, recursive=recursive, full.names=TRUE) ## debugging browser(expr=inDebugMode(c("source", "sourceEntireFolder")), text="in sourceEntireFolder, just after getting files.") lf <- length(files) if (!lf && showWarnings) warning("No R files in ", folderName) else if (verbose) cat("Will source", lf, "files.") ret <- emptylist(files) for (f in names(files)) { if (verbose) cat("sourcing supportFns file: ", f, "\n") ## TODO: add caught whether error or not and return that ret[[f]] <- tryCatch({source(files[[f]], local=FALSE, echo=FALSE); TRUE}, error=function(e) {ret <- FALSE; attr(ret, "error") <- as.character(e); return(ret)}, finally=TRUE, silent=!verbose) } ## Notfify user if (lf && (msg.on.errors || verbose)) { failures <- !(unlist(ret)) if (msg.on.errors && any(failures)) { message(sprintf(" %s\n%i (out of %i) supportFns %s FAILED to load. %s:\n%s %1$s\n", pasteR("~=", 25) , sum(failures), lf, plrl("files", failures), plrl("They are", failures) , pasteC(sprintf("\n * %32s : %s", names(ret)[failures], sapply(ret, attr, "error")[failures] ) ) )) } else if (verbose && !any(failures)) { cat ("All", lf, " supportFns files successfull loaded\n") } } return(invisible(ret)) } copr <- function(x) capture.output(print(x)) as.ch.as.exp <- function(x) as.character(as.expression(x)) indexToLogical <- function(indexVector, totalLength, cleanNA=TRUE) { if(is.logical(indexVector)) { return(if (cleanNA) NAtoFALSE(indexVector) else indexVector) } if(!is.numeric(indexVector)) stop("indexVector should be a numeric or logicla vector") ## Converts an index vector of a designated length to a logical vector ret <- rep(FALSE, totalLength) ret[indexVector] <- TRUE if (cleanNA) ret[is.na(ret)] <- FALSE else ret } withinCutoff <- function(x, bottomPerc=0, topPerc=100, value=FALSE, inverse=FALSE, na.rm=TRUE) { # returns logical vector, same length as x if (value) return(x[withInCutOff(x=x, bottomPerc=bottomPerc, topPerc=topPerc, value=FALSE, inverse=inverse, na.rm=na.rm)]) if (inverse) return(!(withInCutOff(x=x, bottomPerc=bottomPerc, topPerc=topPerc, value=FALSE, inverse=FALSE, na.rm=na.rm))) if (!length(bottomPerc)==1 || !length(topPerc)==1 || !is.numeric(topPerc) || !is.numeric(bottomPerc)) stop("bottomPerc & topPerc must be numeric values of length 1.") bottomPerc = bottomPerc / 100 topPerc = topPerc / 100 if (bottomPerc <=0 & topPerc >= 1) return(rep(TRUE, length(x))) if (bottomPerc == 0 ) x <= quantile(x, topPerc, na.rm=na.rm) else if (topPerc == 1) x >= quantile(x, bottomPerc, na.rm=na.rm) else { qq <- quantile(x, c(bottomPerc, topPerc), na.rm=na.rm) qq[[1]] <= x & x <= qq[[2]] } } gcQuietly <- function(verbose=TRUE) { # the "quietly" refers to the output from gc() if (verbose) cat("Performing garbage cleanup... ") ret <- gc() if (verbose) cat(" DONE.\n") return(invisible(ret)) } order.dec <- function(..., decreasing=TRUE) { # wrapper function useful for clean sapply calls order(..., decreasing=decreasing) } getErrorLineNumbers <- function(e) { ## Always returns FALSE with an attribute of `lines` ret <- FALSE if(length(e$message) > 1) { warning ("In trying to parse error message, I've unexpectadly encountered an e$message whose length > 1.") } if (!length(e$message)) return(FALSE) ## Some known errors ### ## TODO: Turn this into a list to iterate over ## ---------------------------------------------- ## if (grepl("cannot open", e$message)) { attr(ret, "lines") <- "FILE UNAVAILABLE" return(ret) } if (grepl("unexpected end of input", e$message)) { attr(ret, "lines") <- "POSSIBLE UNCLOSED BRACKET" return(ret) } if (grepl("repeated formal argument", e$message)) { attr(ret, "lines") <- gsub("repeated formal argument (.+) on line (.+)", "REPEATED ARG \\1 LINE: \\2", e$message) return(ret) } ## ---------------------------------------------- ## ## If the error is not a specific one listed above, simply parse out the line numbers if (!grepl("\\b\\d+\\b", e$message)) { attr(ret, "lines") <- as.character(e$message) return(ret) } # OLD 20150720: lineNumbers <- gsub("^(\\d*)(.*)", "\\1", strsplit(e$message, "\n")[[1]]) # NEW: lineNumbers <- gsub("^.*?(\\d+)", "\\1", strsplit(e$message, "\n")[[1]]) lineNumbers <- gsub("^(\\d*)(.*)", "\\1", lineNumbers) lineNumbers <- setdiff(lineNumbers, "") lineNumbers <- suppressWarnings(as.numeric(lineNumbers)) lineNumbers[is.na(lineNumbers)] <- (-1) # these should never really happen. ## NA's indicate that there is no error line indicated in the error message. if (!length(lineNumbers)) lineNumbers <- "check getErrorLineNumbers() [!length(lineNumbers)]" attr(ret, "lines") <- lineNumbers return(ret) } tryToSource <- function(file, verbose=FALSE, showWarnings=TRUE) { ## The purpose of the `!isTRUE(.)` : ## ideally, I would like `tryCatch` to return TRUE if successfull (and run the error function if not) ## However, I do not know how to get it to return TRUE if successfull ## hence the logical wrap. ret <- tryCatch( expr = { isTRUE(source(file)) || TRUE } , error = getErrorLineNumbers ) if ((showWarnings || verbose) && !isTRUE(ret)) { warning("\n\n\tThe following ", plrl("files were", ret), " not properly loaded:\n", errParse(ret)) } return(ret) } msg.lineNumber <- function(x, width1=40) paste0(sprintf( paste0("%", width1, "s (Lines: "), names(x)), sapply(lapply(x, sprintf, fmt="%4s"), paste, collapse=", "), ")" ) msg.string <- function(x, width1=40) paste0(sprintf( paste0("%", width1, "s ("), names(x)), sapply(x, paste, collapse=", "), ")" ) errParse <- function(vec, width1=40, collapse="\n") { isNumb <- sapply(vec, is.numeric) paste0(ifelse(isNumb, msg.lineNumber(vec, width1), msg.string(vec, width1)), collapse=collapse) } ### 20140912 - todo for errParse() # # example: ## This is what I produced # example: [ FILE ] [ ERROR LOCATION ] # example: ---------- -------------------- # example: DB_Utils/DB_Utils_Setters_and_Getters.r (attempt to use zero-length variable name) # example: xls_utils.r (Lines: 82, 83) # example: # example: ## Whereas, this was the error: # example: R> source("~/git/misc/rscripts/utils/DB_Utils/DB_Utils_Setters_and_Getters.r") # example: Error in options("") : attempt to use zero-length variable name # example: # example: ## This was the offending line: # example: options("") minmax <- function(x, min.nm="minDate", max.nm="maxDate") { ## Warpper function for use in data.table `j` expression ## returns a list of two named elements, min & max ## ## This function deliberately has no input checks, as it is expected to be used in an iterative fashion setNames(as.list(range(x)), c(min.nm, max.nm)) } # ---------------------- # # test # ## TESTS # test # byCols <- c("genre", "upc", "label") # test # ( rangeDateBy(StreamsReport, dateCol, byCols) ) # test # ( rangeDateBy(StreamsReport, dateCol, byCols, byCols.dict=setNames(obj=c("HELLO", "World"), nm=byCols[1:3])) ) # test # rangeDateBy <- function(DT, dateCol, byCols, byCols.dict=byCols, na.rm=TRUE) { # Calculates the min & max date by `byCols` # changes the names of byCols to that of byCols.dict # byCols.dict : a named list, whose names are values of byCols or a an unnamed vector whose length is equal to byCols ## INPUT CHECK if (any(c("dateMin", "dateMax") %in% c(byCols))) # note, it does not matter if dateMin/dateMax are other names in DT, not even in dateCol stop("Names of `byCols` conflict the new column `dateMin` or `dateMax` which we will be creating.") if (length(dateCol) != 1) stop("`dateCol` must be of length 1") if (!is.character(dateCol) || !is.character(byCols)) stop("`dateCol` & `byCols` must be characters (strings)") if (is.null(names(byCols.dict)) && length(byCols.dict) != length(byCols)) { stop("`byCols.dict` must be either a named list or a a vector the same length as `byCols`") } if (is.null(names(byCols.dict))) names(byCols.dict) <- byCols # Drop any names from dict, not in byCols. This allows for the use of generic table dictionaries. byCols.dict <- removeNA(byCols.dict[byCols]) ## Ensure that valid values still remain if (!length(byCols.dict)) { ## NOTE: This could be a warning, as there would be no adverse impact, but keeping as error stop("No valid names in `byCols.dict` when intersecting with `byCols`.") } ## DEAL WITH NA's inds <- if (!na.rm) TRUE else { which(!is.na(DT[, byCols, with=FALSE]), arr.ind=TRUE)[, "row"] } setnames( DT[inds , setNames(as.list(range(get(dateCol))), c("dateMin", "dateMax")), by=byCols] , old=names(byCols.dict) , new=byCols.dict ) } # ---------------------- # identical.data.table <- function(x, y, ...) { if(!is.data.table(x) || !is.data.table(y)) return(identical(x, y)) identical(setNames(as.data.frame(x), names(x)), setNames(as.data.frame(y), names(y)), ...) } fixColTypes_ <- function(DT, integer=NULL, numeric=NULL, character=NULL , logical=NULL, idcol=NULL, Date=NULL, POSIXct=posix, POSIXct.milli=NULL , factor=NULL, factor_list=NULL , posix=NULL # columns below here, make sure to add to "argspresent" negative list , allowFactorColToNA=FALSE , failOnMissingCols=TRUE , verbose=FALSE , showWarnings=verbose , origin=as.Date("1970-01-01", format="%Y-%m-%d") , origin.posix=as.POSIXct("1970-01-01 00:00:00", format="%Y-%m-%d %H:%M:%S", tz=tz.posix) , tz.posix="UTC" , drop.these.columns=NULL ) { ## posix : a synonym to POSIXct. Needed for (1) caps and even if not cap, POSIXct.milli would still match ## Converts columns to the specified ## Which arguments are present in the current call to this function argspresent <- setdiff(names(match.call()), c("factor_list", "Date", "POSIXct", "posix", "idcol" , "factor", "", "DT", "verbose", "showWarnings" , "origin", "origin.posix", "failOnMissingCols" , "drop.these.columns", "tz.posix", "allowFactorColToNA")) ## Wrapper function to return levels / labels of nm, if they exist. Else returns NULL getLabs <- function(nm) tryCatch(factor_list[[c(nm, "labels")]], error=function(e) return(NULL)) getLevs <- function(nm) tryCatch(factor_list[[c(nm, "levels")]], error=function(e) return(NULL)) if (is.character(DT) && exists(DT, envir=parent.frame())) DT <- get(DT, envir=parent.frame() ) if (!is.data.table(DT)) stop("DT should be a data.table") if(! (nrow(DT) >=1) ) warning("DT does not have any rows. Results might be wrong.") ## Here we just *Check* the factor list before proceeeding. We do not process it until later. if (!is.null(factor_list)) { ## Confirm it is a list if (!is.list(factor_list)) stop ("`factor_list` should be a list.") ## Iterate over each element in the list for (nm in names(factor_list)) # no need for bracket, just checking each col to see if already factor. # first check if it is already a factor, so as to not unwittingly introduce NAs if (is.factor( DT[[nm]] )) { # DT[[nm]] is NULL if nm does not exist as a column ## Remember that factor list has not only which columns to make factors, but also what ## their levels/labels should be. It is too expensive to check the enitre column, ## therefore, we try to match a sampling of the column (ie DT[[nm]]) to the ## described levels in the factor_list. ## if (all(is.na(match(DT[[nm]][sample(nrow(DT), min(100, nrow(DT)))], getLevs(nm))))) { ## Assuming the *levels* match, there is still another issue. Namely, ## if the levels in the factor_list do NOT match up with the current levels of DT[[nm]] ## then the call to factor below, which is: factor(get(nm), levels=getLevs(nm), labels=getLabs(nm)) ## will cause NA's. ## Where this might happen is if running this function for a second time, and, for example, we have ## levels = c(0, 1); labels = c("Male", "Female") ## On the second passing, the values 0 & 1 will no longer be in DT[[nm]]. ## ## Thus we give the user the option of whether or not to allow this. ie, allowFactorColToNA ## This is the message that will be displayed, either as a warning or an error. msg <- paste0("Column '", nm, "' is already a factor and attempting to convert might coerce NAs, especially if the levels are different from the labels.") if (!allowFactorColToNA) stop(msg) else if (showWarnings) warning(msg) ## ELSE here means that the column is a factor, but the values do not match. That is an error. } else { ## grab some of the levels to show to the user levs.actual <- c(head(levels(DT[[nm]]), 3), "..") levs.expect <- c(head(getLevs(nm), 3), "..") msg.levs <- paste(warningCols("\tExpected levels where: ", levs.expect, endl=1), warningCols("\twhile the current levels are: ", levs.actual)) stop("\nPlease manually check column '", nm, "'.\nIt is a factor, but its levels do NOT match those described in the arguments to this function.\n\n", msg.levs, "\n") } } #// end "if (is.factor( DT[[nm]] ))" } # // end checking factor list for valid input ## TODO: ## THIS IS A MISTAKE!! NOTICE THAT THEY GET REMOVED AGAIN FURTHER IN THE CODE. if (!failOnMissingCols) { integer <- intersect(integer, names(DT)) numeric <- intersect(numeric, names(DT)) character <- intersect(character, names(DT)) factor <- intersect(factor, names(DT)) logical <- intersect(logical, names(DT)) Date <- intersect(Date, names(DT)) idcol <- intersect(idcol, names(DT)) factor_list <- factor_list[intersect(names(factor_list), names(DT))] } ## If adding more arguments, add them here too ## Factor cols that will not remain factor/character cols, need to be converted to characters factorCheck <- intersect(c(integer, numeric, logical, Date, idcol, POSIXct, POSIXct.milli), names(DT)) if (length(factorCheck)) factorsToChar <- nwhich(DT[, sapply(.SD, is.factor), .SDcols={factorCheck} ]) if (length(factorsToChar)) DT[, (factorsToChar) := lapply(.SD, as.character), .SDcols={factorsToChar} ] ## Adjust POSIX cols for milliseconds if (!is.null(POSIXct.milli)) { if (length(wh <- setdiff(POSIXct.milli, names(DT)))) { POSIXct.milli <- intersect(POSIXct.milli, names(DT)) if (showWarnings) warning(warningCols("POSIXct.milli columns not found in names(DT): ", wh)) } DT[, c(POSIXct.milli) := lapply(.SD, function(x) if(!is.numeric(x)) {as.numeric(x) / 1000} else {x / 1000} ), .SDcols=POSIXct.milli] POSIXct <- c(POSIXct , POSIXct.milli) POSIXct.milli <- NULL } ## Convert Factor lists if (!is.null(factor_list)) { ## Confirm it is a list if (!is.list(factor_list)) # this check might be redundant stop ("`factor_list` should be a list.") ## Check that all names of factor_list are column names of DT if (length(missing <- setdiff(names(factor_list), names(DT)))) { stop (warningCols("These factor_list elements are not names of DT: ", missing)) } else rm (missing) # We use the var name 'missing' again, later in this function. ## Iterate over each element in the list for (nm in names(factor_list)) { DT[, c(nm) := factor( get(nm), levels=getLevs(nm), labels=getLabs(nm) )] } } #// end if factor_list ## TODO: Wrap these non-DRY sections up into one. ## Also, add verbose output ## Re-copy verbose from last line. # factor ----------------- # if (!is.null(factor)) { # check for missing cols if (length(wh <- setdiff(factor, names(DT)))) { factor <- intersect(factor, names(DT)) if (showWarnings) warning(warningCols("factor columns not found in names(DT): ", wh)) } if (length(factor)) { if (verbose) cat("Converting to ", "factor", "the following: \n", paste_l(factor, sameW=TRUE, preline=" "), "\n") DT[, (factor) := lapply(.SD, as.factor), .SDcols=factor] } } # idcol ----------------- # if (!is.null(idcol)) { # check for missing cols if (length(wh <- setdiff(idcol, names(DT)))) { idcol <- intersect(idcol, names(DT)) if (showWarnings) warning(warningCols("idcol columns not found in names(DT): ", wh)) } if (length(idcol)) { if (verbose) cat("Converting to ", "idcol", "the following: \n", paste_l(idcol, sameW=TRUE, preline=" "), "\n") DT[, (idcol) := lapply(.SD, as.idcol), .SDcols=idcol] } } # date ----------------- # if (!is.null(Date) && !is.na(Date)) { # check for missing cols if (length(wh <- setdiff(Date, names(DT)))) { Date <- intersect(Date, names(DT)) if (showWarnings) warning(warningCols("Date columns not found in names(DT): ", wh)) } if (length(Date)) { if (verbose) cat("Converting to ", "Date", "the following: \n", paste_l(Date, sameW=TRUE, preline=" "), "\n") DT[, (Date) := lapply(.SD, as.Date, origin=origin), .SDcols=Date] } } # posixct ----------------- # if (!is.null(POSIXct) && !is.na(POSIXct)) { # check for missing cols if (length(wh <- setdiff(POSIXct, names(DT)))) { POSIXct <- intersect(POSIXct, names(DT)) if (showWarnings) warning(warningCols("POSIXct columns not found in names(DT): ", wh)) } if (length(POSIXct)) { if (verbose) cat("Converting to ", "POSIXct", "the following: \n", paste_l(POSIXct, sameW=TRUE, preline=" "), "\n") DT[, (POSIXct) := lapply(.SD, function(x) { ret <- as.POSIXct(x, origin=origin.posix) lubridate::tz(ret) <- tz.posix ret }) , .SDcols=POSIXct] } } # -------------------------- # # generic ----------------- # for (classType in argspresent) { cols <- get(classType) # check for missing cols if (length(wh <- setdiff(cols, names(DT)))) { cols <- intersect(cols, names(DT)) if (showWarnings) warning(warningCols(paste(classType, "columns not found in names(DT): "), wh, midbreak=1, endl=0)) } # don't bother converting anything that is already of the correct type. if (length(cols)) { cols <- cols[!DT[, sapply(.SD, inherits, classType), .SDcols=cols]] } if (length(cols)) { if (verbose) cat("Converting to '", classType, "'the following: \n", paste_l(cols, sameW=TRUE, preline=" "), "\n", sep="") DT[, (cols) := lapply(.SD, as, Class=classType), .SDcols=cols] } else { if (verbose) cat("No columns to convert for '", classType, "'\n", sep="") } } # // End for-loop argspresent if (!is.null(drop.these.columns) && is.character(drop.these.columns) && length(drop.these.columns)) DT[, c(drop.these.columns) := NULL] return(invisible(DT)) } as.int_or_num <- function(x, force.numeric=FALSE) { if (!is.vector(x)) stop ("'x' should be a vector") if (!is.numeric(x)) x <- as.numeric(x) ## Coerce if within range of mechine limits if (!force.numeric && all(abs(x) < .Machine$integer.max)) x <- as.integer(x) return(x) } as.num.nowarn <- function(...) suppressWarnings(as.numeric(...)) cleanPosix <- function(X, tz="") { frmt <- "%a %d %b at %R %p" format(X, format=frmt, tz=tz) } OneOrMany <- function(DT, colsToCheck, byCol, dateCol=NULL) { byCols <- c(byCol, dateCol) DT[, lapply(.SD, lunique), by=byCols, .SDcols=colsToCheck][, sapply(.SD, function(x) ifelse(all(x==1), "One", "Many")), .SDcols=colsToCheck] } ## This is simply beacause I cannot type traceaback <- traceaback <- function() { warning("\n\n\t", pasteR("!____", 5), "!\n\n\tSTOP TYPING THAT EXTRA a!!!\n\t", pasteR("!____", 5), "!\n\n") traceback() } warningCols <- function(preMessage=NULL, columns, postMessage=NULL, sameWidth=FALSE, midbreak=1, endl=1, cols=5) { ## returns a string to be included in warning() or message() ## for outputting info such as missing columns, etc. ## ## preMessage & postmessage can be a vector of strings which will be collapsed (with no space) if (missing(columns) && !missing(preMessage)) { columns <- preMessage preMessage <- NULL } if (is.logical(columns) && !is.null(names(columns)) && !any(names(columns) == "")) columns <- nwhich(columns) ## Allow for vector of strings if (length(preMessage) > 1) preMessage <- paste0(preMessage, collapse="") if (length(postMessage) > 1) postMessage <- paste0(postMessage, collapse="") if (!length(preMessage) && !length(columns)) return(paste0(preMessage, "\n", columns)) if (!is.null(postMessage) && !grepl("\\n$", postMessage)) postMessage <- paste0(postMessage, "\n") if (is.numeric(midbreak)) midbreak <- pasteR("\n", midbreak) if (is.numeric(endl)) endl <- pasteR("\n", endl) paste0("\n", preMessage, midbreak, paste_l(x=columns, cols=cols, preline="\t", sameWidth=sameWidth, eol=TRUE, spacer=", "), endl, postMessage) } nwhich <- function(x, arr.ind=FALSE, useNames=TRUE) { # if x is empty, return an empty string vector if (!length(x)) return(character(0L)) ## if x is a 1-row DF/DT OR if x is just a list of elements if ( (is.data.frame(x) && nrow(x)==1) || (is.list(x) && is.null(dim(x))) ) x <- unlist(x, recursive=FALSE, use.names=TRUE) names(which(x=x, arr.ind=arr.ind, useNames=useNames)) } sbind <- function(x, rbind=FALSE) { ## . %>% sort %>% cbind if (!is.atomic(x)) return(x) valueIfErr( expr = { if (rbind) x %>% sort %>% rbind else x %>% sort %>% cbind } , value = x ) } if (FALSE) { x <- 3 is.escaped(x) as.escaped(x) is.escaped(x) x %<>% as.escaped is.escaped(x) } ## TODO: add as.escaped <- function(x) { attr(x, "escaped") <- TRUE x } is.escaped <- function(x) { isTRUE(attr(x, "escaped", exact=TRUE)) } getSpecialChars <- function(nm=c("regexChars", "shellChars")) { ## 2015-08-15 Removed '*' from shellChars ## These are my best guess, might be incomplete regexChars="()[]{}!=*.?+\\^$|" ## no angled brackets. These affect look around but do not need to be escaped shellChars="()[]{}<>!=' ,&\"\\" ## cannot use angled brackets nm <- match.arg(nm) ret <- get(nm) return(ret) } escapeSpecialChars <- function(x, charsToEscape=NULL, use=c("regexChars", "shellChars"), esc="\\") { ## make sure esc is a single string is.char_of_length1(esc, fail=TRUE) if (is.escaped(x)) return(x) if (!length(x)) return(x) # ## These are my best guess, might be incomplete # regexChars="()[]{}<>!=*.?+\\^$" ## no angled brackets. These affect look around but do not need to be escaped # shellChars="()[]{}<>!=*' ,&\"\\" ## cannot use angled brackets regexChars <- getSpecialChars("regexChars") shellChars <- getSpecialChars("shellChars") ## cannot use both 'use' & 'charsToEscape' (unless one is null) if (!missing(use) && !missing(charsToEscape) && !is.null(charsToEscape) && !is.null(use)) { warning ("both 'use' and 'charsToEscape' have been specified. 'use' will be ignored") } if (is.null(charsToEscape)) { use <- match.arg(use) charsToEscape <- get(use, envir=environment()) } if (length(charsToEscape) == 1) charsToEscape <- strsplit(charsToEscape, "")[[1]] if(leftAngled <- {"<" %in% charsToEscape}) charsToEscape <- setdiff(charsToEscape, "<") if(rightAngled <- {">" %in% charsToEscape}) charsToEscape <- setdiff(charsToEscape, ">") ## if duplicated charsToEscape, I'm not sure what effect it will have given the replace charsToEscape <- unique(charsToEscape) if (identical(esc, "\\")) rep <- "\\\\\\1" ## Need six slashes for the replace: \\ \1 else rep <- paste0(esc, "\\1") ## paste together all of the characters, with regex escapes pat <- pasteQ(sprintf("\\%s", charsToEscape), q="", C="|") ## return ret <- gsub(pat, rep, x) ## angled brackets need to be handled separately, to avoid look-around issues with regex if( leftAngled) ret <- gsub("<", "\\\\<", ret) if(rightAngled) ret <- gsub(">", "\\\\>", ret) ret <- as.escaped(ret) return(ret) } shellClean <- function(x, esc="\\", warnAsterisk=TRUE) { is.char_of_length1(esc, fail=TRUE) if (any(grepl("\\*", x))) verboseMsg(warnAsterisk, "An asterisk ('*') was found in the x sent to shellClean() -- This will be left as is and NOT cleaned.", func="warning", call.=FALSE) escapeSpecialChars(x=x, use="shellChars", esc=esc) } escapeRegEx <- function(x=ex, esc="\\", ex, showWarnings=TRUE) { is.char_of_length1(esc, fail=TRUE) ## the main argument used to be called "ex" if (!missing(ex)) { mc <- sys.call() verboseMsg(showWarnings, "Argument 'ex' has been deprecated -- Please use 'x' instead.\nCorrect this call:\n\n ", capture.output(mc), "\t [might not have spaces]\n", func="warning", call.=FALSE) } escapeSpecialChars(x=x, use="regexChars", esc=esc) } escapeHTML <- function(x) { warning("escapeHTML is incomplete -- it only escapes brackets and quotes\n\nTRY: quickUrlEncode()") x %>% gsub("<", "<", .) %>% gsub(">", ">", .) %>% gsub("\"", """, .) %>% gsub("'", "'", .) } ## KEEPING OLD VERSION OF splitOnLast until confident new version works correctly ## 20140825 # splitOnLast <- function(string, splitOn=".", funky="vx33xABCDEFGxvQQRRSSre456789") { # if (!grepl("\\^|\\$|\\\\", splitOn)) # splitOn <- escapeRegEx(splitOn) # # # This is in place of a lookbehind, which I am not sure if it is possible to do with varying length strings # pat <- paste0("(.*", splitOn, ".*)*", splitOn, "" ) # "(.*\\..*)*\\." # pat <- sprintf("(.*%s.*)*%1$s", splitOn) # "(.*\\..*)*\\." # # if (any(grepl(funky, string))) # stop("It's a Tuesday. The randomstring funky='", funky, "' appears in string to be split.") # # replace <- paste0("\\1", funky) # string <- gsub(pat, replace, string, perl=TRUE) # # strsplit(string, funky, perl=TRUE) # } splitOnFirst <- function(string, splitOn=".", perl=FALSE) { splitOnF_L(string=string, splitOn=splitOn, first_or_last="first", perl=perl) } splitOnLast <- function(string, splitOn=".", perl=FALSE) { splitOnF_L(string=string, splitOn=splitOn, first_or_last="last", perl=perl) } splitOnF_L <- function(string, splitOn=".", first_or_last=c("first", "last"), funky="vx33xABCDEFGxvQQRRSSre456789", perl=FALSE) { ## Update 20140916 - changed default perl from TRUE to FALSE, specifically because it was failing when there were escaped chars in string (eg "hello\nwor;d") browser(expr=inDebugMode(c("splitOnF_L", "splitOnFirst", "splitOnLast", "split")), text="in splitOnF_L() at the very top") ## Clean first_or_last ## -------------------------------------- ## allow for first=FALSE or first=TRUE if (is.logical(first_or_last)) { first_or_last <- if(isTRUE(first_or_last)) "first" else if (identical(first_or_last, FALSE)) "last" else NA } if (is.null(first_or_last) || is.na(first_or_last)) stop("invalid value for first_or_last") first_or_last <- match.arg(first_or_last) ## -------------------------------------- ## Clean splitOn ## -------------------------------------- ## Check for escape string, or carrets / dollar signs if (!grepl("\\^|\\$|\\\\", splitOn)) splitOn <- escapeRegEx(splitOn) ## -------------------------------------- ## Create pat to be used in inserting 'funky' at breakpoint ## -------------------------------------- ## We cannot do lookahead/behind with variable length (and non-variable length is useless) ## Thus we substitute the first (or last) instance of splitOn with 'funky' ## and then split on 'funky' ## pat = "S(.*S.*)*", repl = @\\1 for last ## pat = "(.*S.*)*S", repl = \\1@ for first ## note that 'funky' will get inserted after the full match of whats inside ( ) ## what is OUTSIDE of the ( ) will be discarded, ## ie, outsde of the ( ) should be just one little ol' splitOn pat.multiple <- paste0("(.*", splitOn, ".*)*") pat.single <- splitOn if (first_or_last == "first") { pat <- paste0(pat.single, pat.multiple) replace <- paste0(funky, "\\1") } else { pat <- paste0(pat.multiple, pat.single) replace <- paste0("\\1", funky) } ## Guard against the highly improbable, but not impossible, chance that 'funky' occurs natually in the string (perhaps in a hash) if (any(grepl(funky, string))) stop("It's a Tuesday. The randomstring funky='", funky, "' appears in string to be split.") ## replace the first (or last) occurance of 'splitOn' with 'funky' string <- gsub(pat, replace, string, perl=perl) ## split on 'funky' strsplit(string, funky, perl=perl) } fileInListing <- function(f, listing) { ## Searches listing for f and returns T/F if f is in listing ## along with an attirbute "alternate" which finds potential matches ## based on capitilaziation if (!length(f)) stop("f cannot be empty") if (f == "." || !length(listing)) { if (!length(listing) && length(f)) warning("listing was empty") ret <- as.logical(length(listing)) attr(ret, "alternate") <- NA return(ret) } # else splat <- splitOnLast(f)[[1]] ## if *.ext, make sure at least one such item present ## if not, check if a different capitalization. ## if so, return alternates as an attribute if (splat[[1]] == "*") { pat.ext <- paste0("\\.",splat[[2]], "$") if (any(grepl(pat.ext, listing))) return(TRUE) ret <- FALSE attr(ret, "alternate") <- NA if (any(grepl(splat[[2]], listing, ignore.case=TRUE))) { unique.exts <- unique(sapply(splitOnLast(listing), function(x) x[length(x)])) unique.exts <- paste0(".", unique.exts) alt.values <- grep(pat.ext, unique.exts, ignore.case=TRUE, value=TRUE) attr(ret, "alternate") <- paste0(splat[[1]], alt.values) } return(ret) } ## check if present as is. if (any(grepl(glob2rx(f), listing))) return(TRUE) ## check for alternate capitalization f.igncase <- grep(glob2rx(f), listing, ignore.case=TRUE, value=TRUE) if (!length(f.igncase)) f.igncase <- NA ret <- FALSE attr(ret, "alternate") <- f.igncase return(ret) } findCharBetween <- function(string, char.to.find=" ", from=1, to=nchar(string)) { if (length(string) > 1 || length(char.to.find) > 1 || length(to) >1 || length(from) >1) stop ("all arguments must be length 1") if (!length(string) || !length(char.to.find)) stop ("No valid string submitted") found <- gregexpr(char.to.find, string)[[1]] inds <- found > from & found < to found[inds] } findFirstCharBetween <- function(string, char.to.find=" ", from=1, to=nchar(string), findLAST=FALSE) { ## TODO: Incorporate findCharBetween if (length(string) > 1 || length(char.to.find) > 1 || length(to) >1 || length(from) >1) stop ("all arguments must be length 1") if (!length(string) || !length(char.to.find)) stop ("No valid string submitted") found <- gregexpr(char.to.find, string)[[1]] inds <- found > from & found < to if (findLAST) max(found[inds]) else min(found[inds]) } # EXAMPLE: # xx <- 11 * seq(1:9) # moveTo(xx, 7, 5) # [1] 11 22 33 44 55 77 66 88 99 # moveTo(xx, 5, 7) # [1] 11 22 33 44 66 77 55 88 99 # moveTo(xx, 5, 0) # moveTo(xx, 5, length(xx)) moveTo <- function(x, moveFrom, insertAt, showWarnings=TRUE) { ## the value of insertAt should be such that ## x.after[insertAt] == x.before[moveFrom] ## L <- length(x) ## Allow for logical values if (is.logical(moveFrom)) { if (!length(moveFrom) == L) stop("moveFrom is a logical vector but not the same length as x") moveFrom <- which(moveFrom) if (length(moveFrom) > 1) stop("moveFrom is logical and results in more than one value being indexed.") } if (is.logical(insertAt)) { if (!length(insertAt) == L) stop("insertAt is a logical vector but not the same length as x") insertAt <- which(insertAt) if (length(insertAt) > 1) stop("insertAt is logical and results in more than one value being indexed.") } ## Check input if (!is.numeric(moveFrom) || !is.numeric(insertAt)) stop("one of moveFrom & insertAt is neither numeric nor same length as x") if (length(moveFrom) != 1 || length(insertAt) != 1) stop("moveFrom & insertAt must be of length 1") ## Further input check if (moveFrom > L || insertAt > L || moveFrom < 0) stop("both moveFrom & insertAt should be positive values less than length(x)") if (insertAt < 0) stop("You cannot insert at index 0. Did you mean to use `insertAt=1` ?") ## This makes no sense # if (length(moveFrom) > 1) # return(mapply(moveTo, moveFrom=moveFrom, insertAt=insertAt, MoreArgs=list(x=x, showWarnings=showWarnings))) if (moveFrom == insertAt || is.null(x)) { if (showWarnings) warning("no operation performed\npossibly empty x or moveFrom & insertAt are the same.") return(x) } if (!is.atomic(x)) stop("x must be an atomic vector") if (moveFrom > insertAt) c(if(insertAt > 1) x[1L:(insertAt-1L)], x[moveFrom], x[setdiff((insertAt):L, moveFrom)]) else c(x[setdiff(1L:(insertAt), moveFrom)], x[moveFrom], if(insertAt < L) x[(insertAt+1L):L]) } ColsUniqueByKey <- function(DT) { # Identifies which columns in a DT are unique if (!haskey(DT)) stop("DT must have a key") 1==colMeans(DT[, lapply(.SD, lunique), by=key(DT)][, !key(DT), with=FALSE]) } isUniqueByGroup <- function(DT, colsToCheck=setdiff(names(DT), byCols), byCols=key(DT), verbose=TRUE, sampleThresh=5e3) { # ------------------------------------------- # # Input Check # # ------------------------------------------- # if (any(badVal <- colsToCheck %chin% byCols)) { if (all(badVal)) { warning("\nAll columns in `colsToCheck` are also in `byCols`. By definition, there will be only one row per group.") return(invisible(NULL)) } else { warning(warningCols("The following column names are in *both* `colsToCheck` and `byCols` and\n were dropped from colsToCheck (since they will, by definition, have one row per group)", colsToCheck[badVal])) colsToCheck <- colsToCheck[!badVal] } } if (length(badVal <- setdiff(c(colsToCheck, byCols), names(DT)))) { warning(warningCols("The following are *not* columns of the DT: " , badVal)) colsToCheck <- intersect(colsToCheck, names(DT)) byCols <- intersect(byCols, names(DT)) } if (!length(colsToCheck)) { stop("colsToCheck does not have a valid length, and might be NULL") } if (!length(byCols)) { stop("byCols does not have a valid length, and might be NULL") } # ------------------------------------------- # rows.expected <- nrow(DT[, .N, by=byCols]) rows.actual <- nrow(DT[, .N, by=c(byCols, colsToCheck)]) ## IF THEY ARE THE SAME if (identical(rows.expected, rows.actual)) return(TRUE) ## ELSE ret <- FALSE attr(ret, "has.dups") <- DT[, 1, keyby=c(byCols, colsToCheck)][, .N, keyby=byCols][N>1] return(ret) } whereAreTheMultipleRowsPerGroup <- function(DT, colsToCheck=setdiff(names(DT), byCols), byCols=key(DT), verbose=TRUE) { ## Returns value of FALSE is *opposite* `isUniqueByGroup` ## Returns NULL if only one row group. ## Otherwise returns the subset of DT that has more than one row per group # ------------------------------------------- # # Input Check # # ------------------------------------------- # if (any(badVal <- colsToCheck %chin% byCols)) { if (all(badVal)) { warning("\nAll columns in `colsToCheck` are also in `byCols`. By definition, there will be only one row per group.") return(invisible(NULL)) } else { warning(warningCols("The following column names are in *both* `colsToCheck` and `byCols` and\n were dropped from colsToCheck (since they will, by definition, have one row per group)", colsToCheck[badVal])) colsToCheck <- colsToCheck[!badVal] } } if (!length(colsToCheck)) { stop("colsToCheck does not have a valid length, and might be NULL") } if (!length(byCols)) { stop("byCols does not have a valid length, and might be NULL") } # ------------------------------------------- # noDups <- isUniqueByGroup(DT, colsToCheck=colsToCheck, byCols=byCols, verbose=verbose) if (noDups) { if (verbose) cat("When grouping by c", pasteQ(byCols), " all rows in ", pasteC(as.expression(substitute(DT))) ," are unique\n", sep="") return(invisible(NULL)) } # ELSE dups <- attr(noDups, "has.dups") ret <- merge(dups, DT, by=key(dups)) if (verbose) { .colsout <- paste0(" c", pasteQ(byCols)) if (nchar(.colsout) > 34) .colsout <- paste0("\n", .colsout) cat("\nWe're expecting `TOTAL_ROWS` to be 1 for each group of", .colsout , "\n\n", sep="") print(sepAt_( setnames( ret[, c(lapply(.SD, lunique), TOTOL_ROWS=.N, UNIQUE_ROWS=runique(.SD, by=colsToCheck)) , by=byCols, .SDcols=colsToCheck][orderch(colsToCheck)], # fixing column names colsToCheck, paste0("luniq_", colsToCheck)) , -2, sep=" ]|[ ", colname=" ]-[ ")) cat("\n\n") } return(invisible(ret)) } TF.sample <- function(perc.T, n) { # Creats a logical vector of size n, # whith a percentage of TRUE equal to perc.T (within a rounding error) perc.T <- validPercentage(perc.T, min=0, max=1) n.T <- round(n*perc.T) n.F <- round(n*(1-perc.T)) sample(rep(c(TRUE, FALSE), times=c(n.T, n.F))) } gridPages <- function(Plots.list, File, rows=2, cols=3, width=11, height=17, noWarnings=TRUE, open=TRUE, main=NULL) { pdf(File) suppressWarningsFunc <- if (noWarnings) suppressWarnings else identity N <- length(Plots.list) RC <- rows * cols pgs <- ceiling(N / RC) for (i in seq.int(pgs)) { # if (i > 1) # grid.newpage() inds <- (1:RC) + (RC*(i-1)) inds <- inds[inds <= N] print (suppressWarningsFunc( do.call(grid.arrange, c(Plots.list[inds], list(ncol=cols, nrow=rows, main=main)) ) )) } # // for-loop dev.off() cat("Graphs have been saved here: \n\n", pdfFile, "\n\n") if (open) .o(pdfFile) return(invisible(pdfFile)) } seq.exp <- function(from, to, by=1, base=10, length.out, exp.from, exp.to) { # returns 10, 100, 1000, 10000 etc if (!missing(exp.from) || !missing(exp.to)) stop("exp.from & exp.to have not yet been implemented") if (!missing(length.out)) stop("length.out has not yet been implemented") exp.from <- log(from, base=base) exp.to <- log(to, base=base) base ^ seq(from=exp.from, to=exp.to, by=by) } seq.log <- function(from, to, n=abs(from-to)+1, bias=23, round=NULL, showWarnings=TRUE, tighter.end=c("from", "to")) { if (bias > 1000 && showWarnings) warning ("bias is expected to be a value in (0, 1000].\n Values will be highly skewed.") bias <- bias / 1000 base <- bias + 1 tighter.end <- tolower(tighter.end) tighter.end <- match.arg(tighter.end) # since we are applying `scaleunif`, we can start at any arbitrary value # We choose to start at the value that will allow us the most room for a large n. start <- trunc(log(.Machine$double.eps, base)) ## confirm that we will not go out of bounds if (start+n > log(.Machine$double.xmax, base=base) ) stop("`n` is too large relative to machine precision.\nTry decreasing bias to value within (0, 1).") # by default, the "from" side is tighter, since we are using the original seq as powers, they will be more spaced out at the end. if (tighter.end == "to") { .from <- from from <- to to <- .from } ## This is the actual scaling ret <- scaleunif(base^seq(start, length.out=n), from, to) # spin it around if (tighter.end == "to") ret <- ret[length(ret):1L] # round if flagged if (!is.null(round)) ret <- round(ret, round) return(ret) } date.mmddyyyy.regex <- "(0[1-9]|1[012])[- /.](0[1-9]|[12][0-9]|3[01])[- /.](19|20)\\d\\d" sapplyt <- function(..., .c.t=NULL, .to.dt=TRUE) { ## handy wrapper for t(sapply(...)) ## .c.t stands for colnames of the transposed matrix ## if given, will attempt to over-write the colnames of transposed matrix ret <- sapply(...) if(length(dim(ret))==2) { ret <- t(ret) if (!is.null(.c.t)) data.table::setattr(ret, "dimnames", list(dimnames(ret)[[1]], .c.t)) if (.to.dt) ret <- as.data.table(ret) } return(ret) } keepOnlyTheseColumns <- function(x, cols, warn=FALSE) { ## will subset x by cols ## This is essentially similar to x[, cols, with=FALSE] ## but with two added benefits: ## (1) It will only use those values of cols that are in names(x) ## eg, no error thrown if non-matching values ## NA is returned if zero matches ## (2) If `cols` is named, those will be set as the ## column names of the return value nms.x <- names(x) ## Calculate which columns are missing, for warning message if (warn) cols.missing <- setdiff(cols, nms.x) # don't use intersect bc it will lose the names cols <- cols[cols %in% nms.x] ## output any warnings if (warn) { x.chr <- as.character(as.expression(substitute(x))) if (!length(cols)) warning("No values of cols matched any of the ", length(nms.x)," names of ", x.chr) if (length(cols.missing)) warning("The following columns not in ", x.chr, ": \n\t ", paste(cols.missing, collapse="\t ")) } if (!length(cols)) return(NA) ret <- copy(x[, cols, with=FALSE]) if (!is.null(names(ret))) setnames(ret, names(cols)) else invisible(ret) } #_________________________________________# canCoerceToDate <- function(D, n=100, classesChecked=c("numeric", "integer", "character", "factor"), origin=.origin, warn.on.month.year=TRUE, silent=TRUE) { ## Only checks D of class if (is.date_or_time(D)) return(TRUE) if (!inherits(D, classesChecked)) return(FALSE) if (is.list(canCoerceToDate)) stop ("D must not be a list") D.org <- copy(D) non_NAS <- !is.na(D) if (all(is.na(D))) return(NA) D <- sample(D[non_NAS], min(n, sum(non_NAS))) ## Check if regular number or month, day, etc if (is.numeric(D)) { decimalPortion <- D %% 1 hasDecimal <- any(decimalPortion != 0) D.bak <- copy(D) D <- as.numeric(D) numbType <- { if (all(D <= 7 & D > 0)) "day-of-week" else if (all(D <= 12 & D > 0)) "month" else if (all(D <= 31 & D > 0)) "day-of-month" else if (all(D <= 2200 & D > 1700)) "year" else if (hasDecimal && (sd(D) > 1000 || nchar(decimalPortion) > 4)) "that of a regular number" else NULL } if (!is.null(numbType)) { warning(sprintf("D is numeric and appears to have pattern similar to %s; returning FALSE", numbType)) return(FALSE) } } if (is.factor(D)) D <- as.character(D) if (is.character(D)) { ## Note, these are formats without serparators seps.to.remove <- c("-", "/", "\\", ".", "_", " ", ",") ## formats to check for: ## 2014/11/06 2014-May-06 20140406 20140406_1224 140406_1224 January 3, 2014 formatsToTry <- c("%Y%m%d", "%Y%b%d", "%m%d%Y", "%y%m%d") # frmt <- formatsToTry[[2]] # D <- c("2014-01-01", "2014-Nov-01", "2014/04/01") # D <- gsub(regOr(escapeRegEx(seps.to.remove)), "", D) TryToConvert <- function(string, formats, origin=.origin, showWarnings=TRUE) { if (!length(string)) { verboseMsg(showWarnings, "'string' has no length") return(character()) } if (!length(formats) || !is.character(formats)) stop ("formats should be a string vector of length at least 1") ## Count the number of succesfull conversions (sc) L <- length(string) sc <- sapply(formats, function(frmt) { L - sum(is.na(try(as.Date(string, origin=origin, format=frmt), silent=silent))) }, USE.NAMES=FALSE) ret <- formats[sc > 0] verboseMsg(length(ret) > 1 && showWarnings, "More than one format matched") verboseMsg(length(ret) == 0 && showWarnings, "No matching format found") if (length(ret)) { browser() data.table::setattr(ret, "percent.converted", setNames(nm=ret, obj=list(sc[sc>0] / L))) } else { ret <- NA_character_ } return(ret) } (ret <- TryToConvert(D, formats=formatsToTry, origin=origin)) if (!is.na(ret)) return(!is.na(ret)) } ## If not character return(FALSE) } getDateColNames <- function(X, byClass=TRUE, byName=TRUE, ignoreCase=TRUE, ignore.case=ignoreCase, semiloose=FALSE, loose=FALSE) { # ignore.case only applies when byName is TRUE # ignoreCase is a synonym for ignore.case if (!byName & !byClass) { stop("Both `byName` and `byClass` are set to FALSE. What should be used instead? I am throwing an error.") } dateCols <- c() if (byName) { ## String match stringToMatch <- if (loose) "(date|month|year|modified|created)" else if (semiloose) ("date|^(accounting_|activity_)?month$|^year$") else "date|accounting_month|activity_month" dateCols <- c(dateCols, grep(stringToMatch, names(X), value=TRUE, ignore.case=ignore.case )) ## Remove year_to_date and simliar. # dateCols <- dateCols[!tolower(gsub("_ ", "", dateCols)) %in% c("yeartodate")] } if (byClass) { dateClasses <- c("Date", "POSIXct", "POSIXlt", "zoo", "ts") inheritsDateClass <- sapply(X, function(x) any(dateClasses %in% is(x) )) dateCols <- unique(c(dateCols, names(which(inheritsDateClass)))) if (any(duplicated(names(X)))) warning(pasteC(as.expression(substitute(X))), " contains duplicate names. This may throw off results.") } return(dateCols) } setw <- function(x, width=max(nchar(x)), space=" ") { # Pads each element of x with `space` so that it has a total nchar length equal to width toAdd <- width-nchar(x) paste0(pasteR(space, width-nchar(x)), x) } to_ts_string <- function(x) { ## Date conversion function, used in Spotify Metadata API Webscrape as part of the JSON downloadoing, I believe as.tz(x, tz="UTC") %>% format(format="%Y%m%d_%H%M%S_Z") } # ---------------------------------------------------- # setnamesIfBlank_ <- function(x, nms_new=as.character(x), allow_partial_changes=TRUE, allow_recycling=FALSE) { ## This function takes the names of x. If they are completely blank, sets names of x to nms_new ## If allow_partial_changes is TRUE, will replace values of x that are blank with the matching value in nms_new if (!(length(nms_new) %in% c(1, length(x))) && !allow_recycling) stop (sprintf("Lengths of x (%i) and nms_new (%i) differ. Use allow_recycling=TRUE to bypass this check", length(x), length(nms_new))) nms_current <- copy(names(x)) if (is.null(nms_current) || all(nms_current == "")) setattr(x, "names", nms_new) else if (allow_partial_changes) { blanks <- nms_current == "" if (any(blanks)) { nms_current[blanks] <- nms_new[blanks] setattr(x, "names", nms_current) } } return(invisible(x)) } selfname_ <- function(x, clean=FALSE, e=parent.frame(), onlyIfBlank=FALSE, stopifnot.exists=FALSE, showWarnings=TRUE) { ## sets the names of x to themselves ## if clean is set, the names are cleaned first via `make.names(.)` if (!length(x)) stop("x has no length. Cannot selfname_ ") if (length(dim(x))) stop("x must be single-dimensional") # x.nm <- as.character(substitute(x)) x.nm <- capture.output(substitute(x)) ## ERROR CHECK exists.x <- exists(x.nm, envir=e) if (!exists.x) { msg <- paste0("could not find `", x.nm, "` in the prent.frame") if (stopifnot.exists) stop (msg) else { x <- try(eval(x), silent=TRUE) if (isErr(x)) stop(paste(msg, "and attempting to evaluate it resulted in error")) verboseMsg(showWarnings, sprintf("using eval(%s) in place of x. \n Modification is *NOT* by reference -- Please be sure you are using or assigning the results", x.nm)) } } else if (!identical(get(x.nm, envir=e), x)) stop ("Object `", x.nm, "` found, but not identical to the given x.") ## The names will be x, coerced as character. nms <- as.character(x) ## If flagged, replace nms with exiting names if (onlyIfBlank) { nms.current <- names(x) if (!is.null(nms.current)) { inds.non_blank <- nms.current != "" ## If no modifications are needed, just return x if (all(inds.non_blank) && !clean) return(x) nms[inds.non_blank] <- nms.current[inds.non_blank] } } if (clean) nms <- make.names(nms) # assign(x=x.nm, value=setNames(x, nm=as.character(x)), envir=e) if (exists.x) return(data.table::setattr(get(x.nm, envir=e), "names", nms)) else return(data.table::setattr(x, "names", nms)) } # ---------------------------------------------------- # iter.debug <- function(name, restart=FALSE, verbose=TRUE, initializeTo=0L, endl="\n", pos=1, coutFunc=c("cat", "message", "print")) { # An iterating function for debuggin lapply style loops. # # name : defaults to the function name of the function that called iterdebug # restart : resets counter to the value of initializeTo # initializeTo : an integer. If restart==FALSE, initializeTo is ignored. # endl : If no line break desired (ie, cat'ing something else following), then set to "" or other string. coutFunc <- match.fun(match.arg(coutFunc)) if (!identical(coutFunc, "cat") && missing(endl)) endl <- "" ## Assign to name automatically if not done so. if (missing(name)) { sc <- sys.call(pos) # Set name as the first call in the sys.call() one level up. # however, if name is a plyr style function, set the name to the function argument # unless it is an annoynymous function, in which case use the first argument to the plyr function name <- as.character(sc[[1]]) [[1]] if ( grepl("ply", name) ) { name <- as.character(sc[[3]]) [[1]] if (name == "function") name <- as.character(sc[[2]]) [[1]] } } ## Create a specific object name for the counter nm <- paste0(".iterCounter.", name) ## if restarting, initialize the iterator if (restart) { assign(nm, value=initializeTo, envir=.GlobalEnv) # re-grab it to be sure it stuck. i<-get(nm, envir=.GlobalEnv) if (verbose) coutFunc(nm, " initialized to ", i, endl) return(invisible(i)) ## otherwise, grab it and then increment it } else { if (!exists(nm, envir=.GlobalEnv)) assign(nm, value=0, envir=.GlobalEnv) else assign(nm, value=1+get(nm, envir=.GlobalEnv), envir=.GlobalEnv) # re-grab it to be sure it stuck. i <- get(nm, envir=.GlobalEnv) if (verbose) coutFunc(nm, " : ", i, endl) return(invisible(i)) } } clearAllIterCounters <- function(verbose=TRUE) { toRM <- ls(pattern="\\.iterCounter\\.", all=TRUE, envir=.GlobalEnv) if (verbose) cat("\nFound ", length(toRM), " counters and will be rm'ing them.") rm(list=toRM, envir=.GlobalEnv) } resetCounter <- function(name, initializeTo=0, verbose=TRUE, pos=1) { if (missing(name)) iter.debug(restart=TRUE, verbose=verbose, initializeTo=initializeTo, pos=pos+1) else iter.debug(name=name, restart=TRUE, verbose=verbose, initializeTo=initializeTo, pos=pos+1) } uniqueWithNames <- function(x) { # Returns all values of x that are unique, # but considers names as well as values. # Example: # x <- structure(c(1L, 2L, 2L, 3L, 3L), .Names = c("Age", "Gender", "TEST", "Camp", "Camp")) # uniqueWithNames(x) dups.x <- duplicated(x) dups.nm <- duplicated(names(x)) # we want, ((not duplicated names) or (not duplicated)) values # which is same as (not (duplicated names & duplicated values)) # ie, if either one is FALSE (not a dup), then we keep it. x[!(dups.x & dups.nm)] } createCombs <- function(X, groupSize=length(X), allowDups=TRUE, returnIndecies=is.atomic(X)) { if (returnIndecies) X <- seq_along(X) ## Error Check if (groupSize > length(X)) { stop ("\n`groupSize` (", groupSize, ") is too large. It cannot be larger than the length of `X` (", length(X), ").\n") } if (!allowDups) return( t(utils::combn(X, groupSize)) ) # else eg <- expand.grid(rep(list(X), groupSize)) return( unique(t(apply(eg, 1, sort))) ) } anyEqualRows <- function(DF1, DF2=DF1) { ## Checks each row in DF1 against each row in DF2 ## and returns, for each row in DF1, the index to ## the row in DF2 to which it is equal. ## (returning NA for each row that has no match) ## Note: Uses `==` not `all.equal` if(ncol(DF1) != ncol(DF2)) { warning("The number of columns differ") return (FALSE) } DF2 <- t(DF2) NAs.DF2 <- is.na(DF2) TargetSum <- nrow(DF2) # the number of cols in the original apply(DF1, 1, function(row) { # browser() comp <- row == DF2 wh <- which( TargetSum == colSums( # Either the values should be the same or they should both be NA row == DF2 | (is.na(row) & NAs.DF2) )) if (!any(wh)) return(NA) else return(wh) }) } removeBlankCols_ <- function(DT, blanks="", NAs.full.column.as.blank=TRUE) { toDrop.na <- nwhich(colSums(is.na(DT)) == nrow(DT)) if (length(toDrop.na)) DT[, c(toDrop.na) := NULL] for (blank in blanks) { toDrop.b <- nwhich(sapply(DT, function(x) if (xor(is.Date(x), is.Date(blank))) FALSE else all(x == blank))) if (length(toDrop.b)) DT[, c(toDrop.b) := NULL] } return(invisible(DT)) } topLevs <- function(x, n=10, p=.10, top=TRUE, orEqualTo=FALSE, usePerc=!missing(p), showWarnings=TRUE, ...) { # returns the levels of the top # orEqualTo : if TRUE use tbl <= n (or p), if FALSE use tbl < n (or p) if (!missing(p) || usePerc) { usePerc <- TRUE if(!missing(n) && showWarnings) warning("n given but usePerc is TRUE. n will be ignored.") p <- validPercentage(p, 0, 1) } # Calculate Tabulation tbl <- table(x, ...) # Reverse the table if counting from the top if (top) tbl <- rev(tbl) # calculate the total sm <- sum(tbl) cm <- cumsum(tbl) # Determine if using Less Than or Less Than Or Equal To compareFunc <- if (orEqualTo) `<=` else `<` # determine which indecies are in / out inds.tbl <- { if (usePerc) compareFunc(cm / sm, p) else compareFunc(cm, n) } ## no indecies found if(!any(inds.tbl)) { if(orEqualTo) stop("No levels found. This should not be the case. Check for bugs") if (showWarnings) warning("No levels selected.\n Try using `orEqualTo=TRUE` so as to include at least the first level\n or increasing `", ifelse(usePerc, "p", "n"), "`.") } names(which(inds.tbl)) } compress.string <- function(string, max.length, insert="....") { nc <- nchar(string) if (max.length > nc) return(string) max.length <- max.length-nchar(insert) paste0( substr(string, 1, floor(max.length*.7)) , insert , substr(string, nc-floor(max.length*.3)+1, nc) ) } allSetDiff <- function(A, B, names=FALSE, sep=" | ", quiet=FALSE, classcheck=is.list(A) , A.nm=NULL, B.nm=NULL, max.nm.char=17, nm.insert="..", none=" < none >" , showWarnings=TRUE, debug=FALSE) { ## Simple wrapper to compute setdiff(A, B) and setdiff(B, A) ## plus fancy pants output ## ## max.nm.char only affects output for COLUMN COMPARISONS (same with nm.insert) if (is.null(A.nm)) A.nm <- as.character(as.expression(substitute(A))) if (is.null(B.nm)) B.nm <- as.character(as.expression(substitute(B))) if (missing(names) && (is.data.frame(A) || is.data.frame(B))) names <- TRUE # even if names are the same, check the classes browser(expr={debug=="classcheck"}) if (classcheck) { AC <- sapply(A, class) BC <- sapply(B, class) ## If unnamed, use column position (by creating a name along the seq) if (!length(names(A)) || !length(names(A))) { if (showWarnings) warning("`classcheck` was flagged on, but A or B are unnamed.\nComparing by column (or element) position") names(AC) <- make.names(seq_along(AC)) names(BC) <- make.names(seq_along(BC)) } ## If duplicates are found, we will check all combinations AC.d <- BC.d <- c() if (anyDuplicated(names(AC)) || anyDuplicated(names(BC))) { if (showWarnings) warning ("There are duplicate names. This should be avoided.") dups.A <- names(AC)[duplicated(names(AC))] dups.B <- names(BC)[duplicated(names(BC))] dups <- unique(c(dups.A, dups.B)) # these will be added to the list for (d in dups) { dnm <- paste("", d) AC.d[length(AC.d)+1] <- paste0(dnm, " (", paste(AC[names(AC) %in% d], collapse=", "), ")") BC.d[length(BC.d)+1] <- paste0(dnm, " (", paste(BC[names(BC) %in% d], collapse=", "), ")") } } shared <- intersect(names(AC), names(BC)) ## if not allowing for lists, we could simply use `AC[shared] != BC[shared]` notequal <- mapply(function(a, b) any(a != b), AC[shared], BC[shared], SIMPLIFY=TRUE) diffclass <- if (length(notequal)) names(which(notequal)) else character() ACx <- AC[diffclass] BCx <- BC[diffclass] # class.diffs <- list(A=c(), B=c()) # if (!length(diffclass)) # class.diffs <- # list( A=paste0(names(ACx), " (", ACx, ")") , # B=paste0(names(BCx), " (", BCx, ")") # ) # # if (length(c(AC.d, BC.d))) { # class.diffs[["A"]] <- c(AC.d, class.diffs[["A"]]) # class.diffs[["B"]] <- c(BC.d, class.diffs[["B"]]) # } } if (names) { A <- names(A) B <- names(B) } AxB <- setdiff(A, B) BxA <- setdiff(B, A) # if classcheck is on AND we had found a difference, # then add the differences to the list if (classcheck && (length(diffclass) || length(c(AC.d, BC.d)))) { # concatenate with col name with class type ACx <- paste0(names(ACx), " (", sapply(ACx, pasteC, C=", "), ")") # combine the two lists AxB <- c(AC.d, ACx, AxB) # not needed? # drop the `none` term if present # not needed? AxB <- setdiff(AxB, none) # repeat for BxA BCx <- paste0(names(BCx), " (", sapply(BCx, pasteC, C=", "), ")") BxA <- c(BC.d, BCx, BxA) # not needed? BxA <- setdiff(BxA, none) } if(!length(AxB)) AxB <- none if(!length(BxA)) BxA <- none # shrink long strings if (is.numeric(max.nm.char)) { A.nm <- compress.string(string=A.nm, max.length=max.nm.char, insert=nm.insert) B.nm <- compress.string(string=B.nm, max.length=max.nm.char, insert=nm.insert) } # Old nms, now using ⊄ nm <- c( paste("In", A.nm, "not", B.nm) , paste("In", B.nm, "not", A.nm) ) nm <- c( paste(A.nm, "⊄", B.nm) , paste(B.nm, "⊄", A.nm) ) # browser() # BxA <- c(BxA, "one more", "value here") ret <- c(list(AxB), list(BxA)) ret <- setNames(ret, nm) ## FORMATTED OUTPUT if (!quiet) { # rbind for output rb <- unname(rbind(nm, t(listFlatten(ret)))) # make prettiur ## remove NAs rb[is.na(rb)] <- "" ## Padd on the left (less padding for the first row) rb[-1, ] <- paste0(" ", rb[-1, ]) rb[1, ] <- paste0(" ", rb[1, ]) ## Padd on the right, to the longest value in each column rb <- apply(rb, 2, function(x) paste0(x, pasteR(" ", 1+max(nchar(x), 20) - nchar(x)))) ## Add a column of seperator line if (!is.null(sep)) { sep.len <- max(sapply(ret, length)) sep.vec <- rep(sep, sep.len+1) rb <- cbind(rb, sep.vec, "\n")[, c(1,3,2,4)] hr <- pasteR("-", apply(rb, 2, function(x) mnchar(x))) hr[[2]] <- " --+-- " hr[[4]] <- "\n" # rb <- rbind(rb[1, ], pasteR("-", n=2+nchar(rb[1, ])), rb[2:nrow(rb), ]) rb <- rbind(rb[1, ], hr, rb[2:nrow(rb), ]) } ## fancy output # cat("\n", paste_l(t(rb), (2+!is.null(sep)), sameWidth=FALSE, spacer="\t" ), "\n", sep="") catn("\n", pasteC(t(rb)), sep="") } return(invisible(ret)) } midpoint <- function(min, max) { ## wrapper function for halfway between x and y (max - min) / 2 + min } commaToNumeric <- function(x) as.numeric(gsub(",", "", x)) XinNamesDT <- function(X, DT,cleanIDcols=TRUE, ignore.case=TRUE, warnOnMissingX=TRUE) { # This function simply checks if X is a valid column name for DT # and returns those values of X that are in DT. if (cleanIDcols) { wh <- grepl("^(Campaign|Ad)$", X, ignore.case=ignore.case) X[wh] <- paste0(X[wh], "ID") } ## This will wrap X & names(DT). If not ignoring case, then just use identity (no change) caseFunc <- if(ignore.case) tolower else identity # ensure that X are actual column names of DT wh <- removeNA(match(caseFunc(names(DT)), caseFunc(X), nomatch=NA)) if(warnOnMissingX) { if (length(unique(wh)) != length(X)) warning("\n The following columns are not in ", pasteC(as.expression(substitute(DT))), ":\n\t", paste0(X[setdiff(seq_along(X), wh)], collapse="\t"), "\n") if (any(duplicated(wh))) warning("\n The following values in X match more than one column name:\n\t", paste0(X[wh[duplicated(wh)]], collapse="\t"), "\n") } # Drop from X any values which are not names of DT X <- X[unique(wh)] # Return X } showMemLocation <- function(x, parse=FALSE, nms=capture.output(substitute(x)), verbose=TRUE) { ret <- capture.output(.Internal(inspect(x))) if (parse) { ret <- parseInspectLine1(line=ret[[1]], nms=nms) if (verbose) print(ret) } else if (verbose) { catnn(ret) } return(invisible(ret)) } compareDTs <- function(DT1, DT2, mem=TRUE, quiet=FALSE, colclass=TRUE , DT1.nm, DT2.nm, nchar.max.for.cols.compare=17, debug=FALSE) { ## TODO: (1) Explicitly check key ## (2) Check re-ordering browser(expr={isTRUE(debug)},text="At the top of compareDTs()") ## allowing for calls such as `compareDTs(ll)` where `ll` is a list of two DTs. if (missing(DT2) && length(DT1)==2 && is.data.table(DT1[[2]])) { nms <- names(DT1) if(is.null(nms)) nms <- c("[DT1]", "[DT2]") return(compareDTs(DT1=DT1[[1]], DT2=DT1[[2]], mem=mem, quiet=quiet, colclass=colclass, DT1.nm=nms[[1]], DT2.nm=nms[[2]], nchar.max.for.cols.compare=nchar.max.for.cols.compare)) } ## ERROR-CHECK. DT1 and DT2 should be valid data.tables if (!length(DT1) || !length(DT2)) stop ("Invalid input. At least one of DT1 or DT2 has no length.") if (!is.data.table(DT1)) stop("DT1 is *NOT* a data.table.", if (is.data.table(DT1[[1]])) "However, DT1[[1]] *IS*.\n Perhaps you have a '[' where you need a '[[', or maybe a nested list? Please check your input.") if (!is.data.table(DT2)) stop("DT2 is *NOT* a data.table.", if (is.data.table(DT2[[1]])) "However, DT2[[1]] *IS*.\n Perhaps you have a '[' where you need a '[[', or maybe a nested list? Please check your input.") ## ERROR-CHECK. DT1 and DT2 should be valid data.tables if (mem) { ## 2015-10-07 TODO: use showMemLocation() mem1 <- parseInspectLine1(line=capture.output(.Internal(inspect(DT1))) [[1]], nms="DT1") mem2 <- parseInspectLine1(line=capture.output(.Internal(inspect(DT2))) [[1]], nms="DT2") memory <- rbind(mem1, mem2) memLoc <- memory[, mem] memLoc <- c(memLoc, ifelse(areEqual(memLoc), "","")) } ## grab dim information dims <- dimCompare(DT1, DT2) info <- as.data.table(dims, keep.rownames=TRUE) # add memory info if (mem) info <- cbind(info, memLoc) ## clean up names setnames(info, "rn", "DT.NM") setnames(info, toupper(names(info))) ## sub in names of DT's if (missing(DT1.nm)) DT1.nm <- as.character(as.expression(substitute(DT1))) if (missing(DT2.nm)) DT2.nm <- as.character(as.expression(substitute(DT2))) if (!is.character(DT1.nm)) DT1.nm <- as.character(as.expression(substitute(DT1.nm))) if (!is.character(DT2.nm)) DT2.nm <- as.character(as.expression(substitute(DT2.nm))) info[DT.NM == "DT1", DT.NM := DT1.nm] # info[DT.NM == substitute(DT1), DT.NM := DT1.nm] info[DT.NM == "DT2", DT.NM := DT2.nm] # info[DT.NM == substitute(DT2), DT.NM := DT2.nm] ## Fancy Pants Output { # This is only filled if there are differences. Downstream we check for `identical(COL.NMS, "")` COL.NMS <- "" i.c <- center(info, add.endl=FALSE, hbar=TRUE, matrix.lines.collapse=TRUE, all.same=FALSE, pad=2.5) i.c <- c(i.c[-length(i.c)], gsub("\\|", " ", i.c[[2]]), i.c[[length(i.c)]]) i.c <- pasteBars(i.c, 0, centerFirst=FALSE) ln.t <- paste("/", pasteR("-", max(nchar(i.c))-4), "\\") ln.b <- paste("\\", pasteR("-", max(nchar(i.c))-4), "/") h.c <- center(paste0("\n ~~~ DIM & MEMORY COMPARISONS ~~~\n"), width.min=max(nchar(i.c))) # put together DIM.MEM <- center(c(h.c, ln.t, i.c, ln.b), add.endl=TRUE, trim.first=FALSE) } if (identical(DT1, DT2)) { ## Construct basic output setdiffs <- NA bars <- c("| ", " |") tbl.info <- c(paste0(DT1.nm, " and ", DT2.nm, " ARE identical"), print.dims(DT1, verbose=FALSE)) ## Add memory Info if ( info[, !identical(MEMLOC[[1]], MEMLOC[[2]]) ] ) { tbl.info <- c(tbl.info, "-", "but their memory locations differ", if(sum(nchar(c(DT1.nm, DT2.nm))) < 10) paste0(DT1.nm, ": ", info[1, MEMLOC], " - ", DT2.nm, ": ", info[1, MEMLOC]) else paste(center(c(DT1.nm, DT2.nm), align="left"), center(c(info[1, MEMLOC], info[2, MEMLOC]), align="right")) ) } ## Compare the two DTs } else { setdiffs <- allSetDiff(DT1, DT2, names=TRUE, quiet=TRUE, A.nm=DT1.nm, B.nm=DT2.nm, max.nm.char=nchar.max.for.cols.compare, classcheck=TRUE) ## TODO: Clean this into the actual output key.1 <- key(DT1) key.2 <- key(DT2) if (!identical(key.1, key.2)) { message("Differing Keys") } nms1 <- names(DT1) # shallow copy! nms2 <- names(DT2) # shallow copy! ## CHECK FOR "Off only in the order of the columns" ## ---------------- # # This flag is FALSE by default. If the columns are off just by ordering, # the flag will be TRUE and we will reorder DT2. Then reorder when done. colorderisdifferent <- FALSE ## if the names are not the same, but perhaps just misordered if (!identical(nms1, nms2) && identical(sort(nms1), sort(nms2))) { colorderisdifferent <- TRUE DT2.colorder.bak <- copy(names(DT2)) setcolorder(DT2, names(DT1)) colord.str <- "Column ordering differs, but the column names are the same\n" } ## First check if they are "almost identical" ## ie, if their names are the same and the values within ## the tables are themselves all.equal (meaning only an attribute is off) if (identical(names(DT1), names(DT2)) && isTRUE(all.equal(DT1, DT2))) { # Capture all atributes, less "names" & "internal.selfref" att1 <- attributes(DT1) att2 <- attributes(DT2) att1 <- att1[ setdiff(names(att1), c("names", ".internal.selfref")) ] att2 <- att2[ setdiff(names(att2), c("names", ".internal.selfref")) ] ## We want to campture all the difference in attributes. Two types ## (1) Exist in one but not the other (2) Exist in both, but different values ## First we capture (1) via `allSetDiff`, then we capture (2) by iterating over all of attribs in common and checking the values diff.attr <- unlist(allSetDiff(att1, att2, names=TRUE, none=NA, quiet=TRUE), use.names=FALSE) for (aa in setdiff(names(att1), diff.attr)) { if (!identical(att1[[aa]], att2[[aa]])) diff.attr <- c(diff.attr, aa) } ## This is the output tbl.info <- paste0( DT1.nm, " and ", DT2.nm, " are *NEARLY* Identical\n", ## Column ordering sentance if(colorderisdifferent) colord.str, # Attributes & Values sentance. (If there are no differences in attributes, diff.atr will be all NA) if (all(is.na(diff.attr))) "Values and Attributes are all equal (less `.internal.selfref`)" else paste0(c("Values are all equal, but Attributes differ on:\n", paste_l(diff.attr, eolAlsoHasSpacer=TRUE)), collapse=" ") ) } else { setdiffs <- allSetDiff(DT1, DT2, names=TRUE, quiet=TRUE, A.nm=DT1.nm, B.nm=DT2.nm, max.nm.char=nchar.max.for.cols.compare, classcheck=TRUE) col.diffs <- center(setdiffs, header=TRUE, all.same=TRUE, trim.first=TRUE) col.diffs <- { if ( is.twodim(col.diffs) ) sideByside(col.diffs[, 1], col.diffs[, 2], bar=2) else if (is.list(col.diffs)) sideByside(col.diffs[[1]], col.diffs[[2]], bar=2) else stop("I dont know how to output none-list, none-df data.") } col.diffs <- center(col.diffs, hbar=TRUE, trim.first=FALSE) header.cols <- paste0("\nThe two tables are different\n", if(colorderisdifferent) colord.str, " ~~~ COLUMN COMPARISONS ~~~\n", pasteR("_", nchar(col.diffs[[1]])), "\n") COL.NMS <- c(header.cols, col.diffs) COL.NMS <- center(COL.NMS, trim=FALSE) } ## Set the colnames back if we had changed them if (colorderisdifferent) setcolorder(DT2, DT2.colorder.bak) } ## Output browser(expr={debug=="out"}, text="Immediately before output is created.") if (!quiet) { out <- if (identical(COL.NMS, "")) { ## Add Fancy Decoration tbl.info <- pasteBars(tbl.info) ln <- paste("+", pasteR("-", max(nchar(tbl.info))-4), "+") out <- center(c("\n\n", ln, tbl.info, ln, "\n"), trim.first=FALSE, shiftLeft=5) center(paste(" ", out), trim.first=FALSE) } else center(c(COL.NMS, "\n", paste(" ", DIM.MEM), "\n\n"), trim.first=FALSE) cat(out, sep="\n") } return(invisible(list(mem=memory, dims=dims, setdiffs=setdiffs))) } # ----------------------- END OF PRETTY STRING FUNCTIONS ----------------------- # toFactorWithExpectedLevels <- function(x, levels, labels=levels, cleanDuplicates=TRUE, NAs_allowed=TRUE, showWarnings=TRUE) { ## labels are the current values ## levels are the new values force(levels); force(labels) if (is.factor(x)) x <- as.character(x) if (any(is.na(x)) && !NAs_allowed) stop(sprintf("There are %i NA's in x (out of %i elements)\nHINT: use NAs_allowed = TRUE if this is not a problem.", sumn(NAs), length(x))) levels_missing <- setdiff(x, levels) %>% {.[!is.na(.)]} if (length(levels_missing)) { if (showWarnings) warning ("x has values not present in 'levels', namely: ", paste(levels_missing, collapse=", ")) levels <- c(levels, levels_missing) labels <- c(labels, levels_missing) } if (!cleanDuplicates || !anyDuplicated(labels)) return(factor(x, levels=levels, labels=labels)) if (showWarnings) warning ("There are duplicate levels in the new factor vector. They will be cleaned.") ret <- suppressWarnings(factor(x, levels=levels, labels=labels)) return(factor(ret, levels=unique(levels(ret)))) } reverseFactor <- function(x, ...) { setFactorOrder(x, reverse=TRUE, showWarnings=FALSE, ... ) } setFactorOrder <- function(x, ordering=levels(x), last=NULL, reverse=FALSE, showWarnings=TRUE) { # Returns a factor orderinged by `ordering`. # If ordering is missing, defaults to `levels(x)` if available, else to `sort(unique(x))` # Useful for ggplot and elsewhere were orderinging is based on the ordering of the levels # # NOTE: This is different from the base function `relevel()` in that # it allows for multiple values in `ordering` browser(expr=inDebugMode("factor"), text="In setFactorOrder(), at very beginning.") if (length(last) && !is.character(last)) stop ("Argument 'last' should be NULL or a character vector") ## Grab the current levels. If x is not a factor, coerce to string, then take unique value as levels if (!is.factor(x)) { # First coerce to string if (!is.character(x)) x <- as.character(x) levs <- sort(unique(x)) if (missing(ordering)) ordering <- levs } else { levs <- levels(x) } # any values in ordering, not in levels(x) NotInx <- setdiff(c(ordering, last), levs) if (showWarnings) { if (length(NotInx)) warning ("Some values not in x:\n", paste(NotInx, collapse=", ")) if (anyDuplicated(c(ordering, last))) warning ("Duplicate values between `ordering` and `last`: ", paste(intersect(ordering, last), collapse=", "), "\n") } # levels(x) not explicitly named in ordering Remaining <- setdiff(levs, c(ordering, last)) ordering <- setdiff(unique(c(ordering, Remaining, last)), NotInx) if (reverse) ordering <- rev(ordering) factor(x, level=ordering) } isNumber <- function(x, treat.ZeroLength.asNumeric=FALSE, ignore.general=FALSE , ignore.factors=ignore.general, ignore.dates=ignore.general, ignore.logical=ignore.general) { # the purpose of this function is to avoid the warnings that # come with 'is.numeric(as.numeric(x))' when x is not a number. # # treat.ZeroLength.asNumeric : If TRUE, then zero-length elements (ie character(0), logical(0) are considered TRUE for isNumber) if (is.list(x)) return(lapply(x, isNumber, treat.ZeroLength.asNumeric=treat.ZeroLength.asNumeric)) { if (ignore.factors && is.factor(x)) res <- FALSE else if (ignore.logical && is.logical(x)) res <- FALSE else if (ignore.dates && is.Date(x)) res <- FALSE else res <- suppressWarnings(!is.na(as.numeric(x))) } if (treat.ZeroLength.asNumeric) res[length(x) == 0] <- TRUE return (res) } isNumberAll <- function(x, ...) { ## Wrapper function for cleaner *ply syntax all(isNumber(x, ...)) } setnamestopropper <- function(DT, period_to=" - ") { setnames(DT, topropper_keywords(names(DT), period_to=period_to)) } setnamestolower <- function(DT, ...) { setnames(DT, tolower(names(DT)), ...) } setnamestoupper <- function(DT, ...) { setnames(DT, toupper(names(DT)), ...) } setnames_removePreface <- function(DT, preface, sep=".", ignore.case=FALSE) { pat <- paste0(preface, sep) %>% escapeRegEx %>% paste0("^", .) setnames(DT, gsub(pat, "", names(DT), ignore.case=ignore.case)) return(invisible(DT)) } setnames_addPreface <- function(x, with, sep="_") { if (missing(with)) { warning ("with is missing. x will be returned unchanged") return(invisible(x)) } setattr(x=x, name="names", value=paste0(with, sep, names(x))) } # ========================= MetricScaleNextRank <- function(pref, decreasing=TRUE, moveBy=mod, mod=1) { if (!exists("MetricScale")) { MetricScale <- createMetricScale(envir=parent.frame()) } MetricScale <- copy(MetricScale[power %% mod == 0]) msg.mod <- ifelse (mod == 1, "", "\nTry setting `mod=1`") if (pref %ni% MetricScale[["pref"]]) stop ("'", pref, "' is an invalid prefix") currentRank <- MetricScale[pref][, rank] if (decreasing) newRank <- currentRank - moveBy else newRank <- currentRank + moveBy if (newRank %ni% MetricScale[["rank"]]) stop ("Current Rank is ", currentRank, " and with an moveBy of ", moveBy, " the new rank is beyond the values in MetricScale") MetricScale[rank==newRank, pref[[1]]] } createMetricScale <- function(assignTo="MetricScale", envir=globalenv()) { assign(assignTo, envir=envir, value=data.table( read.table(header=TRUE, stringsAsFactors=FALSE, text= '"rank" "power" "pref" "abr" factor 6 12 "tera" "T" 1000000000000 5 9 "giga" "G" 1000000000 4 6 "mega" "M" 1000000 3 3 "kilo" "k" 1000 2 2 "hecto" "h" 100 1 1 "deca" "da" 10 0 0 "unit" "unit" 1 0 0 "" "" 1 -1 -1 "deci" "d" 0.1 -2 -2 "centi" "c" 0.01 -3 -3 "milli" "m" 0.001 -4 -6 "micro" "μ" 0.000001 -5 -9 "nano" "n" 0.000000001 -6 -12 "pico" "p" 0.000000000001'), key="pref")[, rank := as.integer(rank)] ) return(get(assignTo, envir=envir)) } # ========================= rbindFactorCheck <- function(l, silent=FALSE, preserveFactors=FALSE , checkAllForDT=FALSE, debug=FALSE) { ## executes `rbindlist(l)` but first converting any factor columns to characters. ## checkAllForDT : if TRUE will check all values of `l` that they are data.tables ## if FALSE will only check the first element and assume the user ## is correctly calling the function. The function will fail ## during the character-coercien step if not all DT's. ## ## ERROR CHECK - l should be a list of DTs if( (!inherits(l[[1]], "data.table")) || (checkAllForDT && any(!sapply(l, inherits, "data.table"))) ) stop("`l` must be a list of data.tables") # # bank the current columns which are factors # if (preserveFactors) # ## TODO: # stop("preserveFactors is NOT implemented. You need to do that manually.\nPlease switch this flag to FALSE before rerunning this function.") listOfFactorCols <- lapply(l, whichFactors, names=TRUE) ## Mixing non-character with character columns may produce NAs (depending on the order they appear in `l`) ## Therefore, we identify which columns are characters in each list element, and check that they are the same listOfCharCols <- sapply(l, function(x) names(which(sapply(x, inherits, "character"))), simplify=FALSE) ### This _almost_ works... I would need to execute the `mapply` part differently. ### Maybe benchmark that at a laterpoint. For now, just using `simplify=FALSE` in the sapply above. ### # rem: ## A quick trick to seeing if all are the same is that `sapply` will simplify to a matrix # rem: ## if it is not a matrix, then there are offending elements. # rem: if(!inherits(listOfCharCols, "matrix")) { # rem: listOfCharCols <- t(listOfCharCols) # recalling that the matrix is transposed # rem: keepCols <- which(!apply( listOfCharCols, 2, lunique) == 1) # rem: listOfCharCols <- listOfCharCols[, keepCols, drop=FALSE] # rem: allCharCols <- as.vector( listOfCharCols ) # rem: } else { # rem: # Create a vector of _all_ the columns that are character # rem: allCharCols <- unlist(listOfCharCols) # rem: } ## The idea is that if a column is a character column, ## it must be so in _every_ element of l ## Therefore, we tabulate how often each column appears, ## Any column that appears less than length(l) (ie, is not in every l) ## must be addressed. ## We next have to determine which elements of l need addressing for which column. ## We do this by making a vector of all columns that need to be addressed in general, ## then comparing it to the list of character columns for each l. ## Anytime there is an element that does not appear in a given l's column list, ## then that column needs to be addressed for that l. ## ## Note that we are going by column position instead of column name. ## If the two do not match up, it will be caught during rbind. ## x - Not Needed - x # allCharCols <- unlist(listOfCharCols) # # tabulate that list, check which are offenders in _some_ element of `l` # offenders <- names(which(table(allCharCols) != length(l))) # lapply(listOfCharCols, setdiff, x=allCharCols) ## x - Not Needed - X # ## These will be used in the two `setdiff` calls in the `mapply` loop allFactrCols <- unique(unlist(listOfFactorCols)) allCharCols <- unique(unlist(listOfCharCols)) ## For debugging, I'm tracking what each column is before/after the mapply call if (debug) { before <- t(sapply(l, are)); lbak <- copy(l)} invisible(mapply( ## If it is a factor in one, it has to be a converted in all, ## hence the use of c(allFactrCols, allCharCols) ## Then the `setdiff` is to not waste time converting columns ## that are already converted ## TODO: Conceivably we could check the levels / labels of ## the corresponding columns and only convert if necessary ## For now... just coercing everything to character function(i, cc, ff) if (length({cols <- setdiff(c(allFactrCols, allCharCols), cc)})>=1) l[[i]] [, c(cols) := lapply(.SD, as.character), .SDcols=cols] , seq(l), listOfCharCols, listOfFactorCols, SIMPLIFY=FALSE )) ## For debugging if (debug) { after <- t(sapply(l, are)) cat("\t\tBefore VS After: \n ", pasteR("-", 30),"\n") print(rbind(before, c("^^B - Avv"), after)) browser() } if (!preserveFactors) return(rbindlist(l)) # else, convert factor cals ret <- rbindlist(l) ret[, c(allFactrCols) := lapply(.SD, as.factor), .SDcols=allFactrCols] return(ret) } # // End of function dimCompare <- function (..., decr=NA, decreasing=decr, sort=NA, sortOn=sort) { ## TODO: Generalize. This works only if the dots come first. nms <- as.character(match.call()[-1][1:length(list(...))]) if (length(nms)==1 && is.list(..1)) { dims <- lapply(..1, dim) if (!is.null(names(..1))) nms <- names(..1) else nms <- seq_along(..1) } else { # old: ## This is the previous version. preserved in case of bugs # old: dims <- lapply(nms, function(x) dim(get(x, envir=parent.frame(3)))) dims <- lapply(nms, function(x) dim(eval(parse(text=x), envir=parent.frame(3))) ) } ## It is possible that dims will be fully NULL if the ... did not have valid dimension if(any(wh.null <- sapply(dims, is.null))) { stop ("Some items sent to dimCompare() do not have dimension. Possibly culprits are:\n ", paste_l(nms[wh.null])) } # collapse into a single data.frame dims <- do.call(rbind, dims) dimnames(dims) <- list(nms, c("rows", "cols")) # sort if (!is.na(decreasing) || !is.na(sortOn)) { # short hands, to not have to write c(...) if (all(tolower(sortOn)=="cr")) sortOn <- c("cols", "rows") if (all(tolower(sortOn)=="rc")) sortOn <- c("rows", "cols") # try to match sortOn if (!all(is.na(sortOn))) sortOn <- pmatch(tolower(sortOn), colnames(dims)) # if missing, sort on whichever column has the largest variance if(all(is.na(sortOn))) { co <- sd(dims[, "cols"]) ro <- sd(dims[, "rows"]) sortOn <- ifelse(co > ro, "rows", "cols") } if (is.na(decreasing)) decreasing <- TRUE ordering <- do.call(order, c(lapply(sortOn, function(i) dims[, i]), decreasing=decreasing )) dims <- dims[ordering, ] } if (nrow(dims)==2) dims <- rbind(dims, "DIFF" = abs(apply(dims, 2, diff))) return(dims) } showProg <- function(flag, outp, header=FALSE, done=FALSE, tb=1) { # wrapper function for: # if flag is true, then cat() outp. # put tabs after any line break outp <- sub("\n", tbs(tb, T), outp) # If header or done: set tb to 0, unless user defined value tb <- ifelse(missing(tb) && (header || done), 0, tb) if (header) cat ("","========================","Progress Indication....", sep=tbs(tb,T)) if (flag) cat(tbs(tb), outp, "\n", sep="") if (done) cat ("", "----------------", "Process Complete", "========================", sep=tbs(tb,T)) } #-------------------------------------------- #----------------------------------------------- iterateByClass <- function(DT, classes, mc=sys.call(1), ...) { ## useful for calling inside of a function where that func generally applies only to a vector of a given class ## and user would like to apply it to certain columns of a DT, only if they are of the given class(es). ## Other columns get returned unchanged ## ## mc is the match.call() from previous function. default is sys.call(1) ## the function name is taken from here, as is the primary argument ## ## classes : a character vector of which class(es) to apply function to ## A column in DT that does NOT inherit a class from classes will be returned as is ## For debugging and dev'ing browser(expr=inDebugMode("iterate", "iteration"), text="in iterateByClass, at the very beginning.") ## in the match.call, the first argument is the function name, the second is primary argument args <- as.list(mc) if (!(length(args) >= 2)) stop ("'mc' (the match.call() results) must have at least two elements when converted to a list.\n\tIt has only ", length(args), ".") Func <- match.fun(args[[1]]) X.nm <- names(args)[[2]] args <- args[-(1:2)] classes <- c("numeric", "factor", "data.frame") ## RETURN DT[, lapply(.SD, function(col) if (!inherits(col, classes)) col else do.call(Func, c(setNames(list(col), nm=X.nm), args, list(...))) )] } locateFirstNonZeroDigit <- function(x) { # browser() logs <- log10(abs(x)) pos <- logs > 0 noneNAs <- !is.na(logs) if (any(pos, na.rm=TRUE)) logs[pos & noneNAs] <- ceiling(logs[pos & noneNAs]) if (any(!pos, na.rm=TRUE)) logs[!pos & noneNAs] <- floor(logs[!pos & noneNAs]) logs } padOutput <- function(mat, extrapad=0, minpad=0, maxpad=Inf, byColumn=FALSE, space=" ", align=c("left", "right"), ignore.column=c(NULL)) { # Padding will be determined automatically so that all values (or columns) have the same width # minpad : is as close to an "Exact width" as possible, unless there is an existing width that is larger. # extrapad : is the number of padding that will be added in addition to the automatic padding # maxpad : is like a cut-off to extrapad. align <- match.arg(align) # if by column, recurse over each column if (byColumn) { ret <- apply(mat, 2, padOutput, extrapad=extrapad, minpad=minpad, maxpad=maxpad, space=space, align=align) # This is the actual padding } else { nc <- nchar(mat) max.char <- max(nc + extrapad) # the widest of all elements, plus extrapad max.char <- max(max.char, minpad) # if the max.char is less than minpad, increase it to minpad. max.char <- min(max.char, maxpad) # if the max.char is more than maxpad, decrease it to maxpad. # add padding to each element padding <- sapply(max.char-nc, pasteR, x=space) ret <- {if (align=="left") paste0(mat, padding) else paste0(padding, mat)} } # reset the attributes before returning attributes(ret) <- attributes(mat) if(!is.null(ignore.column) && all(ignore.column <= ncol(ret)) && all(ignore.column > 0)) ret[, ignore.column] <- mat[, ignore.column] return(ret) } cbindWithSep <- function(mat1, mat2, sep=" | ", rnames, cnames=NULL) { # combines two matricies using cbind, but adds a seperator column for fancy output if (missing(rnames)) rnames <- {if(length(dim(mat1))) rownames(mat1) else names(mat1)} if (length(dim(mat1))) mat1 <- apply(mat1, 2, as.character) else mat1 <- unlist(mat1) if (length(dim(mat2))) mat2 <- apply(mat2, 2, as.character) else mat2 <- unlist(mat2) ret <- cbind(mat1, " "=sep, mat2) ## add in column names iff cnames is not blank (and the appropriate number of columns given) if(!is.null(cnames)) { # add in a plank for the sep, iff it is one longer than the number of columns in ret if(length(cnames) == ncol(ret) - 1) { cl <- ncol(cbind(mat1)) # we want the number of columns that mat1 will contribute. We wrap in `cbind` incase not matrix like cnames <- c(head(cnames, cl), "", tail(cnames, -cl) ) } # add cnames only if the lengths (now) match if(length(cnames) == ncol(ret)) colnames(ret) <- cnames } rownames(ret) <- rnames return(ret) } probMatrixGiven <- function(probMat, givenHistory, rnames=NULL, print=FALSE, probNames=NULL) { # takes a matrix of probabilities and given history and outputs a matrix of characters, # somewhat nicely formatted to be used with `print( ___, quote=FALSE)` if (missing(rnames)) rnames <- {if(length(dim(probMat))) rownames(probMat) else names(probMat)} # set up names if (identical(rnames, unlist(givenHistory))) rnames <- NULL # cleanup the structure, slightly his <- unlist(givenHistory) probs <- fwp(probMat, justNumbs=TRUE, pad=TRUE) # pad the history on the right his <- padOutput(his, minpad=8, align="left") # add 2 padding to the right, then 3 to the left with a minpad of 8 probs <- padOutput(probs, extrapad=2, align="left") probs <- padOutput(probs, extrapad=3, minpad=8, align="right") # ensure is matrix probs <- cbind(probs) # determine cnames, and add some space onto the left # if null, at least have them be blank, so cnames picks up something if (is.null(colnames(probs))) colnames(probs) <- rep(" ", ncol(cbind(probs))) if(!is.null(probNames) && length(probNames) == length(colnames(probs))) colnames(probs) <- probNames # add padding colnames(probs) <- padOutput(colnames(probs), extrapad=2, maxpad=8, minpad=8, align="right") # max @ 8, instead of min # create cnames cnames <- c(colnames(probs), "Given") ret <- cbindWithSep(probs, his, rnames=rnames, cnames=cnames) # fancy'esque output if (print) { if(length(colnames(ret))) { cat(colnames(ret), sep="\t") cat("\n") # number of characters per column ncs <- apply(rbind(colnames(ret), ret), 2, function(x) max(nchar(x))) bars <- sapply(ncs, pasteR, x="-") bars[length(bars)-1] <- " | " cat(bars, sep="\t") cat("\n") } apply(ret, 1, cat, sep="\t", collapse="\n") # return the output invisibly return(invisible(ret)) } # if not printing, return the output as normal return(ret) } ############################################################### # mean with paramters. Trimming top/bottom p observations (or 1/4 if too few obs present) meantrm <- function(x, p=6) mean(x, trim=min(.25, p/length(x)), na.rm=TRUE) CMT <- getCMT <- getClassModeTypeof <- function(obj) { # Returns as a vector, the class, mode, typeof of the obj # getCMT(), CMT() are useful shorthands return(c("class"=class(obj),"mode"=mode(obj),"typeof"=typeof(obj))) } getNCMT <- getNameClassModeTypeof <- function(obj) { # Returns as a vector, the name, class, mode, typeof of the obj # getNCMT is a useful shorthand return(c("name"=names(obj), "class"=class(obj),"mode"=mode(obj),"typeof"=typeof(obj))) } countNA01s <- function(vec) { # in a given vector, how many are there of each: NA, 0, 1, -1, >1, <(-1), 'other' # useful for helping to determine if the vector is in fact logical # # Args: vec; a vector # NOTE: if the vector is of class "factor", then 'lt-1' and 'gt1' will not calculate # in this case, 'nota' (none of the above) is helpful # CAREFUL: even if 'lt-1', 'gt1' ARE calculated, 'nota' will still count those elements return( c("NAs"=sum(is.na(vec)), "lt-1"=sum(vec < (-1) & !is.na(vec)), "-1s"=sum(vec == (-1) & !is.na(vec)), "0s"=sum(vec == 0 & !is.na(vec)), "1s"=sum(vec == 1 & !is.na(vec)), "gt1"=sum(vec > 1 & !is.na(vec)), "nota"=sum(vec != 1 & vec != 0 & vec != (-1) & !is.na(vec)) #none of the above )) } insert <- function(lis, obj, at=after+1, after=0, objIsMany=FALSE) { # Inserts obj into list *at* position 'at' # all existing items in list, form 'at' onward, are moved forward # NOTE: If 'at' is beyond (1, length(lis)), then it is inserted at the appropriate end # # Args: # lis: the list object # obj: the object being inserted # at: the atition of insert # objIsMany: (TODO) If T, each item in obj is inserted separately # # Returns: # list with obj inserted at atition # # TODO: modify for objIsMany=TRUE # # EXAMPLE # # for (i in 0:5) { # cat("at =", i, " ") # print(insert(1:3, -99, i)) # } # 1 2 3 4 # -- -- -- -- # at = 0 [1] -99 1 2 3 # at = 1 [1] -99 1 2 3 # at = 2 [1] 1 -99 2 3 # at = 3 [1] 1 2 -99 3 # at = 4 [1] 1 2 3 -99 # at = 5 [1] 1 2 3 -99 leng <- length(lis) if (at > leng) { # note strictly greater (not greater or equal!) return (c(lis, obj)) ## TODO: Check for objIsMany ## ifelse(objIsMany, for(i in....)) } if(at <= 1) { c(obj,lis) } else { c(lis[1:at-1], obj, lis[at:leng]) } } #-------------------- sapply.preserving.attributes = function(l, ...) { # by @Owen from http://stackoverflow.com/questions/7698797/why-does-mapply-not-return-date-objects r = sapply(l, ...) attributes(r) = attributes(l) r } #-------------------- #-------------------------- isSubstrAtEnd <- function(x, pattern, ignorecase=TRUE) { # Checks if x ends with pattern if (ignorecase) return (tolower(substr(x, nchar(x)-(nchar(pattern)-1), nchar(x)))==tolower(pattern)) return (substr(x, nchar(x)-(nchar(pattern)-1), nchar(x))==pattern) } tbs <- function(n, nl=FALSE) { # returns a string of n-many tabs, concatenated together # if nl=T, will preface with a new line char. return(paste0(ifelse(nl, "\n", ""), paste0(rep("\t", n), collapse=""))) } miniframe <- function(data, rows=200) { ## returns a dataframe similar to data but with a randomly selected rows miniLength <- 200 l <- nrow(data) ind <- abs(rnorm(miniLength))* l ind <- round(ind) %% l cat(ind) return(data[ind,]) } chkp <-chkpt <- function(logStr, chkpOn=TRUE, final=FALSE) { # Logs the string to the console for checkpointing & troubleshooting # Args: # logStr : a string that will be logged to stdout # chkpOn : If FALSE, then logging does not occur. (for quickly turning chkp on/off) # # Returns Null if (chkpOn) { if (nchar(logStr)<3) logStr <- paste0("\t\t ",logStr) else if (nchar(logStr)<12) logStr <- paste0("\t\t",logStr) else if (nchar(logStr)<15) logStr <- paste0("\t",logStr) else if (nchar(logStr)<17) logStr <- paste0(" ",logStr) else if (nchar(logStr)<20) logStr <- paste0(" ",logStr) #log cat(paste0("\t\t", ")*( checkpoint )*(","\n\t\t",logStr,"\n", collapse="")) } if (final) { cat("\n\n") #for cleanliness } return() } pgDisconnectAll <- function(drv=dbDriver("PostgreSQL")) { # Closes all open connections to drv for (conn in dbListConnections(drv)) { dbDisconnect(conn) } } humanDate <- function(date, wday=TRUE, ...) { if (is.character(date)) { nas <- is.na(date) converted <- suppressWarnings(as.Date(date)) if (!any(is.na(date[!nas]))) date <- converted } if (!is.Date(date)) { warning("The argument to humanDate should be a Date object. It is not. Returning unchanged") return(date) } frmt <- "%b %d, %Y" if (wday) frmt <- paste0("%a ", frmt) timeStamp(time=date, frmt=frmt, human=FALSE, ...) } dateStamp <- function(x=NULL, frmt="%Y%m%d", tz="America/New_York", sep="_", date=now(), time=date, human=FALSE, ...) { ## date is a synonym for time if (human) { if (missing(frmt)) frmt <- "%a %b %d %Y" else warning("'human' is ignored when 'frmt' is given explicitly") } timeStamp(x=x, frmt=frmt, tz=tz, sep=sep, time=time, human=FALSE, ...) } ## this is not called UTC, but I cannot think of the proper term right now UTC_to_human <- function(ts) { gsub("\\-|:", "", gsub("T", "_", gsub("Z$", "_Z", ts))) } timeStampUTC <- function() { ## creates a time stamp in the '2012-10-18T17:57:02Z' format timeStamp(frmt="%Y-%m-%dT%H:%M:%SZ", tz="UTC") } timeStamp <- function(x=NULL, seconds=FALSE, year_when_human=FALSE, sep="_", pre.ext=FALSE, frmt="%Y%m%d_%H%M", tz="America/New_York", time=Sys.time(), human=FALSE) { # basic time stamp: 20111231_2350 for Dec 31, 2012, 11:50pn # if pre.ext is TRUE, then will attempt to insert the time stamp after the base name # for backwards compatability, where previously timeStamp had only one argument, `seconds`. if (identical(x, TRUE) || identical(x, FALSE)) { seconds <- x x <- NULL } if (is.null(x)) sep <- "" if (year_when_human && !human) warning("'human' is set to FALSE, but 'year_when_human' is set to TRUE. 'year_when_human' will be ignored") if (missing(frmt)) { if (human) { frmt <- "%a %b %d %l:%M %p" if (seconds) frmt %<>% gsub("%l:%M", "%l:%M:%S", .) if (year_when_human) frmt %<>% gsub("%b %d ", "%b %d, %Y ", .) } else if (seconds) frmt <- paste0(frmt, "%S") } else { if (human || year_when_human || seconds) warning("Fields 'human', 'year_when_human' and 'seconds' are ignored when 'frmt' is given explicitly") } ts <- format(time, frmt, tz=tz) # check for file extension has to have a dot as well if(pre.ext && isTRUE(grepl("\\.", x))) { ## TODO: allow for many dots, ie file.tar.gz # look at: regexAll(pat=".*\\.", stringVec=x) # the match length will be the char position of the last . dot <- attr(regexpr(pat=".*\\.", text=x), "match.length") ret <- paste0( substr(x, 1, dot-1), # base sep, ts, # separator and time stamp substr(x, dot, nchar(x)) ) # extension } else ret <- paste(x, ts, sep=sep) return(ret) } detectAssignment <- function(obj, single=TRUE, simplify=FALSE) { # detects whether an assignment operator is present. # Returns T if detected. F if not detected. # obj can be list-like # if single=TRUE, returns a single element (ie, any(unlist(.)) ) as opposed to a logical vector # (useuful if one bad apple makes the whole bunch unusable) # simplify is passed through to the sapply call. Single will override simplify # list of operators to search for ops <- c("<-", "<<-", "->", "->>") # compute grepl ret <- sapply(ops, grepl, obj, simplify=simplify) # return value if (single) return(any(unlist(ret))) return(ret) } plength <- printlength <- function(opt=200) { ## Changes the environment's setting for how many elements to output for print command ## ## Arg: opt is the maximum number of elements that will be outputed when print is called ## ## Returns the value returned by the options call, which is the previous max.print setting return(options("max.print" = opt)) } reminder <- function() { ## function to remind which op is which. cat ("SINGLE: \n") cat("c(T, F, T) & c(T, F, T) = ", c(T, F, T) & c(T, F, T), "\n\n") cat ("DOUBLE: \n") cat("c(T, F, T) && c(T, F, T) = ", c(T, F, T) && c(T, F, T), "\n") } saveToFile_TabDelim <- function(obj, directory=getwd()) { ## saves obj as a .csv file of ## the same name, with a time stamp ## in location: directory ## ## Argss: Obj should be matrix or df-like ## ## returns: the path/to/file.Rda where obj was saved #cleanup the strings for a proper filename objName <- cleanChars(substitute(obj)) if (isSubstrAtEnd(directory,"/")) { directory <- substr(directory,1,nchar(directory)-1) } # create the filename, then save it fileName <- paste0(directory,"/",objName,"_",ts(),".csv") write.table(obj, file=fileName, sep="\t", eol="\n", col.names=TRUE, row.names=TRUE, append=TRUE, quote=FALSE, qmethod="double") # write.table(rbind(obj), file=fileName, sep="\t", eol="\n", # col.names=TRUE, row.names=TRUE, append=T, quote=FALSE, qmethod="double") return(fileName) } retTst <- function(n) { ## used for trouble shooting # positive values of n return T # negative values of n return F # NA values of n return NA # all other values of n return NULL if (any(is.na(n) | is.null(n))) return(NA) # return ret <- ifelse(n > 0, TRUE, ifelse(n < 0, FALSE, list(NULL) )) if(length(ret)==1 && is.null(ret[[1]])) return(NULL) return(ret) } #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ allPosCombsList <- function(dat, choose=seq(ncol(dat)), yName="y") { ## returns list of column indicies #----------------------------------------------------------------------# ## NOTE TO SELF ## CANNOT DO THIS. dat must not contain y. otherwise the columns will not match up ## ## This will simply have to be different from allModels for now ## # if (!any(colnames(dat) == yName)) # warning(yname, " not found in the colnames of dat; using whole dataframe.") # # # remove y-column # dat <- dat[, colnames(dat) != yName] #----------------------------------------------------------------------# n <- ncol(dat) # x <- c(rep(TRUE, 3), rep(FALSE, n-3)) lapply(choose, function(r) cbind(permutations(n, r))) } # allPosCombsMatrix.TakesTooLong <- function(dat, choose=-1) { # ## Creates a matrix where each row is a logical-index corresponding # ## to the columns (ie, variables) of dat # ## Where the rows contain all possible 'choose'-combinations of the variables # ## # ## dat is a dataframe of response variables # ## choose is a vector, indicating HOW MANY variables to co-select # ## eg choose=3 will give only rows of 3-co-selections # ## choode=1:3 will give only rows of 1, 2, or 3 co-selections # ## choose=-1 selects ALL rows # # n <- ncol(dat) # # matr <- matrix(rep(c(TRUE, FALSE), n), nrow=n, byrow=TRUE) # matr <- do.call(expand.grid, split(matr, row(matr))) # # # reverse the columns for neatness # matr <- matr[, n:1] # # # add names # colnames(matr) <- colnames(dat) # # # if choose is flagged as -1, select all rows, otherwise only those requested # whichRows <- if (all(choose == (-1))) seq(2^n) else rowSums(matr) %in% choose # # # return # matr[whichRows, ] # # } formulasList <- function(dat, yName="y", VARS.list=NULL, interact=TRUE, intercept=TRUE) { # creates list of formula strings from a dataframe and list of variable indexes # Note: VARS.INDEX should reference dat WITHOUT y present. plusstar <- if (interact) "*" else "+" if (is.null(VARS.list)) VARS.list <- allPosCombsList(dat[colnames(dat) != yName], 1:2) tilde <- ifelse(intercept, "~ 1 + ", "~ -1 + ") vars <- colnames(dat[colnames(dat) != yName]) # datName <- as.character(match.call()[[2]]) # NOT NEEDED formulasList <- lapply(VARS.list, function(varsIndex) apply(varsIndex, 1, function(vec) # the mess with the vec[[1]] is necessary to accomadate the + in tilde, which is necessary for interact=TRUE as.character(paste(c( paste(yName, tilde, vars[vec[[1]]]), vars[vec[-1]]), collapse=plusstar), env=parent.frame(3)) )) formulasList } #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ logscale <- function(range=2:5, intervals=2, base=10) { # returns a sorted vector of powers of the base. # range is a vector of powers # intervals is applied AFTER powers, so that intervals=3 for range=1:4 would return: # (10 * 1/3), (10 * 2/3), (10 * 3/3), (100 * 1/3), (100 * 2/3), (100 * 3/3), etc... # factors <- seq(intervals) / (intervals) ret <- sort(unlist(lapply((base^range), function(x) {x*factors}))) return (ret) } lP <- listPacker <- function(receiver, ...) { # takes all arguments (...) and appends them to receiver # # receiver should be list-like # value returned is list-like return(c(receiver, list(...))) #-----------------------------------------------------------------------# # TODO: Decide if any of the following is still useful, else chuck it. # #-----------------------------------------------------------------------# # if (length(list(...)) > 0L) { # receiver[length(receiver) + 1L] <- ..1 # if (length(list(...)) > 1L) { # receiver <- listPacker(receiver, list(...)[-1L]) # } # } else { # warning("There were nothing to add to the list.") # } # receiver #-----------------------------------------------------------------------# } lsnf <- function(...){ # same as ls(), but such that object is not a function objs <- ls(..., envir=parent.frame(2)) objs[!sapply(objs, function(x) is.function(get(x, envir=parent.frame(2))))] } lsi <- function(what, invert=FALSE, rm=FALSE){ # same as ls(), but such that object inherits `what` if (!is.character(what)) what <- as.character(match.call()[[2]]) objs <- ls(envir=parent.frame(2)) indx <- sapply(objs, function(x) inherits(get(x, envir=parent.frame(3)), what)) if (invert) indx <- !indx if (rm) { rm(list=objs[indx], envir=parent.frame(2)) cat("The following objects have been removed:\n") } return(objs[indx]) } ## ---------------------------------------------## ## FUNC FORM ## ## FOR SOURCING URLS ## ## note the difference in envir=(.) ## ## ## ## ---------------------------------------------## "~~~~~~~~~~~~~ MOST OF THE FUNCTIONS IN THIS SECTION ARE VERY, VERY OLD AND PROBABLY USELESS ~~~~~~~~~~~~~" ## ---------------------------------------------## #---------------------------------------# #_________________________________________# ### GRAB COEFFICIENTS TABLE FROM SUMMARY ### coefTable <- function(model) { # captures the summary output table and returns it in a data.frame require(stringr) # this param indicates p-value less than machine precision. # we need to swap it out for the string splicing in read.table machPrec <- " < 2e-16" machPrec.replace <- "2e-16" # form a table of the pvalues, etc mout <- capture.output(summary(model)) # find borders to the table, based on coefficients and --- table.top <- grep("^Coefficients:", mout) + 1 table.bottom <- which(mout == "---") - 1 # if couldn't find bottom, look for next clue if (identical(table.bottom, numeric(0))) table.bottom <- grep("^Residual standard error", mout) - 2 # if still 0, count up 4 from bottom and issue warning if (identical(table.bottom, numeric(0))) { table.bottom <- length(mout) - 4 warning("couldnt find exact bottom of table. Please confirm manually") } # get table m.table <- mout[(table.top+1):table.bottom] m.table <- sub(" $", " -- ", m.table) # clean significance column m.table <- sub(machPrec, machPrec.replace, m.table) # clean p-value column m.table <- read.table(text=m.table, stringsAsFactors=FALSE) # convert to matrix/datafrmae # Column Names cnames <- mout[table.top] cnames <- str_trim(mgsub(c("Std. Error", "t value", "Pr(>|t|)"), c("SE", "tVal", "pVal"), cnames)) cnames <- c("Predictor", strsplit(cnames, " ")[[1]]) # check if significance column is present. (ie, there should be one more column than cnames) sigPresent <- ncol(m.table) > length(cnames) # add column names to table, adding Signif if column present colnames(m.table) <- if(sigPresent) c(cnames, "Signif") else cnames # make signif column factor, if present. if (sigPresent) m.table$Signif <- factor(m.table$Signif, levels=c("***", "**", "*", ".", "--")) return(m.table) } #_________________________________________# splitEvery <- function(string, n, remSpace = FALSE) { # if n is too small, return error if (n < 1) stop("n must be at least 1") # if vector, iterate over each if (length(string) > 1) { if(!is.ts(string)) return(sapply(string, function(s) splitEvery(s, n))) return(sapply(seq(string), function(i) splitEvery(string[[i]], n))) } if(!is.character(string)) string <- as.character(string) # remove space if selected if (remSpace) string <- gsub(" ", "", string) # for smaller n, do more quickly if (n == 1) return(strsplit(string, "")[[1]]) if (n >= nchar(string)) return(string) # error prevention: buffer will be added to end of string to avoid recycling of first letters buffer <- rep("", (0 - nchar(string)) %% n) if (n == 2) { sst <- c(strsplit(string, "")[[1]], buffer) return(paste0(sst[c(TRUE, FALSE)], sst[c(FALSE, TRUE)])) } # else # create index vectors of T/F. eg for n=4 # T, F, F, F # F, T, F, F # F, F, T, F # F, F, F, T TrueFalseVec <- rep(c(T, F), c(1, n-1)) indexs <- lapply(rev(seq(n)), function(i) TrueFalseVec[((1:n + i-1) %% n) + 1]) # split the string by letter, adding buffer at end (to avoid recylcling of letters) sst <- c(strsplit(string, "")[[1]], buffer) # outer apply loop simply pastes the letters back together # inner mapply loop selects the letters per group, using the F/T/F/F, etc/ apply(mapply("[", list(sst), indexs), 1, paste0, collapse="") } #----------------------------------- cls <- function(LINES=100) cat(rep("\n", LINES)) #===================================================================# pkgFind <- function(toFind) { # useful when you cant remember the capitalization, etc of a package # ie, is it rCurl, RCurl, rcurl ... ? pkgs <- dir(.libPaths()) pkgs[stringr::str_detect(pkgs, stringr::ignore.case(toFind))] } #===================================================================# #-------------------------------------# ## FUNCTIONS #-------------------------------------# namesdetect <- function(x, pattern) names(x)[grepl(pattern, names(x))] namesIn <- function(x, vec, positive=TRUE) names(x)[xor(!positive, names(x) %in% vec)] namesNotIn <- function(x, vec) namesIn(x, vec, positive=FALSE) orderedColumns <- function(DT, frontCols=NULL, ignoreCase=TRUE, endCols=NULL) { # function to ignore case ifToUpp <- if (ignoreCase) toupper else function(x) x # returns metric columns in an ordered fashion nm <- names(DT) # set of columns to frontCols, if not supplied if (!length(frontCols)) frontCols <- c("artistID", "concertID", "Date", "Day", "artistName", "state", "venue", "perc", "isTraining", "name", "day", "month", "year", "MinDate") # which columns are `ends` ends <- ifToUpp(nm) %in% ifToUpp(endCols) # which columns are 'non-metrics' and not `endCols` non <- ifToUpp(nm) %in% ifToUpp(frontCols) # reorder: first the `non-metrics` in the order they appeared # then the `metrics` ordered alphabetically c(nm[non & !ends], nm[!non][order(nm[!non])], nm[ends]) } combineRows <- function(x) if (all(is.na(x))) as.numeric(NA) else if(anyDuplicated(x)) max(x, na.rm=TRUE) else sum(x, na.rm=TRUE) #-------------------------------------# wordCount <- function(obj, words, ignore.case=TRUE, preservePunct=FALSE) { # basic word count, whole words only # obj is the source to search for and count words # words can be a single word, a vector or list of words, or it can be blank (for just a "total word" count) # words, if it is only one word, does not to be quoted. # preservePunct, if TRUE, punctuation will be considered part of a word. # split on whitespace and punctuation, unless flagged not to use punct. splitOn <- "[[:space:]]" obj.split <- strsplit(obj, splitOn) if (!preservePunct) obj.split <- lapply(obj.split, gsub, pattern="[[:punct:]]", replacement="") # extra spaces etc, will have nchar of 0. Count only those > 0. .totalWords <- sapply(obj.split, function(x) sum(nchar(x) > 0)) #initialize results <- NULL # count occurance of specific word #--------------------------------# if(!missing(words)) { # check if words exists and is character .tried <- try(sapply(words, is.character), silent=TRUE) if (inherits(.tried, "try-error") || !all(sapply(words, is.character))) words <- as.character(match.call()[[3]]) # in case words is a list instead of a vector words <- unlist(words) # for each words, count the number of occurences in each x .wordCount <- sapply(words, function(word) sapply(obj.split, function(x) sum(grepl(word, x, ignore.case=ignore.case)) ) ) results <- data.frame(.wordCount) } else words <- NULL #--------------------------------# results <- data.frame(cbind(results, .totalWords)) colnames(results) <- c(words, "TotalWords") rownames(results) <- names(obj) return(results) } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# dateCheck <- function(d) { if (lubridate::is.Date(d)) return(d) return(lubridate::ymd(as.character(d))) } # wrapper for use in *ply functions is.allNA <- function(x) all(is.na(x)) uniqueKeys <- function(DT) { # returns all unique tuples of values of the key-columns of a given data.table if (!is.data.table(DT)) stop ("DT passed to `uniqueKeys(DT)` is not a data.table") if (!hasKey(DT)) { warning("DT does not have a key set") return (NULL) } unique(DT[,.SD, .SDcols=key(DT)]) } convertClass <- function(DT, colnameVector, to, from=NULL, originDate="1970-01-01", excelOriginName=".xlorigin") UseMethod('convertClass') convertClass.default <- function(DT, ...) stop(match.call()[[2]], " is not a data.table. (This function only works on data.tables)") convertClass.data.table <- function(DT, colnameVector, to, from=NULL, originDate="1970-01-01", excelOriginName=".xlorigin") { # possible values for from: # c("percent") # Convert from... if(!is.null(from) && !is.na(from) && !from=="") { if(from=="percent") { for (cname in colnameVector) DT[, c(cname) := gsub("%", "", get(cname))] } else if (from=="excel" & to=="date") { if(!exists(excelOriginName)) stop("Need excel origin date to convert. Cannot find ", excelOriginName, ".") for (cname in colnameVector) DT[, c(cname) := as.Date(as.numeric(as.character(get(cname))), origin=get(excelOriginName))] } else { stop("dont know how to convert from ", from) } } # convert to: #--------------# ## FACTOR if (to == "factor") { for (cname in colnameVector) DT[, c(cname) := factor(as.character(get(cname)))] ## DATE } else if(to=="date") { if (!from=="excel") { for (cname in colnameVector) DT[, c(cname) := as.Date(as.numeric(as.character(get(cname))), origin=originDate)] } ## GENERAL } else { for (cname in colnameVector) DT[, c(cname) := as(as.character(get(cname)), to)] } } #-------- end convertClass.data.table --------# CamelCaseSplit <- function(string, flat=FALSE) { ## TODO: Preserve TheAmericanADLLeague splat <- strsplit(string, "(? 1) # warning("`Title` should be a single string. Results unpredictable") if(is.na(as.numeric(tabs))) { warning("`tabs` should be an integer. Defaulting to 1.") tabs <- 1 } # split on "\n" if present Title <- unlist(strsplit(Title, "\n")) # if pref or suf are numeric, they represent number of "\n" if (is.numeric(pref)) pref <- pasteC(rep("\n", pref)) if (is.numeric(suf)) suf <- pasteC(rep("\n", suf)) # count the longest line nc <- max(nchar(Title)) if (center) nc <- max(nchar(stringr::str_trim(Title))) # the dashes are two spaces shorter than nc tabs <- pasteC(rep("\t", tabs)) sep <- paste0("\n", tabs) dashes <- pasteC(rep(dash, nc-(2*!center))) if (!(center || (nc %% 2))) dashes <- paste0(" ", dashes, " ") preline <- if(topline) paste0(tabs, dashes) else character(0) Title <- paste0(Title, collapse=sep) ret <- paste(preline, Title, dashes, sep=sep) if (center) ret <- centerText(ret, trim=TRUE, tabs=tabs) ret <- paste(pref, ret, suf, "\n", sep="") cat(ret) } centerText <- function(x, eol="\n", padWith=" ", trim=TRUE, tabs="") alignText (x, eol, padWith, trim, tabs, halign="center") alignText <- function(x, eol="\n", padWith=" ", trim=TRUE, tabs="", halign="center") { # depends: `pasteC`, `stringr` package # padWith: character used # tabs: a string of white-space at beginning of a line that should be preserved. ## TODO: double-check the portion with extracted, and `spaces`. Might have to rethink it. require(stringr) # match halign halign.table <- c("left", "center", "right") hmatched <- pmatch(tolower(halign), halign.table) if (is.na(hmatched)) { warning('halign value should be from c("left", "center", "right").\nDefaulting to "center"') hmatched <- which(halign.table=="center") } halign <- halign.table[hmatched] # replace "\t" in `padWith` # "\t" is one char. It will throw off calculations padWith <- gsub("\t", " ", padWith) # split on eol and unlist text <- unlist(strsplit(x, eol)) # remove `tabs` at start of any line, it will be added back after pat <- paste0("^",tabs, " ?") extracted <- str_extract(string=text, pattern=pat) extracted <- ifelse(is.na(extracted), "", extracted) text <- gsub(pat, "", text) # trim whitespace if (isTRUE(trim)) text <- stringr::str_trim(text) # count the chars, and find the longest line ncs <- nchar(text) nce <- nchar(extracted) nce <- nce - max(nce) mx <- max(ncs) + max(nce) # the number of spaces required on each side spaces <- (mx - ncs - nce) / 2 spaces <- spaces / min(1, nchar(padWith)) # dividing by 1, in case nchar(padWith) > 1 # using min(.) in case nchar(padWith) == 0 # round down for left, round up for right. left <- lapply(spaces, function(s) pasteC(rep(padWith, floor(s)))) right <- lapply(spaces, function(s) pasteC(rep(padWith, ceiling(s)))) # padd each line in text with appropriate spaces padded <- if (halign=="left") { paste(extracted, text, left, right, sep="") } else if (halign=="right") { paste(extracted, left, right, text, sep="") } else { paste(extracted, left, text, right, sep="") } # paste back together with "\n" or other eol return(paste(padded, collapse=eol)) } splitToWidth <- function(x, width, safetyBreak=100) { if (width < 20) stop("Width too small. Stay above 20") splat <- unlist(strsplit(x, "\n")) ncs <- nchar(splat) tooWide <- (ncs > width) while(any(tooWide) && safetyBreak > 0) { # where to split, and where to force-insert white space TwoThirds <- max(floor(width*2/3) - 5, 2) sp <- max(3, floor(width-TwoThirds / 2) - sample(1:5, 1)) firstPart <- substr(splat[tooWide], 1, TwoThirds) secondPart <- substr(splat[tooWide], TwoThirds+1, ncs[tooWide]) hasWhiteSpace <- stringr::str_locate(secondPart, "\\s+")[, 'start'] noWS <- is.na(hasWhiteSpace) if(any(noWS)){ firstPart[noWS] <- substr(splat[tooWide][noWS], 1, width-TwoThirds) secondPart[noWS] <- substr(splat[tooWide][noWS], width-TwoThirds+1, ncs[tooWide][noWS]) } # secondPart[noWS] <- paste0(substr(secondPart[noWS], 1, sp), "- " # , substr(secondPart[noWS], sp+1, max(ncs))) secondPart <- stringr::str_replace(secondPart, "\\s+", "\n") splat[tooWide] <- paste0(firstPart, secondPart) # re-split splat <- unlist(strsplit(splat, "\n")) ncs <- nchar(splat) tooWide <- (ncs > width) safetyBreak <- safetyBreak - 1 } if(safetyBreak < 1) warning("Did not fully split") return(splat) } isFALSE <- function(x) { if (is.null(x)) return(FALSE) if (is.logical(x)) return(identical(x, FALSE)) if (is.character(x)) return(toupper(x) %in% c("F", "FALSE")) return(FALSE) } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # # Model Call Description # # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # modelDescrFromCall <- function(...) { UseMethod("modelDescrFromCall") } modelDescrFromCall.Arima <- function(M) { # creates model description from the `call` entry of # the model output # call description from model parts <- M$call # extract needed parts type <- toupper(parts[[1]]) ordr <- parts$order seasonal <- parts$seasonal s.out <- character() if(!is.null(seasonal)) { s.ordr <- seasonal$order s.prd <- seasonal$period s.out <- paste0(" x ", paste.call(s.ordr),"_", s.prd) ## TODO: Allow for expressions in title, ie (..)[12] instead of _12 } paste0(type, " ", paste.call(ordr), s.out) } modelDescrFromCall.lm <- function(M) { # creates model description from the `call` entry of # the model output # call description from model parts <- M$call # extract needed parts type <- toupper(parts[[1]]) formul <- parts$formula paste(type, paste.call(formul)) } modelDescrFromCall.default <- function(M) { # Returns as a nice string the call element of # model M. # If call element does not exist, returns NA. # if M has no call element, return NA if(!"call" %in% names(M)) return(NA) # call description from model parts <- M$call # extract needed parts type <- toupper(parts[[1]]) paste(type, paste.call(parts)) } # ------------ # modelDataSetFromCall <- function(...) { UseMethod("modelDataSetFromCall") } modelDataSetFromCall.Arima <- function(M) { # if M has no call element, return NA if(!"call" %in% names(M)) return(NA) ret <- as.character(M$call$x) ret <- ret[!ret == "("] return(ret) } modelDataSetFromCall.lm <- function(M) { # depends on: `areEqual()` # if M has no call element, return NA if(!"call" %in% names(M)) return(NA) parts <- M$call # if data is explicitly set if(!is.null(parts$data)) return(as.character(parts$data)) # else if(is.null(parts$formula)) return(NA) # dont know how to parse # else - check the formula parts for the data name forml <- parts$formula forml.parts <- forml[!sapply(forml, function(x) is.name(x) )] forml.parts <- as.character(forml.parts) # split the formula portions into components splat1 <- unlist(strsplit(forml.parts, "\\s*(:|\\+)\\s*")) # we split on '$', and in each formula part, all terms except the last splat <- strsplit(splat1, "\\$") header <- unique(lapply(splat, head, -1)) # if they are all the same, that is the data set if(length(header)==1) return(paste(header[[1]], collapse="$")) # else cannot determine data set return(NA) } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # rangesFromInt <- function(int, numberOfRanges, sizeOfEach, pairs=TRUE, aslist=TRUE, sequence=TRUE, fractions=FALSE) { if(!missing(numberOfRanges) & !missing(sizeOfEach)) warning("Can use both, `numberOfRanges` and `sizeOfEach`. Defaulting to `sizeOfEach`") # if (pairs), then at the end we will be subtracting 1. Hence add it in now. int <- int + pairs if (! missing (sizeOfEach)) { rngs <- seq(from=1, to=ceiling(1 + int/sizeOfEach)*sizeOfEach, by=sizeOfEach) rngs[length(rngs)] <- int } else { rngs <- seq(from=1, to=int+pairs, length.out=numberOfRanges+1) } if(!fractions) rngs <- round(rngs) if(!pairs) return(rngs) FUNC <- if(sequence) seq else c ret <- mapply(FUNC, head(rngs, -1), tail(rngs, -1) - 1, SIMPLIFY=FALSE) if (aslist) return(ret) return(do.call(rbind, ret)) } sortXbyY <- function(X, Y, justIndex=FALSE, names=FALSE, names.X=names, names.Y=names) { # returns X, sorted by the order in Y if(names.Y) Y <- names(Y) # if justIndex is flagged, then using order instead of sort for returns sortFunc <- if(justIndex) order else sort if (names.X) { if(justIndex) return(sortFunc(names(X))[order(Y)] ) return( X[ sortFunc(names(X))[order(Y)] ] ) } # else return( sortFunc(X)[order(Y)] ) } spacecnt <- function(x=clipPaste()) { ## Counts the spacing for a given x (possibly in the clipboard) ## useful for mr() ## strip all white space at ends x <- gsub("^[[:space:]]*", "", x) x <- gsub("[[:space:]]*$", "", x) # count how many beginning or ending punctuation pounds.start <- attr(regexpr("^[[:punct:]]*", x), "match.length") # for ending punct, we are looking for the same characters as that of pounds.start pounds.end <- attr(regexpr(paste0(substr(x, 1, 1), "*$"), x), "match.length") ## TODO: Allow for mirrored punctuation start/end # count how many spaces in the substr after the pounds.start mindent <- attr(regexpr("^[[:space:]]*", substr(x, pounds.start+1, nchar(x))), "match.length") totalLength <- nchar(x) # minWidth is the total length of the stripped x, less any pounds on either end minWidth <- totalLength - sum(pounds.start, pounds.end) ret <- c(mindent=mindent, minWidth=minWidth, totalLength=totalLength) assign("spacecntoutputvalues", ret, envir=.GlobalEnv) return(ret) } dtWideToLong <- function(DT, cols=names(DT), cnames=c("Name", "Value")) { copy(setnames(DT[, list(Name=rep(names(.SD), each=nrow(DT)), Value=unlist(.SD)), .SDcols=cols], cnames)) } knito <- function(input, output=gsub("src", "out", dirname(input)), encoding="UTF-8", ...) { dir.create(dirname(output)) knit(input=input, output=output, encoding=encoding, ...) } # ------------------------------------------------------------------------------------------ # options(supportFnsReload=TRUE) utilSource <- function(.Pfm=Sys.info()[['sysname']], main=TRUE, notify.welcome=FALSE, update.lastran=TRUE, warn.on.erros=TRUE, supportFnsReload=getOption("supportFnsReload", FALSE), verbose=FALSE) { ## loads a series of util files from the utils folder ## if `main` is flagged TRUE, then will reload this utils file as well. ## Supress Welcome message from Notify if (identical(notify.welcome, FALSE)) options("notify.startup"=FALSE) ## POSSIBLE MISSING FUNCTIONS if(!exists("as.path")) as.path <- function(...) do.call(function(...) paste(..., sep="/"), list(...)) if (!exists("plrl")) plrl <- function(word.pluarl.form, ...) return(word.pluarl.form) if (!exists("inDebugMode")) inDebugMode <- function(...) return(FALSE) if (!exists("getErrorLineNumbers") || !exists("tryToSource")) tryToSource <- function(file, showWarnings=FALSE) { ## this is a quick replacement inside of utilSource() in case the actual function is missing tryCatch(TRUE | isTRUE(source(file)) , error= function(e) { if (!length(e$message)) return(FALSE) if (grepl("cannot open the connection", e$message)) { ret <- FALSE attr(ret, "lines") <- "FILE UNAVAILABLE" return(ret) } lineNumbers <- gsub("^(\\d*)(.*)", "\\1", strsplit(e$message, "\n")[[1]]) lineNumbers <- suppressWarnings(as.numeric(setdiff(lineNumbers, ""))) lineNumbers[is.na(lineNumbers)] <- (-1) # these should never really happen. ret <- FALSE attr(ret, "lines") <- if (length(lineNumbers)) lineNumbers else NA return(ret) }) } ## // end tryToSource quick replacement ## No need for distinction utilsFolder <- "~/git/misc/rscripts/utils" # only (re-)load the main utils file if flagged if (main) { caught.main <- try(source(as.path(utilsFolder, "../utilsRS.r")), silent=TRUE) if (inherits(caught.main, "try-error")) { warning("Loading main `utilsRS` file was unsuccessfull and encountered the following error\n\t\"", gsub("\n$", "", caught.main[[1]]), "\"\n") } else if (verbose) cat("Main 'utilsRS.r' File Loaded successfully.\n\n", sep="") } utilsToLoad <- extractFilesFromFolder(utilsFolder, all=TRUE, recursive=TRUE, full.names=TRUE , ignore.subfolders=c("Setup Info", getOption("ignore.subfolders"))) failed <- list() for (nm in names(utilsToLoad)) { ## Try to source each file. If it fails, the returned value will have an attribute indicating reason or location of error loaded_ok <- tryToSource(utilsToLoad[[nm]], showWarnings=FALSE) ## Extract specific location or reason for error if (!loaded_ok) failed[[nm]] <- attr(loaded_ok, "lines") ## communicate to user if (verbose) cat(sprintf(" %40s ", paste0("\'", nm,"\'")), ifelse(loaded_ok, "Loaded successfully", "---+ FAILED +---"), "\n", sep="") } ## Output what failed, if there where failures. if (length(failed) && warn.on.erros) { failed <- c(list("[ FILE ]" = "[ ERROR LOCATION ]", "----------" = "--------------------"), failed) ## the 'width1' argument affects only the left hand (file name) column fileNameWidth <- max(35, mnchar(names(failed)) + 4) ## these three functions are simply used to cleanely output the failurs msg.lineNumber <- function(x, width1=fileNameWidth) paste0(sprintf( paste0("%", width1, "s (Lines: "), names(x)), sapply(lapply(x, sprintf, fmt="%4s"), paste, collapse=", "), ")" ) msg.string <- function(x, width1=fileNameWidth) { lb <- ifelse(seq(x) < 3, "", "(") rb <- ifelse(seq(x) < 3, "", ")") paste0(sprintf( paste0("%", width1, "s ", lb), names(x)), sapply(x, paste, collapse=", "), rb ) } errParse <- function(vec, width1=fileNameWidth, collapse="\n") { isNumb <- sapply(vec, is.numeric) paste0(ifelse(isNumb, msg.lineNumber(vec), msg.string(vec)), collapse="\n") } warning("\n\n", pasteR(" ", fileNameWidth*.6), " The following utils ", plrl("files were", failed), " not properly loaded:\n\n", errParse(failed)) } ## set options to know when last ran if (update.lastran) { if (exists("setLastRan")) setLastRan(x="utilSource") else options("lastran" = {.lran <- getOption("lastran", default=list()); .lran[["utilSource"]] <- Sys.time(); .lran}) } ## Resource supportFns if flagged if (supportFnsReload && exists("srcDir")) { try(sourceSupportFns(showWarnings=FALSE), silent=TRUE) } ## if all was succesfull, clear safetybreak from .g() safety <- ".gitpull.safety.break." if(exists(safety, envir=globalenv())) { safetyVal <- get(safety, envir=globalenv()) prev.lastLoaded <- attr(safetyVal, "lastLoaded") if (is.null(prev.lastLoaded) || as.numeric(Sys.time() - prev.lastLoaded) > 240){ safetyVal[] <- 0 assign(safety, value=safetyVal, envir=globalenv()) } } return(invisible(TRUE)) } getLastRan <- function(x=NULL, tz="America/New_York", verbose=TRUE) { .lran <- getOption("lastran") .lran <- lapply(.lran, as.tz, tz=tz) if (!length(x)) { ret <- .lran } else { present <- x[x %in% names(.lran)] ret <- as.POSIXct(rep(NA, length(x))) names(ret) <- x for (p in present) ret[[p]] <- .lran[[p]] } if (verbose) { if (length(ret)) cat(sprintf("%s was last ran on: %s (%s ago)\n", names(ret), sapply(ret, format, format="%c", usetz=TRUE), fwSecs(Sys.time() - unlist(ret))), sep="") else cat("There is no values set yet for lastran\n") } return(invisible(ret)) } setLastRan <- function(x="utilSource", tz=getOption("default.tz", "America/New_York"), reset=FALSE) { tm <- as.tz(Sys.time(), tz=tz) .lran <- getOption("lastran", default=list()) if (isTRUE(reset)) { cat("Current value for lastRan is:\n", capture.output(.lran), "\nAre you sure you want to erase them (y / n) ?\n", sep=" ") sure <- readline() if (sure %in% c("Y", "y", "yes", "Yes", "YES")) return(options("lastran" = NULL)) else return(invisible(cat("\nOK, nothing changed.\n"))) } for (ind in x) .lran[[ind]] <- tm options("lastran" = .lran) return(invisible(.lran)) } # ------------------------------------------------------------------------------------------ # plrl <- function(word.pluarl.form, count, singular=(length(count)==1), sep=" ", dontSumLogicals=FALSE, makePlrl=FALSE) { ## Makes grammatically correct words based on the quanity of count ## dontSumLogicals : by default, if count is logical, we will use sum(count), unless this flag is TRUE ## TODO: ## singular : I'm not sure why this is in the definition. Might have been old. if (!is.character(word.pluarl.form)) stop ("word.pluarl.form should be a string.\n\nDid you forget quotation marks? ") ## If there are no letters, return the string if (!grepl("[A-Za-z]", word.pluarl.form)) return(word.pluarl.form) ## For words where simple 's' (or 'es') wont make plural plrl.single.dict <- c(were="was", are="is", have="has", plural="singular" , files="file", exist="exists", directories="directory" , do="does" , Does="Does" , countries="country" , they="it" , dates="date" , Dates="Date" , They="It" , Are="Is") ## If user serlects makeplrl, then we simply use the dictionary above, but perform different ops. if (isTRUE(makePlrl)) { dd <- invDict(plrl.single.dict) splat <- lapply(strsplit(word.pluarl.form, " "), tail, 1) for (i in seq(splat)) { w <- splat[[i]] w2 <- dd[w] if (is.na(w2)) w2 <- paste0(w, ifelse(toupper(w) == w, "S", "s")) word.pluarl.form[[i]] <- gsub (w, w2, word.pluarl.form[[i]]) } return(word.pluarl.form) } ## ----------- ## if (is.logical(count) && !dontSumLogicals) count <- ifelse(sum(count), sum(count), 1) # if vector of words if(length(word.pluarl.form) > 1) return(paste(sapply(word.pluarl.form, plrl, count=count), collapse=sep)) # if single string of many words ## Need to check if the word ends in a space, and if so we need to paste an additional space. Othwersie, the strsplit will eat up that one last sapce. if (grepl(" ", word.pluarl.form)) word.pluarl.form <- paste0(word.pluarl.form, " ") word.pluarl.form <- strsplit(word.pluarl.form, " ")[[1]] if (length(word.pluarl.form) > 1) { ret <- sapply(word.pluarl.form, plrl, count=count) return(paste(ret, collapse=" ")) } # Otherwise, proceed on just one word word. ## --- Calculate if singular or not ----- # ## if count has length greater than one, then not singular ## otherwise, if count is numeric then check if it is not one { if (length(count)!=1 || (is.numeric(count) && count != 1) ) singular <- FALSE else singular <- TRUE } # if the word is singular process it if (singular) { # if the word is our dictionary, return its singular form if (word.pluarl.form %in% names(plrl.single.dict)) return(plrl.single.dict[word.pluarl.form]) # otherwise, return the word with a dropped final `s`, if found return(sub("(e)?s$", "", word.pluarl.form)) } # not singular, just return the word return(word.pluarl.form) } whichFactors <- function(x, names=FALSE) { # Identifies which columns in a df/dt (or elements in a list) are `factor` # if names==TRUE, will return the names, else will return the indecies. ret <- which(sapply(x, is.factor)) # check if names are available. If not, throw a warning if (isTRUE(names) & is.null(names(ret))) warning("User flagged for names to be returned from `whichFactors` but names(x) is NULL.\nReturning indecies instead.") if (isTRUE(names) & ! is.null(names(ret))) return(names(ret)) return(ret) } getNamesFromDTCols <- function(DT, na.rm=TRUE, uniquify=TRUE) { ## The values in a DT column can have their own names, although may not be displayed. ## For example, if we run DT[, lapply(.SD, someFunc)] ## ## This function returns a vector of those names. ## Specifically, it expects all of the columns in the DT to have the same structure # grab the names from each element names.list <- lapply(DT, names) # grab only those that are not null whichNAs <- (sapply(names.list, length) == 0) if (na.rm) names.list <- names.list[!whichNAs] else names.list[whichNAs] <- NA # grab the unique values if (uniquify) names.list <- unique(names.list) return(names.list) } # ----------------------------------------------------------------------------------------------------------- # orderedHeadTail <- function(x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE, value=FALSE, f=c("head", "tail")) { ## User should not need to invoke this function, but instead the wrapper functions `orderHead` and `orderTail` ## returns an index to x indicating the top/bottom n values. ## Useful for data.table indexing if (!is.atomic(x)) stop("Currently, orderHead and orderTail are only implemented for atomic vectors. Try using unlist() or other workarounds.") len <- length(x) # set FUN to either `head()` or `tail()` f <- match.arg(f) FUN <- match.fun(f) # ------------------------------------------------------------------- # # human error check # if (n > len) warning("n is larger than ", len, "=length(x). Using length(x).") if (value & logical) warning ("Both `value` and `logical` were set to TRUE.\n", "Retruning `value` superscedes (be careful if expected an index)") # ------------------------------------------------------------------- # # grab the ordering ordering <- order(x, na.last=na.last) # note, the decreasing argument is not used in `order()` but rather in output # take the first or last n-many elements indx.to.x <- FUN(ordering, n) if (decreasing) indx.to.x <- rev(indx.to.x) if (value) return(x[indx.to.x]) if (!logical) return(indx.to.x) # else, create a logical vector and return that ret <- rep(FALSE, len) ## TODO: There should be a C way to flip these booleans ret[indx.to.x] <- TRUE return(ret) } orderedHead <- function(x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE, value=FALSE) return(orderedHeadTail(f="head", x=x, n=n, na.last=na.last , decreasing=decreasing , logical=logical, value=value)) orderedTail <- function(x, n=min(length(x), 5), na.last=TRUE, decreasing=FALSE, logical=FALSE, value=FALSE) return(orderedHeadTail(f="tail", x=x, n=n, na.last=na.last , decreasing=decreasing , logical=logical, value=value)) # ----------------------------------------------------------------------------------------------------------- # is.vector.of.object.names <- function(x, na.rm=FALSE, class.to.check.for=NULL) { ## check if x is a vector of object names # returns TRUE / FALSE, with attribute of class ## if class.to.check.for is not NULL, the attribute checks if that class is inherited if (na.rm) x <- removeNA(x) ## Check that x is a basic vector of characters if (!(is.character(x) && is.vector(x) && is.null(dim(x)) && all(sapply(x, length) == 1))) return (FALSE) if (!all( sapply(x, exists) )) return (FALSE) if (is.null(class.to.check.for)) { classes <- lapply(x, function(z) class(get(z))) group.class <- ifelse(all(sapply(classes, function(z) identical(z, classes[[1]]))), classes[[1]], "varied classes") } else { group.class <- ifelse(all(sapply(x, function(z) inherits(get(x), class.to.check.for))), TRUE, FALSE) } ret <- TRUE data.table::setattr(ret, "group.class", group.class) data.table::setattr(ret, "class.to.check.for", class.to.check.for) return(ret) } sprintfcenter <- function(x, pad.each=1, mn=max(nchar(x))) { if (is.character(mn)) mn <- max(nchar(mn)) sp <- mn - nchar(x) + (2*pad.each) lt <- floor(sp / 2) rt <- ceiling(sp/2) sprintf("%*s%*s", nchar(x) + lt, x, rt, "") } ## REMOVING are() -- 2014-02-10 # # are <- function(..., warn.use.desc=TRUE) { # ## Moving to desc instead of are # if (warn.use.desc) # warning("are() is deprecated. Use desc() instead. ") # desc(...) # # } ## returns the char index to the last space in a string findLastSpace <- function(x, space=" ") { if (length(x) > 1) return(sapply(x, findLastSpace)) # stop ("x must be atomic") tail(gregexpr(space, x)[[1]], 1) } ## counts number of uique values for col in DT cnt <- function(col, DT=defaultDT) { col <- substitute(col) DT[, 1, by=col][, .N] } sourceManyFiles <- function(files=NULL, dir=NULL) { if (missing(files)) { filesWithPath <- list.files(dir, full.names=TRUE) # Grab only R files filesWithPath <- filesWithPath[ grepl("\\.[rRsS]$", filesWithPath) ] # what about `.Rprofile` -- only if manually given to sourceFiles? } else { filesWithPath <- as.path(dir, files, showWarnings=FALSE) } if (length(filesWithPath)==0 || all(sapply(filesWithPath, nchar)==0)) { warning("No valid files to source.") } ## bank the names nms <- if(!is.null(names(files))) names(files) else files ## source the files res <- invisible(lapply(filesWithPath, function(f) try(source(f, local=FALSE, echo=FALSE), silent=TRUE) ) ) ## return T/F based on if the output is an error; setting names accorind to nms, above setNames(!sapply(res, isErr), nms) } lunique <- function(x, ..., na.rm=FALSE) { # shorthand for finding the number of unique elements if (!is.null(dim(x))) { if (na.rm) stop ("lunique() does not know how to process 'na.rm=TRUE' when 'x' has dim") return(dim(unique(x, ...))) } if (na.rm) return(length(unique(x[!is.na(x)]))) return(length(unique(x, ...)) ) } runique <- function(x, ..., by=names(x)) { # shorthand for counting the unique rows in x if (!is.twodim(x)) stop("`x` must be two dimensional to call `runique` on it.") return(nrow(x[!duplicated(x, ..., by=by), , drop=FALSE])) } sunique <- function(x) { # shorthand for sorting the unique elements sort(unique(x)) } makeIntervals <- function(vec, final.val.to.add=NULL) { # takes a vector of integers (presumably indecies) and creates a list of sequences # using the vecotr values as the HEAD of each new sequence # eg I_1 : I_2 - 1, I_2 : I_3 - 1, etc. # vec <- c(vec, final.val.to.add) vec[length(vec)] <- vec[length(vec)] + 1 mapply(seq, head(vec, -1), tail(vec, -1) - 1, SIMPLIFY=FALSE) } sepAt_ <- function(DT, at=(-1), sep="|", colname=".sep") { ## Inserts a column of `sep` withinDT # if at < 0 : .sep inserted to the LEFT of (L - |at|) # if at >= 0 : .sep inserted to the RIGHT of at if (!length(DT)) return(invisible(DT)) L <- length(DT) if (!length(at) || is.na(at) || !is.numeric(at) || abs(at) > L) { stop("`at` must be a (posisbly negative) index number to a col in DT (eg in 0:", L, ")") } nms <- names(DT) if (anyDuplicated(nms)) { nm.DT <- pasteC(as.expression(substitute(DT))) if (nchar(nm.DT) > 25) nm.DT <- "the DT" warning(warningCols(paste0("Duplicate column names in ", nm.DT, ":"), nms[duplicated(nms)], post="Not adding sep column", mid=1, )) return(invisible(DT)) } if (at > 0) { left <- nms[1:at] right <- setdiff(nms, left) } else { right <- nms[(L+1) - (abs(at):1) ] left <- setdiff(nms, right) } neworder <- c(left, colname, right) DT[, (colname) := rep(sep, nrow(DT))] setcolorder(DT, neworder) return(invisible(DT)) } remsep_ <- function(DT, colname=".sep") { DT[, (colname) := NULL] } # ----------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------- # as.num.as.char <- function(x, noWarnOnChar=FALSE) { if (noWarnOnChar) suppressWarnings(as.numeric(as.character(x))) else as.numeric(as.character(x)) } spliceOutDate.2.2.2 <- function(x, format="%m.%d.%y", simplify=TRUE) { ## TODO: replace plus with {1-2} datePatterns <- c("[0-9][0-9]?\\.[0-9][0-9]?\\.[0-9][0-9]?") pat <- regOr(datePatterns) splat <- strsplit(x, " ") ret <- sapply(splat, function(x) grep(pat, x, value=TRUE), simplify=simplify) if(any(blanks <- sapply(ret, identical, character(0)))) { ret[blanks] <- NA if (simplify) ret <- unlist(ret) } if (is.null(format) || is.na(format) || nchar(format)==0) return(ret) return(as.Date(ret, format=format)) } meanIfThresh <- function(vec, thresh=12/15, len) { # Calculates the mean of vec, however, # if the number of non-NA values of vec is less than thresh, returns NA # thresh : represents how much data must be PRSENT. # ie, if thresh is 80%, then there must be at least # for efficiency, allow len to be an argument. If not set, compute it. if (missing(len)) len <- length(vec) # find all NA's nas <- is.na(vec) # count how many NAs nacounts <- sum(nas) # if the proportion of NA's is greater than the threshold, return NA if( (nacounts / len) > thresh) return(NA_real_) # example: if I'm looking at 14 days, and I have 12 NA's, # my proportion is 85.7 % = (12 / 14) # default thesh is 80.0 % = (12 / 15) # Thus, 12 NAs out of 14 would be rejected # else manually compute the mean and return that return( sum(vec[!nas]) / (len-nacounts) ) } # For when I'm too lazy to copy and paste dputc <- function(...) { clipCopy(capture.output(dput(...))) } copyAsCol <- function(...) { clipCopy(capture.output(cat(cbind(as.character(...)), "", sep="\n"))) } s.t <- function(expr, msg="", verbose=TRUE, gcFirst=FALSE, title="", pause=0, use=c("elapsed", "user", "system", "all"), message.instead.of.cat=TRUE, envir=parent.frame(), quiet.if.less.than.seconds=Inf) { # wrapper for system.time with fancy output # title is an alternate for msg, where user needs simply give a name to the section being timed. # msg is for a custome message before the sytem.time output # pause is for debugging. Genearlly should be 0 force(envir) ## -------------------------------- ## ## Which time measurement to use ## ## -------------------------------- ## use <- match.arg(use) if (use == "all") use <- c("user.self", "sys.self", "elapsed") if (use == "system") use <- "sys.self" if (use == "user") user <- "user.self" ## -------------------------------- ## times <- system.time(eval(substitute(expr), envir=envir), gcFirst=gcFirst) ret <- times [use] ret <- fwSecs(ret) # ret <- capture.output(system.time(expr=expr, gcFirst=gcFirst)) # ret <- paste(ret, collapse="\n") ## Collapse the message into one string msg <- pasteC(msg) if (nchar(title)) { if (nchar(msg)) msg <- paste0("\n", msg) msg <- paste0("Time to complete '", title, "'", msg, ": ") } if (pause != 0) Sys.sleep(pause) # Which function to use to output the msg. cat.fun <- if (message.instead.of.cat) message else cat if (is.finite(quiet.if.less.than.seconds) && times[use][1] < quiet.if.less.than.seconds) verbose <- FALSE if (verbose){ if (nchar(msg) == 0) { capt <- capture.output(print(ret, quote=FALSE)) capt <- gsub("^\\s*\\[\\d+\\]", "", capt) cat.fun(paste(capt, sep="\n")) } else cat.fun(paste(msg, ret, sep=" ")) } return(invisible(times)) } clean.capture.output <- function (... , pipe_ok=FALSE, file=NULL, append=FALSE, quote=FALSE, envir=parent.frame()) { ## like capture.output, but removes all of the [1] [2] .. etc from the start of the line ## NOTE: (1) This does NOT clean matrix output ## (2) This works poorly on a vector of strings browser(expr=inDebugMode("clean.capture.output"), text="in clean.capture.output, at top") # formals(print.default)$quote <- FALSE # on.exit(formals(print.default)$quote <- TRUE, add=TRUE) if (!isTRUE(pipe_ok) && any(sapply(sys.calls(), "==", c("eval(lhs, parent, parent)")))) { stop ("capture.output (and hence clean.capture.output) does not work with pipe %>% or %T>%") } last_few_sys.calls <- tail(sys.calls(), 4) ## for some reason tail(sys.calls()) on one machine caputres 'tail()' and on the other does not ## thus, Identify which index to drop. If "tail" is included drop the last one. Otherwise, drop the first one (we grabbed to many) if (last_few_sys.calls[[length(last_few_sys.calls)]][[1L]] == "tail") last_few_sys.calls <- head(last_few_sys.calls, -1) else last_few_sys.calls <- tail(last_few_sys.calls, -1) ## Old is left for comments... too tired ... # OLD: is_in_sapply <- grepl("X\\[\\[\\d+L\\]\\]", capture.output(substitute(...))) || # OLD: "lapply" %in% sapply(last_few_sys.calls, function(x) as.character(as.list(x)[[1L]])) ## NEW: is_in_sapply <- grepl("X\\[\\[\\d+L\\]\\]", capture.output(substitute(...))) || "lapply" %in% sapply(last_few_sys.calls, function(x) {if (is(as.list(x)[[1]])[[1]] == "promise") "" else as.character(as.list(x)[[1L]])}) # cat("is_in_sapply == ", is_in_sapply, fill=TRUE) if (is_in_sapply) ret <- capture.output(print(...)) else { ## For some reason, calling eval first allows capture.output to work better. ## I have this wrapped in sink() to avoid any output that was not captured sink(tempfile(pattern="capt_output_tmpfile_")) eval(substitute(...), envir=envir) sink() ## removing quotes requires calling print. However, not all expressions woould be appropriate to ## call print() for. There are a few that we know for sure. Add to this list as needed ## This list is only important when using quotes=FALSE use_print_for_funcs <- c("cbind", "rbind") sub_dots <- substitute(...) if (isTRUE(as.character(sub_dots)[[1]] %in% use_print_for_funcs)) ret <- capture.output(print(eval(sub_dots, envir=envir), quote=quote)) else ret <- capture.output(eval(sub_dots, envir=envir)) # if (isTRUE(as.character(substitute(...)[[1]]) %in% use_print_for_funcs)) # ret <- capture.output(print(eval(substitute(...), envir=envir), quote=quote)) # else # ret <- capture.output(eval(substitute(...), envir=envir)) } ## remove any starting " [1] " ret <- gsub("^\\s*\\[\\d+\\]\\s*", "", ret) ## if there is more than one line, and the output is a function, clear any lastline "NULL" if (length(ret) > 1 && tail(ret, 1) == "NULL" && any(grepl("function \\(", ret[1:2]))) ret <- head(ret, -1) ## if quote is set to FALSE, remove the quote marks if (!isTRUE(quote) & all(grepl("^\\\"", ret)) & all(grepl("\\\"$", ret))) ret <- gsub("^\\\"|\\\"$", "", ret) return(ret) } ## Default options for verboseMsg if (is.null(getOption("verbose_seconds"))) options("verbose_seconds" = FALSE) if (is.null(getOption("verbose_minw"))) options("verbose_minw" = 62) verboseMsg <- function(verbose, ..., time=TRUE, sep=" ", stampFirstLine=TRUE, endl=1, simple=FALSE, formnumb=TRUE, round=FALSE , minw=getOption("verbose_minw", 62), frmt=ifelse(isTRUE(seconds), "%H:%M:%S %Z", "%H:%M %Z"), sleep=0, seconds=getOption("verbose_seconds", FALSE) , func=c("cat", "message", "warning"), call.=TRUE, .call=TRUE) { ## Wrapper function for verbose outputting ## time: indicates whether or not to add time stamp ## stampFirstLine: if TRUE, time stamp will go before first line break. if FALSE goes at end of whole message ## endl: number of new line breaks. Set to FALSE or 0 for none. ## simple: Tries to emulate cat, with sep="" ## minw : the min width for the first line, before time stamp. If negative, will subtract from getOption("width") ## FOR NOW, minw Only applies when stampFirstLine is TRUE ## Quick exit, avoiding any errors if(isTRUE(try(identical(verbose, FALSE), silent=TRUE))) return(invisible(NULL)) ## I keep using .call instead of call. if (!missing(.call)) { message(pasteR("!", 100), "\nYOU USED THE WRONG ARGUMENT FOR WARNING -- put the dot AFTER call --- call.=", as.character(.call), "\n", pasteR("!", 100)) call. <- .call } force(verbose) try({ if (is.character(verbose) && isTRUE(tolower(verbose)=="auto")) verbose <- TRUE }) if (missing(func) && grepl("warning", capture.output(substitute(verbose)), ignore.case=TRUE)) func <- "warning" func <- match.arg(func) func.out <- match.fun(func) is_warning <- identical(func.out, warning) if (!is.numeric(minw)) { warning ("minw must be numeric in verboseMsg -- setting to 60", call.=FALSE) minw <- 60 } if (minw < 0) minw <- minw + getOption("width") - ( {15 + 3 * isTRUE(seconds)} * isTRUE(time)) ## use simply-output for warnings, unless user specified otherwise if (is_warning && missing(simple)) simple <- TRUE if (simple) { if (missing(time)) time <- FALSE if (missing(sep)) sep <- "" if (missing(endl)) endl <- FALSE } browser(expr=inDebugMode(c("verboseMsg")), text="in verboseMsg() right before tryCatch") ## CONFIRM verbose FLAG IS AS EXPECTED, AND IF NOT TRY TO RESOLVE ## -------------------- # Sometimes 'verbose' is not found tryCatch(expr=(verbose), error=function(e) { err <- capture.output(e) calls <- as.character(sapply(sys.calls(), "[[", 1)) calls <- paste0(calls, "(.)") calls[[1]] <- capture.output(sys.call(1)) calls <- paste0(calls, collapse="... ") assign("verbose", getOption("verbose", default=TRUE), envir=parent.frame(4)) warning("\n The verbose flag not properly set inside call\n\t\t", calls, "\n Will use default value of '", verbose,"'") }) if (!is.logical(verbose)) stop("The first argument in verboseMsg() should be a T/F flag.\nDid you forget to include it?. Check your traceback\n\n") if (!verbose) return(invisible(NULL)) ## -------------------- dots <- list(...) dots <- dots[!sapply(dots, is.null)] if (isTRUE(formnumb)) { wh.numbs <- sapply(dots, is.numeric) dots[wh.numbs] <- formnumb(dots[wh.numbs], round=round) } dots.flat <- paste(dots, collapse=sep) if (time) { ## split on line break splat <- strsplit(dots.flat, "\n")[[1]] ## Find the first none-blank. Check that at least one is none-blank if (length(splat) > 1 && any(nchar(splat) > 0)) { firstLine <- min(which(nchar(splat) > 0)) lastLine <- max(which(nchar(splat) > 0)) } else { firstLine <- 1 lastLine <- length(splat) } ## index to which to time stamp i <- ifelse(stampFirstLine, firstLine, lastLine) ## spacer for time stamped line spcr <- paste0("%", if (!is.null(minw)) -minw, "s -- [%s]") # splat[i] <- sprintf(spcr, splat[i], format(Sys.time(), frmt)) splat[i] <- sprintf(spcr, splat[i], format(Sys.time(), frmt, tz="America/New_York")) dots.flat <- pasteC(splat, C="\n") } ## Specifically for warning(), we want the warning to come from the function calling verboseMsg, not from verboseMsg itself if (is_warning && isTRUE(call.)) { wtext <- capture.output(sys.call(1)) if (length(wtext) > 1) { wtext[-1L] <- gsub("^ ", "", wtext[-1L]) wtext <- pasteC(wtext) } dots.flat <- sprintf("in %s :\n %s", substr(wtext, 1, getOption("width")-10), dots.flat) } # output msg <- c(dots.flat, if (endl>0) pasteR("\n", endl)) if (func == "message") message(msg, appendLF = FALSE) else if (is_warning) { ## For long warnings, add an extra line break if there is not one there if (nchar(msg) > 800 && !grepl("\\n\\s*$", msg)) msg <- paste0(msg, "\n") ## Expand the character length so that warnings don't get cropped (ie, when showing urls in long API calls) .prev_w_len <- options(warning.length = 6000) warning(msg, call. = FALSE) ## Put the option length back options(.prev_w_len) } else cat(msg) if (sleep) Sys.sleep(sleep) return(invisible(NULL)) } is.twodim <- function(x) { return(isTRUE(length(dim(x))==2)) } has.listColumn <- function(x) { return(any(sapply(x, is.list))) } wnames <- function(x, selection=NULL, copy=TRUE) { nms <- names(x) names(nms) <- seq_along(nms) if (is.null(selection)) return(nms) ret <- nms[selection] if (copy && .Pfm == "Darwin") { cat("\n\n (copied to clipboard)\n\n") dputc(unname(ret)) } return(ret) } # meanIfThresh.old <- function(vec, thresh=12/15, len) { # # Calculates the mean of vec, however, # # if the number of non-NA values of vec is less than thresh, returns NA # # thresh : represents how much data must be PRSENT. # # ie, if thresh is 80%, then there must be at least # # for efficiency, allow len to be an argument. If not set, compute it. # if (missing(len)) # len <- length(vec) # # if the proportion of NA's is greater than the threshold, return NA # if( (sum(is.na(vec)) / len) > thresh) # return(NA_real_) # # example: if I'm looking at 14 days, and I have 12 NA's, # # my proportion is 85.7 % = (12 / 14) # # default thesh is 80.0 % = (12 / 15) # # Thus, 12 NAs out of 14 would be rejected # # else # return(mean(vec, na.rm=TRUE)) # } # ----------------------------------------------------------------------------------------------------------- # scaleunif <- function(vec, min=0, max=1, round=FALSE) { # (vec-mn) / (mx-mn) == (NEW - min) / (max - min) # (vec-mn) / (mx-mn) * (max - min) == (NEW - min) # ((vec-mn) / (mx-mn) * (max - min)) + min == NEW vec[!is.finite(vec)] <- NA mn <- min(vec, na.rm=TRUE) mx <- max(vec, na.rm=TRUE) ret <- ((vec-mn) / (mx-mn) * (max - min)) + min if (round) ret <- round(ret) ret } # --------------------------------------------------------------- # # substitute.mc <- function(what, alternate) { # ### what could help make this function work? # } # --------------------------------------------------------------- # runShiny <- function(shinyapp.name) { require(shiny) runApp(as.path(srcDir, shinyapp.name)) } BetaFunc <- function(a, b) # creates a single parameter function based on a, b return( function(x) (gamma(a+b)/(gamma(a)*gamma(b))) * (x^(a-1) * (1-x)^(b-1)) ) Beta <- function(x, a, b) BetaFunc(a, b)(x) # --------------------------------------------------------- # make.rgba <- function(N, start=c(r=0,g=0,b=0,a=0), end=c(r=1,g=1,b=1,a=1) , color=c("linear", "log"), alpha=c("log", "linear"), final.alpha.gap=0.1) { alpha <- match.arg(alpha) color <- match.arg(color) # start & end should be vectors of the form `c(r=0,g=0,b=0,a=0)` # However, if alternate form given, try to convert if (length(start)==1) start <- as.vector(col2rgb(start, alpha=TRUE)/255) if (length(end)==1) end <- as.vector(col2rgb(end, alpha=TRUE)/255) # in case user mis interprets type of argument, default to 0.1 if (isTRUE(final.alpha.gap)) final.alpha.gap <- 0.1 if (is.numeric(final.alpha.gap) && final.alpha.gap < 0) final.alpha.gap <- abs(final.alpha.gap) # alpha and color scaling functions A.func <- {if (alpha=="linear") scaleColorLinear else scaleColorLog} C.func <- {if (color=="linear") scaleColorLinear else scaleColorLog} # clean and check names of `start` and `end` # ---------------------------------------- # nms <- c("r", "g", "b", "a") if (is.null(names(start))) names(start) <- nms if (is.null(names(end))) names(end) <- nms # take only first letter of each name names(start) <- sapply(names(start), substr, 1, 1) names(end) <- sapply(names(end), substr, 1, 1) if (!all(nms %in% names(start))) stop("The names of `start` must be c('r', 'g', 'b', 'a') ") if (!all(nms %in% names(end))) stop("The names of `end` must be c('r', 'g', 'b', 'a') ") # ---------------------------------------- # a.end <- end[["a"]] A <- A.func(N=N, start=start[["a"]], end=a.end) # squash down the alphas for all but the last value if (is.numeric(final.alpha.gap) && final.alpha.gap < a.end) A <- c(scaleunif(head(A, -1), start[["a"]], a.end-final.alpha.gap), a.end) R <- C.func(N=N, start=start[["r"]], end=end[["r"]]) G <- C.func(N=N, start=start[["g"]], end=end[["g"]]) B <- C.func(N=N, start=start[["b"]], end=end[["b"]]) rgb(R, G, B, A) } # --------------------------------------------------------- # scaleColorLog <- function(N, start, end) { log(seq(from=10^start, to=10^end, length.out=N), 10) } scaleColorLinear <- function(N, start, end) { seq(from=start, to=end, length.out=N) } # --------------------------------------------------------- # # --------------------------------------------------------- # # for neo4j # # --------------------------------------------------------- # sn <- function(max, length.out=max, min=1) { # create a sampling of "nodes" for start query S <- unique(round(seq(from=min, to=max, length.out=length.out))) dp <- capture.output(dput(as.numeric(S))) dp[[1]] <- gsub("c\\(", "node\\(", dp[[1]]) dp <- paste(dp, collapse="") clipCopy(dp) } # --------------------------------------------------------- # showCharIndex <- function(x, width=getOption("width"), silent=FALSE, replace.space.with="~", single.digit.inds=TRUE, mod=10) { ## width refers to the total width of output, including any spaces for padding ## ## depends on : pasteC if (length(x) > 1) stop("One x at a time.") if (!is.null(replace.space.with)) x <- gsub(" ", replace.space.with, x) letrs <- strsplit(x, "")[[1]] inds <- seq(nchar(x)) if (!single.digit.inds) { ## Number of spaces each index will take up spc <- 1 + ceiling(log(nchar(x), 10)) spc.f <- sprintf("%%%is", spc) } else { spc <- 2 spc.f <- "%2s" ## Modify the indeces, every M items is mod 100, the rest, just the one's digit drop <- c() M1 <- inds %% (mod*10) == 0 inds[M1] <- inds[M1] %% (100 * 10) inds[!M1] <- inds[!M1] %% (10 * 10) drop <- c(drop, which(M1)-(log(10, 10) + 1)) M <- inds %% mod == 0 inds[M & !M1] <- inds[M & !M1] %% 100 inds[!M & !M1] <- inds[!M & !M1] %% 10 drop <- c(drop, which(M)-1) inds[drop] <- "" } ## number of letters per row cols = floor(width / spc) ## The last row of the output will need some extra blanks, one ("") for each empty column ## pad the letrs array with blanks for the last line. ## First calculate how many spaces are need to complete the row (for now a col, until apply'd) toadd <- cols - (length(letrs) %% cols) ## pad in blank space letrs <- c(letrs, rep("", toadd)) inds <- c(inds, rep("", toadd)) ## All of the indecies as a matrix mat <- matrix(c(inds, letrs), ncol=cols, byrow=TRUE) ## fill in with spaces, then correct mat[] <- sprintf(spc.f, mat) # find those taking up an extra space, and make sure the elements to the left are skinny enough # TODO: This might have to be extended to not just one element back, but multiple fatties <- which(nchar(mat) > spc) if (length(fatties)) mat[fatties - nrow(mat)] <- pasteR(" ", nchar(mat[fatties]) - spc) ## Flatten each row into a single string, using pasteC flat <- apply(mat, 1, pasteC) ## Flat needs to be reordered ## the order(..) portion cuts the vector in half, then alternates, taking one row from each half flat <- flat[ order(rep(seq(length(flat)/2), 2)) ] ## Collapse it into a single string flat <- pasteC(flat, C="\n") if (!silent) cat(flat) return(invisible(flat)) } # ----------------------------------------------------------------------------------------------------------- # sampleChunks.data.table <- function(DT, perc=.1, NumberOfChunks=1000L, head=0, tail=0, plusHeadTail=FALSE, prserveOrder=TRUE) { ## TODO: if (!plusHeadTail) warning("`plusHeadTail` not yet implemented for value of FALSE. Defaulting to TRUE.") # Make sure perc is a whole number, not a decimal perc <- validPercentage(perc, 0, 1) L <- nrow(DT) # L is the total length sampling from. The `indx` max inds <- seq(L) TotalNoOfSamples <- ceiling(L * perc) # chunksize should not fall below 1 chunksize <- max(1, TotalNoOfSamples / NumberOfChunks) # round down to nearest hundreds, only if chunksize is more than 1,000 roundTo <- 100 chunksize <- ifelse (chunksize > roundTo * 10, roundOutToX(chunksize, x=-roundTo), round(chunksize)) # The simple way is to chop up into groups, then sample the head of the groups and expand. # The big problem here is that the tail will never be selected # Alternatively, we could sample from anywhere, then expand. # If any duplicates are encountered, spread out to the edges evenly. # Repeat this check until no duplicates found ##TODO: ## There should be a warning about relative sizes of everything ## For now we will do the simpler approach, as we do not care of purity. indxHeads <- seq( max(1, floor(L / chunksize))) HeadIndexOfEachChunk <- sample(indxHeads, TotalNoOfSamples, replace=FALSE) selections <- unlist(lapply(HeadIndexOfEachChunk * chunksize, `+`, seq(chunksize))) if (head>0 && is.numeric(head)) slections <- c(1:head, selections) if (tail>0 && is.numeric(head)) slections <- c(tail:L, selections) selections <- unique(selections) # error check. if (length(selections) < TotalNoOfSamples) warning("Somethings odd, too few samples:\n Required: ", TotalNoOfSamples, "\n Actual: ", length(selections), "\n") # sort the indexes if flagged if (prserveOrder) selections <- sort(selections) return(DT[selections, ]) } sampleChunks <- function(x, ...) { warning("\n\tNOTE TO SELF\n\t------------\n\tYou have TWO similar functions.\n\t sampleInChunks() & sampleChunks()\n\n ") UseMethod ("sampleChunks") } sampleChunks.default <- function(...) { stop ("\n\nsampleChunks is only defined for data.table's\n") } .rg <- function() { ## resets .gitpull.safety.break. safety <- ".gitpull.safety.break." assign(safety, value=0, envir=globalenv()) } gitfile <- function(file, msg=sprintf("Adding file %s from %s", gsub("~/git(/orch/(out|src|data)/)", "", file), ifelse(.Pfm=="Darwin", "local machine", "remote machine")), force=TRUE) { if (force) system(sprintf("git add -f %s", file)) cmd <- sprintf('git commit -m "%s" %s', msg, shellClean(file)) system(cmd) gitpull() return(invisible(cmd)) } showGitBranch <- function(verbose=TRUE) { cmd <- "cd ~/git; git branch" if (verbose) cmd <- paste(cmd, "-v") cat("\n") ret <- system(cmd) cat("\n") return(invisible(ret)) } setGitBranch <- function(branch=getOption("git.defaultbranch", default="master"), checkout=FALSE, dir="~/git") { if (checkout) { system(sprintf("cd %s; git checkout %s", dir, branch), FALSE) } options("gitBranch" = branch) } getGitBranch <- function(default=getOption("git.defaultbranch", default="master"), from_where=c("R_options", "system", "System"), dir="~/git") { from_where <- match.arg(from_where) from_R <- from_where == "R_options" R_branch <- getOption("gitBranch", default) current_branch <- gsub("\\*\\s*", "", extract("\\* ", system(sprintf("cd %s; git branch", dir), TRUE))) if (!length(current_branch)) { warning ("There is no git branch set on the system side for directory '", dir, "'", call.=FALSE) current_branch <- "" } if (from_R && current_branch != R_branch) warning ("The current git branch on the system ('", current_branch, "') is different from the one in R ('", R_branch,"')") if (from_R) return(R_branch) else return(current_branch) } setGitBranchToSystem <- function(dir="~/git") { setGitBranch(branch=getGitBranch(dir=dir, from="system"), dir=dir) cat("The current git branch is set to '", getGitBranch(), "'\n", sep="") } .g <- .gitPull <- function(dir="~/git", utilsReload=TRUE, branch=getGitBranch(), remote=getOption("git.origin", "origin"), supportFnsReload=getOption("supportFnsReload", FALSE), quiet_git=TRUE, onlyIfChanged=NULL, verbose=TRUE, intern=TRUE, maxSafety=14) { if (missing(branch)) { # current_branch <- gsub("\\*\\s*", "", extract("\\* ", system(sprintf("cd %s; git branch", dir), TRUE))) current_branch <- getGitBranch(from="system", dir=dir) if (current_branch != branch) stop ("The current git branch on the system ('", current_branch, "') is different from the one in R ('", branch,"')\nTo proceed please set the 'branch' argument explicitly in .g()") } ## avoid infinite loop. I sometimes leave calls to .g() inside files that get sourced in .g() safety <- ".gitpull.safety.break." safetyVal <- 1 + {if(exists(safety, envir=globalenv())) get(safety, envir=globalenv()) else 0} ## dont use ifelse, drops attribute prev.lastLoaded <- attr(safetyVal, "lastLoaded") if (!length(safetyVal)) safetyVal <- 1 if (is.null(prev.lastLoaded)) prev.lastLoaded <- Sys.time() - 1e6 attr(safetyVal, "lastLoaded") <- Sys.time() assign(safety, value=safetyVal, envir=globalenv()) if (length(safetyVal) && safetyVal > maxSafety) { if (as.numeric(Sys.time() - prev.lastLoaded) < 4) stop("\n\nSafety reached. To clear it, use :\n ", safety, " <- 0 .") warning("\n\nSafety reached. To clear it, use :\n ", safety, " <- 0\n\nWill sleep for 5 seconds") Sys.sleep(5) } if (!missing(onlyIfChanged)) warning("onlyIfChanged has been depracated and will be ignored") ## Create this string one time, to avoid having a multitude of 'ifelse(...)' inside paste commands quiet_flag <- ifelse(quiet_git, "--quiet", "") ## If executing from mac, do a quick pull AND push if (.Pfm == "Darwin") { return(system(sprintf("cd ~/git;git pull %s %s %s; git push %1$s %2$s %3$s", quiet_flag, remote, branch), intern=intern)) } ## msg for verbose output msg.out <- c() ## If user is not me, indicate which user it is pulling for if (Sys.getenv("USER") != "rsaporta") msg.out <- c(msg.out, sprintf(" # Executing git pull under user '%s' #", Sys.getenv("USER"))) # if (verbose) { # hr.l <- 66 # cat(" ", rep("~", hr.l), "\n", sep="") # # cat("\n ------------------\n git Pull Request\n ------------------ \n\n") # if (Sys.getenv("USER") != "rsaporta") # cat( " Executing git pull under user", Sys.getenv("USER"), "\n" ) # } if (verbose && exists("data.table")) { folds <- c("~rsaporta/git/orch/src", "~rsaporta/git/orch/ingest", "~rsaporta/git/misc/rscripts") DT.currentFiles <- setkey(as.data.table(file.info(dir(folds, full=TRUE, recursive=TRUE)), keep.rownames=TRUE), rn) } ## ------------- ## ## EXECUTE ## ## ------------- ## res <- system(sprintf("cd ~/git; git pull %s %s %s;", quiet_flag, remote, branch), intern=intern) ## VERBOSE if (verbose && exists("data.table")) { DT.afterFiles <- setkey(as.data.table(file.info(dir(folds, full=TRUE, recursive=TRUE)), keep.rownames=TRUE), rn) browser(expr=inDebugMode("gitverbose"), text="in .g() right before merging modifiedFiles") DT.changed <- DT.currentFiles[DT.afterFiles, nomatch=NA][(!isdir | is.na(isdir))] ## dont worry about directories modifiedFiles <- DT.changed[(mtime != i.mtime) | (size != i.size) | (atime != i.atime)] [, path.unexpand(rn)] newfiles <- DT.changed[is.na(size)] [, path.unexpand(rn)] deletedfiles <- DT.changed[is.na(i.size)] [, path.unexpand(rn)] if (!length(c(modifiedFiles, newfiles, deletedfiles))) msg.out <- c(msg.out, "No files changed") else { msg.out <- c(msg.out , if (length(modifiedFiles)) c("Updated Files:", paste0(" * ", cleanFileStringOutput(modifiedFiles))) , if (length(newfiles)) c("Added Files:", paste0(" * ", cleanFileStringOutput(newfiles))) , if (length(deletedfiles)) c("Deleted Files:", paste0(" * ", cleanFileStringOutput(deletedfiles))) ) } ## // end of else if (exists("boxit")) msg.out <- boxit(msg.out, C="\n", align="left", pad=4) cat(msg.out, fill=TRUE) } ## // end of if (verbose) ## If flagged on && either forceYes (ie `onlyIf..`) OR detect 'utils' in the git res. if (utilsReload) { if (verbose) cat("Reloading utils ... ") if (exists("utilSource")) try(utilSource(supportFnsReload=supportFnsReload)) else warning("Could not find function `utilSource`") if (verbose) cat(" LOADED.\n") } return(invisible(res)) } # // end of .gitPull() aka .g() ## .us() is in console_utils.r -- simple version here if (!exists(".us")) .us <- function(...) utilSource(...) ## ------------------------------------------ ## ## States variables are missing Washington DC ## ## ------------------------------------------ ## try({ try(force(state.name), silent=TRUE) try(force(state.abb), silent=TRUE) if (exists("state.name")) assign("state.name" , unique(c(state.name, "Washington DC")) , envir=globalenv()) if (exists("state.abb")) assign("state.abb" , unique(c(state.abb, "DC")), envir=globalenv()) }, silent=TRUE) ## ------------------------------------------ ## # ----------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------- # # ## THIS IS MOVED TO .RProfile # .Last <- function() { # rm(.First) # options("utilsLoaded"=FALSE) ## Indicates that this file has been loaded # } options("utilsLoaded"=TRUE) ## Indicates that this file has been loaded options("dontReloadUtils"=FALSE) ## .RProfile will generally run `utilSource()` unless this is set to TRUE